git.iko.soy/elk
on 4e73834 help sign in
elk/src/AST/Type.hs
210 lines 4.0 kB history raw
1module AST.Type
2 ( Raw, Raw'(..)
3 , Canonical(..), Aliased(..)
4 , Port(..), getPortType
5 , deepDealias, iteratedDealias, dealias
6 , collectLambdas
7 , tuple
8 ) where
10import Control.Arrow (second)
11import Data.Binary
12import qualified Data.Map as Map
14import qualified AST.Variable as Var
15import qualified Reporting.Annotation as A
16import qualified Reporting.Region as R
20-- DEFINITION
23type Raw =
24 A.Located Raw'
27data Raw'
28 = RLambda Raw Raw
29 | RVar String
30 | RType Var.Raw
31 | RApp Raw [Raw]
32 | RRecord [(String, Raw)] (Maybe Raw)
35data Canonical
36 = Lambda Canonical Canonical
37 | Var String
38 | Type Var.Canonical
39 | App Canonical [Canonical]
40 | Record [(String, Canonical)] (Maybe Canonical)
41 | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)
42 deriving (Eq, Ord)
45data Aliased t
46 = Holey t
47 | Filled t
48 deriving (Eq, Ord)
51data Port t
52 = Normal t
53 | Signal { root :: t, arg :: t }
54 deriving (Eq)
57getPortType :: Port tipe -> tipe
58getPortType portType =
59 case portType of
60 Normal tipe -> tipe
61 Signal tipe _ -> tipe
64tuple :: R.Region -> [Raw] -> Raw
65tuple region types =
66 let
67 name =
68 Var.Raw ("_Tuple" ++ show (length types))
69 in
70 A.A region (RApp (A.A region (RType name)) types)
74-- DEALIASING
77deepDealias :: Canonical -> Canonical
78deepDealias tipe =
79 case tipe of
80 Lambda a b ->
81 Lambda (deepDealias a) (deepDealias b)
83 Var _ ->
84 tipe
86 Record fields ext ->
87 Record (map (second deepDealias) fields) (fmap deepDealias ext)
89 Aliased _name args tipe' ->
90 deepDealias (dealias args tipe')
92 Type _ ->
93 tipe
95 App f args ->
96 App (deepDealias f) (map deepDealias args)
99iteratedDealias :: Canonical -> Canonical
100iteratedDealias tipe =
101 case tipe of
102 Aliased _ args realType ->
103 iteratedDealias (dealias args realType)
105 _ ->
106 tipe
109dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
110dealias args aliasType =
111 case aliasType of
112 Holey tipe ->
113 dealiasHelp (Map.fromList args) tipe
115 Filled tipe ->
116 tipe
119dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
120dealiasHelp typeTable tipe =
121 let
122 go =
123 dealiasHelp typeTable
124 in
125 case tipe of
126 Lambda a b ->
127 Lambda (go a) (go b)
129 Var x ->
130 Map.findWithDefault tipe x typeTable
132 Record fields ext ->
133 Record (map (second go) fields) (fmap go ext)
135 Aliased original args t' ->
136 Aliased original (map (second go) args) t'
138 Type _ ->
139 tipe
141 App f args ->
142 App (go f) (map go args)
146-- COLLECT LAMBDAS
149collectLambdas :: Canonical -> [Canonical]
150collectLambdas tipe =
151 case tipe of
152 Lambda arg result ->
153 arg : collectLambdas result
155 _ ->
156 [tipe]
160-- BINARY
163instance Binary Canonical where
164 put tipe =
165 case tipe of
166 Lambda t1 t2 ->
167 putWord8 0 >> put t1 >> put t2
169 Var x ->
170 putWord8 1 >> put x
172 Type name ->
173 putWord8 2 >> put name
175 App t1 t2 ->
176 putWord8 3 >> put t1 >> put t2
178 Record fs ext ->
179 putWord8 4 >> put fs >> put ext
181 Aliased var args t ->
182 putWord8 5 >> put var >> put args >> put t
184 get =
185 do n <- getWord8
186 case n of
187 0 -> Lambda <$> get <*> get
188 1 -> Var <$> get
189 2 -> Type <$> get
190 3 -> App <$> get <*> get
191 4 -> Record <$> get <*> get
192 5 -> Aliased <$> get <*> get <*> get
193 _ -> error "Error reading a valid type from serialized string"
196instance Binary t => Binary (Aliased t) where
197 put aliasType =
198 case aliasType of
199 Holey tipe ->
200 putWord8 0 >> put tipe
202 Filled tipe ->
203 putWord8 1 >> put tipe
205 get =
206 do n <- getWord8
207 case n of
208 0 -> Holey <$> get
209 1 -> Filled <$> get
210 _ -> error "Error reading a valid type from serialized string"