git.iko.soy/elk
on ecaa5bd help sign in
elk/compiler/Gen/CompileToJS.hs
337 lines 13 kB history raw
1module CompileToJS (showErr, jsModule) where
3import Control.Arrow (first,second)
4import Control.Monad (liftM,(<=<),join,ap)
5import Data.Char (isAlpha,isDigit)
6import Data.List (intercalate,sortBy,inits,foldl')
7import qualified Data.Map as Map
8import Data.Either (partitionEithers)
9import qualified Text.Pandoc as Pan
11import Ast
12import Context
13import Rename (derename)
14import Cases
15import Guid
16import LetBoundVars
17import Parse.Library (isOp)
18import Rename (deprime)
19import Types.Types ( Type(RecordT) )
21showErr :: String -> String
22showErr err = "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
23 where msg = show . concatMap (++"<br>") . lines $ err
25indent = concatMap f
26 where f '\n' = "\n "
27 f c = [c]
29internalImports =
30 [ ("N" , "Elm.Native"),
31 ("_N", "N.Utils(elm)"),
32 ("_L", "N.List(elm)"),
33 ("_E", "N.Error(elm)"),
34 ("_str", "N.JavaScript(elm).toString")
35 ]
37parens s = "(" ++ s ++ ")"
38brackets s = "{" ++ s ++ "}"
39jsList ss = "["++ intercalate "," ss ++"]"
40jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
41assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
42ret e = "\nreturn "++ e ++";"
43iff a b c = a ++ "?" ++ b ++ ":" ++ c
44quoted s = "'" ++ concatMap f s ++ "'"
45 where f '\n' = "\\n"
46 f '\'' = "\\'"
47 f '\t' = "\\t"
48 f '\"' = "\\\""
49 f '\\' = "\\\\"
50 f c = [c]
52globalAssign n e = "\n" ++ assign' n e ++ ";"
53assign' n e = n ++ " = " ++ e
55jsModule (Module names exports imports stmts) =
56 setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
57 where
58 modNames = if null names then ["Main"] else names
59 modName = intercalate "." modNames
60 includes = concatMap jsImport imports
61 body = stmtsToJS stmts
62 defs = assign "$op" "{}"
63 program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
64 setup ("elm":"Native":modNames) ++
65 assign "_" ("elm.Native." ++ modName ++ "||{}") ++
66 getExports exports stmts ++ setup ("elm":modNames) ++
67 ret (assign' ("elm." ++ modName) "_") ++ "\n"
68 setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
69 map (intercalate ".") . drop 2 . inits $ init modNames
70 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
72getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
73 where exNames n = either derename id n `elem` names
74 exports | null names = concatMap get stmts
75 | otherwise = filter exNames (concatMap get stmts)
77 (fns,ops) = partitionEithers exports
79 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
80 fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
82 op = ("_.$op = "++) . brackets . intercalate ", " $ map opPair ops
84 get' (FnDef x _ _) = Left x
85 get' (OpDef op _ _ _) = Right op
86 get s = case s of Definition d -> [ get' d ]
87 Datatype _ _ tcs -> map (Left . fst) tcs
88 ImportEvent _ _ x _ -> [ Left x ]
89 ExportEvent _ _ _ -> []
90 TypeAlias _ _ _ -> []
91 TypeAnnotation _ _ -> []
94jsImport (modul, how) =
95 case how of
96 As name -> assign name ("Elm." ++ modul ++ parens "elm")
97 Importing vs ->
98 "\nvar $ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul ++
99 if null vs then "\nfor (var k in $) {eval('var '+k+'=$[\"'+k+'\"]')}"
100 else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
101 where
102 imprt v = assign' v ("$." ++ v)
103 def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
104 setup moduleName =
105 "\nvar " ++ concatMap (++";") (defs ++ [assign' moduleName "$"])
106 where
107 defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
108 subnames = map (intercalate ".") . tail . inits . init . split
109 split names = case go [] names of
110 (name, []) -> [name]
111 (name, ns) -> name : split ns
112 go name str = case str of
113 '.':rest -> (reverse name, rest)
114 c:rest -> go (c:name) rest
115 [] -> (reverse name, [])
119stmtsToJS :: [Statement] -> String
120stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
121 return (vars ++ concat program)
122 where
123 vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"
124 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
125 valueOf s = case s of
126 Datatype _ _ _ -> 1
127 ImportEvent _ _ _ _ -> 2
128 Definition (FnDef f [] _) ->
129 if derename f == "main" then 5 else 4
130 Definition _ -> 3
131 ExportEvent _ _ _ -> 6
132 TypeAlias _ _ _ -> 0
133 TypeAnnotation _ _ -> 0
135class ToJS a where
136 toJS :: a -> GuidCounter String
138instance ToJS Def where
139 toJS (FnDef x [] e) = assign' x `liftM` toJS' e
140 toJS (FnDef f as e) = (assign' f . wrapper . func) `liftM` toJS' e
141 where func body = jsFunc (intercalate ", " as) (ret body)
142 wrapper e | length as == 1 = e
143 | otherwise = 'F' : show (length as) ++ parens e
144 toJS (OpDef op a1 a2 e) =
145 do body <- toJS' e
146 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
147 return (globalAssign ("$op['" ++ op ++ "']") func)
149instance ToJS Statement where
150 toJS stmt =
151 case stmt of
152 Definition d -> (\asgn -> "\n" ++ asgn ++ ";") `liftM` toJS d
153 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
154 where toDef (name,args) =
155 let vars = map (('a':) . show) [1..length args] in
156 Definition . FnDef name vars . noContext $
157 Data (derename name) (map (noContext . Var) vars)
158 ImportEvent js base elm _ ->
159 do v <- toJS' base
160 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
161 , "\ndocument.addEventListener('", js
162 , "_' + elm.id, function(e) { elm.notify(", elm
163 , ".id, e.value); });" ]
164 ExportEvent js elm _ ->
165 return $ concat [ "\nlift(function(v) { "
166 , "var e = document.createEvent('Event');"
167 , "e.initEvent('", js, "_' + elm.id, true, true);"
168 , "e.value = v;"
169 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
170 TypeAnnotation _ _ -> return ""
171 TypeAlias n _ t -> return ""
173toJS' :: CExpr -> GuidCounter String
174toJS' (C txt span expr) =
175 case expr of
176 MultiIf ps -> multiIfToJS span ps
177 Case e cases -> caseToJS span e cases
178 _ -> toJS expr
180remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
181addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
182setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
183 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
184access x e = parens e ++ "." ++ x
185makeRecord kvs = record `liftM` collect kvs
186 where
187 combine r (k,v) = Map.insertWith (++) k v r
188 collect = liftM (foldl' combine Map.empty) . mapM prep
189 prep (k, as, e@(C t s _)) =
190 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
191 return (k,[v])
192 fields fs =
193 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
194 hidden = fields . map (second jsList) .
195 filter (not . null . snd) . Map.toList . Map.map tail
196 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
199instance ToJS Expr where
200 toJS expr =
201 case expr of
202 IntNum n -> return $ show n
203 FloatNum n -> return $ show n
204 Var x -> return $ x
205 Chr c -> return $ quoted [c]
206 Str s -> return $ "_str" ++ parens (quoted s)
207 Boolean b -> return $ if b then "true" else "false"
208 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
209 Access e x -> access x `liftM` toJS' e
210 Remove e x -> remove x `liftM` toJS' e
211 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
212 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
213 setField fs' `liftM` toJS' e
214 Record fs -> makeRecord fs
215 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
217 If eb et ef ->
218 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
220 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
222 App e1 e2 -> jsApp e1 e2
223 Let defs e -> jsLet defs e
224 Data name es ->
225 do fs <- mapM toJS' es
226 return $ case name of
227 "Nil" -> jsNil
228 "Cons" -> jsCons (head fs) ((head . tail) fs)
229 _ -> brackets $ "ctor:" ++ show name ++ concatMap (", "++) fields
230 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
232 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
233 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
234 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
236jsApp e1 e2 =
237 do f <- toJS' func
238 as <- mapM toJS' args
239 return $ case as of
240 [a] -> f ++ parens a
241 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
242 where
243 (func, args) = go [e2] e1
244 go args e =
245 case e of
246 (C _ _ (App e1 e2)) -> go (e2 : args) e1
247 _ -> (e, args)
249formatMarkdown = concatMap f
250 where f '\'' = "\\'"
251 f '\n' = "\\n"
252 f '"' = "\""
253 f c = [c]
255multiIfToJS span ps =
256 case last ps of
257 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
258 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
259 where
260 format base ps =
261 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
262 f (b,e) = do b' <- toJS' b
263 e' <- toJS' e
264 return (b' ++ " ? " ++ e')
266jsLet defs e' = do ds <- jsDefs defs
267 e <- toJS' e'
268 return $ parens (intercalate ", " ds ++ ", " ++ e)
269 where
270 jsDefs defs = mapM toJS (sortBy f defs)
271 f a b = compare (valueOf a) (valueOf b)
272 valueOf (FnDef _ args _) = min 1 (length args)
273 valueOf (OpDef _ _ _ _) = 1
275caseToJS span e ps = do
276 match <- caseToMatch ps
277 e' <- toJS' e
278 (match',stmt) <- case (match,e) of
279 (Match name _ _, C _ _ (Var x)) ->
280 return (matchSubst [(name,x)] match, Nothing)
281 (Match name _ _, _) ->
282 return (match, Just (name ++ " = " ++ e'))
283 _ -> return (match, Nothing)
284 matches <- matchToJS span match'
285 return $ case stmt of
286 Nothing -> matches
287 Just exp -> parens (exp ++ ", " ++ matches)
289matchToJS span match =
290 let sqnc e1 e2 = parens ("e=" ++ e1 ++ ":null,e!==null?e:" ++ e2)
291 in case match of
292 Match name clauses def ->
293 do cases <- intercalate ":" `liftM` mapM (clauseToJS span name) clauses
294 finally <- matchToJS span def
295 return (sqnc cases finally)
296 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
297 Break -> return "null"
298 Other e -> toJS' e
299 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
300 where dropEnd acc [] = acc
301 dropEnd acc (m:ms) =
302 case m of
303 Other _ -> acc ++ [m]
304 _ -> dropEnd (acc ++ [m]) ms
307clauseToJS span var (Clause name vars e) = do
308 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
309 s <- matchToJS span $ matchSubst (zip vars vars') e
310 return $ concat [ var, ".ctor===", quoted name, "?", s ]
312jsNil = "_L.Nil"
313jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
314jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
315jsCompare e1 e2 op = parens ("_N.compare(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
317binop (o:p) e1 e2
318 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
319 | otherwise =
320 let ops = ["+","-","*","/","&&","||"] in
321 case o:p of
322 "::" -> jsCons e1 e2
323 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
324 "$" -> e1 ++ parens e2
325 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
326 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
327 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
328 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
329 "<" -> jsCompare e1 e2 "==='LT'"
330 ">" -> jsCompare e1 e2 "==='GT'"
331 "<=" -> jsCompare e1 e2 "!=='GT'"
332 ">=" -> jsCompare e1 e2 "!=='LT'"
333 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
334 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
335 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
336 | otherwise -> concat [ "$op['", o:p, "']"
337 , parens e1, parens e2 ]