@@ -13,6 +13,7 @@
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
15module Language.PureScript.CodeGen.JS (
15module Language.PureScript.CodeGen.JS (
@@ -20,7 +21,7 @@ import Data.Char
20import Data.Maybe (fromMaybe)
21import Data.Maybe (fromMaybe)
21import Data.List (intercalate)
22import Data.List (intercalate)
22import qualified Control.Arrow as A
23import qualified Control.Arrow as A
23−import Control.Arrow ((<+>))
24+import Control.Arrow ((<+>), second)
24import Control.Monad (forM)
25import Control.Monad (forM)
25import Control.Applicative
26import Control.Applicative
@@ -30,203 +31,110 @@ import Language.PureScript.Names
30import Language.PureScript.Declarations
31import Language.PureScript.Declarations
31import Language.PureScript.Pretty.Common
32import Language.PureScript.Pretty.Common
32import Language.PureScript.CodeGen.Monad
33import Language.PureScript.CodeGen.Monad
34+import Language.PureScript.CodeGen.JS.AST as AST
34−declToJs :: Declaration -> Maybe String
36+declToJs :: Declaration -> Maybe [JS]
35−declToJs (ValueDeclaration ident (Abs args ret)) = Just $ "function " ++ identToJs ident ++ "(" ++ intercalate "," (map identToJs args) ++ ") { return " ++ valueToJs ret ++ "; }"
37+declToJs (ValueDeclaration ident (Abs args ret)) = Just [JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs ret)])]
36−declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"
38+declToJs (ValueDeclaration ident val) = Just [JSVariableIntroduction ident (valueToJs val)]
37declToJs (DataDeclaration _ _ ctors) =
39declToJs (DataDeclaration _ _ ctors) =
38− Just $ flip concatMap ctors $ \(ctor, maybeTy) ->
40+ Just $ flip map ctors $ \(ctor, maybeTy) ->
39 case maybeTy of
41 case maybeTy of
40− Nothing -> "var " ++ ctor ++ " = { ctor: '" ++ ctor ++ "' };"
42+ Nothing -> JSVariableIntroduction (Ident ctor) (JSObjectLiteral [ ("ctor", JSStringLiteral ctor) ])
41− Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"
43+ Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
45+ (JSObjectLiteral [ ("ctor", JSStringLiteral ctor)
46+ , ("value", JSVar (Ident "value")) ])])
42declToJs _ = Nothing
47declToJs _ = Nothing
44−literals :: Pattern Value String
49+valueToJs :: Value -> JS
45−literals = Pattern $ A.Kleisli match
47− match (NumericLiteral n) = Just $ either show show n
50+valueToJs (NumericLiteral n) = JSNumericLiteral n
48− match (StringLiteral s) = Just $ show s
51+valueToJs (StringLiteral s) = JSStringLiteral s
49− match (BooleanLiteral True) = Just "true"
52+valueToJs (BooleanLiteral b) = JSBooleanLiteral b
50− match (BooleanLiteral False) = Just "false"
51− match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]"
53+valueToJs (ArrayLiteral xs) = JSArrayLiteral (map valueToJs xs)
52− match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"
54+valueToJs (ObjectLiteral ps) = JSObjectLiteral (map (second valueToJs) ps)
53− match (ObjectUpdate o ps) = Just $ "Object.extend("
55+valueToJs (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs o, JSObjectLiteral (map (second valueToJs) ps)]
54− ++ valueToJs o ++ ", { "
55− ++ intercalate ", " (map objectPropertyToJs ps) ++ " }"
56− match (Constructor name) = Just name
56+valueToJs (Constructor name) = JSVar (Ident name)
57− match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"
57+valueToJs (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map statementToJs sts))) []
58− match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"
58+valueToJs (Case value binders) = runGen (bindersToJs binders (valueToJs value))
60− bindersToJs :: [(Binder, Value)] -> Gen String
61− bindersToJs binders = do
63− jss <- forM binders $ \(binder, result) -> do
64− let js = valueToJs result
65− binderToJs valName ("return " ++ js ++ ";") binder
66− return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }"
67− match (Var ident) = Just (identToJs ident)
70−ifThenElse :: Pattern Value ((Value, Value), Value)
71−ifThenElse = Pattern $ A.Kleisli match
73− match (IfThenElse cond th el) = Just ((th, el), cond)
59+valueToJs (IfThenElse cond th el) = JSConditional (valueToJs cond) (valueToJs th) (valueToJs el)
76−accessor :: Pattern Value (String, Value)
77−accessor = Pattern $ A.Kleisli match
79− match (Accessor prop val) = Just (prop, val)
60+valueToJs (Accessor prop val) = JSAccessor prop (valueToJs val)
82−indexer :: Pattern Value (String, Value)
83−indexer = Pattern $ A.Kleisli match
85− match (Indexer index val) = Just (valueToJs index, val)
61+valueToJs (Indexer index val) = JSIndexer (valueToJs index) (valueToJs val)
88−app :: Pattern Value (String, Value)
89−app = Pattern $ A.Kleisli match
91− match (App val args) = Just (intercalate "," (map valueToJs args), val)
62+valueToJs (App val args) = JSApp (valueToJs val) (map valueToJs args)
92− match _ = Nothing
63+valueToJs (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs val)])
94−lam :: Pattern Value ([String], Value)
95−lam = Pattern $ A.Kleisli match
97− match (Abs args val) = Just (map identToJs args, val)
100−unary :: UnaryOperator -> String -> Operator Value String
101−unary op str = Wrap pattern (++)
103− pattern :: Pattern Value (String, Value)
104− pattern = Pattern $ A.Kleisli match
106− match (Unary op' val) | op' == op = Just (str, val)
64+valueToJs (Unary op val) = JSUnary op (valueToJs val)
107− match _ = Nothing
65+valueToJs (Binary op v1 v2) = JSBinary op (valueToJs v1) (valueToJs v2)
108−
66+valueToJs (Var ident) = JSVar ident
109−binary :: BinaryOperator -> String -> Operator Value String
67+valueToJs (TypedValue val _) = valueToJs val
110−binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
68+
111− where
69+bindersToJs :: [(Binder, Value)] -> JS -> Gen JS
112− pattern :: Pattern Value (Value, Value)
70+bindersToJs binders val = do
113− pattern = Pattern $ A.Kleisli match
71+ valName <- fresh
114− where
72+ jss <- forM binders $ \(binder, result) -> binderToJs valName [JSReturn (valueToJs result)] binder
115− match (Binary op' v1 v2) | op' == op = Just (v1, v2)
73+ return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
116− match _ = Nothing
74+ [val]
118−valueToJs :: Value -> String
76+binderToJs :: String -> [JS] -> Binder -> Gen [JS]
119−valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue
121− matchValue :: Pattern Value String
122− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
123− operators :: OperatorTable Value String
125− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
126− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
127− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
128− , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }" ]
129− , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ valueToJs th ++ " : " ++ valueToJs el ]
130− , [ binary LessThan "<" ]
131− , [ binary LessThanOrEqualTo "<=" ]
132− , [ binary GreaterThan ">" ]
133− , [ binary GreaterThanOrEqualTo ">=" ]
135− , [ unary BitwiseNot "~" ]
136− , [ unary Negate "-" ]
137− , [ binary Multiply "*" ]
138− , [ binary Divide "/" ]
139− , [ binary Modulus "%" ]
140− , [ binary Concat "+" ]
141− , [ binary Add "+" ]
142− , [ binary Subtract "-" ]
143− , [ binary ShiftLeft "<<" ]
144− , [ binary ShiftRight ">>" ]
145− , [ binary ZeroFillShiftRight ">>>" ]
146− , [ binary EqualTo "===" ]
147− , [ binary NotEqualTo "!==" ]
148− , [ binary BitwiseAnd "&" ]
149− , [ binary BitwiseXor "^" ]
150− , [ binary BitwiseOr "|" ]
151− , [ binary And "&&" ]
152− , [ binary Or "||" ]
155−binderToJs :: String -> String -> Binder -> Gen String
156binderToJs varName done NullBinder = return done
77binderToJs varName done NullBinder = return done
157binderToJs varName done (StringBinder str) =
78binderToJs varName done (StringBinder str) =
158− return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"
79+ return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) done Nothing]
159binderToJs varName done (NumberBinder num) =
80binderToJs varName done (NumberBinder num) =
160− return $ "if (" ++ varName ++ " === " ++ either show show num ++ ") {" ++ done ++ " }"
81+ return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) done Nothing]
161binderToJs varName done (BooleanBinder True) =
82binderToJs varName done (BooleanBinder True) =
162− return $ "if (" ++ varName ++ ") {" ++ done ++ " }"
83+ return [JSIfElse (JSVar (Ident varName)) done Nothing]
163binderToJs varName done (BooleanBinder False) =
84binderToJs varName done (BooleanBinder False) =
164− return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"
85+ return [JSIfElse (JSUnary Not (JSVar (Ident varName))) done Nothing]
165binderToJs varName done (VarBinder ident) =
86binderToJs varName done (VarBinder ident) =
166− return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ done
87+ return (JSVariableIntroduction ident (JSVar (Ident varName)) : done)
167binderToJs varName done (NullaryBinder ctor) =
88binderToJs varName done (NullaryBinder ctor) =
168− return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"
89+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) done Nothing]
169binderToJs varName done (UnaryBinder ctor b) = do
90binderToJs varName done (UnaryBinder ctor b) = do
170 value <- fresh
91 value <- fresh
171 js <- binderToJs value done b
92 js <- binderToJs value done b
172− return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"
93+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSVariableIntroduction (Ident value) (JSAccessor "value" (JSVar (Ident varName))) : js) Nothing]
173binderToJs varName done (ObjectBinder bs) = go done bs
94binderToJs varName done (ObjectBinder bs) = go done bs
96+ go :: [JS] -> [(String, Binder)] -> Gen [JS]
175 go done [] = return done
97 go done [] = return done
176 go done ((prop, binder):bs) = do
98 go done ((prop, binder):bs) = do
177 propVar <- fresh
99 propVar <- fresh
178 done' <- go done bs
100 done' <- go done bs
179 js <- binderToJs propVar done' binder
101 js <- binderToJs propVar done' binder
180− return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js
102+ return (JSVariableIntroduction (Ident propVar) (JSAccessor prop (JSVar (Ident varName))) : js)
181binderToJs varName done (ArrayBinder bs rest) = do
103binderToJs varName done (ArrayBinder bs rest) = do
182 js <- go done rest 0 bs
104 js <- go done rest 0 bs
183− return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }"
105+ return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) js Nothing]
107+ cmp :: BinaryOperator
185− cmp = maybe "===" (const ">=") rest
108+ cmp = maybe EqualTo (const GreaterThanOrEqualTo) rest
109+ go :: [JS] -> Maybe Binder -> Integer -> [Binder] -> Gen [JS]
186 go done Nothing _ [] = return done
110 go done Nothing _ [] = return done
187 go done (Just binder) index [] = do
111 go done (Just binder) index [] = do
188 restVar <- fresh
112 restVar <- fresh
189 js <- binderToJs restVar done binder
113 js <- binderToJs restVar done binder
190− return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js
114+ return (JSVariableIntroduction (Ident restVar) (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)]) : js)
191 go done rest index (binder:bs) = do
115 go done rest index (binder:bs) = do
192 elVar <- fresh
116 elVar <- fresh
193 done' <- go done rest (index + 1) bs
117 done' <- go done rest (index + 1) bs
194 js <- binderToJs elVar done' binder
118 js <- binderToJs elVar done' binder
195− return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js
119+ return (JSVariableIntroduction (Ident elVar) (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName))) : js)
196binderToJs varName done (NamedBinder ident binder) = do
120binderToJs varName done (NamedBinder ident binder) = do
197 js <- binderToJs varName done binder
121 js <- binderToJs varName done binder
198− return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ js
122+ return (JSVariableIntroduction ident (JSVar (Ident varName)) : js)
199binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
123binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
201− done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"
125+ done' = [JSIfElse (valueToJs cond) done Nothing]
203−objectPropertyToJs :: (String, Value) -> String
204−objectPropertyToJs (key, value) = key ++ ": " ++ valueToJs value
206−statementToJs :: Statement -> String
127+statementToJs :: Statement -> JS
207−statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value
128+statementToJs (VariableIntroduction ident value) = JSVariableIntroduction ident (valueToJs value)
208−statementToJs (Assignment target value) = identToJs target ++ " = " ++ valueToJs value
129+statementToJs (Assignment target value) = JSAssignment target (valueToJs value)
209−statementToJs (While cond sts) = "while ("
130+statementToJs (While cond sts) = JSWhile (valueToJs cond) (map statementToJs sts)
210− ++ valueToJs cond ++ ") {"
211− ++ intercalate ";" (map statementToJs sts) ++ "}"
212−statementToJs (For ident start end sts) = "for (" ++
131+statementToJs (For ident start end sts) = JSFor ident (valueToJs start) (valueToJs end) (map statementToJs sts)
213− identToJs ident ++ " = " ++ valueToJs start ++ ";"
132+statementToJs (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs arr)) [JSFunction Nothing [ident] (JSBlock (map statementToJs sts))]
214− ++ identToJs ident ++ " < " ++ valueToJs end ++ ";"
215− ++ identToJs ident ++ "++) {"
216− ++ intercalate ";" (map statementToJs sts) ++ "}"
217−statementToJs (ForEach ident arr sts) = valueToJs arr
218− ++ ".forEach(function(" ++ identToJs ident ++ ") {"
219− ++ intercalate ";" (map statementToJs sts) ++ "})"
220−statementToJs (If ifst) = ifStatementToJs ifst
133+statementToJs (If ifst) = ifToJs ifst
221−statementToJs (Return value) = "return " ++ valueToJs value
134+ where
223−ifStatementToJs :: IfStatement -> String
135+ ifToJs :: IfStatement -> JS
224−ifStatementToJs (IfStatement cond thens elst) =
136+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs cond) (map statementToJs thens) (fmap elseToJs elses)
226− ++ valueToJs cond ++ ") {"
227− ++ intercalate ";" (map statementToJs thens) ++ "}"
228− ++ maybe "" elseStatementToJs elst
230−elseStatementToJs :: ElseStatement -> String
137+ elseToJs :: ElseStatement -> JS
231−elseStatementToJs (Else sts) = " else {" ++ intercalate ";" (map statementToJs sts) ++ "}"
138+ elseToJs (Else sts) = JSBlock (map statementToJs sts)
232−elseStatementToJs (ElseIf ifst) = " else " ++ ifStatementToJs ifst
139+ elseToJs (ElseIf ifst) = ifToJs ifst
140+statementToJs (Return value) = JSReturn (valueToJs value)