git.iko.soy/elk
on ccc6bc5 help sign in
elk/src/AST/Type.hs
196 lines 3.7 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
13import qualified AST.Variable as Var
14import qualified Reporting.Annotation as A
15import qualified Reporting.Region as R
19-- DEFINITION
22type Raw =
23 A.Located Raw'
26data Raw'
27 = RLambda Raw Raw
28 | RVar String
29 | RType Var.Raw
30 | RApp Raw [Raw]
31 | RRecord [(String, Raw)] (Maybe Raw)
34data Canonical
35 = Lambda Canonical Canonical
36 | Var String
37 | Type Var.Canonical
38 | App Canonical [Canonical]
39 | Record [(String, Canonical)] (Maybe Canonical)
40 | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)
41 deriving (Eq, Ord)
44data Aliased t
45 = Holey t
46 | Filled t
47 deriving (Eq, Ord)
50tuple :: R.Region -> [Raw] -> Raw
51tuple region types =
52 let
53 name =
54 Var.Raw ("_Tuple" ++ show (length types))
55 in
56 A.A region (RApp (A.A region (RType name)) types)
60-- DEALIASING
63deepDealias :: Canonical -> Canonical
64deepDealias tipe =
65 case tipe of
66 Lambda a b ->
67 Lambda (deepDealias a) (deepDealias b)
69 Var _ ->
70 tipe
72 Record fields ext ->
73 Record (map (second deepDealias) fields) (fmap deepDealias ext)
75 Aliased _name args tipe' ->
76 deepDealias (dealias args tipe')
78 Type _ ->
79 tipe
81 App f args ->
82 App (deepDealias f) (map deepDealias args)
85iteratedDealias :: Canonical -> Canonical
86iteratedDealias tipe =
87 case tipe of
88 Aliased _ args realType ->
89 iteratedDealias (dealias args realType)
91 _ ->
92 tipe
95dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
96dealias args aliasType =
97 case aliasType of
98 Holey tipe ->
99 dealiasHelp (Map.fromList args) tipe
101 Filled tipe ->
102 tipe
105dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
106dealiasHelp typeTable tipe =
107 let
108 go =
109 dealiasHelp typeTable
110 in
111 case tipe of
112 Lambda a b ->
113 Lambda (go a) (go b)
115 Var x ->
116 Map.findWithDefault tipe x typeTable
118 Record fields ext ->
119 Record (map (second go) fields) (fmap go ext)
121 Aliased original args t' ->
122 Aliased original (map (second go) args) t'
124 Type _ ->
125 tipe
127 App f args ->
128 App (go f) (map go args)
132-- COLLECT LAMBDAS
135collectLambdas :: Canonical -> [Canonical]
136collectLambdas tipe =
137 case tipe of
138 Lambda arg result ->
139 arg : collectLambdas result
141 _ ->
142 [tipe]
146-- BINARY
149instance Binary Canonical where
150 put tipe =
151 case tipe of
152 Lambda t1 t2 ->
153 putWord8 0 >> put t1 >> put t2
155 Var x ->
156 putWord8 1 >> put x
158 Type name ->
159 putWord8 2 >> put name
161 App t1 t2 ->
162 putWord8 3 >> put t1 >> put t2
164 Record fs ext ->
165 putWord8 4 >> put fs >> put ext
167 Aliased var args t ->
168 putWord8 5 >> put var >> put args >> put t
170 get =
171 do n <- getWord8
172 case n of
173 0 -> Lambda <$> get <*> get
174 1 -> Var <$> get
175 2 -> Type <$> get
176 3 -> App <$> get <*> get
177 4 -> Record <$> get <*> get
178 5 -> Aliased <$> get <*> get <*> get
179 _ -> error "Error reading a valid type from serialized string"
182instance Binary t => Binary (Aliased t) where
183 put aliasType =
184 case aliasType of
185 Holey tipe ->
186 putWord8 0 >> put tipe
188 Filled tipe ->
189 putWord8 1 >> put tipe
191 get =
192 do n <- getWord8
193 case n of
194 0 -> Holey <$> get
195 1 -> Filled <$> get
196 _ -> error "Error reading a valid type from serialized string"