@@ -15,6 +15,9 @@ import SourceSyntax.Everything hiding (parens)
15import SourceSyntax.Location as Loc
15import SourceSyntax.Location as Loc
16import qualified Transform.SortDefinitions as SD
16import qualified Transform.SortDefinitions as SD
18+deprime :: String -> String
19+deprime = map (\c -> if c == '\'' then '$' else c)
18showErr :: String -> String
21showErr :: String -> String
19showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
22showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
20 where msg = show . concatMap (++"<br>") . lines $ err
23 where msg = show . concatMap (++"<br>") . lines $ err
@@ -66,24 +69,25 @@ jsModule modul =
66 modName = dotSep (names modul)
69 modName = dotSep (names modul)
67 makeProgram body foreignImport =
70 makeProgram body foreignImport =
68 concat [ "\nvar " ++ usefulFuncs ++ ";"
71 concat [ "\nvar " ++ usefulFuncs ++ ";"
70 , concatMap jsImport (imports modul)
72 , concatMap jsImport (imports modul)
71 , concat foreignImport
73 , concat foreignImport
72 , concatMap exportEvent $ foreignExports modul
74 , concatMap exportEvent $ foreignExports modul
74− , assign "_" "{}"
77+ , jsExports
75− , concatMap jsExport (exports modul)
76− , setup ("elm" : names modul)
77− , ret (assign' ("elm." ++ modName) "_")
79− setup names = concatMap (\n -> globalAssign n $ n ++ "||{}") .
79+ setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
80 map dotSep . drop 2 . List.inits $ init names
80 map dotSep . drop 2 . List.inits $ init names
81 usefulFuncs = commaSep (map (uncurry assign') internalImports)
81 usefulFuncs = commaSep (map (uncurry assign') internalImports)
83− jsExport x =
83+ jsExports = setup ("elm" : names modul) ++
84− if isOp x then "\n_._op['" ++ x ++ "'] = _op['" ++ x ++ "'];"
84+ ret (assign' ("elm." ++ modName) (brackets exs))
85− else "\n_." ++ x ++ " = " ++ x ++ ";"
85+ where
86−
86+ exs = indent . commaSep . concatMap pair $ "_op" : exports modul
88+ | otherwise = ["\n" ++ x ++ " : " ++ x]
87 importEvent (js,base,elm,_) =
91 importEvent (js,base,elm,_) =
88 do v <- toJS' base
92 do v <- toJS' base
89 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
93 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
@@ -98,30 +102,21 @@ jsModule modul =
98 , "e.value = v;"
102 , "e.value = v;"
99 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
103 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
101−jsImport (modul, how) =
105+jsImport (modul, method) =
102− case how of
106+ concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
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
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) ++ ";"
113− include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
108+ starters = "\nvar " : repeat "\n"
114− setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
109+ values = map (\name -> name ++ " || {}") (init subnames) ++
115− where
110+ ["Elm." ++ modul ++ parens "elm"]
116− defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
117− subnames = map dotSep . tail . List.inits . init . split
111+ subnames = map dotSep . tail . List.inits $ split modul
118− split names = case go [] names of
113+ split names = case go [] names of
119− (name, []) -> [name]
114+ (name, []) -> [name]
120− (name, ns) -> name : split ns
115+ (name, ns) -> name : split ns
121− go name str = case str of
116+ go name str = case str of
122− '.':rest -> (reverse name, rest)
117+ '.':rest -> (reverse name, rest)
123− c:rest -> go (c:name) rest
118+ c:rest -> go (c:name) rest
124− [] -> (reverse name, [])
119+ [] -> (reverse name, [])
127class ToJS a where
122class ToJS a where
@@ -133,13 +128,14 @@ instance ToJS (Def t v) where
133 -- TODO: Make this handle patterns besides plain variables
128 -- TODO: Make this handle patterns besides plain variables
134 toJS (Def (PVar x) e)
129 toJS (Def (PVar x) e)
135 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
130 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
136− | otherwise = assign x `liftM` toJS' e
131+ | otherwise = assign (deprime x) `liftM` toJS' e
138 toJS (Def pattern e) =
133 toJS (Def pattern e) =
139 do n <- guid
134 do n <- guid
140 let x = "_" ++ show n
135 let x = "_" ++ show n
141 var = Loc.none . Var
136 var = Loc.none . Var
137+ toDef y' = let y = deprime y' in
142− toDef y = Def (PVar y) (Loc.none $ Case (var x) [(pattern, var y)])
138+ Def (PVar y) (Loc.none $ Case (var x) [(pattern, var y)])
143 stmt <- assign x `liftM` toJS' e
139 stmt <- assign x `liftM` toJS' e
144 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
140 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
145 return (stmt ++ vars)
141 return (stmt ++ vars)
@@ -157,18 +153,18 @@ toJS' (L txt span expr) =
157 Case e cases -> caseToJS span e cases
153 Case e cases -> caseToJS span e cases
158 _ -> toJS expr
154 _ -> toJS expr
160−remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
156+remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"
161−addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
157+addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"
162setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
158setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
163− where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
159+ where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"
164−access x e = e ++ "." ++ x
160+access x e = e ++ "." ++ deprime x
165makeRecord kvs = record `liftM` collect kvs
161makeRecord kvs = record `liftM` collect kvs
167 combine r (k,v) = Map.insertWith (++) k v r
163 combine r (k,v) = Map.insertWith (++) k v r
168 collect = liftM (List.foldl' combine Map.empty) . mapM prep
164 collect = liftM (List.foldl' combine Map.empty) . mapM prep
169 prep (k, e) =
165 prep (k, e) =
170 do v <- toJS' e
166 do v <- toJS' e
171− return (k,[v])
167+ return (deprime k, [v])
172 fields fs =
168 fields fs =
173 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
169 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
174 hidden = fields . map (second jsList) .
170 hidden = fields . map (second jsList) .
@@ -189,7 +185,7 @@ instance ToJS Literal where
189instance ToJS (Expr t v) where
185instance ToJS (Expr t v) where
190 toJS expr =
186 toJS expr =
191 case expr of
187 case expr of
192− Var x -> return x
188+ Var x -> return (deprime x)
193 Literal lit -> toJS lit
189 Literal lit -> toJS lit
194 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
190 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
195 Access e x -> access x `liftM` toJS' e
191 Access e x -> access x `liftM` toJS' e
@@ -200,13 +196,16 @@ instance ToJS (Expr t v) where
200 Record fs -> makeRecord fs
196 Record fs -> makeRecord fs
201 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
197 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
203− Lambda p e -> liftM (jsFunc (commaSep args) . ret) (toJS' body)
199+ Lambda p e -> liftM (fastFunc . ret) (toJS' body)
202+ | length args < 2 || length args > 9 = foldr jsFunc body args
203+ | otherwise = "F" ++ show (length args) ++ parens (jsFunc (commaSep args) body)
205 (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
204 (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
207 depattern (pattern,n) (args, body) =
206 depattern (pattern,n) (args, body) =
208 case pattern of
207 case pattern of
209− PVar x -> (x:args, body)
208+ PVar x -> (deprime x : args, body)
210 _ -> let arg = "arg" ++ show n
209 _ -> let arg = "arg" ++ show n
211 in (arg:args, Loc.none (Case (Loc.none (Var arg)) [(pattern, body)]))
210 in (arg:args, Loc.none (Case (Loc.none (Var arg)) [(pattern, body)]))
@@ -274,7 +273,7 @@ caseToJS span e ps = do
274 match <- caseToMatch ps
273 match <- caseToMatch ps
275 e' <- toJS' e
274 e' <- toJS' e
276 let (match',stmt) = case (match,e) of
275 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, "")
278 (Match name _ _, _) -> (match, assign name e')
277 (Match name _ _, _) -> (match, assign name e')
279 _ -> (match, "")
278 _ -> (match, "")
280 matches <- matchToJS span match'
279 matches <- matchToJS span match'
@@ -317,26 +316,32 @@ jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
317jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
316jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
318jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
317jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
320−-- todo: this is incorrect. Operators come in prefixed by their module now.
319+
321−binop (o:p) e1 e2
320+binop op e1 e2 =
322− | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
321+ case Map.lookup op opDict of
323+ Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, e1, e2 ])
325+ func | isOp op' = "_op['" ++ op' ++ "']"
323− | otherwise =
326+ | otherwise = op'
324− let ops = ["+","-","*","/","&&","||"] in
327+ (prefix, op') = case List.elemIndices '.' op of
325− case o:p of
328+ [] -> ("", op)
329+ xs -> splitAt (last xs + 1) op
331+ opDict = Map.fromList $ basics ++
326− "::" -> jsCons e1 e2
332+ [ ("::", jsCons e1 e2)
327− "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
333+ , ("List.++", "_L.append" ++ parens (e1 ++ "," ++ e2)) ]
335+ basics = map (\(op,e) -> ("Basics." ++ op, e)) $
328− "<|" -> e1 ++ parens e2
336+ [ ("<|", e1 ++ parens e2)
329− "|>" -> e2 ++ parens e1
337+ , ("|>", e2 ++ parens e1)
330− "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
338+ , ("." , jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x"))
331− "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
339+ , ("^" , "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")")
332− "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
340+ , ("==", "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")")
333− "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
341+ , ("/=", "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")")
334− "<" -> jsCompare e1 e2 "==='LT'"
342+ , ("<" , jsCompare e1 e2 "==='LT'")
335− ">" -> jsCompare e1 e2 "==='GT'"
343+ , (">" , jsCompare e1 e2 "==='GT'")
336− "<=" -> jsCompare e1 e2 "!=='GT'"
344+ , ("<=", jsCompare e1 e2 "!=='GT'")
337− ">=" -> jsCompare e1 e2 "!=='LT'"
345+ , (">=", jsCompare e1 e2 "!=='LT'")
338− "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
346+ , ("div", parens (e1 ++ "/" ++ e2 ++ "|0"))
339− "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
340− _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
347+ ] ++ map (\op -> (op, parens (e1 ++ op ++ e2))) ["+","-","*","/","&&","||"]
341− | otherwise -> concat [ "_op['", o:p, "']"
342− , parens e1, parens e2 ]