@@ -13,6 +13,7 @@
1313-----------------------------------------------------------------------------
1414
1515module Language.PureScript.CodeGen.JS (
16+ module AST,
1617 declToJs
1718) where
1819
@@ -20,7 +21,7 @@ import Data.Char
2021import Data.Maybe (fromMaybe)
2122import Data.List (intercalate)
2223import qualified Control.Arrow as A
23−import Control.Arrow ((<+>))
24+import Control.Arrow ((<+>), second)
2425import Control.Monad (forM)
2526import Control.Applicative
2627
@@ -30,203 +31,110 @@ import Language.PureScript.Names
3031import Language.PureScript.Declarations
3132import Language.PureScript.Pretty.Common
3233import Language.PureScript.CodeGen.Monad
34+import Language.PureScript.CodeGen.JS.AST as AST
3335
34−declToJs :: Declaration -> Maybe String
35−declToJs (ValueDeclaration ident (Abs args ret)) = Just $ "function " ++ identToJs ident ++ "(" ++ intercalate "," (map identToJs args) ++ ") { return " ++ valueToJs ret ++ "; }"
36−declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"
36+declToJs :: Declaration -> Maybe [JS]
37+declToJs (ValueDeclaration ident (Abs args ret)) = Just [JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs ret)])]
38+declToJs (ValueDeclaration ident val) = Just [JSVariableIntroduction ident (valueToJs val)]
3739declToJs (DataDeclaration _ _ ctors) =
38− Just $ flip concatMap ctors $ \(ctor, maybeTy) ->
40+ Just $ flip map ctors $ \(ctor, maybeTy) ->
3941 case maybeTy of
40− Nothing -> "var " ++ ctor ++ " = { ctor: '" ++ ctor ++ "' };"
41− Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"
42+ Nothing -> JSVariableIntroduction (Ident ctor) (JSObjectLiteral [ ("ctor", JSStringLiteral ctor) ])
43+ Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
44+ (JSBlock [JSReturn
45+ (JSObjectLiteral [ ("ctor", JSStringLiteral ctor)
46+ , ("value", JSVar (Ident "value")) ])])
4247declToJs _ = Nothing
4348
44−literals :: Pattern Value String
45−literals = Pattern $ A.Kleisli match
46− where
47− match (NumericLiteral n) = Just $ either show show n
48− match (StringLiteral s) = Just $ show s
49− match (BooleanLiteral True) = Just "true"
50− match (BooleanLiteral False) = Just "false"
51− match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]"
52− match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"
53− match (ObjectUpdate o ps) = Just $ "Object.extend("
54− ++ valueToJs o ++ ", { "
55− ++ intercalate ", " (map objectPropertyToJs ps) ++ " }"
56− match (Constructor name) = Just name
57− match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"
58− match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"
59− where
60− bindersToJs :: [(Binder, Value)] -> Gen String
61− bindersToJs binders = do
62− valName <- fresh
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)
68− match _ = Nothing
69−
70−ifThenElse :: Pattern Value ((Value, Value), Value)
71−ifThenElse = Pattern $ A.Kleisli match
72− where
73− match (IfThenElse cond th el) = Just ((th, el), cond)
74− match _ = Nothing
75−
76−accessor :: Pattern Value (String, Value)
77−accessor = Pattern $ A.Kleisli match
78− where
79− match (Accessor prop val) = Just (prop, val)
80− match _ = Nothing
81−
82−indexer :: Pattern Value (String, Value)
83−indexer = Pattern $ A.Kleisli match
84− where
85− match (Indexer index val) = Just (valueToJs index, val)
86− match _ = Nothing
87−
88−app :: Pattern Value (String, Value)
89−app = Pattern $ A.Kleisli match
90− where
91− match (App val args) = Just (intercalate "," (map valueToJs args), val)
92− match _ = Nothing
93−
94−lam :: Pattern Value ([String], Value)
95−lam = Pattern $ A.Kleisli match
96− where
97− match (Abs args val) = Just (map identToJs args, val)
98− match _ = Nothing
99−
100−unary :: UnaryOperator -> String -> Operator Value String
101−unary op str = Wrap pattern (++)
102− where
103− pattern :: Pattern Value (String, Value)
104− pattern = Pattern $ A.Kleisli match
105− where
106− match (Unary op' val) | op' == op = Just (str, val)
107− match _ = Nothing
108−
109−binary :: BinaryOperator -> String -> Operator Value String
110−binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
111− where
112− pattern :: Pattern Value (Value, Value)
113− pattern = Pattern $ A.Kleisli match
114− where
115− match (Binary op' v1 v2) | op' == op = Just (v1, v2)
116− match _ = Nothing
117−
118−valueToJs :: Value -> String
119−valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue
120− where
121− matchValue :: Pattern Value String
122− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
123− operators :: OperatorTable Value String
124− operators =
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 ">=" ]
134− , [ unary Not "!" ]
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 "||" ]
153− ]
154−
155−binderToJs :: String -> String -> Binder -> Gen String
49+valueToJs :: Value -> JS
50+valueToJs (NumericLiteral n) = JSNumericLiteral n
51+valueToJs (StringLiteral s) = JSStringLiteral s
52+valueToJs (BooleanLiteral b) = JSBooleanLiteral b
53+valueToJs (ArrayLiteral xs) = JSArrayLiteral (map valueToJs xs)
54+valueToJs (ObjectLiteral ps) = JSObjectLiteral (map (second valueToJs) ps)
55+valueToJs (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs o, JSObjectLiteral (map (second valueToJs) ps)]
56+valueToJs (Constructor name) = JSVar (Ident name)
57+valueToJs (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map statementToJs sts))) []
58+valueToJs (Case value binders) = runGen (bindersToJs binders (valueToJs value))
59+valueToJs (IfThenElse cond th el) = JSConditional (valueToJs cond) (valueToJs th) (valueToJs el)
60+valueToJs (Accessor prop val) = JSAccessor prop (valueToJs val)
61+valueToJs (Indexer index val) = JSIndexer (valueToJs index) (valueToJs val)
62+valueToJs (App val args) = JSApp (valueToJs val) (map valueToJs args)
63+valueToJs (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs val)])
64+valueToJs (Unary op val) = JSUnary op (valueToJs val)
65+valueToJs (Binary op v1 v2) = JSBinary op (valueToJs v1) (valueToJs v2)
66+valueToJs (Var ident) = JSVar ident
67+valueToJs (TypedValue val _) = valueToJs val
68+
69+bindersToJs :: [(Binder, Value)] -> JS -> Gen JS
70+bindersToJs binders val = do
71+ valName <- fresh
72+ jss <- forM binders $ \(binder, result) -> binderToJs valName [JSReturn (valueToJs result)] binder
73+ return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
74+ [val]
75+
76+binderToJs :: String -> [JS] -> Binder -> Gen [JS]
15677binderToJs varName done NullBinder = return done
15778binderToJs varName done (StringBinder str) =
158− return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"
79+ return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) done Nothing]
15980binderToJs 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]
16182binderToJs varName done (BooleanBinder True) =
162− return $ "if (" ++ varName ++ ") {" ++ done ++ " }"
83+ return [JSIfElse (JSVar (Ident varName)) done Nothing]
16384binderToJs varName done (BooleanBinder False) =
164− return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"
85+ return [JSIfElse (JSUnary Not (JSVar (Ident varName))) done Nothing]
16586binderToJs varName done (VarBinder ident) =
166− return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ done
87+ return (JSVariableIntroduction ident (JSVar (Ident varName)) : done)
16788binderToJs 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]
16990binderToJs varName done (UnaryBinder ctor b) = do
17091 value <- fresh
17192 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]
17394binderToJs varName done (ObjectBinder bs) = go done bs
17495 where
96+ go :: [JS] -> [(String, Binder)] -> Gen [JS]
17597 go done [] = return done
17698 go done ((prop, binder):bs) = do
17799 propVar <- fresh
178100 done' <- go done bs
179101 js <- binderToJs propVar done' binder
180− return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js
102+ return (JSVariableIntroduction (Ident propVar) (JSAccessor prop (JSVar (Ident varName))) : js)
181103binderToJs varName done (ArrayBinder bs rest) = do
182104 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]
184106 where
185− cmp = maybe "===" (const ">=") rest
107+ cmp :: BinaryOperator
108+ cmp = maybe EqualTo (const GreaterThanOrEqualTo) rest
109+ go :: [JS] -> Maybe Binder -> Integer -> [Binder] -> Gen [JS]
186110 go done Nothing _ [] = return done
187111 go done (Just binder) index [] = do
188112 restVar <- fresh
189113 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)
191115 go done rest index (binder:bs) = do
192116 elVar <- fresh
193117 done' <- go done rest (index + 1) bs
194118 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)
196120binderToJs varName done (NamedBinder ident binder) = do
197121 js <- binderToJs varName done binder
198− return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ js
122+ return (JSVariableIntroduction ident (JSVar (Ident varName)) : js)
199123binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder
200124 where
201− done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"
202−
203−objectPropertyToJs :: (String, Value) -> String
204−objectPropertyToJs (key, value) = key ++ ": " ++ valueToJs value
205−
206−statementToJs :: Statement -> String
207−statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value
208−statementToJs (Assignment target value) = identToJs target ++ " = " ++ valueToJs value
209−statementToJs (While cond sts) = "while ("
210− ++ valueToJs cond ++ ") {"
211− ++ intercalate ";" (map statementToJs sts) ++ "}"
212−statementToJs (For ident start end sts) = "for (" ++
213− identToJs ident ++ " = " ++ valueToJs start ++ ";"
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
221−statementToJs (Return value) = "return " ++ valueToJs value
222−
223−ifStatementToJs :: IfStatement -> String
224−ifStatementToJs (IfStatement cond thens elst) =
225− "if ("
226− ++ valueToJs cond ++ ") {"
227− ++ intercalate ";" (map statementToJs thens) ++ "}"
228− ++ maybe "" elseStatementToJs elst
229−
230−elseStatementToJs :: ElseStatement -> String
231−elseStatementToJs (Else sts) = " else {" ++ intercalate ";" (map statementToJs sts) ++ "}"
232−elseStatementToJs (ElseIf ifst) = " else " ++ ifStatementToJs ifst
125+ done' = [JSIfElse (valueToJs cond) done Nothing]
126+
127+statementToJs :: Statement -> JS
128+statementToJs (VariableIntroduction ident value) = JSVariableIntroduction ident (valueToJs value)
129+statementToJs (Assignment target value) = JSAssignment target (valueToJs value)
130+statementToJs (While cond sts) = JSWhile (valueToJs cond) (map statementToJs sts)
131+statementToJs (For ident start end sts) = JSFor ident (valueToJs start) (valueToJs end) (map statementToJs sts)
132+statementToJs (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs arr)) [JSFunction Nothing [ident] (JSBlock (map statementToJs sts))]
133+statementToJs (If ifst) = ifToJs ifst
134+ where
135+ ifToJs :: IfStatement -> JS
136+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs cond) (map statementToJs thens) (fmap elseToJs elses)
137+ elseToJs :: ElseStatement -> JS
138+ elseToJs (Else sts) = JSBlock (map statementToJs sts)
139+ elseToJs (ElseIf ifst) = ifToJs ifst
140+statementToJs (Return value) = JSReturn (valueToJs value)