@@ -20,132 +20,207 @@ module Language.PureScript.Pretty.Values (
2020
2121import Data.Maybe (fromMaybe)
2222import Data.List (intercalate)
23−import Control.Arrow ((<+>))
23+
24+import Control.Arrow ((<+>), runKleisli)
2425import Control.PatternArrows
26+import Control.Monad.State
27+import Control.Applicative
2528
26−import Language.PureScript.Types
2729import Language.PureScript.Declarations
2830import Language.PureScript.Pretty.Common
29−import Language.PureScript.Pretty.Types
31+import Language.PureScript.Pretty.Types (prettyPrintType)
3032
31−literals :: Pattern () Value String
32−literals = mkPattern match
33+literals :: Pattern PrinterState Value String
34+literals = mkPattern' match
3335 where
34− match (NumericLiteral n) = Just $ either show show n
35− match (StringLiteral s) = Just $ show s
36− match (BooleanLiteral True) = Just "true"
37− match (BooleanLiteral False) = Just "false"
38− match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
39− match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
40− match (Constructor name) = Just $ show name
41− match (Case values binders) = Just $ "case " ++ unwords (map prettyPrintValue values) ++
42− " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"
43− match (Let _ val) = Just $ "let ... in " ++ prettyPrintValue val
44− match (Var ident) = Just $ show ident
45− match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"
36+ match :: Value -> StateT PrinterState Maybe String
37+ match (NumericLiteral n) = return $ either show show n
38+ match (StringLiteral s) = return $ show s
39+ match (BooleanLiteral True) = return "true"
40+ match (BooleanLiteral False) = return "false"
41+ match (ArrayLiteral xs) = fmap concat $ sequence
42+ [ return "[ "
43+ , withIndent $ prettyPrintMany prettyPrintValue' xs
44+ , return " ]"
45+ ]
46+ match (ObjectLiteral []) = return "{}"
47+ match (ObjectLiteral ps) = fmap concat $ sequence
48+ [ return "{\n"
49+ , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
50+ , currentIndent
51+ , return "}"
52+ ]
53+ match (Constructor name) = return $ show name
54+ match (Case values binders) = fmap concat $ sequence
55+ [ return "case "
56+ , unwords <$> forM values prettyPrintValue'
57+ , return " of\n"
58+ , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
59+ , currentIndent
60+ ]
61+ match (Let ds val) = fmap concat $ sequence
62+ [ return "let\n"
63+ , withIndent $ prettyPrintMany prettyPrintDeclaration ds
64+ , return "\n"
65+ , currentIndent
66+ , return "in "
67+ , prettyPrintValue' val
68+ ]
69+ match (Var ident) = return $ show ident
70+ match (Do els) = fmap concat $ sequence
71+ [ return "do "
72+ , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
73+ , currentIndent
74+ ]
4675 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
47− match _ = Nothing
48−
49−prettyPrintCaseAlternative :: CaseAlternative -> String
76+ match (TypedValue _ val _) = prettyPrintValue' val
77+ match (PositionedValue _ val) = prettyPrintValue' val
78+ match _ = mzero
79+
80+prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
81+prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty
82+prettyPrintDeclaration (ValueDeclaration ident _ [] Nothing val) = fmap concat $ sequence
83+ [ return $ show ident ++ " = "
84+ , prettyPrintValue' val
85+ ]
86+prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d
87+prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"
88+
89+prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
5090prettyPrintCaseAlternative (CaseAlternative binders grd val) =
51− "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
52− maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val
53−
54−ifThenElse :: Pattern () Value ((Value, Value), Value)
91+ fmap concat $ sequence
92+ [ intercalate ", " <$> forM binders prettyPrintBinder'
93+ , maybe (return "") (fmap ("| " ++) . prettyPrintValue') grd
94+ , return " -> "
95+ , prettyPrintValue' val
96+ ]
97+
98+prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String
99+prettyPrintDoNotationElement (DoNotationValue val) =
100+ prettyPrintValue' val
101+prettyPrintDoNotationElement (DoNotationBind binder val) =
102+ fmap concat $ sequence
103+ [ prettyPrintBinder' binder
104+ , return " <- "
105+ , prettyPrintValue' val
106+ ]
107+prettyPrintDoNotationElement (DoNotationLet binder val) =
108+ fmap concat $ sequence
109+ [ return "let "
110+ , prettyPrintBinder' binder
111+ , return " = "
112+ , prettyPrintValue' val
113+ ]
114+prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el
115+
116+ifThenElse :: Pattern PrinterState Value ((Value, Value), Value)
55117ifThenElse = mkPattern match
56118 where
57119 match (IfThenElse cond th el) = Just ((th, el), cond)
58120 match _ = Nothing
59121
60−accessor :: Pattern () Value (String, Value)
122+accessor :: Pattern PrinterState Value (String, Value)
61123accessor = mkPattern match
62124 where
63125 match (Accessor prop val) = Just (prop, val)
64126 match _ = Nothing
65127
66−objectUpdate :: Pattern () Value ([String], Value)
128+objectUpdate :: Pattern PrinterState Value ([String], Value)
67129objectUpdate = mkPattern match
68130 where
69131 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
70132 match _ = Nothing
71133
72−app :: Pattern () Value (String, Value)
134+app :: Pattern PrinterState Value (String, Value)
73135app = mkPattern match
74136 where
75137 match (App val arg) = Just (prettyPrintValue arg, val)
76138 match _ = Nothing
77139
78−lam :: Pattern () Value (String, Value)
140+lam :: Pattern PrinterState Value (String, Value)
79141lam = mkPattern match
80142 where
81143 match (Abs (Left arg) val) = Just (show arg, val)
82144 match _ = Nothing
83145
84−typed :: Pattern () Value (Type, Value)
85−typed = mkPattern match
86− where
87− match (TypedValue _ val ty) = Just (ty, val)
88− match _ = Nothing
89−
90−prettyPrintDoNotationElement :: DoNotationElement -> String
91−prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val
92−prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val
93−prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val
94−
95146-- |
96−-- Generate a pretty-printed string representing a Value
147+-- Generate a pretty-printed string representing an expression
97148--
98149prettyPrintValue :: Value -> String
99−prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
150+prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
151+
152+prettyPrintValue' :: Value -> StateT PrinterState Maybe String
153+prettyPrintValue' = runKleisli $ runPattern matchValue
100154 where
101− matchValue :: Pattern () Value String
155+ matchValue :: Pattern PrinterState Value String
102156 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
103− operators :: OperatorTable () Value String
157+ operators :: OperatorTable PrinterState Value String
104158 operators =
105159 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
106160 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
107161 , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]
108162 , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]
109163 , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]
110− , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
111164 ]
112165
113−prettyPrintBinderAtom :: Pattern () Binder String
114−prettyPrintBinderAtom = mkPattern match
166+prettyPrintBinderAtom :: Pattern PrinterState Binder String
167+prettyPrintBinderAtom = mkPattern' match
115168 where
116− match :: Binder -> Maybe String
117− match NullBinder = Just "_"
118− match (StringBinder str) = Just $ show str
119− match (NumberBinder num) = Just $ either show show num
120− match (BooleanBinder True) = Just "true"
121− match (BooleanBinder False) = Just "false"
122− match (VarBinder ident) = Just $ show ident
123− match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ unwords (map (parens . prettyPrintBinder) args)
124− match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
125− match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
126− match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
127− match _ = Nothing
169+ match :: Binder -> StateT PrinterState Maybe String
170+ match NullBinder = return "_"
171+ match (StringBinder str) = return $ show str
172+ match (NumberBinder num) = return $ either show show num
173+ match (BooleanBinder True) = return "true"
174+ match (BooleanBinder False) = return "false"
175+ match (VarBinder ident) = return $ show ident
176+ match (ConstructorBinder ctor args) = fmap concat $ sequence
177+ [ return $ show ctor ++ " "
178+ , unwords <$> forM args match
179+ ]
180+ match (ObjectBinder bs) = fmap concat $ sequence
181+ [ return "{\n"
182+ , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
183+ , currentIndent
184+ , return "}"
185+ ]
186+ match (ArrayBinder bs) = fmap concat $ sequence
187+ [ return "["
188+ , unwords <$> mapM prettyPrintBinder' bs
189+ , return "]"
190+ ]
191+ match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder
192+ match (PositionedBinder _ binder) = prettyPrintBinder' binder
193+ match _ = mzero
128194
129195-- |
130196-- Generate a pretty-printed string representing a Binder
131197--
132198prettyPrintBinder :: Binder -> String
133−prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()
199+prettyPrintBinder = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintBinder'
200+
201+prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String
202+prettyPrintBinder' = runKleisli $ runPattern matchBinder
134203 where
135− matchBinder :: Pattern () Binder String
204+ matchBinder :: Pattern PrinterState Binder String
136205 matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
137− operators :: OperatorTable () Binder String
206+ operators :: OperatorTable PrinterState Binder String
138207 operators =
139208 OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
140209
141−matchConsBinder :: Pattern () Binder (Binder, Binder)
210+matchConsBinder :: Pattern PrinterState Binder (Binder, Binder)
142211matchConsBinder = mkPattern match'
143212 where
144213 match' (ConsBinder b1 b2) = Just (b1, b2)
145214 match' _ = Nothing
146215
147−prettyPrintObjectPropertyBinder :: String -> Binder -> String
148−prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
149−
150−prettyPrintObjectProperty :: String -> Value -> String
151−prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value
216+prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
217+prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence
218+ [ return $ key ++ ": "
219+ , prettyPrintBinder' binder
220+ ]
221+
222+prettyPrintObjectProperty :: (String, Value) -> StateT PrinterState Maybe String
223+prettyPrintObjectProperty (key, value) = fmap concat $ sequence
224+ [ return $ key ++ ": "
225+ , prettyPrintValue' value
226+ ]