@@ -1,50 +1,154 @@
1−module Generate.JavaScript (jsModule) where
1+module Generate.JavaScript where
3−import Control.Arrow (first,second)
4import Control.Monad (liftM,(<=<),join,ap)
3import Control.Monad (liftM,(<=<),join,ap)
5import Data.Char (isAlpha,isDigit)
4import Data.Char (isAlpha,isDigit)
6import qualified Data.List as List
5import qualified Data.List as List
7import qualified Data.Map as Map
6import qualified Data.Map as Map
8import qualified Data.Set as Set
7import qualified Data.Set as Set
9import Data.Either (partitionEithers)
8import Data.Either (partitionEithers)
10−import qualified Text.Pandoc as Pan
9+
12import Unique
11import Unique
13import Generate.Cases
12import Generate.Cases
14import SourceSyntax.Everything
13import SourceSyntax.Everything
15import SourceSyntax.Location
14import SourceSyntax.Location
16import qualified Transform.SortDefinitions as SD
15import qualified Transform.SortDefinitions as SD
16+import Language.ECMAScript3.Syntax
17+import Language.ECMAScript3.PrettyPrint
18+import Parse.Helpers (makeSafe, iParse)
18−indent = concatMap f
20+import Parse.Expression
19− where f '\n' = "\n "
21+
20− f c = [c]
22+testExpr str = (prettyPrint . expression) `fmap` iParse expr "" str
24+var name = Id () (makeSafe name)
25+ref name = VarRef () (var name)
26+prop name = PropId () (var name)
27+f <| x = CallExpr () f [x]
28+args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
32+dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
35+ VarDecl () (var x) (Just expr)
37+include alias moduleName =
38+ varDecl alias (dotSep moduleName <| ref "elm")
22internalImports name =
40internalImports name =
23− [ ("N" , "Elm.Native"),
42+ [ varDecl "N" (dotSep ["Elm","Native"])
24− ("_N", "N.Utils(elm)"),
43+ , include "_N" ["N","Utils"]
25− ("_L", "N.List(elm)"),
44+ , include "_L" ["N","List"]
26− ("_E", "N.Error(elm)"),
45+ , include "_E" ["N","Error"]
27− ("_J", "N.JavaScript(elm)"),
46+ , include "_J" ["N","JavaScript"]
28− ("_str", "_J.toString"),
47+ , varDecl "_str" (dotSep ["_J","toString"])
29− ("$moduleName", quoted name)
48+ , varDecl "$moduleName" (string name)
32−parens s = "(" ++ s ++ ")"
51+literal lit =
33−brackets s = "{" ++ s ++ "}"
52+ case lit of
34−commaSep = List.intercalate ", "
53+ Chr c -> string [c]
35−dotSep = List.intercalate "."
54+ Str s -> ref "_str" <| string s
36−jsObj = brackets . commaSep
55+ IntNum n -> IntLit () n
37−jsList ss = "["++ List.intercalate "," ss ++"]"
56+-- FloatNum n -> NumLit () (float2Double n) -- wrong!!!
38−jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
57+ Boolean b -> BoolLit () b
39−assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
58+
40−ret e = "\nreturn "++ e ++";"
59+expression (L span expr) =
41−quoted s = "'" ++ concatMap f s ++ "'"
60+ case expr of
42− where f '\n' = "\\n"
61+ Var x -> ref x
43− f '\'' = "\\'"
62+ Literal lit -> literal lit
44− f '\t' = "\\t"
63+ Range lo hi -> dotSep ["_L","range"] `call` [expression lo, expression hi]
46− f '\\' = "\\\\"
65+ Access e x -> DotRef () (expression e) (var x)
47− f c = [c]
66+ Remove e x -> dotSep ["_N","remove"] `call` [ref x, expression e]
67+ Insert e x v -> dotSep ["_N","insert"] `call` [ref x, expression v, expression e]
69+ Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
70+ setField fs' `liftM` toJS' e
71+ Record fs -> makeRecord fs
73+addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
74+setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
75+ where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
76+makeRecord kvs = record `liftM` collect kvs
78+ combine r (k,v) = Map.insertWith (++) k v r
79+ collect = liftM (List.foldl' combine Map.empty) . mapM prep
84+ brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
85+ hidden = fields . map (second jsList) .
86+ filter (not . null . snd) . Map.toList . Map.map tail
87+ record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
89+ Binop op e1 e2 -> binop span op e1 e2
91+ Lambda p e@(L s _) -> fastFunc
94+ | length args < 2 || length args > 9 =
95+ foldr (==>) (expression body) (map (:[]) args)
97+ ref ("F" ++ show (length args)) <| (args ==> expression body)
99+ (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
101+ depattern (pattern,n) (args, body) =
103+ PVar x -> (args ++ [x], body)
104+ _ -> let arg = "arg" ++ show n
105+ in (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
107+ (patterns, innerBody) = collect [p] e
109+ collect patterns lexpr@(L _ expr) =
111+ Lambda p e -> collect (p:patterns) e
112+ _ -> (patterns, lexpr)
116+ [arg] -> func <| arg
117+ _ -> ref aN `call` (func:args)
119+ aN = "A" ++ show (length args)
120+ (func, args) = getArgs e1 [e2]
123+ (L _ (App f arg)) -> getArgs f (arg : args)
124+ _ -> (expression func, map expression args)
126+ Let defs e -> jsLet $ SD.flattenLets defs e
130+ case last branches of
131+ (L _ (Var "otherwise"), e) -> ifs (init branches) (expression e)
132+ _ -> ifs branches (dotSep ["_E","If"] `call` [ ref "$moduleName", string (show span) ])
134+ ifs branches finally = foldr iff finally branches
135+ iff (if', then') else' = CondExpr () (expression if') (expression then') else'
138+ dotSep ["_J","toList"] <| ArrayLit () (map expression es)
141+ ObjectLit () (ctor : fields)
143+ ctor = (prop "ctor", string (makeSafe name))
144+ fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es
146+ Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
147+ where pad = "<div style=\"height:0;width:0;\"> </div>"
148+ md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
49globalAssign n e = "\n" ++ assign' n e ++ ";"
153globalAssign n e = "\n" ++ assign' n e ++ ";"
50assign' n e = n ++ " = " ++ e
154assign' n e = n ++ " = " ++ e
@@ -141,125 +245,17 @@ instance ToJS a => ToJS [a] where
141toJS' :: LExpr t v -> Unique String
245toJS' :: LExpr t v -> Unique String
142toJS' (L span expr) =
246toJS' (L span expr) =
143 case expr of
247 case expr of
144− MultiIf ps -> multiIfToJS span ps
145 Case e cases -> caseToJS span e cases
248 Case e cases -> caseToJS span e cases
146 _ -> toJS expr
249 _ -> toJS expr
148−remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
149−addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
150−setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
151− where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
152−access x e = e ++ "." ++ x
153−makeRecord kvs = record `liftM` collect kvs
155− combine r (k,v) = Map.insertWith (++) k v r
156− collect = liftM (List.foldl' combine Map.empty) . mapM prep
161− brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
162− hidden = fields . map (second jsList) .
163− filter (not . null . snd) . Map.toList . Map.map tail
164− record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
167−instance ToJS Literal where
170− Chr c -> return $ quoted [c]
171− Str s -> return $ "_str" ++ parens (quoted s)
172− IntNum n -> return $ show n
173− FloatNum n -> return $ show n
174− Boolean b -> return $ if b then "true" else "false"
177−instance ToJS (Expr t v) where
181− Literal lit -> toJS lit
182− Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
183− Access e x -> access x `liftM` toJS' e
184− Remove e x -> remove x `liftM` toJS' e
185− Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
186− Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
187− setField fs' `liftM` toJS' e
188− Record fs -> makeRecord fs
189− Binop op e1 e2 -> binop op e1 e2
191− Lambda p e@(L s _) -> liftM fastFunc (toJS' body)
194− | length args < 2 || length args > 9 =
195− foldr (\arg bod -> jsFunc arg (ret bod)) body args
197− "F" ++ show (length args) ++ parens (jsFunc (commaSep args) (ret body))
199− (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
201− depattern (pattern,n) (args, body) =
203− PVar x -> (x : args, body)
204− _ -> let arg = "arg" ++ show n
205− in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))
207− (patterns, innerBody) = collect [p] e
209− collect patterns lexpr@(L _ expr) =
211− Lambda p e -> collect (p:patterns) e
212− _ -> (patterns, lexpr)
214− App e1 e2 -> jsApp e1 e2
215− Let defs e -> jsLet $ SD.flattenLets defs e
218− do es' <- mapM toJS' es
219− return $ "_J.toList" ++ parens (jsList es')
222− do fs <- mapM toJS' es
223− return $ case name of
225− "::" -> jsCons (head fs) ((head . tail) fs)
226− _ -> jsObj $ ("ctor:" ++ show name) : fields
227− where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
229− Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
230− where pad = "<div style=\"height:0;width:0;\"> </div>"
231− md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
235− as <- mapM toJS' args
237− [a] -> f ++ parens a
238− _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))
240− (func, args) = go [e2] e1
243− (L _ (App e1 e2)) -> go (e2 : args) e1
246formatMarkdown = concatMap f
253formatMarkdown = concatMap f
247 where f '\'' = "\\'"
254 where f '\'' = "\\'"
248 f '\n' = "\\n"
255 f '\n' = "\\n"
249 f '"' = "\""
256 f '"' = "\""
250 f c = [c]
257 f c = [c]
252−multiIfToJS span ps =
254− (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
255− _ -> format ("_E.If" ++ parens ("$moduleName," ++ quoted (show span))) ps
258− foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
259− f (b,e) = do b' <- toJS' b
261− return (b' ++ " ? " ++ e')
263jsLet (defs,e') = do ds <- mapM toJS defs
259jsLet (defs,e') = do ds <- mapM toJS defs
264 e <- toJS' e'
260 e <- toJS' e'
265 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
261 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
@@ -307,56 +303,60 @@ clauseToJS span var (Clause value vars e) = do
307 is -> drop (last is + 1) name
303 is -> drop (last is + 1) name
308 return $ concat [ "\ncase ", pattern, ":", indent s ]
304 return $ concat [ "\ncase ", pattern, ":", indent s ]
311jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
306jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
312−jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
313jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
307jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
316−binop op e1 e2
310+binop span op e1 e2 =
317− | op == "Basics.." =
311+ case op of
318− do ss <- mapM toJS' (e1 : collect [] e2)
312+ "Basics.." -> ["$"] ==> foldr (<|) (ref "$") (map expression (e1 : collect [] e2))
319− return . jsFunc "$" . ret $ apply "$" ss
313+ "Basics.<|" -> foldr (<|) (expression e2) (map expression (collect [] e1))
320− | op == "Basics.<|" =
314+ "::" -> expression (L span (Data "::" [e1,e2]))
321− do arg <- toJS' e2
315+ "List.++" -> dotSep ["_L","append"] `call` [js1, js2]
322− funcs <- mapM toJS' (collect [] e1)
316+ _ -> case Map.lookup op opDict of
323− return (apply arg funcs)
317+ Just f -> f js1 js2
324− | otherwise =
318+ Nothing -> ref "A2" `call` [ func [] op, js1, js2 ]
325− binopNormal op `liftM` toJS' e1 `ap` toJS' e2
327− apply = foldr (\f arg-> f ++ parens arg)
329 collect es e =
320 collect es e =
330 case e of
321 case e of
331 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
322 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
332 _ -> es ++ [e]
323 _ -> es ++ [e]
334−binopNormal op s1 s2 =
325+ js1 = expression e1
335− case Map.lookup op opDict of
326+ js2 = expression e2
337− Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, s1, s2 ])
328+ func vs str =
338− where
329+ case break (=='.') str of
330+ (x,'.':rest) -> func (vs ++ [x]) rest
339− func | isOp op' = "_op['" ++ op' ++ "']"
332+ | isOp op -> BracketRef () (dotSep (vs ++ ["_op"])) (string op)
340− | otherwise = op'
333+ | otherwise -> dotSep (vs ++ [op])
341− (prefix, op') = case List.elemIndices '.' op of
334+
343− xs -> splitAt (last xs + 1) op
345− opDict = Map.fromList $ basics ++
335+ opDict = Map.fromList (infixOps ++ specialOps)
346− [ ("::", jsCons s1 s2)
336+
347− , ("List.++", "_L.append" ++ parens (s1 ++ "," ++ s2)) ]
337+ specialOp str func = ("Basic." ++ str, func)
348−
338+ infixOp str op = specialOp str (InfixExpr () op)
349− ops = pow : map (\op -> (op, parens (s1 ++ op ++ s2))) ["+","-","*","/","&&","||"]
339+
350− where pow = ("^" , "Math.pow(" ++ s1 ++ "," ++ s2 ++ ")")
340+ infixOps =
351−
341+ [ infixOp "+" OpAdd
352− basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))
342+ , infixOp "-" OpSub
353− (ops ++ [ ("<|", s1 ++ parens s2)
343+ , infixOp "*" OpMul
354− , ("|>", s2 ++ parens s1)
344+ , infixOp "/" OpDiv
355− , ("==", "_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
345+ , infixOp "&&" OpLAnd
356− , ("/=", "!_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
346+ , infixOp "||" OpLOr
357− , ("<" , jsCompare s1 s2 "<0")
347+ ]
358− , (">" , jsCompare s1 s2 ">0")
348+
359− , ("<=", jsCompare s1 s2 "<1")
349+ specialOps =
360− , (">=", jsCompare s1 s2 ">-1")
350+ [ specialOp "^" $ \a b -> dotSep ["Math","pow"] `call` [a,b]
361− , ("div", parens (s1 ++ "/" ++ s2 ++ "|0"))
351+ , specialOp "|>" $ flip (<|)
352+ , specialOp "==" $ \a b -> dotSep ["_N","eq"] `call` [a,b]
353+ , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (dotSep ["_N","eq"] `call` [a,b])
354+ , specialOp "<" $ cmp OpLT 0
355+ , specialOp ">" $ cmp OpGT 0
356+ , specialOp "<=" $ cmp OpLT 1
357+ , specialOp ">=" $ cmp OpGT (-1)
358+ , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
361+ cmp op n a b = InfixExpr () op (dotSep ["_N","cmp"] `call` [a,b]) (IntLit () n)