git.iko.soy/elk
on master help sign in
Add pretty printing for raw types
b76ad63Evan Czaplicki
src/AST/Type.hs+166−73
compare with master
unifiedsplit
@@ -12,6 +12,7 @@ import Control.Applicative ((<$>), (<*>))
12import Control.Arrow (second)
12import Control.Arrow (second)
13import Data.Binary
13import Data.Binary
14import qualified Data.Map as Map
14import qualified Data.Map as Map
15+import qualified Data.Maybe as Maybe
15import Text.PrettyPrint as P
16import Text.PrettyPrint as P
16
17
17import qualified AST.Variable as Var
18import qualified AST.Variable as Var
@@ -161,74 +162,49 @@ instance (P.Pretty t) => P.Pretty (Port t) where
161
162
162
163
163instance P.Pretty Raw' where
164instance P.Pretty Raw' where
164− pretty _ tipe =
165+ pretty needsParens tipe =
166+ case tipe of
167+ RLambda arg body ->
168+ P.parensIf needsParens (prettyLambda getRawLambda arg body)
169+
170+ RVar x ->
165− P.text (show tipe)
171+ P.text x
172+
173+ RType var ->
174+ prettyType var
175+
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
182+
183+ RRecord fields ext ->
184+ prettyRecord (flattenRawRecord fields ext)
166
185
167
186
168instance P.Pretty Canonical where
187instance P.Pretty Canonical where
169 pretty needsParens tipe =
188 pretty needsParens tipe =
170 case tipe of
189 case tipe of
171− Lambda _ _ ->
190+ Lambda arg body ->
172− P.parensIf needsParens $
191+ P.parensIf needsParens (prettyLambda getCanLambda arg body)
173− P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
174− where
175− t:ts =
176− map prettyLambda (collectLambdas tipe)
177−
178− prettyLambda t =
179− case t of
180− Lambda _ _ ->
181− P.pretty True t
182− _ ->
183− P.pretty False t
184
192
185 Var x ->
193 Var x ->
186 P.text x
194 P.text x
187
195
188 Type var ->
196 Type var ->
189− let v = Var.toString var
197+ prettyType var
198+
199+ App func args ->
200+ let
201+ isTuple (Type name) = Help.isTuple (Var.toString name)
202+ isTuple _ = False
190 in
203 in
191− P.text (if v == "_Tuple0" then "()" else v)
204+ prettyApp needsParens isTuple func args
192
205
193− App f args ->
194− case (f,args) of
195− (Type name, _)
196− | Help.isTuple (Var.toString name) ->
197− P.parens $ P.sep $
198− P.punctuate P.comma (map (P.pretty False) args)
199−
200− (_, []) ->
201− P.pretty True f
202−
203− (_, _) ->
204− P.parensIf needsParens $
205− P.hang
206− (P.pretty True f)
207− 2
208− (P.sep (map (P.pretty True) args))
209−
210− Record _ _ ->
206+ Record fields ext ->
211− case flattenRecord tipe of
207+ prettyRecord (flattenCanRecord fields ext)
212− ([], Nothing) ->
213− P.text "{}"
214−
215− (fields, Nothing) ->
216− P.sep
217− [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
218− , P.rbrace
219− ]
220−
221− (fields, Just x) ->
222− P.hang
223− (P.lbrace <+> P.text x <+> P.text "|")
224− 4
225− (P.sep
226− [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
227− , P.rbrace
228− ])
229− where
230− prettyField (field, tipe) =
231− P.text field <+> P.text ":" <+> P.pretty False tipe
232
208
233 Aliased name args _ ->
209 Aliased name args _ ->
234 P.parensIf (needsParens && not (null args)) $
210 P.parensIf (needsParens && not (null args)) $
@@ -238,32 +214,149 @@ instance P.Pretty Canonical where
238 (P.sep (map (P.pretty True . snd) args))
214 (P.sep (map (P.pretty True . snd) args))
239
215
240
216
241−collectLambdas :: Canonical -> [Canonical]
217+-- PRETTY HELPERS
242−collectLambdas tipe =
218+
219+prettyType :: (Var.ToString var) => var -> P.Doc
220+prettyType var =
221+ let
222+ v = Var.toString var
223+ in
224+ P.text (if v == "_Tuple0" then "()" else v)
225+
226+
227+-- PRETTY LAMBDAS
228+
229+prettyLambda :: (P.Pretty t) => (t -> Maybe (t,t)) -> t -> t -> P.Doc
230+prettyLambda getLambda arg body =
231+ let
232+ rest =
233+ gatherLambda getLambda body
234+
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+ ]
242+
243+
244+getRawLambda :: Raw -> Maybe (Raw, Raw)
245+getRawLambda (A.A _ tipe) =
243 case tipe of
246 case tipe of
244− Lambda arg body ->
247+ RLambda arg body -> Just (arg, body)
245− arg : collectLambdas body
248+ _ -> Nothing
246
249
247− _ ->
250+
251+getCanLambda :: Canonical -> Maybe (Canonical, Canonical)
252+getCanLambda tipe =
253+ case tipe of
254+ Lambda arg body -> Just (arg, body)
255+ _ -> Nothing
256+
257+
258+gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]
259+gatherLambda get tipe =
260+ case get tipe of
261+ Just (arg, body) ->
262+ arg : gatherLambda get body
263+
264+ Nothing ->
248 [tipe]
265 [tipe]
249
266
250
267
251−flattenRecord :: Canonical -> ( [(String, Canonical)], Maybe String )
268+collectLambdas :: Canonical -> [Canonical]
252−flattenRecord tipe =
269+collectLambdas tipe =
253− case tipe of
270+ gatherLambda getCanLambda tipe
254− Var x ->
271+
255− ([], Just x)
272+
273+-- PRETTY APP
274+
275+prettyApp :: (P.Pretty t) => Bool -> (t -> Bool) -> t -> [t] -> P.Doc
276+prettyApp needsParens isTuple func args
277+ | isTuple func =
278+ P.parens $ P.sep $
279+ P.punctuate P.comma (map (P.pretty False) args)
280+
281+ | null args =
282+ P.pretty needsParens func
283+
284+ | otherwise =
285+ P.parensIf needsParens $
286+ P.hang
287+ (P.pretty True func)
288+ 2
289+ (P.sep (map (P.pretty True) args))
256
290
291+
292+-- PRETTY RECORD
293+
294+prettyRecord :: (P.Pretty t) => ([(String, t)], Maybe String) -> P.Doc
295+prettyRecord 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 "{}"
306+
257− Record fields Nothing ->
307+ (fields, Nothing) ->
308+ P.sep
309+ [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
310+ , P.rbrace
311+ ]
312+
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+ )
322+
323+
324+flattenRawRecord
325+ :: [(String, Raw)]
326+ -> Maybe Raw
327+ -> ( [(String, Raw)], Maybe String )
328+flattenRawRecord fields ext =
329+ case ext of
330+ Nothing ->
331+ (fields, Nothing)
332+
333+ Just (A.A _ (RVar x)) ->
334+ (fields, Just x)
335+
336+ Just (A.A _ (RRecord fields' ext')) ->
337+ flattenRawRecord (fields' ++ fields) ext'
338+
339+ _ ->
340+ error "Trying to flatten ill-formed record."
341+
342+
343+flattenCanRecord
344+ :: [(String, Canonical)]
345+ -> Maybe Canonical
346+ -> ( [(String, Canonical)], Maybe String )
347+flattenCanRecord fields ext =
348+ case ext of
349+ Nothing ->
258 (fields, Nothing)
350 (fields, Nothing)
259
351
352+ Just (Var x) ->
353+ (fields, Just x)
354+
260− Record fields (Just ext) ->
355+ Just (Record fields' ext') ->
261− let (fields',ext') = flattenRecord ext
262− in
263− (fields' ++ fields, ext')
356+ flattenCanRecord (fields' ++ fields) ext'
264
357
265− Aliased _ args tipe' ->
358+ Just (Aliased _ args tipe) ->
266− flattenRecord (dealias args tipe')
359+ flattenCanRecord fields (Just (dealias args tipe))
267
360
268 _ ->
361 _ ->
269 error "Trying to flatten ill-formed record."
362 error "Trying to flatten ill-formed record."