@@ -12,6 +12,7 @@ import Control.Applicative ((<$>), (<*>))
1212import Control.Arrow (second)
1313import Data.Binary
1414import qualified Data.Map as Map
15+import qualified Data.Maybe as Maybe
1516import Text.PrettyPrint as P
1617
1718import qualified AST.Variable as Var
@@ -161,74 +162,49 @@ instance (P.Pretty t) => P.Pretty (Port t) where
161162
162163
163164instance P.Pretty Raw' where
164− pretty _ tipe =
165− P.text (show 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 ->
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)
166185
167186
168187instance P.Pretty Canonical where
169188 pretty needsParens tipe =
170189 case tipe of
171− Lambda _ _ ->
172− P.parensIf needsParens $
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
190+ Lambda arg body ->
191+ P.parensIf needsParens (prettyLambda getCanLambda arg body)
184192
185193 Var x ->
186194 P.text x
187195
188196 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
190203 in
191− P.text (if v == "_Tuple0" then "()" else v)
204+ prettyApp needsParens isTuple func args
192205
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 _ _ ->
211− case flattenRecord tipe of
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
206+ Record fields ext ->
207+ prettyRecord (flattenCanRecord fields ext)
232208
233209 Aliased name args _ ->
234210 P.parensIf (needsParens && not (null args)) $
@@ -238,32 +214,149 @@ instance P.Pretty Canonical where
238214 (P.sep (map (P.pretty True . snd) args))
239215
240216
241−collectLambdas :: Canonical -> [Canonical]
242−collectLambdas tipe =
217+-- PRETTY HELPERS
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) =
243246 case tipe of
244− Lambda arg body ->
245− arg : collectLambdas body
247+ RLambda arg body -> Just (arg, body)
248+ _ -> Nothing
246249
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 ->
248265 [tipe]
249266
250267
251−flattenRecord :: Canonical -> ( [(String, Canonical)], Maybe String )
252−flattenRecord tipe =
253− case tipe of
254− Var x ->
255− ([], Just x)
268+collectLambdas :: Canonical -> [Canonical]
269+collectLambdas tipe =
270+ gatherLambda getCanLambda tipe
271+
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))
256290
257− Record fields Nothing ->
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+
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 ->
258350 (fields, Nothing)
259351
260− Record fields (Just ext) ->
261− let (fields',ext') = flattenRecord ext
262− in
263− (fields' ++ fields, ext')
352+ Just (Var x) ->
353+ (fields, Just x)
354+
355+ Just (Record fields' ext') ->
356+ flattenCanRecord (fields' ++ fields) ext'
264357
265− Aliased _ args tipe' ->
266− flattenRecord (dealias args tipe')
358+ Just (Aliased _ args tipe) ->
359+ flattenCanRecord fields (Just (dealias args tipe))
267360
268361 _ ->
269362 error "Trying to flatten ill-formed record."