git.iko.soy/elk
on 0c3db69 help sign in
elk/compiler/src/Gen/CompileToJS.hs
330 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.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 ++ 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 "\n_ = " ++ "elm.Native." ++ modName ++ " || {};" ++
65 getExports exports stmts ++
66 ret (assign' ("elm." ++ modName) "_") ++ "\n"
67 setup = concatMap (\n -> globalAssign n $ n ++ " || {}") .
68 map (intercalate ".") . tail . inits $
69 take (length modNames - 1) 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" ++ ";" ++
99 if null vs then "\nfor (var k in _$) {eval('var '+k+'=_$[\"'+k+'\"]')}"
100 else concatMap def vs
101 where
102 imprt asgn v = asgn v ("elm." ++ modul ++ "." ++ v)
103 def (o:p) =
104 if isOp o then imprt globalAssign ("$op['" ++ o:p ++ "']")
105 else imprt assign (deprime (o:p))
108stmtsToJS :: [Statement] -> String
109stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
110 return (vars ++ concat program)
111 where
112 vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"
113 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
114 valueOf s = case s of
115 Datatype _ _ _ -> 1
116 ImportEvent _ _ _ _ -> 2
117 Definition (FnDef f [] _) ->
118 if derename f == "main" then 5 else 4
119 Definition _ -> 3
120 ExportEvent _ _ _ -> 6
121 TypeAlias _ _ _ -> 0
122 TypeAnnotation _ _ -> 0
124class ToJS a where
125 toJS :: a -> GuidCounter String
127instance ToJS Def where
128 toJS (FnDef x [] e) = assign' x `liftM` toJS' e
129 toJS (FnDef f as e) = (assign' f . wrapper . func) `liftM` toJS' e
130 where func body = jsFunc (intercalate ", " as) (ret body)
131 wrapper e | length as == 1 = e
132 | otherwise = 'F' : show (length as) ++ parens e
133 toJS (OpDef op a1 a2 e) =
134 do body <- toJS' e
135 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
136 return (globalAssign ("$op['" ++ op ++ "']") func)
138instance ToJS Statement where
139 toJS stmt =
140 case stmt of
141 Definition d -> (\asgn -> "\n" ++ asgn ++ ";") `liftM` toJS d
142 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
143 where toDef (name,args) =
144 let vars = map (('a':) . show) [1..length args] in
145 Definition . FnDef name vars . noContext $
146 Data (derename name) (map (noContext . Var) vars)
147 ImportEvent js base elm _ ->
148 do v <- toJS' base
149 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
150 , "\ndocument.addEventListener('", js
151 , "_' + elm.id, function(e) { elm.notify(", elm
152 , ".id, e.value); });" ]
153 ExportEvent js elm _ ->
154 return $ concat [ "\nlift(function(v) { "
155 , "var e = document.createEvent('Event');"
156 , "e.initEvent('", js, "_' + elm.id, true, true);"
157 , "e.value = v;"
158 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
159 TypeAnnotation _ _ -> return ""
160 TypeAlias n _ t ->
161 case t of
162 RecordT kvs _ -> return $ "\nfunction" ++ args ++ brackets body
163 where fs = Map.keys kvs
164 args = parens (intercalate "," fs)
165 body = ret . brackets . intercalate "," $
166 map (\k -> k ++ ":" ++ k) fs
167 _ -> return ""
169toJS' :: CExpr -> GuidCounter String
170toJS' (C txt span expr) =
171 case expr of
172 MultiIf ps -> multiIfToJS span ps
173 Case e cases -> caseToJS span e cases
174 _ -> toJS expr
176remove x e = "_.remove('" ++ x ++ "', " ++ e ++ ")"
177addField x v e = "_.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
178setField fs e = "_.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
179 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
180access x e = parens e ++ "." ++ x
181makeRecord kvs = record `liftM` collect kvs
182 where
183 combine r (k,v) = Map.insertWith (++) k v r
184 collect = liftM (foldl' combine Map.empty) . mapM prep
185 prep (k, as, e@(C t s _)) =
186 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
187 return (k,[v])
188 fields fs =
189 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
190 hidden = fields . map (second jsList) .
191 filter (not . null . snd) . Map.toList . Map.map tail
192 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
195instance ToJS Expr where
196 toJS expr =
197 case expr of
198 IntNum n -> return $ show n
199 FloatNum n -> return $ show n
200 Var x -> return $ x
201 Chr c -> return $ quoted [c]
202 Str s -> return $ "_str" ++ parens (quoted s)
203 Boolean b -> return $ if b then "true" else "false"
204 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
205 Access e x -> access x `liftM` toJS' e
206 Remove e x -> remove x `liftM` toJS' e
207 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
208 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
209 setField fs' `liftM` toJS' e
210 Record fs -> makeRecord fs
211 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
213 If eb et ef ->
214 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
216 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
218 App e1 e2 -> jsApp e1 e2
219 Let defs e -> jsLet defs e
220 Data name es ->
221 do fs <- mapM toJS' es
222 let fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
223 return (brackets ("ctor:" ++ show name ++ concatMap (", "++) fields))
225 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
226 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
227 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
229jsApp e1 e2 =
230 do f <- toJS' func
231 as <- mapM toJS' args
232 return $ case as of
233 [a] -> f ++ parens a
234 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
235 where
236 (func, args) = go [e2] e1
237 go args e =
238 case e of
239 (C _ _ (App e1 e2)) -> go (e2 : args) e1
240 _ -> (e, args)
242formatMarkdown = concatMap f
243 where f '\'' = "\\'"
244 f '\n' = "\\n"
245 f '"' = "\""
246 f c = [c]
248multiIfToJS span ps =
249 case last ps of
250 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
251 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
252 where
253 format base ps =
254 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
255 f (b,e) = do b' <- toJS' b
256 e' <- toJS' e
257 return (b' ++ " ? " ++ e')
259jsLet defs e' = do ds <- jsDefs defs
260 e <- toJS' e'
261 return $ parens (intercalate ", " ds ++ ", " ++ e)
262 where
263 jsDefs defs = mapM toJS (sortBy f defs)
264 f a b = compare (valueOf a) (valueOf b)
265 valueOf (FnDef _ args _) = min 1 (length args)
266 valueOf (OpDef _ _ _ _) = 1
268caseToJS span e ps = do
269 match <- caseToMatch ps
270 e' <- toJS' e
271 (match',stmt) <- case (match,e) of
272 (Match name _ _, C _ _ (Var x)) ->
273 return (matchSubst [(name,x)] match, Nothing)
274 (Match name _ _, _) ->
275 return (match, Just (name ++ " = " ++ e'))
276 _ -> return (match, Nothing)
277 matches <- matchToJS span match'
278 return $ case stmt of
279 Nothing -> matches
280 Just exp -> parens (exp ++ ", " ++ matches)
282matchToJS span match =
283 let sqnc e1 e2 = parens ("e=" ++ e1 ++ ":null,e!==null?e:" ++ e2)
284 in case match of
285 Match name clauses def ->
286 do cases <- intercalate ":" `liftM` mapM (clauseToJS span name) clauses
287 finally <- matchToJS span def
288 return (sqnc cases finally)
289 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
290 Break -> return "null"
291 Other e -> toJS' e
292 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
293 where dropEnd acc [] = acc
294 dropEnd acc (m:ms) =
295 case m of
296 Other _ -> acc ++ [m]
297 _ -> dropEnd (acc ++ [m]) ms
300clauseToJS span var (Clause name vars e) = do
301 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
302 s <- matchToJS span $ matchSubst (zip vars vars') e
303 return $ concat [ var, ".ctor===", quoted name, "?", s ]
305jsNil = "_L.Nil"
306jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
307jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
308jsCompare e1 e2 op = parens ("_.compare(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
310binop (o:p) e1 e2
311 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
312 | otherwise =
313 let ops = ["+","-","*","/","&&","||"] in
314 case o:p of
315 "::" -> jsCons e1 e2
316 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
317 "$" -> e1 ++ parens e2
318 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
319 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
320 "==" -> "_.eq(" ++ e1 ++ "," ++ e2 ++ ")"
321 "/=" -> "!_.eq(" ++ e1 ++ "," ++ e2 ++ ")"
322 "<" -> jsCompare e1 e2 "==='LT'"
323 ">" -> jsCompare e1 e2 "==='GT'"
324 "<=" -> jsCompare e1 e2 "!=='GT'"
325 ">=" -> jsCompare e1 e2 "!=='LT'"
326 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
327 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
328 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
329 | otherwise -> concat [ "$op['", o:p, "']"
330 , parens e1, parens e2 ]