@@ -20,89 +20,133 @@ 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
2629import Language.PureScript.Types
2730import Language.PureScript.Declarations
2831import Language.PureScript.Pretty.Common
2932import Language.PureScript.Pretty.Types
3033
31−literals :: Pattern () Value String
32−literals = mkPattern match
34+literals :: Pattern PrinterState Value String
35+literals = mkPattern' match
3336 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) ++ " }"
37+ match :: Value -> StateT PrinterState Maybe String
38+ match (NumericLiteral n) = return $ either show show n
39+ match (StringLiteral s) = return $ show s
40+ match (BooleanLiteral True) = return "true"
41+ match (BooleanLiteral False) = return "false"
42+ match (ArrayLiteral xs) = fmap concat $ sequence
43+ [ return "[ "
44+ , withIndent $ prettyPrintMany prettyPrintValue' xs
45+ , return " ]"
46+ ]
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 _ val) = fmap concat $ sequence
62+ [ return "let ... in " -- TODO
63+ , prettyPrintValue' val
64+ ]
65+ match (Var ident) = return $ show ident
66+ match (Do els) = fmap concat $ sequence
67+ [ return "do "
68+ , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
69+ , currentIndent
70+ ]
4671 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
47− match (PositionedValue _ val) = Just $ prettyPrintValue val
48− match _ = Nothing
72+ match (PositionedValue _ val) = prettyPrintValue' val
73+ match _ = mzero
4974
50−prettyPrintCaseAlternative :: CaseAlternative -> String
75+prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
5176prettyPrintCaseAlternative (CaseAlternative binders grd val) =
52− "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
53− maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val
77+ fmap concat $ sequence
78+ [ intercalate ", " <$> forM binders prettyPrintBinder'
79+ , maybe (return "") (fmap ("| " ++) . prettyPrintValue') grd
80+ , return " -> "
81+ , prettyPrintValue' val
82+ ]
83+
84+prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String
85+prettyPrintDoNotationElement (DoNotationValue val) =
86+ prettyPrintValue' val
87+prettyPrintDoNotationElement (DoNotationBind binder val) =
88+ fmap concat $ sequence
89+ [ prettyPrintBinder' binder
90+ , return " <- "
91+ , prettyPrintValue' val
92+ ]
93+prettyPrintDoNotationElement (DoNotationLet binder val) =
94+ fmap concat $ sequence
95+ [ return "let "
96+ , prettyPrintBinder' binder
97+ , return " = "
98+ , prettyPrintValue' val
99+ ]
100+prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el
54101
55−ifThenElse :: Pattern () Value ((Value, Value), Value)
102+ifThenElse :: Pattern PrinterState Value ((Value, Value), Value)
56103ifThenElse = mkPattern match
57104 where
58105 match (IfThenElse cond th el) = Just ((th, el), cond)
59106 match _ = Nothing
60107
61−accessor :: Pattern () Value (String, Value)
108+accessor :: Pattern PrinterState Value (String, Value)
62109accessor = mkPattern match
63110 where
64111 match (Accessor prop val) = Just (prop, val)
65112 match _ = Nothing
66113
67−objectUpdate :: Pattern () Value ([String], Value)
114+objectUpdate :: Pattern PrinterState Value ([String], Value)
68115objectUpdate = mkPattern match
69116 where
70117 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
71118 match _ = Nothing
72119
73−app :: Pattern () Value (String, Value)
120+app :: Pattern PrinterState Value (String, Value)
74121app = mkPattern match
75122 where
76123 match (App val arg) = Just (prettyPrintValue arg, val)
77124 match _ = Nothing
78125
79−lam :: Pattern () Value (String, Value)
126+lam :: Pattern PrinterState Value (String, Value)
80127lam = mkPattern match
81128 where
82129 match (Abs (Left arg) val) = Just (show arg, val)
83130 match _ = Nothing
84131
85−typed :: Pattern () Value (Type, Value)
132+typed :: Pattern PrinterState Value (Type, Value)
86133typed = mkPattern match
87134 where
88135 match (TypedValue _ val ty) = Just (ty, val)
89136 match _ = Nothing
90137
91−prettyPrintDoNotationElement :: DoNotationElement -> String
92−prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val
93−prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val
94−prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val
95−prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el
96−
97138-- |
98−-- Generate a pretty-printed string representing a Value
139+-- Generate a pretty-printed string representing an expression
99140--
100141prettyPrintValue :: Value -> String
101−prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
142+prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
143+
144+prettyPrintValue' :: Value -> StateT PrinterState Maybe String
145+prettyPrintValue' = runKleisli $ runPattern matchValue
102146 where
103− matchValue :: Pattern () Value String
147+ matchValue :: Pattern PrinterState Value String
104148 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
105− operators :: OperatorTable () Value String
149+ operators :: OperatorTable PrinterState Value String
106150 operators =
107151 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
108152 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
@@ -112,43 +156,64 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (
112156 , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
113157 ]
114158
115−prettyPrintBinderAtom :: Pattern () Binder String
116−prettyPrintBinderAtom = mkPattern match
159+prettyPrintBinderAtom :: Pattern PrinterState Binder String
160+prettyPrintBinderAtom = mkPattern' match
117161 where
118− match :: Binder -> Maybe String
119− match NullBinder = Just "_"
120− match (StringBinder str) = Just $ show str
121− match (NumberBinder num) = Just $ either show show num
122− match (BooleanBinder True) = Just "true"
123− match (BooleanBinder False) = Just "false"
124− match (VarBinder ident) = Just $ show ident
125− match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ unwords (map (parens . prettyPrintBinder) args)
126− match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
127− match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
128− match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
129− match (PositionedBinder _ binder) = Just $ prettyPrintBinder binder
130− match _ = Nothing
162+ match :: Binder -> StateT PrinterState Maybe String
163+ match NullBinder = return "_"
164+ match (StringBinder str) = return $ show str
165+ match (NumberBinder num) = return $ either show show num
166+ match (BooleanBinder True) = return "true"
167+ match (BooleanBinder False) = return "false"
168+ match (VarBinder ident) = return $ show ident
169+ match (ConstructorBinder ctor args) = fmap concat $ sequence
170+ [ return $ show ctor ++ " "
171+ , unwords <$> forM args match
172+ ]
173+ match (ObjectBinder bs) = fmap concat $ sequence
174+ [ return "{\n"
175+ , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
176+ , currentIndent
177+ , return "}"
178+ ]
179+ match (ArrayBinder bs) = fmap concat $ sequence
180+ [ return "["
181+ , unwords <$> mapM prettyPrintBinder' bs
182+ , return "]"
183+ ]
184+ match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder
185+ match (PositionedBinder _ binder) = prettyPrintBinder' binder
186+ match _ = mzero
131187
132188-- |
133189-- Generate a pretty-printed string representing a Binder
134190--
135191prettyPrintBinder :: Binder -> String
136−prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()
192+prettyPrintBinder = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintBinder'
193+
194+prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String
195+prettyPrintBinder' = runKleisli $ runPattern matchBinder
137196 where
138− matchBinder :: Pattern () Binder String
197+ matchBinder :: Pattern PrinterState Binder String
139198 matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
140− operators :: OperatorTable () Binder String
199+ operators :: OperatorTable PrinterState Binder String
141200 operators =
142201 OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
143202
144−matchConsBinder :: Pattern () Binder (Binder, Binder)
203+matchConsBinder :: Pattern PrinterState Binder (Binder, Binder)
145204matchConsBinder = mkPattern match'
146205 where
147206 match' (ConsBinder b1 b2) = Just (b1, b2)
148207 match' _ = Nothing
149208
150−prettyPrintObjectPropertyBinder :: String -> Binder -> String
151−prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
152−
153−prettyPrintObjectProperty :: String -> Value -> String
154−prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value
209+prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
210+prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence
211+ [ return $ key ++ ": "
212+ , prettyPrintBinder' binder
213+ ]
214+
215+prettyPrintObjectProperty :: (String, Value) -> StateT PrinterState Maybe String
216+prettyPrintObjectProperty (key, value) = fmap concat $ sequence
217+ [ return $ key ++ ": "
218+ , prettyPrintValue' value
219+ ]