git.iko.soy/elk
on ff98144 help sign in
elk/src/AST/Type.hs
413 lines 9.2 kB history raw
1module AST.Type
2 ( Raw, Raw'(..)
3 , Canonical(..), Aliased(..)
4 , Port(..), getPortType
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)
62getPortType :: Port tipe -> tipe
63getPortType 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 dealiaser needsParens portType =
156 P.pretty dealiaser needsParens (getPortType portType)
159instance P.Pretty Raw' where
160 pretty dealiaser needsParens tipe =
161 case tipe of
162 RLambda arg body ->
163 P.parensIf needsParens (prettyLambda dealiaser getRawLambda arg body)
165 RVar x ->
166 P.text x
168 RType var ->
169 prettyType dealiaser var
171 RApp func args ->
172 let
173 isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)
174 isTuple _ = False
175 in
176 prettyApp dealiaser needsParens isTuple func args
178 RRecord fields ext ->
179 prettyRecord dealiaser (flattenRawRecord fields ext)
182instance P.Pretty Canonical where
183 pretty dealiaser needsParens tipe =
184 case tipe of
185 Lambda arg body ->
186 P.parensIf needsParens (prettyLambda dealiaser getCanLambda arg body)
188 Var x ->
189 P.text x
191 Type var ->
192 prettyType dealiaser var
194 App func args ->
195 let
196 isTuple (Type name) = Help.isTuple (Var.toString name)
197 isTuple _ = False
198 in
199 prettyApp dealiaser needsParens isTuple func args
201 Record fields ext ->
202 prettyRecord dealiaser (flattenCanRecord fields ext)
204 Aliased name args _ ->
205 P.parensIf (needsParens && not (null args)) $
206 P.hang
207 (P.pretty dealiaser False name)
208 2
209 (P.sep (map (P.pretty dealiaser True . snd) args))
212-- PRETTY HELPERS
214prettyType :: (Var.ToString var) => P.Dealiaser -> var -> P.Doc
215prettyType dealiaser var =
216 let
217 v = Var.toString var
218 in
219 P.text $
220 if v == "_Tuple0" then
221 "()"
222 else
223 maybe v id (Map.lookup v dealiaser)
226-- PRETTY LAMBDAS
228prettyLambda :: (P.Pretty t) => P.Dealiaser -> (t -> Maybe (t,t)) -> t -> t -> P.Doc
229prettyLambda dealiaser getLambda arg body =
230 let
231 rest =
232 gatherLambda getLambda body
234 prettyArg t =
235 P.pretty dealiaser (Maybe.isJust (getLambda t)) t
236 in
237 P.sep
238 [ prettyArg arg
239 , P.sep (map (\t -> P.text "->" <+> prettyArg t) rest)
240 ]
243getRawLambda :: Raw -> Maybe (Raw, Raw)
244getRawLambda (A.A _ tipe) =
245 case tipe of
246 RLambda arg body -> Just (arg, body)
247 _ -> Nothing
250getCanLambda :: Canonical -> Maybe (Canonical, Canonical)
251getCanLambda tipe =
252 case tipe of
253 Lambda arg body -> Just (arg, body)
254 _ -> Nothing
257gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]
258gatherLambda get tipe =
259 case get tipe of
260 Just (arg, body) ->
261 arg : gatherLambda get body
263 Nothing ->
264 [tipe]
267collectLambdas :: Canonical -> [Canonical]
268collectLambdas tipe =
269 gatherLambda getCanLambda tipe
272-- PRETTY APP
274prettyApp :: (P.Pretty t) => P.Dealiaser -> Bool -> (t -> Bool) -> t -> [t] -> P.Doc
275prettyApp dealiaser needsParens isTuple func args
276 | isTuple func =
277 P.parens $ P.sep $
278 P.punctuate P.comma (map (P.pretty dealiaser False) args)
280 | null args =
281 P.pretty dealiaser needsParens func
283 | otherwise =
284 P.parensIf needsParens $
285 P.hang
286 (P.pretty dealiaser True func)
287 2
288 (P.sep (map (P.pretty dealiaser True) args))
291-- PRETTY RECORD
293prettyRecord :: (P.Pretty t) => P.Dealiaser -> ([(String, t)], Maybe String) -> P.Doc
294prettyRecord dealiaser recordInfo =
295 let
296 prettyField (field, tipe) =
297 P.hang
298 (P.text field <+> P.text ":")
299 4
300 (P.pretty dealiaser False tipe)
301 in
302 case recordInfo of
303 ([], Nothing) ->
304 P.text "{}"
306 (fields, Nothing) ->
307 P.sep
308 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
309 , P.rbrace
310 ]
312 (fields, Just x) ->
313 P.hang
314 (P.lbrace <+> P.text x <+> P.text "|")
315 4
316 (P.sep
317 [ P.sep (P.punctuate P.comma (map prettyField fields))
318 , P.rbrace
319 ]
320 )
323flattenRawRecord
324 :: [(String, Raw)]
325 -> Maybe Raw
326 -> ( [(String, Raw)], Maybe String )
327flattenRawRecord fields ext =
328 case ext of
329 Nothing ->
330 (fields, Nothing)
332 Just (A.A _ (RVar x)) ->
333 (fields, Just x)
335 Just (A.A _ (RRecord fields' ext')) ->
336 flattenRawRecord (fields' ++ fields) ext'
338 _ ->
339 error "Trying to flatten ill-formed record."
342flattenCanRecord
343 :: [(String, Canonical)]
344 -> Maybe Canonical
345 -> ( [(String, Canonical)], Maybe String )
346flattenCanRecord fields ext =
347 case ext of
348 Nothing ->
349 (fields, Nothing)
351 Just (Var x) ->
352 (fields, Just x)
354 Just (Record fields' ext') ->
355 flattenCanRecord (fields' ++ fields) ext'
357 Just (Aliased _ args tipe) ->
358 flattenCanRecord fields (Just (dealias args tipe))
360 _ ->
361 error "Trying to flatten ill-formed record."
364-- BINARY
366instance Binary Canonical where
367 put tipe =
368 case tipe of
369 Lambda t1 t2 ->
370 putWord8 0 >> put t1 >> put t2
372 Var x ->
373 putWord8 1 >> put x
375 Type name ->
376 putWord8 2 >> put name
378 App t1 t2 ->
379 putWord8 3 >> put t1 >> put t2
381 Record fs ext ->
382 putWord8 4 >> put fs >> put ext
384 Aliased var args t ->
385 putWord8 5 >> put var >> put args >> put t
387 get = do
388 n <- getWord8
389 case n of
390 0 -> Lambda <$> get <*> get
391 1 -> Var <$> get
392 2 -> Type <$> get
393 3 -> App <$> get <*> get
394 4 -> Record <$> get <*> get
395 5 -> Aliased <$> get <*> get <*> get
396 _ -> error "Error reading a valid type from serialized string"
399instance Binary t => Binary (Aliased t) where
400 put aliasType =
401 case aliasType of
402 Holey tipe ->
403 putWord8 0 >> put tipe
405 Filled tipe ->
406 putWord8 1 >> put tipe
408 get = do
409 n <- getWord8
410 case n of
411 0 -> Holey <$> get
412 1 -> Filled <$> get
413 _ -> error "Error reading a valid type from serialized string"