@@ -9,11 +9,10 @@ import Control.Arrow (second)
99import Data.Aeson ((.:), (.=))
1010import qualified Data.Aeson as Json
1111import qualified Data.ByteString.Lazy.Char8 as BS
12−import qualified Data.List as List
1312import qualified Data.Text as Text
13+import Text.PrettyPrint as P
1414
1515import qualified AST.Helpers as Help
16−import Elm.Utils ((|>))
1716
1817
1918data Type
@@ -31,66 +30,87 @@ data Context = None | ADT | Function
3130
3231toString :: Type -> String
3332toString tipe =
34− toStringHelp None tipe
33+ P.render (toDoc None tipe)
3534
3635
37−toStringHelp :: Context -> Type -> String
38−toStringHelp context tipe =
36+toDoc :: Context -> Type -> P.Doc
37+toDoc context tipe =
3938 case tipe of
40− Lambda t1 t2 ->
41− let string = toStringHelp Function t1 ++ " -> " ++ toString t2
39+ Lambda _ _ ->
40+ let t:ts =
41+ map (toDoc Function) (collectLambdas tipe)
42+
43+ lambda =
44+ P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
4245 in
4346 case context of
44− None -> string
45− _ -> parens string
47+ None -> lambda
48+ _ -> P.parens lambda
4649
47− Var name -> name
50+ Var name ->
51+ P.text name
4852
49− Type name -> name
53+ Type name ->
54+ P.text (if name == "_Tuple0" then "()" else name)
5055
5156 App (Type name) args
5257 | Help.isTuple name ->
53− map toString args
54− |> List.intercalate ", "
55− |> parens
58+ P.sep
59+ [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
60+ , P.rparen
61+ ]
5662
5763 | otherwise ->
58− let string = name ++ spacePrefix (map (toStringHelp ADT) args)
64+ let adt = P.hang (P.text name) 2 (P.sep $ map (toDoc ADT) args)
5965 in
6066 case (context, args) of
61− (ADT, _ : _) -> parens string
62− _ -> string
63−
64− Record fields maybeExtension ->
65− let viewField (key, value) =
66− key ++ " : " ++ toString value
67−
68− viewExtension maybeType =
69− case maybeType of
70− Nothing -> ""
71− Just t -> toString t ++ " | "
72− in
73− sandwich "{ " " }" $
74− concat
75− [ viewExtension maybeExtension
76− , map viewField fields
77− |> List.intercalate ", "
78− ]
67+ (ADT, _ : _) -> P.parens adt
68+ _ -> adt
69+
70+ Record _ _ ->
71+ case flattenRecord tipe of
72+ ([], Nothing) ->
73+ P.text "{}"
74+
75+ (fields, Nothing) ->
76+ P.sep
77+ [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
78+ , P.rbrace
79+ ]
7980
81+ (fields, Just x) ->
82+ P.hang
83+ (P.lbrace <+> P.text x <+> P.text "|")
84+ 4
85+ (P.sep
86+ [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
87+ , P.rbrace
88+ ])
89+ where
90+ prettyField (field, tipe) =
91+ P.text field <+> P.text ":" <+> toDoc None tipe
92+
93+
94+collectLambdas :: Type -> [Type]
95+collectLambdas tipe =
96+ case tipe of
97+ Lambda arg body -> arg : collectLambdas body
98+ _ -> [tipe]
8099
81−parens :: String -> String
82−parens string =
83− sandwich "(" ")" string
84100
101+flattenRecord :: Type -> ( [(String, Type)], Maybe String )
102+flattenRecord tipe =
103+ case tipe of
104+ Var x -> ([], Just x)
85105
86−spacePrefix :: [String] -> String
87−spacePrefix strings =
88− concatMap (" " ++) strings
106+ Record fields Nothing -> (fields, Nothing)
89107
108+ Record fields (Just ext) ->
109+ let (fields',ext') = flattenRecord ext
110+ in
111+ (fields' ++ fields, ext')
90112
91−sandwich :: String -> String -> String -> String
92−sandwich start stop string =
93− start ++ string ++ stop
113+ _ -> error "Trying to flatten ill-formed record."
94114
95115
96116-- JSON for TYPE