git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Bump version, pretty printing JS
7456058Phil Freeman
purescript.cabal+1−1
compare with golang
unifiedsplit
@@ -1,5 +1,5 @@
1name: purescript
1name: purescript
2−version: 0.1.8
2+version: 0.1.9
3cabal-version: >=1.8
3cabal-version: >=1.8
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
src/Language/PureScript.hs+1−1
@@ -33,6 +33,6 @@ compile :: [Declaration] -> Either String (String, String, Environment)
33compile decls = do
33compile decls = do
34 bracketted <- rebracket decls
34 bracketted <- rebracket decls
35 (_, env) <- check (typeCheckAll bracketted)
35 (_, env) <- check (typeCheckAll bracketted)
36− let js = intercalate "; " . map (prettyPrintJS . optimize) . concat . mapMaybe (declToJs Nothing global) $ bracketted
36+ let js = prettyPrintJS . map optimize . concat . mapMaybe (declToJs Nothing global) $ bracketted
37 let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ bracketted
37 let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ bracketted
38 return (js, exts, env)
38 return (js, exts, env)
src/Language/PureScript/Pretty/Common.hs+21−15
@@ -39,38 +39,44 @@ identToJs (Op op) = concatMap opCharToString op
39 opCharToString :: Char -> String
39 opCharToString :: Char -> String
40 opCharToString = (:) '$'. show . ord
40 opCharToString = (:) '$'. show . ord
41
41
42−newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
42+newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
43
43
44−instance Functor (Pattern a) where
44+instance Functor (Pattern u a) where
45 fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
45 fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
46
46
47−pattern :: Pattern a b -> a -> Maybe b
47+pattern :: Pattern u a b -> u -> a -> Maybe b
48−pattern = A.runKleisli . runPattern
48+pattern p u = flip evalStateT u . A.runKleisli (runPattern p)
49+
50+mkPattern :: (a -> Maybe b) -> Pattern u a b
51+mkPattern f = Pattern $ A.Kleisli (lift . f)
52+
53+mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
54+mkPattern' = Pattern . A.Kleisli
49
55
50parens :: String -> String
56parens :: String -> String
51parens s = ('(':s) ++ ")"
57parens s = ('(':s) ++ ")"
52
58
53−chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
59+chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
54chainl split f p = fix $ \c -> split >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
60chainl split f p = fix $ \c -> split >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
55
61
56−chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
62+chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
57chainr split f p = fix $ \c -> split >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
63chainr split f p = fix $ \c -> split >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
58
64
59−wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r
65+wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
60wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
66wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
61
67
62−split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r
68+split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r -> Pattern u a r
63split s f p = s >>> A.arr (uncurry f)
69split s f p = s >>> A.arr (uncurry f)
64
70
65−data OperatorTable a r = OperatorTable { runOperatorTable :: [ [Operator a r] ] }
71+data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
66
72
67−data Operator a r where
73+data Operator u a r where
68− AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
74+ AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
69− AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
75+ AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
70− Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r
76+ Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
71− Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r
77+ Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r
72
78
73−buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
79+buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r
74buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
80buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
75 case op of
81 case op of
76 AssocL pat g -> chainl pat g p'
82 AssocL pat g -> chainl pat g p'
src/Language/PureScript/Pretty/JS.hs+129−52
@@ -25,94 +25,171 @@ import Data.List
25import Data.Maybe (fromMaybe)
25import Data.Maybe (fromMaybe)
26import qualified Control.Arrow as A
26import qualified Control.Arrow as A
27import Control.Arrow ((***), (<+>), first, second)
27import Control.Arrow ((***), (<+>), first, second)
28+import Control.Applicative
29+import Control.Monad.State
28
30
31+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
32+
33+blockIndent :: Int
34+blockIndent = 4
35+
36+withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
37+withIndent s = do
38+ current <- get
39+ modify $ \s -> s { indent = indent s + blockIndent }
40+ result <- s
41+ modify $ \s -> s { indent = indent s - blockIndent }
42+ return result
43+
44+currentIndent :: StateT PrinterState Maybe String
45+currentIndent = do
46+ current <- get
47+ return $ replicate (indent current) ' '
48+
29−literals :: Pattern JS String
49+literals :: Pattern PrinterState JS String
30−literals = Pattern $ A.Kleisli match
50+literals = mkPattern' match
31 where
51 where
52+ match :: JS -> StateT PrinterState Maybe String
32− match (JSNumericLiteral n) = Just $ either show show n
53+ match (JSNumericLiteral n) = return $ either show show n
33− match (JSStringLiteral s) = Just $ show s
54+ match (JSStringLiteral s) = return $ show s
34− match (JSBooleanLiteral True) = Just "true"
55+ match (JSBooleanLiteral True) = return "true"
35− match (JSBooleanLiteral False) = Just "false"
56+ match (JSBooleanLiteral False) = return "false"
36− match (JSArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintJS xs) ++ "]"
57+ match (JSArrayLiteral xs) = fmap concat $ sequence
58+ [ return "[ "
59+ , fmap (intercalate ", ") $ forM xs prettyPrintJS'
60+ , return " ]"
61+ ]
62+ match (JSObjectLiteral ps) = fmap concat $ sequence
63+ [ return "{\n"
64+ , withIndent $ do
37− match (JSObjectLiteral ps) = Just $ "{ " ++ intercalate ", " (map (\(key, value) -> key ++ ": " ++ prettyPrintJS value) ps) ++ " }"
65+ jss <- forM ps $ \(key, value) -> fmap ((key ++ ": ") ++) . prettyPrintJS' $ value
38− match (JSBlock sts) = Just $ "{ " ++ intercalate "; " (map prettyPrintJS sts) ++ " }"
66+ indentString <- currentIndent
67+ return $ intercalate ", \n" $ map (indentString ++) jss
68+ , return "\n"
69+ , currentIndent
70+ , return "}"
71+ ]
72+ match (JSBlock sts) = fmap concat $ sequence
73+ [ return "{\n"
74+ , withIndent $ do
75+ jss <- forM sts prettyPrintJS'
76+ indentString <- currentIndent
77+ return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss
78+ , return "\n"
79+ , currentIndent
80+ , return "}"
81+ ]
39− match (JSVar ident) = Just (identToJs ident)
82+ match (JSVar ident) = return (identToJs ident)
40− match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ maybe "" ((" = " ++) . prettyPrintJS) value
83+ match (JSVariableIntroduction ident value) = fmap concat $ sequence
84+ [ return "var "
85+ , return $ identToJs ident
86+ , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
87+ ]
41− match (JSAssignment target value) = Just $ targetToJs target ++ " = " ++ prettyPrintJS value
88+ match (JSAssignment target value) = fmap concat $ sequence
89+ [ return $ targetToJs target
90+ , return " = "
91+ , prettyPrintJS' value
92+ ]
42− match (JSWhile cond sts) = Just $ "while ("
93+ match (JSWhile cond sts) = fmap concat $ sequence
94+ [ return "while ("
43− ++ prettyPrintJS cond ++ ") "
95+ , prettyPrintJS' cond
96+ , return ") "
44− ++ prettyPrintJS sts
97+ , prettyPrintJS' sts
98+ ]
45− match (JSFor ident start end sts) = Just $ "for ("
99+ match (JSFor ident start end sts) = fmap concat $ sequence
100+ [ return $ "for (" ++ identToJs ident ++ " = "
46− ++ identToJs ident ++ " = " ++ prettyPrintJS start ++ "; "
101+ , prettyPrintJS' start
102+ , return $ "; " ++ identToJs ident ++ " < "
47− ++ identToJs ident ++ " < " ++ prettyPrintJS end ++ "; "
103+ , prettyPrintJS' end
48− ++ identToJs ident ++ "++) "
104+ , return $ "; " ++ identToJs ident ++ "++) "
49− ++ prettyPrintJS sts
105+ , prettyPrintJS' sts
106+ ]
50− match (JSIfElse cond thens elses) = Just $ "if ("
107+ match (JSIfElse cond thens elses) = fmap concat $ sequence
108+ [ return "if ("
51− ++ prettyPrintJS cond ++ ") "
109+ , prettyPrintJS' cond
110+ , return ") "
52− ++ prettyPrintJS thens
111+ , prettyPrintJS' thens
53− ++ maybe "" ((" else " ++) . prettyPrintJS) elses
112+ , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
113+ ]
114+ match (JSReturn value) = fmap concat $ sequence
115+ [ return "return "
54− match (JSReturn value) = Just $ "return " ++ prettyPrintJS value
116+ , prettyPrintJS' value
117+ ]
118+ match (JSThrow value) = fmap concat $ sequence
119+ [ return "throw "
55− match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value
120+ , prettyPrintJS' value
121+ ]
56− match _ = Nothing
122+ match _ = mzero
57
123
58targetToJs :: JSAssignment -> String
124targetToJs :: JSAssignment -> String
59targetToJs (JSAssignVariable ident) = identToJs ident
125targetToJs (JSAssignVariable ident) = identToJs ident
60targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop
126targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop
61
127
62−conditional :: Pattern JS ((JS, JS), JS)
128+conditional :: Pattern PrinterState JS ((JS, JS), JS)
63−conditional = Pattern $ A.Kleisli match
129+conditional = mkPattern match
64 where
130 where
65 match (JSConditional cond th el) = Just ((th, el), cond)
131 match (JSConditional cond th el) = Just ((th, el), cond)
66 match _ = Nothing
132 match _ = Nothing
67
133
68−accessor :: Pattern JS (String, JS)
134+accessor :: Pattern PrinterState JS (String, JS)
69−accessor = Pattern $ A.Kleisli match
135+accessor = mkPattern match
70 where
136 where
71 match (JSAccessor prop val) = Just (prop, val)
137 match (JSAccessor prop val) = Just (prop, val)
72 match _ = Nothing
138 match _ = Nothing
73
139
74−indexer :: Pattern JS (String, JS)
140+indexer :: Pattern PrinterState JS (String, JS)
75−indexer = Pattern $ A.Kleisli match
141+indexer = mkPattern' match
76 where
142 where
77− match (JSIndexer index val) = Just (prettyPrintJS index, val)
143+ match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
78− match _ = Nothing
144+ match _ = mzero
79
145
80−lam :: Pattern JS ((Maybe Ident, [Ident]), JS)
146+lam :: Pattern PrinterState JS ((Maybe Ident, [Ident]), JS)
81−lam = Pattern $ A.Kleisli match
147+lam = mkPattern match
82 where
148 where
83 match (JSFunction name args ret) = Just ((name, args), ret)
149 match (JSFunction name args ret) = Just ((name, args), ret)
84 match _ = Nothing
150 match _ = Nothing
85
151
86−app :: Pattern JS (String, JS)
152+app :: Pattern PrinterState JS (String, JS)
87−app = Pattern $ A.Kleisli match
153+app = mkPattern' match
88 where
154 where
89− match (JSApp val args) = Just (intercalate "," (map prettyPrintJS args), val)
155+ match (JSApp val args) = do
156+ jss <- mapM prettyPrintJS' args
157+ return (intercalate ", " jss, val)
90− match _ = Nothing
158+ match _ = mzero
91
159
92−unary :: UnaryOperator -> String -> Operator JS String
160+unary :: UnaryOperator -> String -> Operator PrinterState JS String
93unary op str = Wrap pattern (++)
161unary op str = Wrap pattern (++)
94 where
162 where
95− pattern :: Pattern JS (String, JS)
163+ pattern :: Pattern PrinterState JS (String, JS)
96− pattern = Pattern $ A.Kleisli match
164+ pattern = mkPattern match
97 where
165 where
98 match (JSUnary op' val) | op' == op = Just (str, val)
166 match (JSUnary op' val) | op' == op = Just (str, val)
99 match _ = Nothing
167 match _ = Nothing
100
168
101−binary :: BinaryOperator -> String -> Operator JS String
169+binary :: BinaryOperator -> String -> Operator PrinterState JS String
102binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
170binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
103 where
171 where
104− pattern :: Pattern JS (JS, JS)
172+ pattern :: Pattern PrinterState JS (JS, JS)
105− pattern = Pattern $ A.Kleisli match
173+ pattern = mkPattern match
106 where
174 where
107 match (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
175 match (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
108 match _ = Nothing
176 match _ = Nothing
109
177
178+prettyPrintJS1 :: JS -> String
179+prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
180+
110−prettyPrintJS :: JS -> String
181+prettyPrintJS :: [JS] -> String
111−prettyPrintJS = fromMaybe (error "Incomplete pattern") . pattern matchValue
182+prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do
183+ jss <- forM sts prettyPrintJS'
184+ indentString <- currentIndent
185+ return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss
186+
187+prettyPrintJS' :: JS -> StateT PrinterState Maybe String
188+prettyPrintJS' = A.runKleisli $ runPattern matchValue
112 where
189 where
113− matchValue :: Pattern JS String
190+ matchValue :: Pattern PrinterState JS String
114 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
191 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
115− operators :: OperatorTable JS String
192+ operators :: OperatorTable PrinterState JS String
116 operators =
193 operators =
117 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
194 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
118 , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
195 , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
@@ -121,7 +198,7 @@ prettyPrintJS = fromMaybe (error "Incomplete pattern") . pattern matchValue
121 ++ maybe "" identToJs name
198 ++ maybe "" identToJs name
122 ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "
199 ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "
123 ++ ret ]
200 ++ ret ]
124− , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS th ++ " : " ++ prettyPrintJS el ]
201+ , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
125 , [ binary LessThan "<" ]
202 , [ binary LessThan "<" ]
126 , [ binary LessThanOrEqualTo "<=" ]
203 , [ binary LessThanOrEqualTo "<=" ]
127 , [ binary GreaterThan ">" ]
204 , [ binary GreaterThan ">" ]
src/Language/PureScript/Pretty/Kinds.hs+7−7
@@ -26,25 +26,25 @@ import Control.Applicative
26import Language.PureScript.Kinds
26import Language.PureScript.Kinds
27import Language.PureScript.Pretty.Common
27import Language.PureScript.Pretty.Common
28
28
29−typeLiterals :: Pattern Kind String
29+typeLiterals :: Pattern () Kind String
30−typeLiterals = Pattern $ A.Kleisli match
30+typeLiterals = mkPattern match
31 where
31 where
32 match Star = Just "*"
32 match Star = Just "*"
33 match Row = Just "#"
33 match Row = Just "#"
34 match (KUnknown u) = Just $ 'u' : show u
34 match (KUnknown u) = Just $ 'u' : show u
35 match _ = Nothing
35 match _ = Nothing
36
36
37−funKind :: Pattern Kind (Kind, Kind)
37+funKind :: Pattern () Kind (Kind, Kind)
38−funKind = Pattern $ A.Kleisli match
38+funKind = mkPattern match
39 where
39 where
40 match (FunKind arg ret) = Just (arg, ret)
40 match (FunKind arg ret) = Just (arg, ret)
41 match _ = Nothing
41 match _ = Nothing
42
42
43prettyPrintKind :: Kind -> String
43prettyPrintKind :: Kind -> String
44−prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind
44+prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
45 where
45 where
46− matchKind :: Pattern Kind String
46+ matchKind :: Pattern () Kind String
47 matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
47 matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
48− operators :: OperatorTable Kind String
48+ operators :: OperatorTable () Kind String
49 operators =
49 operators =
50 OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
50 OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
src/Language/PureScript/Pretty/Types.hs+11−11
@@ -32,8 +32,8 @@ import Language.PureScript.Declarations
32import Language.PureScript.TypeChecker.Monad
32import Language.PureScript.TypeChecker.Monad
33import Language.PureScript.Pretty.Common
33import Language.PureScript.Pretty.Common
34
34
35−typeLiterals :: Pattern Type String
35+typeLiterals :: Pattern () Type String
36−typeLiterals = Pattern $ A.Kleisli match
36+typeLiterals = mkPattern match
37 where
37 where
38 match Number = Just "Number"
38 match Number = Just "Number"
39 match String = Just "String"
39 match String = Just "String"
@@ -59,30 +59,30 @@ prettyPrintRow = (\(tys, tail) -> intercalate ", " (map (uncurry nameAndTypeToPs
59 toList tys (RCons name ty row) = toList ((name, ty):tys) row
59 toList tys (RCons name ty row) = toList ((name, ty):tys) row
60 toList tys r = (tys, r)
60 toList tys r = (tys, r)
61
61
62−typeApp :: Pattern Type (Type, Type)
62+typeApp :: Pattern () Type (Type, Type)
63−typeApp = Pattern $ A.Kleisli match
63+typeApp = mkPattern match
64 where
64 where
65 match (TypeApp f x) = Just (f, x)
65 match (TypeApp f x) = Just (f, x)
66 match _ = Nothing
66 match _ = Nothing
67
67
68−singleArgumentFunction :: Pattern Type (Type, Type)
68+singleArgumentFunction :: Pattern () Type (Type, Type)
69−singleArgumentFunction = Pattern $ A.Kleisli match
69+singleArgumentFunction = mkPattern match
70 where
70 where
71 match (Function [arg] ret) = Just (arg, ret)
71 match (Function [arg] ret) = Just (arg, ret)
72 match _ = Nothing
72 match _ = Nothing
73
73
74−function :: Pattern Type ([Type], Type)
74+function :: Pattern () Type ([Type], Type)
75−function = Pattern $ A.Kleisli match
75+function = mkPattern match
76 where
76 where
77 match (Function args ret) = Just (args, ret)
77 match (Function args ret) = Just (args, ret)
78 match _ = Nothing
78 match _ = Nothing
79
79
80prettyPrintType :: Type -> String
80prettyPrintType :: Type -> String
81−prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType
81+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()
82 where
82 where
83− matchType :: Pattern Type String
83+ matchType :: Pattern () Type String
84 matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
84 matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
85− operators :: OperatorTable Type String
85+ operators :: OperatorTable () Type String
86 operators =
86 operators =
87 OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
87 OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
88 , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
88 , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
src/Language/PureScript/Pretty/Values.hs+23−23
@@ -29,8 +29,8 @@ import Language.PureScript.Values
29import Language.PureScript.Names
29import Language.PureScript.Names
30import Language.PureScript.Pretty.Common
30import Language.PureScript.Pretty.Common
31
31
32−literals :: Pattern Value String
32+literals :: Pattern () Value String
33−literals = Pattern $ A.Kleisli match
33+literals = mkPattern match
34 where
34 where
35 match (NumericLiteral n) = Just $ either show show n
35 match (NumericLiteral n) = Just $ either show show n
36 match (StringLiteral s) = Just $ show s
36 match (StringLiteral s) = Just $ show s
@@ -47,66 +47,66 @@ literals = Pattern $ A.Kleisli match
47prettyPrintCaseAlternative :: Binder -> Value -> String
47prettyPrintCaseAlternative :: Binder -> Value -> String
48prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val
48prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val
49
49
50−ifThenElse :: Pattern Value ((Value, Value), Value)
50+ifThenElse :: Pattern () Value ((Value, Value), Value)
51−ifThenElse = Pattern $ A.Kleisli match
51+ifThenElse = mkPattern match
52 where
52 where
53 match (IfThenElse cond th el) = Just ((th, el), cond)
53 match (IfThenElse cond th el) = Just ((th, el), cond)
54 match _ = Nothing
54 match _ = Nothing
55
55
56−accessor :: Pattern Value (String, Value)
56+accessor :: Pattern () Value (String, Value)
57−accessor = Pattern $ A.Kleisli match
57+accessor = mkPattern match
58 where
58 where
59 match (Accessor prop val) = Just (prop, val)
59 match (Accessor prop val) = Just (prop, val)
60 match _ = Nothing
60 match _ = Nothing
61
61
62−indexer :: Pattern Value (Value, Value)
62+indexer :: Pattern () Value (Value, Value)
63−indexer = Pattern $ A.Kleisli match
63+indexer = mkPattern match
64 where
64 where
65 match (Indexer index val) = Just (index, val)
65 match (Indexer index val) = Just (index, val)
66 match _ = Nothing
66 match _ = Nothing
67
67
68−objectUpdate :: Pattern Value ([String], Value)
68+objectUpdate :: Pattern () Value ([String], Value)
69−objectUpdate = Pattern $ A.Kleisli match
69+objectUpdate = mkPattern match
70 where
70 where
71 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
71 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
72 match _ = Nothing
72 match _ = Nothing
73
73
74−app :: Pattern Value (String, Value)
74+app :: Pattern () Value (String, Value)
75−app = Pattern $ A.Kleisli match
75+app = mkPattern match
76 where
76 where
77 match (App val args) = Just (intercalate "," (map prettyPrintValue args), val)
77 match (App val args) = Just (intercalate "," (map prettyPrintValue args), val)
78 match _ = Nothing
78 match _ = Nothing
79
79
80−lam :: Pattern Value ([String], Value)
80+lam :: Pattern () Value ([String], Value)
81−lam = Pattern $ A.Kleisli match
81+lam = mkPattern match
82 where
82 where
83 match (Abs args val) = Just (map show args, val)
83 match (Abs args val) = Just (map show args, val)
84 match _ = Nothing
84 match _ = Nothing
85
85
86−unary :: UnaryOperator -> String -> Operator Value String
86+unary :: UnaryOperator -> String -> Operator () Value String
87unary op str = Wrap pattern (++)
87unary op str = Wrap pattern (++)
88 where
88 where
89− pattern :: Pattern Value (String, Value)
89+ pattern :: Pattern () Value (String, Value)
90− pattern = Pattern $ A.Kleisli match
90+ pattern = mkPattern match
91 where
91 where
92 match (Unary op' val) | op' == op = Just (str, val)
92 match (Unary op' val) | op' == op = Just (str, val)
93 match _ = Nothing
93 match _ = Nothing
94
94
95−binary :: BinaryOperator -> String -> Operator Value String
95+binary :: BinaryOperator -> String -> Operator () Value String
96binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
96binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
97 where
97 where
98− pattern :: Pattern Value (Value, Value)
98+ pattern :: Pattern () Value (Value, Value)
99− pattern = Pattern $ A.Kleisli match
99+ pattern = mkPattern match
100 where
100 where
101 match (Binary op' v1 v2) | op' == op = Just (v1, v2)
101 match (Binary op' v1 v2) | op' == op = Just (v1, v2)
102 match _ = Nothing
102 match _ = Nothing
103
103
104prettyPrintValue :: Value -> String
104prettyPrintValue :: Value -> String
105−prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue
105+prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
106 where
106 where
107− matchValue :: Pattern Value String
107+ matchValue :: Pattern () Value String
108 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
108 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
109− operators :: OperatorTable Value String
109+ operators :: OperatorTable () Value String
110 operators =
110 operators =
111 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
111 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
112 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
112 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]