git.iko.soy/elk
on 74db13f help sign in
elk/src/AST/Type.hs
224 lines 4.4 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 name = Var.Raw ("_Tuple" ++ show (length types))
67 in
68 A.A region (RApp (A.A region (RType name)) types)
72-- DEALIASING
75deepDealias :: Canonical -> Canonical
76deepDealias tipe =
77 case tipe of
78 Lambda a b ->
79 Lambda (deepDealias a) (deepDealias b)
81 Var _ ->
82 tipe
84 Record fields ext ->
85 Record (map (second deepDealias) fields) (fmap deepDealias ext)
87 Aliased _name args tipe' ->
88 deepDealias (dealias args tipe')
90 Type _ ->
91 tipe
93 App f args ->
94 App (deepDealias f) (map deepDealias args)
97iteratedDealias :: Canonical -> Canonical
98iteratedDealias tipe =
99 case tipe of
100 Aliased _ args realType ->
101 iteratedDealias (dealias args realType)
103 _ ->
104 tipe
107dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
108dealias args aliasType =
109 case aliasType of
110 Holey tipe ->
111 dealiasHelp (Map.fromList args) tipe
113 Filled tipe ->
114 tipe
117dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
118dealiasHelp typeTable tipe =
119 let go = dealiasHelp typeTable in
120 case tipe of
121 Lambda a b ->
122 Lambda (go a) (go b)
124 Var x ->
125 Map.findWithDefault tipe x typeTable
127 Record fields ext ->
128 Record (map (second go) fields) (fmap go ext)
130 Aliased original args t' ->
131 Aliased original (map (second go) args) t'
133 Type _ ->
134 tipe
136 App f args ->
137 App (go f) (map go args)
141-- COLLECT LAMBDAS
144collectLambdas :: Canonical -> [Canonical]
145collectLambdas tipe =
146 gatherLambda getCanLambda tipe
149gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]
150gatherLambda get tipe =
151 case get tipe of
152 Just (arg, body) ->
153 arg : gatherLambda get body
155 Nothing ->
156 [tipe]
159getRawLambda :: Raw -> Maybe (Raw, Raw)
160getRawLambda (A.A _ tipe) =
161 case tipe of
162 RLambda arg body -> Just (arg, body)
163 _ -> Nothing
166getCanLambda :: Canonical -> Maybe (Canonical, Canonical)
167getCanLambda tipe =
168 case tipe of
169 Lambda arg body -> Just (arg, body)
170 _ -> Nothing
174-- BINARY
177instance Binary Canonical where
178 put tipe =
179 case tipe of
180 Lambda t1 t2 ->
181 putWord8 0 >> put t1 >> put t2
183 Var x ->
184 putWord8 1 >> put x
186 Type name ->
187 putWord8 2 >> put name
189 App t1 t2 ->
190 putWord8 3 >> put t1 >> put t2
192 Record fs ext ->
193 putWord8 4 >> put fs >> put ext
195 Aliased var args t ->
196 putWord8 5 >> put var >> put args >> put t
198 get = do
199 n <- getWord8
200 case n of
201 0 -> Lambda <$> get <*> get
202 1 -> Var <$> get
203 2 -> Type <$> get
204 3 -> App <$> get <*> get
205 4 -> Record <$> get <*> get
206 5 -> Aliased <$> get <*> get <*> get
207 _ -> error "Error reading a valid type from serialized string"
210instance Binary t => Binary (Aliased t) where
211 put aliasType =
212 case aliasType of
213 Holey tipe ->
214 putWord8 0 >> put tipe
216 Filled tipe ->
217 putWord8 1 >> put tipe
219 get = do
220 n <- getWord8
221 case n of
222 0 -> Holey <$> get
223 1 -> Filled <$> get
224 _ -> error "Error reading a valid type from serialized string"