@@ -1,50 +1,154 @@
1−module Generate.JavaScript (jsModule) where
1+module Generate.JavaScript where
22
3−import Control.Arrow (first,second)
43import Control.Monad (liftM,(<=<),join,ap)
54import Data.Char (isAlpha,isDigit)
65import qualified Data.List as List
76import qualified Data.Map as Map
87import qualified Data.Set as Set
98import Data.Either (partitionEithers)
10−import qualified Text.Pandoc as Pan
9+
1110
1211import Unique
1312import Generate.Cases
1413import SourceSyntax.Everything
1514import SourceSyntax.Location
1615import qualified Transform.SortDefinitions as SD
16+import Language.ECMAScript3.Syntax
17+import Language.ECMAScript3.PrettyPrint
18+import Parse.Helpers (makeSafe, iParse)
1719
18−indent = concatMap f
19− where f '\n' = "\n "
20− f c = [c]
20+import Parse.Expression
21+
22+testExpr str = (prettyPrint . expression) `fmap` iParse expr "" str
23+
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) ]
29+call = CallExpr ()
30+string = StringLit ()
31+
32+dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
33+
34+varDecl x expr =
35+ VarDecl () (var x) (Just expr)
36+
37+include alias moduleName =
38+ varDecl alias (dotSep moduleName <| ref "elm")
2139
2240internalImports name =
23− [ ("N" , "Elm.Native"),
24− ("_N", "N.Utils(elm)"),
25− ("_L", "N.List(elm)"),
26− ("_E", "N.Error(elm)"),
27− ("_J", "N.JavaScript(elm)"),
28− ("_str", "_J.toString"),
29− ("$moduleName", quoted name)
41+ VarDeclStmt ()
42+ [ varDecl "N" (dotSep ["Elm","Native"])
43+ , include "_N" ["N","Utils"]
44+ , include "_L" ["N","List"]
45+ , include "_E" ["N","Error"]
46+ , include "_J" ["N","JavaScript"]
47+ , varDecl "_str" (dotSep ["_J","toString"])
48+ , varDecl "$moduleName" (string name)
3049 ]
3150
32−parens s = "(" ++ s ++ ")"
33−brackets s = "{" ++ s ++ "}"
34−commaSep = List.intercalate ", "
35−dotSep = List.intercalate "."
36−jsObj = brackets . commaSep
37−jsList ss = "["++ List.intercalate "," ss ++"]"
38−jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
39−assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
40−ret e = "\nreturn "++ e ++";"
41−quoted s = "'" ++ concatMap f s ++ "'"
42− where f '\n' = "\\n"
43− f '\'' = "\\'"
44− f '\t' = "\\t"
45− f '\"' = "\\\""
46− f '\\' = "\\\\"
47− f c = [c]
51+literal lit =
52+ case lit of
53+ Chr c -> string [c]
54+ Str s -> ref "_str" <| string s
55+ IntNum n -> IntLit () n
56+-- FloatNum n -> NumLit () (float2Double n) -- wrong!!!
57+ Boolean b -> BoolLit () b
58+
59+expression (L span expr) =
60+ case expr of
61+ Var x -> ref x
62+ Literal lit -> literal lit
63+ Range lo hi -> dotSep ["_L","range"] `call` [expression lo, expression hi]
64+
65+ Access e x -> DotRef () (expression e) (var x)
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]
68+{--
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
72+
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
77+ where
78+ combine r (k,v) = Map.insertWith (++) k v r
79+ collect = liftM (List.foldl' combine Map.empty) . mapM prep
80+ prep (k, e) =
81+ do v <- toJS' e
82+ return (k, [v])
83+ fields fs =
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
88+--}
89+ Binop op e1 e2 -> binop span op e1 e2
90+
91+ Lambda p e@(L s _) -> fastFunc
92+ where
93+ fastFunc
94+ | length args < 2 || length args > 9 =
95+ foldr (==>) (expression body) (map (:[]) args)
96+ | otherwise =
97+ ref ("F" ++ show (length args)) <| (args ==> expression body)
98+
99+ (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
100+
101+ depattern (pattern,n) (args, body) =
102+ case pattern of
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)]))
106+
107+ (patterns, innerBody) = collect [p] e
108+
109+ collect patterns lexpr@(L _ expr) =
110+ case expr of
111+ Lambda p e -> collect (p:patterns) e
112+ _ -> (patterns, lexpr)
113+--}
114+ App e1 e2 ->
115+ case args of
116+ [arg] -> func <| arg
117+ _ -> ref aN `call` (func:args)
118+ where
119+ aN = "A" ++ show (length args)
120+ (func, args) = getArgs e1 [e2]
121+ getArgs func args =
122+ case func of
123+ (L _ (App f arg)) -> getArgs f (arg : args)
124+ _ -> (expression func, map expression args)
125+{--
126+ Let defs e -> jsLet $ SD.flattenLets defs e
127+--}
128+
129+ MultiIf branches ->
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) ])
133+ where
134+ ifs branches finally = foldr iff finally branches
135+ iff (if', then') else' = CondExpr () (expression if') (expression then') else'
136+
137+ ExplicitList es ->
138+ dotSep ["_J","toList"] <| ArrayLit () (map expression es)
139+
140+ Data name es ->
141+ ObjectLit () (ctor : fields)
142+ where
143+ ctor = (prop "ctor", string (makeSafe name))
144+ fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es
145+{--
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
149+--}
150+
151+{--
48152
49153globalAssign n e = "\n" ++ assign' n e ++ ";"
50154assign' n e = n ++ " = " ++ e
@@ -141,125 +245,17 @@ instance ToJS a => ToJS [a] where
141245toJS' :: LExpr t v -> Unique String
142246toJS' (L span expr) =
143247 case expr of
144− MultiIf ps -> multiIfToJS span ps
145248 Case e cases -> caseToJS span e cases
146249 _ -> toJS expr
147250
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
154− where
155− combine r (k,v) = Map.insertWith (++) k v r
156− collect = liftM (List.foldl' combine Map.empty) . mapM prep
157− prep (k, e) =
158− do v <- toJS' e
159− return (k, [v])
160− fields fs =
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
165251
166252
167−instance ToJS Literal where
168− toJS lit =
169− case lit of
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"
175−
176−
177−instance ToJS (Expr t v) where
178− toJS expr =
179− case expr of
180− Var x -> return x
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
190−
191− Lambda p e@(L s _) -> liftM fastFunc (toJS' body)
192− where
193− fastFunc body
194− | length args < 2 || length args > 9 =
195− foldr (\arg bod -> jsFunc arg (ret bod)) body args
196− | otherwise =
197− "F" ++ show (length args) ++ parens (jsFunc (commaSep args) (ret body))
198−
199− (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
200−
201− depattern (pattern,n) (args, body) =
202− case pattern of
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)]))
206−
207− (patterns, innerBody) = collect [p] e
208−
209− collect patterns lexpr@(L _ expr) =
210− case expr of
211− Lambda p e -> collect (p:patterns) e
212− _ -> (patterns, lexpr)
213−
214− App e1 e2 -> jsApp e1 e2
215− Let defs e -> jsLet $ SD.flattenLets defs e
216−
217− ExplicitList es ->
218− do es' <- mapM toJS' es
219− return $ "_J.toList" ++ parens (jsList es')
220−
221− Data name es ->
222− do fs <- mapM toJS' es
223− return $ case name of
224− "[]" -> jsNil
225− "::" -> jsCons (head fs) ((head . tail) fs)
226− _ -> jsObj $ ("ctor:" ++ show name) : fields
227− where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
228−
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
232−
233−jsApp e1 e2 =
234− do f <- toJS' func
235− as <- mapM toJS' args
236− return $ case as of
237− [a] -> f ++ parens a
238− _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))
239− where
240− (func, args) = go [e2] e1
241− go args e =
242− case e of
243− (L _ (App e1 e2)) -> go (e2 : args) e1
244− _ -> (e, args)
245−
246253formatMarkdown = concatMap f
247254 where f '\'' = "\\'"
248255 f '\n' = "\\n"
249256 f '"' = "\""
250257 f c = [c]
251258
252−multiIfToJS span ps =
253− case last ps of
254− (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
255− _ -> format ("_E.If" ++ parens ("$moduleName," ++ quoted (show span))) ps
256− where
257− format base ps =
258− foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
259− f (b,e) = do b' <- toJS' b
260− e' <- toJS' e
261− return (b' ++ " ? " ++ e')
262−
263259jsLet (defs,e') = do ds <- mapM toJS defs
264260 e <- toJS' e'
265261 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
@@ -307,56 +303,60 @@ clauseToJS span var (Clause value vars e) = do
307303 is -> drop (last is + 1) name
308304 return $ concat [ "\ncase ", pattern, ":", indent s ]
309305
310−jsNil = "_L.Nil"
311306jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
312−jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
313307jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
314308
315−
316−binop op e1 e2
317− | op == "Basics.." =
318− do ss <- mapM toJS' (e1 : collect [] e2)
319− return . jsFunc "$" . ret $ apply "$" ss
320− | op == "Basics.<|" =
321− do arg <- toJS' e2
322− funcs <- mapM toJS' (collect [] e1)
323− return (apply arg funcs)
324− | otherwise =
325− binopNormal op `liftM` toJS' e1 `ap` toJS' e2
309+--}
310+binop span op e1 e2 =
311+ case op of
312+ "Basics.." -> ["$"] ==> foldr (<|) (ref "$") (map expression (e1 : collect [] e2))
313+ "Basics.<|" -> foldr (<|) (expression e2) (map expression (collect [] e1))
314+ "::" -> expression (L span (Data "::" [e1,e2]))
315+ "List.++" -> dotSep ["_L","append"] `call` [js1, js2]
316+ _ -> case Map.lookup op opDict of
317+ Just f -> f js1 js2
318+ Nothing -> ref "A2" `call` [ func [] op, js1, js2 ]
326319 where
327− apply = foldr (\f arg-> f ++ parens arg)
328−
329320 collect es e =
330321 case e of
331322 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
332323 _ -> es ++ [e]
333324
334−binopNormal op s1 s2 =
335− case Map.lookup op opDict of
336− Just e -> e
337− Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, s1, s2 ])
338− where
339− func | isOp op' = "_op['" ++ op' ++ "']"
340− | otherwise = op'
341− (prefix, op') = case List.elemIndices '.' op of
342− [] -> ("", op)
343− xs -> splitAt (last xs + 1) op
344−
345− opDict = Map.fromList $ basics ++
346− [ ("::", jsCons s1 s2)
347− , ("List.++", "_L.append" ++ parens (s1 ++ "," ++ s2)) ]
348−
349− ops = pow : map (\op -> (op, parens (s1 ++ op ++ s2))) ["+","-","*","/","&&","||"]
350− where pow = ("^" , "Math.pow(" ++ s1 ++ "," ++ s2 ++ ")")
351−
352− basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))
353− (ops ++ [ ("<|", s1 ++ parens s2)
354− , ("|>", s2 ++ parens s1)
355− , ("==", "_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
356− , ("/=", "!_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
357− , ("<" , jsCompare s1 s2 "<0")
358− , (">" , jsCompare s1 s2 ">0")
359− , ("<=", jsCompare s1 s2 "<1")
360− , (">=", jsCompare s1 s2 ">-1")
361− , ("div", parens (s1 ++ "/" ++ s2 ++ "|0"))
362− ])
325+ js1 = expression e1
326+ js2 = expression e2
327+
328+ func vs str =
329+ case break (=='.') str of
330+ (x,'.':rest) -> func (vs ++ [x]) rest
331+ (op,[])
332+ | isOp op -> BracketRef () (dotSep (vs ++ ["_op"])) (string op)
333+ | otherwise -> dotSep (vs ++ [op])
334+
335+ opDict = Map.fromList (infixOps ++ specialOps)
336+
337+ specialOp str func = ("Basic." ++ str, func)
338+ infixOp str op = specialOp str (InfixExpr () op)
339+
340+ infixOps =
341+ [ infixOp "+" OpAdd
342+ , infixOp "-" OpSub
343+ , infixOp "*" OpMul
344+ , infixOp "/" OpDiv
345+ , infixOp "&&" OpLAnd
346+ , infixOp "||" OpLOr
347+ ]
348+
349+ specialOps =
350+ [ specialOp "^" $ \a b -> dotSep ["Math","pow"] `call` [a,b]
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)
359+ ]
360+
361+ cmp op n a b = InfixExpr () op (dotSep ["_N","cmp"] `call` [a,b]) (IntLit () n)
362+--}