git.iko.soy/elk
on bbbd6ee help sign in
elk/compiler/Gen/CompileToJS.hs
334 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 let fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
227 return (brackets ("ctor:" ++ show name ++ concatMap (", "++) fields))
229 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
230 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
231 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
233jsApp 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 (intercalate ", " (f:as))
239 where
240 (func, args) = go [e2] e1
241 go args e =
242 case e of
243 (C _ _ (App e1 e2)) -> go (e2 : args) e1
244 _ -> (e, args)
246formatMarkdown = concatMap f
247 where f '\'' = "\\'"
248 f '\n' = "\\n"
249 f '"' = "\""
250 f c = [c]
252multiIfToJS span ps =
253 case last ps of
254 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
255 _ -> format ("_E.If" ++ parens (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')
263jsLet defs e' = do ds <- jsDefs defs
264 e <- toJS' e'
265 return $ parens (intercalate ", " ds ++ ", " ++ e)
266 where
267 jsDefs defs = mapM toJS (sortBy f defs)
268 f a b = compare (valueOf a) (valueOf b)
269 valueOf (FnDef _ args _) = min 1 (length args)
270 valueOf (OpDef _ _ _ _) = 1
272caseToJS span e ps = do
273 match <- caseToMatch ps
274 e' <- toJS' e
275 (match',stmt) <- case (match,e) of
276 (Match name _ _, C _ _ (Var x)) ->
277 return (matchSubst [(name,x)] match, Nothing)
278 (Match name _ _, _) ->
279 return (match, Just (name ++ " = " ++ e'))
280 _ -> return (match, Nothing)
281 matches <- matchToJS span match'
282 return $ case stmt of
283 Nothing -> matches
284 Just exp -> parens (exp ++ ", " ++ matches)
286matchToJS span match =
287 let sqnc e1 e2 = parens ("e=" ++ e1 ++ ":null,e!==null?e:" ++ e2)
288 in case match of
289 Match name clauses def ->
290 do cases <- intercalate ":" `liftM` mapM (clauseToJS span name) clauses
291 finally <- matchToJS span def
292 return (sqnc cases finally)
293 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
294 Break -> return "null"
295 Other e -> toJS' e
296 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
297 where dropEnd acc [] = acc
298 dropEnd acc (m:ms) =
299 case m of
300 Other _ -> acc ++ [m]
301 _ -> dropEnd (acc ++ [m]) ms
304clauseToJS span var (Clause name vars e) = do
305 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
306 s <- matchToJS span $ matchSubst (zip vars vars') e
307 return $ concat [ var, ".ctor===", quoted name, "?", s ]
309jsNil = "_L.Nil"
310jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
311jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
312jsCompare e1 e2 op = parens ("_N.compare(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
314binop (o:p) e1 e2
315 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
316 | otherwise =
317 let ops = ["+","-","*","/","&&","||"] in
318 case o:p of
319 "::" -> jsCons e1 e2
320 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
321 "$" -> e1 ++ parens e2
322 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
323 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
324 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
325 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
326 "<" -> jsCompare e1 e2 "==='LT'"
327 ">" -> jsCompare e1 e2 "==='GT'"
328 "<=" -> jsCompare e1 e2 "!=='GT'"
329 ">=" -> jsCompare e1 e2 "!=='LT'"
330 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
331 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
332 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
333 | otherwise -> concat [ "$op['", o:p, "']"
334 , parens e1, parens e2 ]