git.iko.soy/elk
on 84bfb4e help sign in
elk/src/AST/Type.hs
412 lines 9.1 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.Arrow (second)
12import Data.Binary
13import qualified Data.Map as Map
14import qualified Data.Maybe as Maybe
15import Text.PrettyPrint as P
17import qualified AST.Variable as Var
18import qualified AST.Helpers as Help
19import qualified Reporting.Annotation as A
20import qualified Reporting.PrettyPrint as P
21import qualified Reporting.Region as R
24-- DEFINITION
26type Raw =
27 A.Located Raw'
30data Raw'
31 = RLambda Raw Raw
32 | RVar String
33 | RType Var.Raw
34 | RApp Raw [Raw]
35 | RRecord [(String, Raw)] (Maybe Raw)
36 deriving (Show)
39data Canonical
40 = Lambda Canonical Canonical
41 | Var String
42 | Type Var.Canonical
43 | App Canonical [Canonical]
44 | Record [(String, Canonical)] (Maybe Canonical)
45 | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)
46 deriving (Eq, Ord, Show)
49data Aliased t
50 = Holey t
51 | Filled t
52 deriving (Eq, Ord, Show)
55data Port t
56 = Normal t
57 | Signal { root :: t, arg :: t }
58 deriving (Eq, Show)
61getPortType :: Port tipe -> tipe
62getPortType portType =
63 case portType of
64 Normal tipe -> tipe
65 Signal tipe _ -> tipe
68fieldMap :: [(String,a)] -> Map.Map String [a]
69fieldMap fields =
70 let add r (field,tipe) =
71 Map.insertWith (++) field [tipe] r
72 in
73 foldl add Map.empty fields
75{--
76recordOf :: [(String, Type var)] -> Type var
77recordOf fields =
78 Record fields Nothing
81listOf :: RawType -> RawType
82listOf tipe =
83 App (Type (Var.Raw "List")) [tipe]
84--}
86tuple :: R.Region -> [Raw] -> Raw
87tuple region types =
88 let name = Var.Raw ("_Tuple" ++ show (length types))
89 in
90 A.A region (RApp (A.A region (RType name)) types)
93-- DEALIASING
95deepDealias :: Canonical -> Canonical
96deepDealias tipe =
97 let go = deepDealias in
98 case tipe of
99 Lambda a b ->
100 Lambda (go a) (go b)
102 Var _ ->
103 tipe
105 Record fields ext ->
106 Record (map (second go) fields) (fmap go ext)
108 Aliased _name args tipe' ->
109 deepDealias (dealias args tipe')
111 Type _ ->
112 tipe
114 App f args ->
115 App (go f) (map go args)
118dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
119dealias args aliasType =
120 case aliasType of
121 Holey tipe ->
122 dealiasHelp (Map.fromList args) tipe
124 Filled tipe ->
125 tipe
128dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
129dealiasHelp typeTable tipe =
130 let go = dealiasHelp typeTable in
131 case tipe of
132 Lambda a b ->
133 Lambda (go a) (go b)
135 Var x ->
136 Map.findWithDefault tipe x typeTable
138 Record fields ext ->
139 Record (map (second go) fields) (fmap go ext)
141 Aliased original args t' ->
142 Aliased original (map (second go) args) t'
144 Type _ ->
145 tipe
147 App f args ->
148 App (go f) (map go args)
151-- PRETTY PRINTING
153instance (P.Pretty t) => P.Pretty (Port t) where
154 pretty dealiaser needsParens portType =
155 P.pretty dealiaser needsParens (getPortType portType)
158instance P.Pretty Raw' where
159 pretty dealiaser needsParens tipe =
160 case tipe of
161 RLambda arg body ->
162 P.parensIf needsParens (prettyLambda dealiaser getRawLambda arg body)
164 RVar x ->
165 P.text x
167 RType var ->
168 prettyType dealiaser var
170 RApp func args ->
171 let
172 isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)
173 isTuple _ = False
174 in
175 prettyApp dealiaser needsParens isTuple func args
177 RRecord fields ext ->
178 prettyRecord dealiaser (flattenRawRecord fields ext)
181instance P.Pretty Canonical where
182 pretty dealiaser needsParens tipe =
183 case tipe of
184 Lambda arg body ->
185 P.parensIf needsParens (prettyLambda dealiaser getCanLambda arg body)
187 Var x ->
188 P.text x
190 Type var ->
191 prettyType dealiaser var
193 App func args ->
194 let
195 isTuple (Type name) = Help.isTuple (Var.toString name)
196 isTuple _ = False
197 in
198 prettyApp dealiaser needsParens isTuple func args
200 Record fields ext ->
201 prettyRecord dealiaser (flattenCanRecord fields ext)
203 Aliased name args _ ->
204 P.parensIf (needsParens && not (null args)) $
205 P.hang
206 (P.pretty dealiaser False name)
207 2
208 (P.sep (map (P.pretty dealiaser True . snd) args))
211-- PRETTY HELPERS
213prettyType :: (Var.ToString var) => P.Dealiaser -> var -> P.Doc
214prettyType dealiaser var =
215 let
216 v = Var.toString var
217 in
218 P.text $
219 if v == "_Tuple0" then
220 "()"
221 else
222 maybe v id (Map.lookup v dealiaser)
225-- PRETTY LAMBDAS
227prettyLambda :: (P.Pretty t) => P.Dealiaser -> (t -> Maybe (t,t)) -> t -> t -> P.Doc
228prettyLambda dealiaser getLambda arg body =
229 let
230 rest =
231 gatherLambda getLambda body
233 prettyArg t =
234 P.pretty dealiaser (Maybe.isJust (getLambda t)) t
235 in
236 P.sep
237 [ prettyArg arg
238 , P.sep (map (\t -> P.text "->" <+> prettyArg t) rest)
239 ]
242getRawLambda :: Raw -> Maybe (Raw, Raw)
243getRawLambda (A.A _ tipe) =
244 case tipe of
245 RLambda arg body -> Just (arg, body)
246 _ -> Nothing
249getCanLambda :: Canonical -> Maybe (Canonical, Canonical)
250getCanLambda tipe =
251 case tipe of
252 Lambda arg body -> Just (arg, body)
253 _ -> Nothing
256gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]
257gatherLambda get tipe =
258 case get tipe of
259 Just (arg, body) ->
260 arg : gatherLambda get body
262 Nothing ->
263 [tipe]
266collectLambdas :: Canonical -> [Canonical]
267collectLambdas tipe =
268 gatherLambda getCanLambda tipe
271-- PRETTY APP
273prettyApp :: (P.Pretty t) => P.Dealiaser -> Bool -> (t -> Bool) -> t -> [t] -> P.Doc
274prettyApp dealiaser needsParens isTuple func args
275 | isTuple func =
276 P.parens $ P.sep $
277 P.punctuate P.comma (map (P.pretty dealiaser False) args)
279 | null args =
280 P.pretty dealiaser needsParens func
282 | otherwise =
283 P.parensIf needsParens $
284 P.hang
285 (P.pretty dealiaser True func)
286 2
287 (P.sep (map (P.pretty dealiaser True) args))
290-- PRETTY RECORD
292prettyRecord :: (P.Pretty t) => P.Dealiaser -> ([(String, t)], Maybe String) -> P.Doc
293prettyRecord dealiaser recordInfo =
294 let
295 prettyField (field, tipe) =
296 P.hang
297 (P.text field <+> P.text ":")
298 4
299 (P.pretty dealiaser False tipe)
300 in
301 case recordInfo of
302 ([], Nothing) ->
303 P.text "{}"
305 (fields, Nothing) ->
306 P.sep
307 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
308 , P.rbrace
309 ]
311 (fields, Just x) ->
312 P.hang
313 (P.lbrace <+> P.text x <+> P.text "|")
314 4
315 (P.sep
316 [ P.sep (P.punctuate P.comma (map prettyField fields))
317 , P.rbrace
318 ]
319 )
322flattenRawRecord
323 :: [(String, Raw)]
324 -> Maybe Raw
325 -> ( [(String, Raw)], Maybe String )
326flattenRawRecord fields ext =
327 case ext of
328 Nothing ->
329 (fields, Nothing)
331 Just (A.A _ (RVar x)) ->
332 (fields, Just x)
334 Just (A.A _ (RRecord fields' ext')) ->
335 flattenRawRecord (fields' ++ fields) ext'
337 _ ->
338 error "Trying to flatten ill-formed record."
341flattenCanRecord
342 :: [(String, Canonical)]
343 -> Maybe Canonical
344 -> ( [(String, Canonical)], Maybe String )
345flattenCanRecord fields ext =
346 case ext of
347 Nothing ->
348 (fields, Nothing)
350 Just (Var x) ->
351 (fields, Just x)
353 Just (Record fields' ext') ->
354 flattenCanRecord (fields' ++ fields) ext'
356 Just (Aliased _ args tipe) ->
357 flattenCanRecord fields (Just (dealias args tipe))
359 _ ->
360 error "Trying to flatten ill-formed record."
363-- BINARY
365instance Binary Canonical where
366 put tipe =
367 case tipe of
368 Lambda t1 t2 ->
369 putWord8 0 >> put t1 >> put t2
371 Var x ->
372 putWord8 1 >> put x
374 Type name ->
375 putWord8 2 >> put name
377 App t1 t2 ->
378 putWord8 3 >> put t1 >> put t2
380 Record fs ext ->
381 putWord8 4 >> put fs >> put ext
383 Aliased var args t ->
384 putWord8 5 >> put var >> put args >> put t
386 get = do
387 n <- getWord8
388 case n of
389 0 -> Lambda <$> get <*> get
390 1 -> Var <$> get
391 2 -> Type <$> get
392 3 -> App <$> get <*> get
393 4 -> Record <$> get <*> get
394 5 -> Aliased <$> get <*> get <*> get
395 _ -> error "Error reading a valid type from serialized string"
398instance Binary t => Binary (Aliased t) where
399 put aliasType =
400 case aliasType of
401 Holey tipe ->
402 putWord8 0 >> put tipe
404 Filled tipe ->
405 putWord8 1 >> put tipe
407 get = do
408 n <- getWord8
409 case n of
410 0 -> Holey <$> get
411 1 -> Filled <$> get
412 _ -> error "Error reading a valid type from serialized string"