@@ -25,94 +25,171 @@ import Data.List
2525import Data.Maybe (fromMaybe)
2626import qualified Control.Arrow as A
2727import Control.Arrow ((***), (<+>), first, second)
28+import Control.Applicative
29+import Control.Monad.State
2830
29−literals :: Pattern JS String
30−literals = Pattern $ A.Kleisli match
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+
49+literals :: Pattern PrinterState JS String
50+literals = mkPattern' match
3151 where
32− match (JSNumericLiteral n) = Just $ either show show n
33− match (JSStringLiteral s) = Just $ show s
34− match (JSBooleanLiteral True) = Just "true"
35− match (JSBooleanLiteral False) = Just "false"
36− match (JSArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintJS xs) ++ "]"
37− match (JSObjectLiteral ps) = Just $ "{ " ++ intercalate ", " (map (\(key, value) -> key ++ ": " ++ prettyPrintJS value) ps) ++ " }"
38− match (JSBlock sts) = Just $ "{ " ++ intercalate "; " (map prettyPrintJS sts) ++ " }"
39− match (JSVar ident) = Just (identToJs ident)
40− match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ maybe "" ((" = " ++) . prettyPrintJS) value
41− match (JSAssignment target value) = Just $ targetToJs target ++ " = " ++ prettyPrintJS value
42− match (JSWhile cond sts) = Just $ "while ("
43− ++ prettyPrintJS cond ++ ") "
44− ++ prettyPrintJS sts
45− match (JSFor ident start end sts) = Just $ "for ("
46− ++ identToJs ident ++ " = " ++ prettyPrintJS start ++ "; "
47− ++ identToJs ident ++ " < " ++ prettyPrintJS end ++ "; "
48− ++ identToJs ident ++ "++) "
49− ++ prettyPrintJS sts
50− match (JSIfElse cond thens elses) = Just $ "if ("
51− ++ prettyPrintJS cond ++ ") "
52− ++ prettyPrintJS thens
53− ++ maybe "" ((" else " ++) . prettyPrintJS) elses
54− match (JSReturn value) = Just $ "return " ++ prettyPrintJS value
55− match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value
56− match _ = Nothing
52+ match :: JS -> StateT PrinterState Maybe String
53+ match (JSNumericLiteral n) = return $ either show show n
54+ match (JSStringLiteral s) = return $ show s
55+ match (JSBooleanLiteral True) = return "true"
56+ match (JSBooleanLiteral False) = return "false"
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
65+ jss <- forM ps $ \(key, value) -> fmap ((key ++ ": ") ++) . prettyPrintJS' $ value
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+ ]
82+ match (JSVar ident) = return (identToJs ident)
83+ match (JSVariableIntroduction ident value) = fmap concat $ sequence
84+ [ return "var "
85+ , return $ identToJs ident
86+ , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
87+ ]
88+ match (JSAssignment target value) = fmap concat $ sequence
89+ [ return $ targetToJs target
90+ , return " = "
91+ , prettyPrintJS' value
92+ ]
93+ match (JSWhile cond sts) = fmap concat $ sequence
94+ [ return "while ("
95+ , prettyPrintJS' cond
96+ , return ") "
97+ , prettyPrintJS' sts
98+ ]
99+ match (JSFor ident start end sts) = fmap concat $ sequence
100+ [ return $ "for (" ++ identToJs ident ++ " = "
101+ , prettyPrintJS' start
102+ , return $ "; " ++ identToJs ident ++ " < "
103+ , prettyPrintJS' end
104+ , return $ "; " ++ identToJs ident ++ "++) "
105+ , prettyPrintJS' sts
106+ ]
107+ match (JSIfElse cond thens elses) = fmap concat $ sequence
108+ [ return "if ("
109+ , prettyPrintJS' cond
110+ , return ") "
111+ , prettyPrintJS' thens
112+ , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
113+ ]
114+ match (JSReturn value) = fmap concat $ sequence
115+ [ return "return "
116+ , prettyPrintJS' value
117+ ]
118+ match (JSThrow value) = fmap concat $ sequence
119+ [ return "throw "
120+ , prettyPrintJS' value
121+ ]
122+ match _ = mzero
57123
58124targetToJs :: JSAssignment -> String
59125targetToJs (JSAssignVariable ident) = identToJs ident
60126targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop
61127
62−conditional :: Pattern JS ((JS, JS), JS)
63−conditional = Pattern $ A.Kleisli match
128+conditional :: Pattern PrinterState JS ((JS, JS), JS)
129+conditional = mkPattern match
64130 where
65131 match (JSConditional cond th el) = Just ((th, el), cond)
66132 match _ = Nothing
67133
68−accessor :: Pattern JS (String, JS)
69−accessor = Pattern $ A.Kleisli match
134+accessor :: Pattern PrinterState JS (String, JS)
135+accessor = mkPattern match
70136 where
71137 match (JSAccessor prop val) = Just (prop, val)
72138 match _ = Nothing
73139
74−indexer :: Pattern JS (String, JS)
75−indexer = Pattern $ A.Kleisli match
140+indexer :: Pattern PrinterState JS (String, JS)
141+indexer = mkPattern' match
76142 where
77− match (JSIndexer index val) = Just (prettyPrintJS index, val)
78− match _ = Nothing
143+ match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
144+ match _ = mzero
79145
80−lam :: Pattern JS ((Maybe Ident, [Ident]), JS)
81−lam = Pattern $ A.Kleisli match
146+lam :: Pattern PrinterState JS ((Maybe Ident, [Ident]), JS)
147+lam = mkPattern match
82148 where
83149 match (JSFunction name args ret) = Just ((name, args), ret)
84150 match _ = Nothing
85151
86−app :: Pattern JS (String, JS)
87−app = Pattern $ A.Kleisli match
152+app :: Pattern PrinterState JS (String, JS)
153+app = mkPattern' match
88154 where
89− match (JSApp val args) = Just (intercalate "," (map prettyPrintJS args), val)
90− match _ = Nothing
155+ match (JSApp val args) = do
156+ jss <- mapM prettyPrintJS' args
157+ return (intercalate ", " jss, val)
158+ match _ = mzero
91159
92−unary :: UnaryOperator -> String -> Operator JS String
160+unary :: UnaryOperator -> String -> Operator PrinterState JS String
93161unary op str = Wrap pattern (++)
94162 where
95− pattern :: Pattern JS (String, JS)
96− pattern = Pattern $ A.Kleisli match
163+ pattern :: Pattern PrinterState JS (String, JS)
164+ pattern = mkPattern match
97165 where
98166 match (JSUnary op' val) | op' == op = Just (str, val)
99167 match _ = Nothing
100168
101−binary :: BinaryOperator -> String -> Operator JS String
169+binary :: BinaryOperator -> String -> Operator PrinterState JS String
102170binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
103171 where
104− pattern :: Pattern JS (JS, JS)
105− pattern = Pattern $ A.Kleisli match
172+ pattern :: Pattern PrinterState JS (JS, JS)
173+ pattern = mkPattern match
106174 where
107175 match (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
108176 match _ = Nothing
109177
110−prettyPrintJS :: JS -> String
111−prettyPrintJS = fromMaybe (error "Incomplete pattern") . pattern matchValue
178+prettyPrintJS1 :: JS -> String
179+prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
180+
181+prettyPrintJS :: [JS] -> String
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
112189 where
113− matchValue :: Pattern JS String
190+ matchValue :: Pattern PrinterState JS String
114191 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
115− operators :: OperatorTable JS String
192+ operators :: OperatorTable PrinterState JS String
116193 operators =
117194 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
118195 , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
@@ -121,7 +198,7 @@ prettyPrintJS = fromMaybe (error "Incomplete pattern") . pattern matchValue
121198 ++ maybe "" identToJs name
122199 ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "
123200 ++ ret ]
124− , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS th ++ " : " ++ prettyPrintJS el ]
201+ , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
125202 , [ binary LessThan "<" ]
126203 , [ binary LessThanOrEqualTo "<=" ]
127204 , [ binary GreaterThan ">" ]