@@ -1,7 +1,5 @@
11module CompileToJS (showErr, jsModule) where
22
3−import Ast
4−import Context
53import Control.Arrow (first,second)
64import Control.Monad (liftM,(<=<),join,ap)
75import Data.Char (isAlpha,isDigit)
@@ -10,12 +8,15 @@ import qualified Data.Map as Map
108import Data.Either (partitionEithers)
119import qualified Text.Pandoc as Pan
1210
13−import Initialize
11+import Ast
12+import Context
1413import Rename (derename)
1514import Cases
1615import Guid
16+import LetBoundVars
1717import Parse.Library (isOp)
1818import Rename (deprime)
19+import Types.Types ( Type(RecordT) )
1920
2021showErr :: String -> String
2122showErr err = mainEquals $ "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
@@ -41,47 +42,26 @@ quoted s = "'" ++ concatMap f s ++ "'"
4142 f c = [c]
4243
4344mainEquals s = globalAssign "Elm.main" (jsFunc "" (ret s))
44−globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
45−
46−tryBlock escapees names e =
47− concat [ "\ntry{\n" ++ e ++ "\n} catch (e) {"
48− , "\nElm.main=function() {"
49− , "\nvar msg = ('<br/><h2>Your browser may not be supported. " ++
50− "Are you using a modern browser?</h2>' +" ++
51− " '<br/><span style=\"color:grey\">Runtime Error in " ++
52− intercalate "." names ++ " module:<br/>' + e + '" ++ msg ++ "</span>');"
53− , "\ndocument.body.innerHTML = Elm.Text.monospace(msg);"
54− , "throw e;"
55− , "};}"
56− ]
57− where msg | escapees /= [] = concat [ "<br/><br/>The problem may stem from an improper usage of:<br/>"
58− , intercalate ", " $ map (concatMap escape) escapees ]
59− | otherwise = ""
60− escape '\'' = "\\'"
61− escape '"' = "\\\""
62− escape c = [c]
63−
64−
65−jsModule (escapees, Module names exports imports stmts) =
66− tryBlock escapees (tail modNames) $ concat
67− [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
68− map (intercalate ".") . drop 2 . inits $
69− take (length modNames - 1) modNames
70− , "\nif (" ++ modName ++ ") throw new Error(\"Module name collision, '" ++
71− intercalate "." (tail modNames) ++ "' is already defined.\"); "
72− , globalAssign modName $ jsFunc "" (defs ++ includes ++ body ++ export) ++ "()"
73− , mainEquals $ modName ++ ".main" ]
74− where modNames = if null names then ["Elm", "Main"]
75− else "Elm" : names
76− modName = intercalate "." modNames
77− includes = concatMap jsImport $ map (first ("Elm."++)) imports
78− body = stmtsToJS stmts
79− export = getExports exports stmts
80− exps = if null exports then ["main"] else exports
81− defs = concat [ assign "$op" "{}"
82− , "\nfor(Elm['i'] in Elm){eval('var '+Elm['i']+'=Elm[Elm.i];');}" ]
83−
84−getExports names stmts = ret . brackets $ intercalate ",\n" (op : map fnPair fns)
45+globalAssign n e = "\n" ++ assign' n e ++ ";"
46+assign' n e = n ++ " = " ++ e
47+
48+jsModule (Module names exports imports stmts) =
49+ concat [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
50+ map (intercalate ".") . drop 2 . inits $
51+ take (length modNames - 1) modNames
52+ , parens (jsFunc "" (defs ++ includes ++ body ++ globalAssign modName export) ++ "()")
53+ , mainEquals $ modName ++ ".main" ]
54+ where modNames = if null names then ["Elm", "Main"]
55+ else "Elm" : names
56+ modName = intercalate "." modNames
57+ includes = concatMap jsImport imports
58+ body = stmtsToJS stmts
59+ export = getExports exports stmts
60+ exps = if null exports then ["main"] else exports
61+ defs = assign "$op" "{}"
62+
63+getExports names stmts = brackets . ("\n "++) $
64+ intercalate ",\n " (op : map fnPair fns)
8565 where exNames n = either derename id n `elem` names
8666 exports | null names = concatMap get stmts
8767 | otherwise = filter exNames (concatMap get stmts)
@@ -104,75 +84,75 @@ getExports names stmts = ret . brackets $ intercalate ",\n" (op : map fnPair fns
10484
10585
10686jsImport (modul, how) =
107− concat [ "\ntry{\n if (!(" ++ modul ++ " instanceof Object)) throw new Error('module not found');\n} catch(e) {\n throw new Error(\"Module '"
108− , drop 1 (dropWhile (/='.') modul)
109− , "' is missing. Compile with --make flag or load missing "
110− , "module in a separate JavaScript file.\");\n}" ] ++
111− jsImport' (modul, how)
112−
113−jsImport' (modul, As name) = assign name modul
114−jsImport' (modul, Importing vs) = concatMap def vs
115− where def [] = []
116− def (o:p) | isOp o = let v = "$op['" ++ o:p ++ "']" in
117− "\n" ++ v ++ " = " ++ modul ++ "." ++ v ++ ";"
118− | otherwise = let v = deprime (o:p) in
119− assign v $ modul ++ "." ++ v
120−
121−jsImport' (modul, Hiding vs) =
122− concat [ assign "hiddenVars" . ("{"++) . (++"}") . intercalate "," $
123− map (\v -> v ++ ":true") (map deprime vs)
124− , "\nfor (Elm['i'] in " ++ modul ++ ") "
125− , brackets . indent . concat $
126− [ "\nif (hiddenVars[Elm['i']]) continue;"
127− , "\neval('var ' + Elm['i'] + ' = "
128− , modul, "[Elm.i];');" ]
129− ]
87+ case how of
88+ As name -> assign name ("Elm." ++ modul)
89+ Importing vs ->
90+ assign modul ("Elm." ++ modul) ++ concatMap def vs
91+ where
92+ imprt asgn v = asgn v ("Elm." ++ modul ++ "." ++ v)
93+ def (o:p) =
94+ if isOp o then imprt globalAssign ("$op['" ++ o:p ++ "']")
95+ else imprt assign (deprime (o:p))
96+
13097
13198stmtsToJS :: [Statement] -> String
132−stmtsToJS stmts = run (concat `liftM` mapM toJS (sortBy cmpStmt stmts))
133− where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
134− valueOf s = case s of
135− Datatype _ _ _ -> 1
136− ImportEvent _ _ _ _ -> 2
137− Definition (FnDef f [] _) ->
138− if derename f == "main" then 5 else 4
139− Definition _ -> 3
140− ExportEvent _ _ _ -> 6
141− TypeAlias _ _ _ -> 0
142− TypeAnnotation _ _ -> 0
99+stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
100+ return (vars ++ concat program)
101+ where
102+ vars = "\nvar " ++ intercalate "," (letBoundVars stmts) ++ ";"
103+ cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
104+ valueOf s = case s of
105+ Datatype _ _ _ -> 1
106+ ImportEvent _ _ _ _ -> 2
107+ Definition (FnDef f [] _) ->
108+ if derename f == "main" then 5 else 4
109+ Definition _ -> 3
110+ ExportEvent _ _ _ -> 6
111+ TypeAlias _ _ _ -> 0
112+ TypeAnnotation _ _ -> 0
143113
144114class ToJS a where
145115 toJS :: a -> GuidCounter String
146116
147117instance ToJS Def where
148− toJS (FnDef x [] e) = assign x `liftM` toJS' e
118+ toJS (FnDef x [] e) = assign' x `liftM` toJS' e
149119 toJS (FnDef f (a:as) e) =
150120 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e as)
151− return $ concat ["\nfunction ",f,parens a, brackets . indent $ ret body]
121+ return $ assign' f (jsFunc a (ret body))
152122 toJS (OpDef op a1 a2 e) =
153123 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e [a1,a2])
154124 return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
155125
156126instance ToJS Statement where
157− toJS (Definition d) = toJS d
158− toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs
159− where toDef (name,args) = Definition . FnDef name vars . noContext $
160− Data (derename name) (map (noContext . Var) vars)
161− where vars = map (('a':) . show) [1..length args]
162− toJS (ImportEvent js base elm _) =
127+ toJS stmt =
128+ case stmt of
129+ Definition d -> (\asgn -> "\n" ++ asgn ++ ";") `liftM` toJS d
130+ Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
131+ where toDef (name,args) =
132+ let vars = map (('a':) . show) [1..length args] in
133+ Definition . FnDef name vars . noContext $
134+ Data (derename name) (map (noContext . Var) vars)
135+ ImportEvent js base elm _ ->
163136 do v <- toJS' base
164137 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
165138 , "\nValue.addListener(document, '" ++ js
166139 , "', function(e) { Dispatcher.notify(" ++ elm
167140 , ".id, e.value); });" ]
168− toJS (ExportEvent js elm _) =
141+ ExportEvent js elm _ ->
169142 return $ concat [ "\nlift(function(v) { "
170143 , "var e = document.createEvent('Event');"
171144 , "e.initEvent('", js, "', true, true);"
172145 , "e.value = v;"
173146 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
174− toJS (TypeAnnotation _ _) = return ""
175− toJS (TypeAlias _ _ _) = return ""
147+ TypeAnnotation _ _ -> return ""
148+ TypeAlias n _ t ->
149+ case t of
150+ RecordT kvs _ -> return $ "\nfunction" ++ args ++ brackets body
151+ where fs = Map.keys kvs
152+ args = parens (intercalate "," fs)
153+ body = ret . brackets . intercalate "," $
154+ map (\k -> k ++ ":" ++ k) fs
155+ _ -> return ""
176156
177157toJS' :: CExpr -> GuidCounter String
178158toJS' (C txt span expr) =
@@ -203,7 +183,7 @@ makeRecord kvs = record `liftM` collect kvs
203183instance ToJS Expr where
204184 toJS expr =
205185 case expr of
206− IntNum n -> return $ show n
186+ IntNum n -> return $ show n ++ "|0"
207187 FloatNum n -> return $ show n
208188 Var x -> return $ x
209189 Chr c -> return $ quoted [c]
@@ -249,22 +229,27 @@ formatMarkdown = concatMap f
249229 f '"' = "\""
250230 f c = [c]
251231
252−multiIfToJS span ps = format `liftM` mapM f ps
253− where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
254− err = concat [ "(function(){throw new Error(\"Non-exhaustive "
255− , "multi-way-if expression (", show span, ")\");}())" ]
256− f (b,e) = do b' <- toJS' b
257− e' <- toJS' e
258− return (b' ++ " ? " ++ e')
259−
260−jsLet defs e' = do
261− body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
262− return $ jsFunc "" body ++ "()"
263−
264−jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
265− where f a b = compare (valueOf a) (valueOf b)
266− valueOf (FnDef _ args _) = min 1 (length args)
267− valueOf (OpDef _ _ _ _) = 1
232+multiIfToJS span ps =
233+ case last ps of
234+ (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
235+ _ -> format err ps
236+ where
237+ format base ps =
238+ foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
239+ err = "throw new Error('Non-exhaustive multi-way-if expression (" ++
240+ show span ++ ")')"
241+ f (b,e) = do b' <- toJS' b
242+ e' <- toJS' e
243+ return (b' ++ " ? " ++ e')
244+
245+jsLet defs e' = do ds <- jsDefs defs
246+ e <- toJS' e'
247+ return $ parens (intercalate ", " ds ++ ", " ++ e)
248+ where
249+ jsDefs defs = mapM toJS (sortBy f defs)
250+ f a b = compare (valueOf a) (valueOf b)
251+ valueOf (FnDef _ args _) = min 1 (length args)
252+ valueOf (OpDef _ _ _ _) = 1
268253
269254caseToJS span e ps = do
270255 match <- caseToMatch ps
@@ -280,8 +265,9 @@ matchToJS span (Match name clauses def) = do
280265 cases <- concat `liftM` mapM (clauseToJS span name) clauses
281266 finally <- matchToJS span def
282267 return $ concat [ "\nswitch(", name, ".ctor){", indent cases, "\n}", finally ]
283−matchToJS span Fail = return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
284− "in case expression (" ++ show span ++ ")\");")
268+matchToJS span Fail =
269+ return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
270+ "in case expression (" ++ show span ++ ")\");")
285271matchToJS span Break = return "break;"
286272matchToJS span (Other e) = ret `liftM` toJS' e
287273matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
@@ -291,12 +277,9 @@ clauseToJS span var (Clause name vars e) = do
291277 s <- matchToJS span $ matchSubst (zip vars vars') e
292278 return $ concat [ "\ncase ", quoted name, ":", s ]
293279
294−jsNil = "[\"Nil\"]"
295−jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
296−jsRange e1 e2 = (++"()") . jsFunc "" $
297− assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
298− "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
299− ret "lst"
280+jsNil = "{ctor:'Nil'}"
281+jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"
282+jsRange e1 e2 = "Elm.Native.List.range" ++ parens (e1 ++ "," ++ e2)
300283
301284binop (o:p) e1 e2
302285 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2