git.iko.soy/elk
on dca97ae help sign in
elk/src/AST/Type.hs
414 lines 8.9 kB history raw
1module AST.Type
2 ( Raw, Raw'(..)
3 , Canonical(..), Aliased(..)
4 , Port(..), portType
5 , deepDealias, dealias
6 , collectLambdas
7 , fieldMap
8 , tuple
9 ) where
11import Control.Applicative ((<$>), (<*>))
12import Control.Arrow (second)
13import Data.Binary
14import qualified Data.Map as Map
15import qualified Data.Maybe as Maybe
16import Text.PrettyPrint as P
18import qualified AST.Variable as Var
19import qualified AST.Helpers as Help
20import qualified Reporting.Annotation as A
21import qualified Reporting.PrettyPrint as P
22import qualified Reporting.Region as R
25-- DEFINITION
27type Raw =
28 A.Located Raw'
31data Raw'
32 = RLambda Raw Raw
33 | RVar String
34 | RType Var.Raw
35 | RApp Raw [Raw]
36 | RRecord [(String, Raw)] (Maybe Raw)
37 deriving (Show)
40data Canonical
41 = Lambda Canonical Canonical
42 | Var String
43 | Type Var.Canonical
44 | App Canonical [Canonical]
45 | Record [(String, Canonical)] (Maybe Canonical)
46 | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)
47 deriving (Eq, Ord, Show)
50data Aliased t
51 = Holey t
52 | Filled t
53 deriving (Eq, Ord, Show)
56data Port t
57 = Normal t
58 | Signal { root :: t, arg :: t }
59 deriving (Show)
62portType :: Port tipe -> tipe
63portType portType =
64 case portType of
65 Normal tipe -> tipe
66 Signal tipe _ -> tipe
69fieldMap :: [(String,a)] -> Map.Map String [a]
70fieldMap fields =
71 let add r (field,tipe) =
72 Map.insertWith (++) field [tipe] r
73 in
74 foldl add Map.empty fields
76{--
77recordOf :: [(String, Type var)] -> Type var
78recordOf fields =
79 Record fields Nothing
82listOf :: RawType -> RawType
83listOf tipe =
84 App (Type (Var.Raw "List")) [tipe]
85--}
87tuple :: R.Region -> [Raw] -> Raw
88tuple region types =
89 let name = Var.Raw ("_Tuple" ++ show (length types))
90 in
91 A.A region (RApp (A.A region (RType name)) types)
94-- DEALIASING
96deepDealias :: Canonical -> Canonical
97deepDealias tipe =
98 let go = deepDealias in
99 case tipe of
100 Lambda a b ->
101 Lambda (go a) (go b)
103 Var _ ->
104 tipe
106 Record fields ext ->
107 Record (map (second go) fields) (fmap go ext)
109 Aliased _name args tipe' ->
110 deepDealias (dealias args tipe')
112 Type _ ->
113 tipe
115 App f args ->
116 App (go f) (map go args)
119dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
120dealias args aliasType =
121 case aliasType of
122 Holey tipe ->
123 dealiasHelp (Map.fromList args) tipe
125 Filled tipe ->
126 tipe
129dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
130dealiasHelp typeTable tipe =
131 let go = dealiasHelp typeTable in
132 case tipe of
133 Lambda a b ->
134 Lambda (go a) (go b)
136 Var x ->
137 Map.findWithDefault tipe x typeTable
139 Record fields ext ->
140 Record (map (second go) fields) (fmap go ext)
142 Aliased original args t' ->
143 Aliased original (map (second go) args) t'
145 Type _ ->
146 tipe
148 App f args ->
149 App (go f) (map go args)
152-- PRETTY PRINTING
154instance (P.Pretty t) => P.Pretty (Port t) where
155 pretty needsParens portType =
156 case portType of
157 Normal tipe ->
158 P.pretty needsParens tipe
160 Signal tipe _ ->
161 P.pretty needsParens tipe
164instance P.Pretty Raw' where
165 pretty needsParens tipe =
166 case tipe of
167 RLambda arg body ->
168 P.parensIf needsParens (prettyLambda getRawLambda arg body)
170 RVar x ->
171 P.text x
173 RType var ->
174 prettyType var
176 RApp func args ->
177 let
178 isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)
179 isTuple _ = False
180 in
181 prettyApp needsParens isTuple func args
183 RRecord fields ext ->
184 prettyRecord (flattenRawRecord fields ext)
187instance P.Pretty Canonical where
188 pretty needsParens tipe =
189 case tipe of
190 Lambda arg body ->
191 P.parensIf needsParens (prettyLambda getCanLambda arg body)
193 Var x ->
194 P.text x
196 Type var ->
197 prettyType var
199 App func args ->
200 let
201 isTuple (Type name) = Help.isTuple (Var.toString name)
202 isTuple _ = False
203 in
204 prettyApp needsParens isTuple func args
206 Record fields ext ->
207 prettyRecord (flattenCanRecord fields ext)
209 Aliased name args _ ->
210 P.parensIf (needsParens && not (null args)) $
211 P.hang
212 (P.pretty False name)
213 2
214 (P.sep (map (P.pretty True . snd) args))
217-- PRETTY HELPERS
219prettyType :: (Var.ToString var) => var -> P.Doc
220prettyType var =
221 let
222 v = Var.toString var
223 in
224 P.text (if v == "_Tuple0" then "()" else v)
227-- PRETTY LAMBDAS
229prettyLambda :: (P.Pretty t) => (t -> Maybe (t,t)) -> t -> t -> P.Doc
230prettyLambda getLambda arg body =
231 let
232 rest =
233 gatherLambda getLambda body
235 prettyArg t =
236 P.pretty (Maybe.isJust (getLambda t)) t
237 in
238 P.sep
239 [ prettyArg arg
240 , P.sep (map (\t -> P.text "->" <+> prettyArg t) rest)
241 ]
244getRawLambda :: Raw -> Maybe (Raw, Raw)
245getRawLambda (A.A _ tipe) =
246 case tipe of
247 RLambda arg body -> Just (arg, body)
248 _ -> Nothing
251getCanLambda :: Canonical -> Maybe (Canonical, Canonical)
252getCanLambda tipe =
253 case tipe of
254 Lambda arg body -> Just (arg, body)
255 _ -> Nothing
258gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]
259gatherLambda get tipe =
260 case get tipe of
261 Just (arg, body) ->
262 arg : gatherLambda get body
264 Nothing ->
265 [tipe]
268collectLambdas :: Canonical -> [Canonical]
269collectLambdas tipe =
270 gatherLambda getCanLambda tipe
273-- PRETTY APP
275prettyApp :: (P.Pretty t) => Bool -> (t -> Bool) -> t -> [t] -> P.Doc
276prettyApp needsParens isTuple func args
277 | isTuple func =
278 P.parens $ P.sep $
279 P.punctuate P.comma (map (P.pretty False) args)
281 | null args =
282 P.pretty needsParens func
284 | otherwise =
285 P.parensIf needsParens $
286 P.hang
287 (P.pretty True func)
288 2
289 (P.sep (map (P.pretty True) args))
292-- PRETTY RECORD
294prettyRecord :: (P.Pretty t) => ([(String, t)], Maybe String) -> P.Doc
295prettyRecord recordInfo =
296 let
297 prettyField (field, tipe) =
298 P.hang
299 (P.text field <+> P.text ":")
300 4
301 (P.pretty False tipe)
302 in
303 case recordInfo of
304 ([], Nothing) ->
305 P.text "{}"
307 (fields, Nothing) ->
308 P.sep
309 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
310 , P.rbrace
311 ]
313 (fields, Just x) ->
314 P.hang
315 (P.lbrace <+> P.text x <+> P.text "|")
316 4
317 (P.sep
318 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
319 , P.rbrace
320 ]
321 )
324flattenRawRecord
325 :: [(String, Raw)]
326 -> Maybe Raw
327 -> ( [(String, Raw)], Maybe String )
328flattenRawRecord fields ext =
329 case ext of
330 Nothing ->
331 (fields, Nothing)
333 Just (A.A _ (RVar x)) ->
334 (fields, Just x)
336 Just (A.A _ (RRecord fields' ext')) ->
337 flattenRawRecord (fields' ++ fields) ext'
339 _ ->
340 error "Trying to flatten ill-formed record."
343flattenCanRecord
344 :: [(String, Canonical)]
345 -> Maybe Canonical
346 -> ( [(String, Canonical)], Maybe String )
347flattenCanRecord fields ext =
348 case ext of
349 Nothing ->
350 (fields, Nothing)
352 Just (Var x) ->
353 (fields, Just x)
355 Just (Record fields' ext') ->
356 flattenCanRecord (fields' ++ fields) ext'
358 Just (Aliased _ args tipe) ->
359 flattenCanRecord fields (Just (dealias args tipe))
361 _ ->
362 error "Trying to flatten ill-formed record."
365-- BINARY
367instance Binary Canonical where
368 put tipe =
369 case tipe of
370 Lambda t1 t2 ->
371 putWord8 0 >> put t1 >> put t2
373 Var x ->
374 putWord8 1 >> put x
376 Type name ->
377 putWord8 2 >> put name
379 App t1 t2 ->
380 putWord8 3 >> put t1 >> put t2
382 Record fs ext ->
383 putWord8 4 >> put fs >> put ext
385 Aliased var args t ->
386 putWord8 5 >> put var >> put args >> put t
388 get = do
389 n <- getWord8
390 case n of
391 0 -> Lambda <$> get <*> get
392 1 -> Var <$> get
393 2 -> Type <$> get
394 3 -> App <$> get <*> get
395 4 -> Record <$> get <*> get
396 5 -> Aliased <$> get <*> get <*> get
397 _ -> error "Error reading a valid type from serialized string"
400instance Binary t => Binary (Aliased t) where
401 put aliasType =
402 case aliasType of
403 Holey tipe ->
404 putWord8 0 >> put tipe
406 Filled tipe ->
407 putWord8 1 >> put tipe
409 get = do
410 n <- getWord8
411 case n of
412 0 -> Holey <$> get
413 1 -> Filled <$> get
414 _ -> error "Error reading a valid type from serialized string"