git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Better layout for pretty printed values
2a0553aPhil Freeman
src/Language/PureScript/Pretty/Common.hs+38
compare with golang
unifiedsplit
@@ -15,8 +15,46 @@
15
15
16module Language.PureScript.Pretty.Common where
16module Language.PureScript.Pretty.Common where
17
17
18+import Control.Monad.State
19+import Data.List (intercalate)
20+
18-- |
21-- |
19-- Wrap a string in parentheses
22-- Wrap a string in parentheses
20--
23--
21parens :: String -> String
24parens :: String -> String
22parens s = ('(':s) ++ ")"
25parens s = ('(':s) ++ ")"
26+
27+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
28+
29+-- |
30+-- Number of characters per identation level
31+--
32+blockIndent :: Int
33+blockIndent = 4
34+
35+-- |
36+-- Pretty print with a new indentation level
37+--
38+withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
39+withIndent action = do
40+ modify $ \st -> st { indent = indent st + blockIndent }
41+ result <- action
42+ modify $ \st -> st { indent = indent st - blockIndent }
43+ return result
44+
45+-- |
46+-- Get the current indentation level
47+--
48+currentIndent :: StateT PrinterState Maybe String
49+currentIndent = do
50+ current <- get
51+ return $ replicate (indent current) ' '
52+
53+-- |
54+-- Print many lines
55+--
56+prettyPrintMany :: (a -> StateT PrinterState Maybe String) -> [a] -> StateT PrinterState Maybe String
57+prettyPrintMany f xs = do
58+ ss <- mapM f xs
59+ indentString <- currentIndent
60+ return $ intercalate "\n" $ map (indentString ++) ss
src/Language/PureScript/Pretty/JS.hs−26
@@ -29,32 +29,6 @@ import Control.Applicative
29import Control.Monad.State
29import Control.Monad.State
30import Numeric
30import Numeric
31
31
32−newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
33−
34−-- |
35−-- Number of characters per identation level
36−--
37−blockIndent :: Int
38−blockIndent = 4
39−
40−-- |
41−-- Pretty print with a new indentation level
42−--
43−withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
44−withIndent action = do
45− modify $ \st -> st { indent = indent st + blockIndent }
46− result <- action
47− modify $ \st -> st { indent = indent st - blockIndent }
48− return result
49−
50−-- |
51−-- Get the current indentation level
52−--
53−currentIndent :: StateT PrinterState Maybe String
54−currentIndent = do
55− current <- get
56− return $ replicate (indent current) ' '
57−
58literals :: Pattern PrinterState JS String
32literals :: Pattern PrinterState JS String
59literals = mkPattern' match
33literals = mkPattern' match
60 where
34 where
src/Language/PureScript/Pretty/Values.hs+125−60
@@ -20,89 +20,133 @@ module Language.PureScript.Pretty.Values (
20
20
21import Data.Maybe (fromMaybe)
21import Data.Maybe (fromMaybe)
22import Data.List (intercalate)
22import Data.List (intercalate)
23+
23−import Control.Arrow ((<+>))
24+import Control.Arrow ((<+>), runKleisli)
24import Control.PatternArrows
25import Control.PatternArrows
26+import Control.Monad.State
27+import Control.Applicative
25
28
26import Language.PureScript.Types
29import Language.PureScript.Types
27import Language.PureScript.Declarations
30import Language.PureScript.Declarations
28import Language.PureScript.Pretty.Common
31import Language.PureScript.Pretty.Common
29import Language.PureScript.Pretty.Types
32import Language.PureScript.Pretty.Types
30
33
31−literals :: Pattern () Value String
34+literals :: Pattern PrinterState Value String
32−literals = mkPattern match
35+literals = mkPattern' match
33 where
36 where
37+ match :: Value -> StateT PrinterState Maybe String
34− match (NumericLiteral n) = Just $ either show show n
38+ match (NumericLiteral n) = return $ either show show n
35− match (StringLiteral s) = Just $ show s
39+ match (StringLiteral s) = return $ show s
36− match (BooleanLiteral True) = Just "true"
40+ match (BooleanLiteral True) = return "true"
37− match (BooleanLiteral False) = Just "false"
41+ match (BooleanLiteral False) = return "false"
38− match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
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"
39− match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
49+ , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
50+ , currentIndent
51+ , return "}"
52+ ]
40− match (Constructor name) = Just $ show name
53+ match (Constructor name) = return $ show name
41− match (Case values binders) = Just $ "case " ++ unwords (map prettyPrintValue values) ++
54+ match (Case values binders) = fmap concat $ sequence
55+ [ return "case "
56+ , unwords <$> forM values prettyPrintValue'
57+ , return " of\n"
42− " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"
58+ , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
59+ , currentIndent
60+ ]
61+ match (Let _ val) = fmap concat $ sequence
62+ [ return "let ... in " -- TODO
43− match (Let _ val) = Just $ "let ... in " ++ prettyPrintValue val
63+ , prettyPrintValue' val
64+ ]
44− match (Var ident) = Just $ show ident
65+ match (Var ident) = return $ show ident
66+ match (Do els) = fmap concat $ sequence
67+ [ return "do "
45− match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"
68+ , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
69+ , currentIndent
70+ ]
46 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
71 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
47− match (PositionedValue _ val) = Just $ prettyPrintValue val
72+ match (PositionedValue _ val) = prettyPrintValue' val
48− match _ = Nothing
73+ match _ = mzero
49
74
50−prettyPrintCaseAlternative :: CaseAlternative -> String
75+prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
51prettyPrintCaseAlternative (CaseAlternative binders grd val) =
76prettyPrintCaseAlternative (CaseAlternative binders grd val) =
77+ fmap concat $ sequence
52− "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
78+ [ intercalate ", " <$> forM binders prettyPrintBinder'
53− maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val
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
54
101
55−ifThenElse :: Pattern () Value ((Value, Value), Value)
102+ifThenElse :: Pattern PrinterState Value ((Value, Value), Value)
56ifThenElse = mkPattern match
103ifThenElse = mkPattern match
57 where
104 where
58 match (IfThenElse cond th el) = Just ((th, el), cond)
105 match (IfThenElse cond th el) = Just ((th, el), cond)
59 match _ = Nothing
106 match _ = Nothing
60
107
61−accessor :: Pattern () Value (String, Value)
108+accessor :: Pattern PrinterState Value (String, Value)
62accessor = mkPattern match
109accessor = mkPattern match
63 where
110 where
64 match (Accessor prop val) = Just (prop, val)
111 match (Accessor prop val) = Just (prop, val)
65 match _ = Nothing
112 match _ = Nothing
66
113
67−objectUpdate :: Pattern () Value ([String], Value)
114+objectUpdate :: Pattern PrinterState Value ([String], Value)
68objectUpdate = mkPattern match
115objectUpdate = mkPattern match
69 where
116 where
70 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
117 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
71 match _ = Nothing
118 match _ = Nothing
72
119
73−app :: Pattern () Value (String, Value)
120+app :: Pattern PrinterState Value (String, Value)
74app = mkPattern match
121app = mkPattern match
75 where
122 where
76 match (App val arg) = Just (prettyPrintValue arg, val)
123 match (App val arg) = Just (prettyPrintValue arg, val)
77 match _ = Nothing
124 match _ = Nothing
78
125
79−lam :: Pattern () Value (String, Value)
126+lam :: Pattern PrinterState Value (String, Value)
80lam = mkPattern match
127lam = mkPattern match
81 where
128 where
82 match (Abs (Left arg) val) = Just (show arg, val)
129 match (Abs (Left arg) val) = Just (show arg, val)
83 match _ = Nothing
130 match _ = Nothing
84
131
85−typed :: Pattern () Value (Type, Value)
132+typed :: Pattern PrinterState Value (Type, Value)
86typed = mkPattern match
133typed = mkPattern match
87 where
134 where
88 match (TypedValue _ val ty) = Just (ty, val)
135 match (TypedValue _ val ty) = Just (ty, val)
89 match _ = Nothing
136 match _ = Nothing
90
137
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−
97-- |
138-- |
98−-- Generate a pretty-printed string representing a Value
139+-- Generate a pretty-printed string representing an expression
99--
140--
100prettyPrintValue :: Value -> String
141prettyPrintValue :: 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
102 where
146 where
103− matchValue :: Pattern () Value String
147+ matchValue :: Pattern PrinterState Value String
104 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
148 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
105− operators :: OperatorTable () Value String
149+ operators :: OperatorTable PrinterState Value String
106 operators =
150 operators =
107 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
151 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
108 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
152 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
@@ -112,43 +156,64 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (
112 , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
156 , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
113 ]
157 ]
114
158
115−prettyPrintBinderAtom :: Pattern () Binder String
159+prettyPrintBinderAtom :: Pattern PrinterState Binder String
116−prettyPrintBinderAtom = mkPattern match
160+prettyPrintBinderAtom = mkPattern' match
117 where
161 where
118− match :: Binder -> Maybe String
162+ match :: Binder -> StateT PrinterState Maybe String
119− match NullBinder = Just "_"
163+ match NullBinder = return "_"
120− match (StringBinder str) = Just $ show str
164+ match (StringBinder str) = return $ show str
121− match (NumberBinder num) = Just $ either show show num
165+ match (NumberBinder num) = return $ either show show num
122− match (BooleanBinder True) = Just "true"
166+ match (BooleanBinder True) = return "true"
123− match (BooleanBinder False) = Just "false"
167+ match (BooleanBinder False) = return "false"
124− match (VarBinder ident) = Just $ show ident
168+ match (VarBinder ident) = return $ show ident
125− match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ unwords (map (parens . prettyPrintBinder) args)
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"
126− match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
175+ , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
176+ , currentIndent
177+ , return "}"
178+ ]
179+ match (ArrayBinder bs) = fmap concat $ sequence
180+ [ return "["
127− match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
181+ , unwords <$> mapM prettyPrintBinder' bs
182+ , return "]"
183+ ]
128− match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
184+ match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder
129− match (PositionedBinder _ binder) = Just $ prettyPrintBinder binder
185+ match (PositionedBinder _ binder) = prettyPrintBinder' binder
130− match _ = Nothing
186+ match _ = mzero
131
187
132-- |
188-- |
133-- Generate a pretty-printed string representing a Binder
189-- Generate a pretty-printed string representing a Binder
134--
190--
135prettyPrintBinder :: Binder -> String
191prettyPrintBinder :: 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
137 where
196 where
138− matchBinder :: Pattern () Binder String
197+ matchBinder :: Pattern PrinterState Binder String
139 matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
198 matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
140− operators :: OperatorTable () Binder String
199+ operators :: OperatorTable PrinterState Binder String
141 operators =
200 operators =
142 OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
201 OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
143
202
144−matchConsBinder :: Pattern () Binder (Binder, Binder)
203+matchConsBinder :: Pattern PrinterState Binder (Binder, Binder)
145matchConsBinder = mkPattern match'
204matchConsBinder = mkPattern match'
146 where
205 where
147 match' (ConsBinder b1 b2) = Just (b1, b2)
206 match' (ConsBinder b1 b2) = Just (b1, b2)
148 match' _ = Nothing
207 match' _ = Nothing
149
208
150−prettyPrintObjectPropertyBinder :: String -> Binder -> String
209+prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
151−prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
210+prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence
152−
211+ [ return $ key ++ ": "
212+ , prettyPrintBinder' binder
213+ ]
214+
153−prettyPrintObjectProperty :: String -> Value -> String
215+prettyPrintObjectProperty :: (String, Value) -> StateT PrinterState Maybe String
154−prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value
216+prettyPrintObjectProperty (key, value) = fmap concat $ sequence
217+ [ return $ key ++ ": "
218+ , prettyPrintValue' value
219+ ]
src/Language/PureScript/TypeChecker/Monad.hs+2−2
@@ -118,8 +118,8 @@ isErrorNonEmpty = not . null . unifyErrorMessage
118
118
119showError :: UnifyError -> String
119showError :: UnifyError -> String
120showError (UnifyError msg Nothing _) = msg
120showError (UnifyError msg Nothing _) = msg
121−showError (UnifyError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ ": \n" ++ msg
121+showError (UnifyError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ "\n" ++ msg
122−showError (UnifyError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ": \n" ++ msg
122+showError (UnifyError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ "\n" ++ msg
123
123
124mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack
124mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack
125mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t Nothing]
125mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t Nothing]