git.iko.soy/elk
on 0ff8a91 help sign in
elk/src/AST/Type.hs
219 lines 4.2 kB history raw
1module AST.Type
2 ( Raw, Raw'(..)
3 , Canonical(..), Aliased(..)
4 , deepDealias, iteratedDealias, dealias
5 , collectLambdas
6 , tuple, cmd, sub
7 )
8 where
10import Control.Arrow (second)
11import Data.Binary
12import qualified Data.Map as Map
14import qualified AST.Module.Name as ModuleName
15import qualified AST.Variable as Var
16import qualified Reporting.Annotation as A
17import qualified Reporting.Region as R
21-- DEFINITION
24type Raw =
25 A.Located Raw'
28data Raw'
29 = RLambda Raw Raw
30 | RVar String
31 | RType Var.Raw
32 | RApp Raw [Raw]
33 | RRecord [(String, Raw)] (Maybe Raw)
36data Canonical
37 = Lambda Canonical Canonical
38 | Var String
39 | Type Var.Canonical
40 | App Canonical [Canonical]
41 | Record [(String, Canonical)] (Maybe Canonical)
42 | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)
43 deriving (Eq, Ord)
46data Aliased t
47 = Holey t
48 | Filled t
49 deriving (Eq, Ord)
53-- CONSTRUCT USEFUL TYPES
56tuple :: R.Region -> [Raw] -> Raw
57tuple region types =
58 let
59 name =
60 Var.Raw ("_Tuple" ++ show (length types))
61 in
62 A.A region (RApp (A.A region (RType name)) types)
65cmd :: ModuleName.Canonical -> String -> Canonical
66cmd =
67 effect Var.cmd
70sub :: ModuleName.Canonical -> String -> Canonical
71sub =
72 effect Var.sub
75effect :: Var.Canonical -> ModuleName.Canonical -> String -> Canonical
76effect effectName moduleName tipe =
77 Lambda
78 (App (Type (Var.fromModule moduleName tipe)) [Var "msg"])
79 (App (Type effectName) [Var "msg"])
83-- DEALIASING
86deepDealias :: Canonical -> Canonical
87deepDealias tipe =
88 case tipe of
89 Lambda a b ->
90 Lambda (deepDealias a) (deepDealias b)
92 Var _ ->
93 tipe
95 Record fields ext ->
96 Record (map (second deepDealias) fields) (fmap deepDealias ext)
98 Aliased _name args tipe' ->
99 deepDealias (dealias args tipe')
101 Type _ ->
102 tipe
104 App f args ->
105 App (deepDealias f) (map deepDealias args)
108iteratedDealias :: Canonical -> Canonical
109iteratedDealias tipe =
110 case tipe of
111 Aliased _ args realType ->
112 iteratedDealias (dealias args realType)
114 _ ->
115 tipe
118dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
119dealias args aliasType =
120 case aliasType of
121 Holey tipe ->
122 dealiasHelp (Map.fromList args) tipe
124 Filled tipe ->
125 tipe
128dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
129dealiasHelp typeTable tipe =
130 let
131 go =
132 dealiasHelp typeTable
133 in
134 case tipe of
135 Lambda a b ->
136 Lambda (go a) (go b)
138 Var x ->
139 Map.findWithDefault tipe x typeTable
141 Record fields ext ->
142 Record (map (second go) fields) (fmap go ext)
144 Aliased original args t' ->
145 Aliased original (map (second go) args) t'
147 Type _ ->
148 tipe
150 App f args ->
151 App (go f) (map go args)
155-- COLLECT LAMBDAS
158collectLambdas :: Canonical -> [Canonical]
159collectLambdas tipe =
160 case tipe of
161 Lambda arg result ->
162 arg : collectLambdas result
164 _ ->
165 [tipe]
169-- BINARY
172instance Binary Canonical where
173 put tipe =
174 case tipe of
175 Lambda t1 t2 ->
176 putWord8 0 >> put t1 >> put t2
178 Var x ->
179 putWord8 1 >> put x
181 Type name ->
182 putWord8 2 >> put name
184 App t1 t2 ->
185 putWord8 3 >> put t1 >> put t2
187 Record fs ext ->
188 putWord8 4 >> put fs >> put ext
190 Aliased var args t ->
191 putWord8 5 >> put var >> put args >> put t
193 get =
194 do n <- getWord8
195 case n of
196 0 -> Lambda <$> get <*> get
197 1 -> Var <$> get
198 2 -> Type <$> get
199 3 -> App <$> get <*> get
200 4 -> Record <$> get <*> get
201 5 -> Aliased <$> get <*> get <*> get
202 _ -> error "Error reading a valid type from serialized string"
205instance Binary t => Binary (Aliased t) where
206 put aliasType =
207 case aliasType of
208 Holey tipe ->
209 putWord8 0 >> put tipe
211 Filled tipe ->
212 putWord8 1 >> put tipe
214 get =
215 do n <- getWord8
216 case n of
217 0 -> Holey <$> get
218 1 -> Filled <$> get
219 _ -> error "Error reading a valid type from serialized string"