git.iko.soy/elk
on 54dfb21 help sign in
elk/src/AST/Type.hs
411 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 case tipe of
98 Lambda a b ->
99 Lambda (deepDealias a) (deepDealias b)
101 Var _ ->
102 tipe
104 Record fields ext ->
105 Record (map (second deepDealias) fields) (fmap deepDealias ext)
107 Aliased _name args tipe' ->
108 deepDealias (dealias args tipe')
110 Type _ ->
111 tipe
113 App f args ->
114 App (deepDealias f) (map deepDealias args)
117dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
118dealias args aliasType =
119 case aliasType of
120 Holey tipe ->
121 dealiasHelp (Map.fromList args) tipe
123 Filled tipe ->
124 tipe
127dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
128dealiasHelp typeTable tipe =
129 let go = dealiasHelp typeTable in
130 case tipe of
131 Lambda a b ->
132 Lambda (go a) (go b)
134 Var x ->
135 Map.findWithDefault tipe x typeTable
137 Record fields ext ->
138 Record (map (second go) fields) (fmap go ext)
140 Aliased original args t' ->
141 Aliased original (map (second go) args) t'
143 Type _ ->
144 tipe
146 App f args ->
147 App (go f) (map go args)
150-- PRETTY PRINTING
152instance (P.Pretty t) => P.Pretty (Port t) where
153 pretty dealiaser needsParens portType =
154 P.pretty dealiaser needsParens (getPortType portType)
157instance P.Pretty Raw' where
158 pretty dealiaser needsParens tipe =
159 case tipe of
160 RLambda arg body ->
161 P.parensIf needsParens (prettyLambda dealiaser getRawLambda arg body)
163 RVar x ->
164 P.text x
166 RType var ->
167 prettyType dealiaser var
169 RApp func args ->
170 let
171 isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)
172 isTuple _ = False
173 in
174 prettyApp dealiaser needsParens isTuple func args
176 RRecord fields ext ->
177 prettyRecord dealiaser (flattenRawRecord fields ext)
180instance P.Pretty Canonical where
181 pretty dealiaser needsParens tipe =
182 case tipe of
183 Lambda arg body ->
184 P.parensIf needsParens (prettyLambda dealiaser getCanLambda arg body)
186 Var x ->
187 P.text x
189 Type var ->
190 prettyType dealiaser var
192 App func args ->
193 let
194 isTuple (Type name) = Help.isTuple (Var.toString name)
195 isTuple _ = False
196 in
197 prettyApp dealiaser needsParens isTuple func args
199 Record fields ext ->
200 prettyRecord dealiaser (flattenCanRecord fields ext)
202 Aliased name args _ ->
203 P.parensIf (needsParens && not (null args)) $
204 P.hang
205 (P.pretty dealiaser False name)
206 2
207 (P.sep (map (P.pretty dealiaser True . snd) args))
210-- PRETTY HELPERS
212prettyType :: (Var.ToString var) => P.Dealiaser -> var -> P.Doc
213prettyType dealiaser var =
214 let
215 v = Var.toString var
216 in
217 P.text $
218 if v == "_Tuple0" then
219 "()"
220 else
221 maybe v id (Map.lookup v dealiaser)
224-- PRETTY LAMBDAS
226prettyLambda :: (P.Pretty t) => P.Dealiaser -> (t -> Maybe (t,t)) -> t -> t -> P.Doc
227prettyLambda dealiaser getLambda arg body =
228 let
229 rest =
230 gatherLambda getLambda body
232 prettyArg t =
233 P.pretty dealiaser (Maybe.isJust (getLambda t)) t
234 in
235 P.sep
236 [ prettyArg arg
237 , P.sep (map (\t -> P.text "->" <+> prettyArg t) rest)
238 ]
241getRawLambda :: Raw -> Maybe (Raw, Raw)
242getRawLambda (A.A _ tipe) =
243 case tipe of
244 RLambda arg body -> Just (arg, body)
245 _ -> Nothing
248getCanLambda :: Canonical -> Maybe (Canonical, Canonical)
249getCanLambda tipe =
250 case tipe of
251 Lambda arg body -> Just (arg, body)
252 _ -> Nothing
255gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]
256gatherLambda get tipe =
257 case get tipe of
258 Just (arg, body) ->
259 arg : gatherLambda get body
261 Nothing ->
262 [tipe]
265collectLambdas :: Canonical -> [Canonical]
266collectLambdas tipe =
267 gatherLambda getCanLambda tipe
270-- PRETTY APP
272prettyApp :: (P.Pretty t) => P.Dealiaser -> Bool -> (t -> Bool) -> t -> [t] -> P.Doc
273prettyApp dealiaser needsParens isTuple func args
274 | isTuple func =
275 P.parens $ P.sep $
276 P.punctuate P.comma (map (P.pretty dealiaser False) args)
278 | null args =
279 P.pretty dealiaser needsParens func
281 | otherwise =
282 P.parensIf needsParens $
283 P.hang
284 (P.pretty dealiaser True func)
285 2
286 (P.sep (map (P.pretty dealiaser True) args))
289-- PRETTY RECORD
291prettyRecord :: (P.Pretty t) => P.Dealiaser -> ([(String, t)], Maybe String) -> P.Doc
292prettyRecord dealiaser recordInfo =
293 let
294 prettyField (field, tipe) =
295 P.hang
296 (P.text field <+> P.text ":")
297 4
298 (P.pretty dealiaser False tipe)
299 in
300 case recordInfo of
301 ([], Nothing) ->
302 P.text "{}"
304 (fields, Nothing) ->
305 P.sep
306 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
307 , P.rbrace
308 ]
310 (fields, Just x) ->
311 P.hang
312 (P.lbrace <+> P.text x <+> P.text "|")
313 4
314 (P.sep
315 [ P.sep (P.punctuate P.comma (map prettyField fields))
316 , P.rbrace
317 ]
318 )
321flattenRawRecord
322 :: [(String, Raw)]
323 -> Maybe Raw
324 -> ( [(String, Raw)], Maybe String )
325flattenRawRecord fields ext =
326 case ext of
327 Nothing ->
328 (fields, Nothing)
330 Just (A.A _ (RVar x)) ->
331 (fields, Just x)
333 Just (A.A _ (RRecord fields' ext')) ->
334 flattenRawRecord (fields' ++ fields) ext'
336 _ ->
337 error "Trying to flatten ill-formed record."
340flattenCanRecord
341 :: [(String, Canonical)]
342 -> Maybe Canonical
343 -> ( [(String, Canonical)], Maybe String )
344flattenCanRecord fields ext =
345 case ext of
346 Nothing ->
347 (fields, Nothing)
349 Just (Var x) ->
350 (fields, Just x)
352 Just (Record fields' ext') ->
353 flattenCanRecord (fields' ++ fields) ext'
355 Just (Aliased _ args tipe) ->
356 flattenCanRecord fields (Just (dealias args tipe))
358 _ ->
359 error "Trying to flatten ill-formed record."
362-- BINARY
364instance Binary Canonical where
365 put tipe =
366 case tipe of
367 Lambda t1 t2 ->
368 putWord8 0 >> put t1 >> put t2
370 Var x ->
371 putWord8 1 >> put x
373 Type name ->
374 putWord8 2 >> put name
376 App t1 t2 ->
377 putWord8 3 >> put t1 >> put t2
379 Record fs ext ->
380 putWord8 4 >> put fs >> put ext
382 Aliased var args t ->
383 putWord8 5 >> put var >> put args >> put t
385 get = do
386 n <- getWord8
387 case n of
388 0 -> Lambda <$> get <*> get
389 1 -> Var <$> get
390 2 -> Type <$> get
391 3 -> App <$> get <*> get
392 4 -> Record <$> get <*> get
393 5 -> Aliased <$> get <*> get <*> get
394 _ -> error "Error reading a valid type from serialized string"
397instance Binary t => Binary (Aliased t) where
398 put aliasType =
399 case aliasType of
400 Holey tipe ->
401 putWord8 0 >> put tipe
403 Filled tipe ->
404 putWord8 1 >> put tipe
406 get = do
407 n <- getWord8
408 case n of
409 0 -> Holey <$> get
410 1 -> Filled <$> get
411 _ -> error "Error reading a valid type from serialized string"