git.iko.soy/elk
on ba5bfd2 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 , deepDealias, iteratedDealias, dealias
5 , collectLambdas
6 , tuple
7 ) where
9import Control.Arrow (second)
10import Data.Binary
11import qualified Data.Map as Map
12import qualified Data.Set as Set
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)
34 | REffects [A.Located ModuleName.Raw]
37data Canonical
38 = Lambda Canonical Canonical
39 | Var String
40 | Type Var.Canonical
41 | App Canonical [Canonical]
42 | Record [(String, Canonical)] (Maybe Canonical)
43 | Effects (Set.Set ModuleName.Canonical)
44 | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)
45 deriving (Eq, Ord)
48data Aliased t
49 = Holey t
50 | Filled t
51 deriving (Eq, Ord)
54tuple :: R.Region -> [Raw] -> Raw
55tuple region types =
56 let
57 name =
58 Var.Raw ("_Tuple" ++ show (length types))
59 in
60 A.A region (RApp (A.A region (RType name)) types)
64-- DEALIASING
67deepDealias :: Canonical -> Canonical
68deepDealias tipe =
69 case tipe of
70 Lambda a b ->
71 Lambda (deepDealias a) (deepDealias b)
73 Var _ ->
74 tipe
76 Record fields ext ->
77 Record (map (second deepDealias) fields) (fmap deepDealias ext)
79 Aliased _name args tipe' ->
80 deepDealias (dealias args tipe')
82 Type _ ->
83 tipe
85 App f args ->
86 App (deepDealias f) (map deepDealias args)
88 Effects _ ->
89 tipe
92iteratedDealias :: Canonical -> Canonical
93iteratedDealias tipe =
94 case tipe of
95 Aliased _ args realType ->
96 iteratedDealias (dealias args realType)
98 _ ->
99 tipe
102dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
103dealias args aliasType =
104 case aliasType of
105 Holey tipe ->
106 dealiasHelp (Map.fromList args) tipe
108 Filled tipe ->
109 tipe
112dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
113dealiasHelp typeTable tipe =
114 let
115 go =
116 dealiasHelp typeTable
117 in
118 case tipe of
119 Lambda a b ->
120 Lambda (go a) (go b)
122 Var x ->
123 Map.findWithDefault tipe x typeTable
125 Record fields ext ->
126 Record (map (second go) fields) (fmap go ext)
128 Aliased original args t' ->
129 Aliased original (map (second go) args) t'
131 Type _ ->
132 tipe
134 App f args ->
135 App (go f) (map go args)
137 Effects _ ->
138 tipe
142-- COLLECT LAMBDAS
145collectLambdas :: Canonical -> [Canonical]
146collectLambdas tipe =
147 case tipe of
148 Lambda arg result ->
149 arg : collectLambdas result
151 _ ->
152 [tipe]
156-- BINARY
159instance Binary Canonical where
160 put tipe =
161 case tipe of
162 Lambda t1 t2 ->
163 putWord8 0 >> put t1 >> put t2
165 Var x ->
166 putWord8 1 >> put x
168 Type name ->
169 putWord8 2 >> put name
171 App t1 t2 ->
172 putWord8 3 >> put t1 >> put t2
174 Record fs ext ->
175 putWord8 4 >> put fs >> put ext
177 Effects names ->
178 putWord8 5 >> put names
180 Aliased var args t ->
181 putWord8 6 >> put var >> put args >> put t
183 get =
184 do n <- getWord8
185 case n of
186 0 -> Lambda <$> get <*> get
187 1 -> Var <$> get
188 2 -> Type <$> get
189 3 -> App <$> get <*> get
190 4 -> Record <$> get <*> get
191 5 -> Effects <$> get
192 6 -> 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"