@@ -15,6 +15,9 @@ import SourceSyntax.Everything hiding (parens)
1515import SourceSyntax.Location as Loc
1616import qualified Transform.SortDefinitions as SD
1717
18+deprime :: String -> String
19+deprime = map (\c -> if c == '\'' then '$' else c)
20+
1821showErr :: String -> String
1922showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
2023 where msg = show . concatMap (++"<br>") . lines $ err
@@ -66,24 +69,25 @@ jsModule modul =
6669 modName = dotSep (names modul)
6770 makeProgram body foreignImport =
6871 concat [ "\nvar " ++ usefulFuncs ++ ";"
69− , assign "_op" "{}"
7072 , concatMap jsImport (imports modul)
7173 , concat foreignImport
7274 , concatMap exportEvent $ foreignExports modul
75+ , assign "_op" "{}"
7376 , body
74− , assign "_" "{}"
75− , concatMap jsExport (exports modul)
76− , setup ("elm" : names modul)
77− , ret (assign' ("elm." ++ modName) "_")
77+ , jsExports
7878 ]
79− setup names = concatMap (\n -> globalAssign n $ n ++ "||{}") .
79+ setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
8080 map dotSep . drop 2 . List.inits $ init names
8181 usefulFuncs = commaSep (map (uncurry assign') internalImports)
8282
83− jsExport x =
84− if isOp x then "\n_._op['" ++ x ++ "'] = _op['" ++ x ++ "'];"
85− else "\n_." ++ x ++ " = " ++ x ++ ";"
86−
83+ jsExports = setup ("elm" : names modul) ++
84+ ret (assign' ("elm." ++ modName) (brackets exs))
85+ where
86+ exs = indent . commaSep . concatMap pair $ "_op" : exports modul
87+ pair x | isOp x = []
88+ | otherwise = ["\n" ++ x ++ " : " ++ x]
89+
90+
8791 importEvent (js,base,elm,_) =
8892 do v <- toJS' base
8993 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
@@ -98,30 +102,21 @@ jsModule modul =
98102 , "e.value = v;"
99103 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
100104
101−jsImport (modul, how) =
102− case how of
103− As name -> assign name ("Elm." ++ modul ++ parens "elm")
104− Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
105− "; for(var k in _){if(k in hiding)continue;" ++
106− "eval('var '+k+'=_[\"'+k+'\"]')}"
107− Importing vs -> include ++ named
108− where
109− imprt v = assign' v ("_." ++ v)
110− def x = imprt $ if isOp x then "_op['" ++ x ++ "']" else deprime x
111− named = if null vs then "" else "\nvar " ++ commaSep (map def vs) ++ ";"
105+jsImport (modul, method) =
106+ concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
112107 where
113− include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
114− setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
115− where
116− defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
117− subnames = map dotSep . tail . List.inits . init . split
118− split names = case go [] names of
119− (name, []) -> [name]
120− (name, ns) -> name : split ns
121− go name str = case str of
122− '.':rest -> (reverse name, rest)
123− c:rest -> go (c:name) rest
124− [] -> (reverse name, [])
108+ starters = "\nvar " : repeat "\n"
109+ values = map (\name -> name ++ " || {}") (init subnames) ++
110+ ["Elm." ++ modul ++ parens "elm"]
111+ subnames = map dotSep . tail . List.inits $ split modul
112+
113+ split names = case go [] names of
114+ (name, []) -> [name]
115+ (name, ns) -> name : split ns
116+ go name str = case str of
117+ '.':rest -> (reverse name, rest)
118+ c:rest -> go (c:name) rest
119+ [] -> (reverse name, [])
125120
126121
127122class ToJS a where
@@ -133,13 +128,14 @@ instance ToJS (Def t v) where
133128 -- TODO: Make this handle patterns besides plain variables
134129 toJS (Def (PVar x) e)
135130 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
136− | otherwise = assign x `liftM` toJS' e
131+ | otherwise = assign (deprime x) `liftM` toJS' e
137132
138133 toJS (Def pattern e) =
139134 do n <- guid
140135 let x = "_" ++ show n
141136 var = Loc.none . Var
142− toDef y = Def (PVar y) (Loc.none $ Case (var x) [(pattern, var y)])
137+ toDef y' = let y = deprime y' in
138+ Def (PVar y) (Loc.none $ Case (var x) [(pattern, var y)])
143139 stmt <- assign x `liftM` toJS' e
144140 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
145141 return (stmt ++ vars)
@@ -157,18 +153,18 @@ toJS' (L txt span expr) =
157153 Case e cases -> caseToJS span e cases
158154 _ -> toJS expr
159155
160−remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
161−addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
156+remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"
157+addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"
162158setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
163− where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
164−access x e = e ++ "." ++ x
159+ where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"
160+access x e = e ++ "." ++ deprime x
165161makeRecord kvs = record `liftM` collect kvs
166162 where
167163 combine r (k,v) = Map.insertWith (++) k v r
168164 collect = liftM (List.foldl' combine Map.empty) . mapM prep
169165 prep (k, e) =
170166 do v <- toJS' e
171− return (k,[v])
167+ return (deprime k, [v])
172168 fields fs =
173169 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
174170 hidden = fields . map (second jsList) .
@@ -189,7 +185,7 @@ instance ToJS Literal where
189185instance ToJS (Expr t v) where
190186 toJS expr =
191187 case expr of
192− Var x -> return x
188+ Var x -> return (deprime x)
193189 Literal lit -> toJS lit
194190 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
195191 Access e x -> access x `liftM` toJS' e
@@ -200,13 +196,16 @@ instance ToJS (Expr t v) where
200196 Record fs -> makeRecord fs
201197 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
202198
203− Lambda p e -> liftM (jsFunc (commaSep args) . ret) (toJS' body)
199+ Lambda p e -> liftM (fastFunc . ret) (toJS' body)
204200 where
201+ fastFunc body
202+ | length args < 2 || length args > 9 = foldr jsFunc body args
203+ | otherwise = "F" ++ show (length args) ++ parens (jsFunc (commaSep args) body)
205204 (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
206205
207206 depattern (pattern,n) (args, body) =
208207 case pattern of
209− PVar x -> (x:args, body)
208+ PVar x -> (deprime x : args, body)
210209 _ -> let arg = "arg" ++ show n
211210 in (arg:args, Loc.none (Case (Loc.none (Var arg)) [(pattern, body)]))
212211
@@ -274,7 +273,7 @@ caseToJS span e ps = do
274273 match <- caseToMatch ps
275274 e' <- toJS' e
276275 let (match',stmt) = case (match,e) of
277− (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
276+ (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,deprime x)] match, "")
278277 (Match name _ _, _) -> (match, assign name e')
279278 _ -> (match, "")
280279 matches <- matchToJS span match'
@@ -317,26 +316,32 @@ jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
317316jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
318317jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
319318
320−-- todo: this is incorrect. Operators come in prefixed by their module now.
321−binop (o:p) e1 e2
322− | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
323− | otherwise =
324− let ops = ["+","-","*","/","&&","||"] in
325− case o:p of
326− "::" -> jsCons e1 e2
327− "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
328− "<|" -> e1 ++ parens e2
329− "|>" -> e2 ++ parens e1
330− "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
331− "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
332− "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
333− "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
334− "<" -> jsCompare e1 e2 "==='LT'"
335− ">" -> jsCompare e1 e2 "==='GT'"
336− "<=" -> jsCompare e1 e2 "!=='GT'"
337− ">=" -> jsCompare e1 e2 "!=='LT'"
338− "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
339− "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
340− _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
341− | otherwise -> concat [ "_op['", o:p, "']"
342− , parens e1, parens e2 ]
319+
320+binop op e1 e2 =
321+ case Map.lookup op opDict of
322+ Just e -> e
323+ Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, e1, e2 ])
324+ where
325+ func | isOp op' = "_op['" ++ op' ++ "']"
326+ | otherwise = op'
327+ (prefix, op') = case List.elemIndices '.' op of
328+ [] -> ("", op)
329+ xs -> splitAt (last xs + 1) op
330+ where
331+ opDict = Map.fromList $ basics ++
332+ [ ("::", jsCons e1 e2)
333+ , ("List.++", "_L.append" ++ parens (e1 ++ "," ++ e2)) ]
334+
335+ basics = map (\(op,e) -> ("Basics." ++ op, e)) $
336+ [ ("<|", e1 ++ parens e2)
337+ , ("|>", e2 ++ parens e1)
338+ , ("." , jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x"))
339+ , ("^" , "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")")
340+ , ("==", "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")")
341+ , ("/=", "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")")
342+ , ("<" , jsCompare e1 e2 "==='LT'")
343+ , (">" , jsCompare e1 e2 "==='GT'")
344+ , ("<=", jsCompare e1 e2 "!=='GT'")
345+ , (">=", jsCompare e1 e2 "!=='LT'")
346+ , ("div", parens (e1 ++ "/" ++ e2 ++ "|0"))
347+ ] ++ map (\op -> (op, parens (e1 ++ op ++ e2))) ["+","-","*","/","&&","||"]