git.iko.soy/elk
on 602bffa help sign in
elk/compiler/src/Gen/CompileToJS.hs
323 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 ".") . tail . 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" ++ ";" ++
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 ("_$." ++ 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 -> return ""
162toJS' :: CExpr -> GuidCounter String
163toJS' (C txt span expr) =
164 case expr of
165 MultiIf ps -> multiIfToJS span ps
166 Case e cases -> caseToJS span e cases
167 _ -> toJS expr
169remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
170addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
171setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
172 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
173access x e = parens e ++ "." ++ x
174makeRecord kvs = record `liftM` collect kvs
175 where
176 combine r (k,v) = Map.insertWith (++) k v r
177 collect = liftM (foldl' combine Map.empty) . mapM prep
178 prep (k, as, e@(C t s _)) =
179 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
180 return (k,[v])
181 fields fs =
182 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
183 hidden = fields . map (second jsList) .
184 filter (not . null . snd) . Map.toList . Map.map tail
185 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
188instance ToJS Expr where
189 toJS expr =
190 case expr of
191 IntNum n -> return $ show n
192 FloatNum n -> return $ show n
193 Var x -> return $ x
194 Chr c -> return $ quoted [c]
195 Str s -> return $ "_str" ++ parens (quoted s)
196 Boolean b -> return $ if b then "true" else "false"
197 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
198 Access e x -> access x `liftM` toJS' e
199 Remove e x -> remove x `liftM` toJS' e
200 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
201 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
202 setField fs' `liftM` toJS' e
203 Record fs -> makeRecord fs
204 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
206 If eb et ef ->
207 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
209 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
211 App e1 e2 -> jsApp e1 e2
212 Let defs e -> jsLet defs e
213 Data name es ->
214 do fs <- mapM toJS' es
215 let fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
216 return (brackets ("ctor:" ++ show name ++ concatMap (", "++) fields))
218 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
219 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
220 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
222jsApp e1 e2 =
223 do f <- toJS' func
224 as <- mapM toJS' args
225 return $ case as of
226 [a] -> f ++ parens a
227 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
228 where
229 (func, args) = go [e2] e1
230 go args e =
231 case e of
232 (C _ _ (App e1 e2)) -> go (e2 : args) e1
233 _ -> (e, args)
235formatMarkdown = concatMap f
236 where f '\'' = "\\'"
237 f '\n' = "\\n"
238 f '"' = "\""
239 f c = [c]
241multiIfToJS span ps =
242 case last ps of
243 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
244 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
245 where
246 format base ps =
247 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
248 f (b,e) = do b' <- toJS' b
249 e' <- toJS' e
250 return (b' ++ " ? " ++ e')
252jsLet defs e' = do ds <- jsDefs defs
253 e <- toJS' e'
254 return $ parens (intercalate ", " ds ++ ", " ++ e)
255 where
256 jsDefs defs = mapM toJS (sortBy f defs)
257 f a b = compare (valueOf a) (valueOf b)
258 valueOf (FnDef _ args _) = min 1 (length args)
259 valueOf (OpDef _ _ _ _) = 1
261caseToJS span e ps = do
262 match <- caseToMatch ps
263 e' <- toJS' e
264 (match',stmt) <- case (match,e) of
265 (Match name _ _, C _ _ (Var x)) ->
266 return (matchSubst [(name,x)] match, Nothing)
267 (Match name _ _, _) ->
268 return (match, Just (name ++ " = " ++ e'))
269 _ -> return (match, Nothing)
270 matches <- matchToJS span match'
271 return $ case stmt of
272 Nothing -> matches
273 Just exp -> parens (exp ++ ", " ++ matches)
275matchToJS span match =
276 let sqnc e1 e2 = parens ("e=" ++ e1 ++ ":null,e!==null?e:" ++ e2)
277 in case match of
278 Match name clauses def ->
279 do cases <- intercalate ":" `liftM` mapM (clauseToJS span name) clauses
280 finally <- matchToJS span def
281 return (sqnc cases finally)
282 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
283 Break -> return "null"
284 Other e -> toJS' e
285 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
286 where dropEnd acc [] = acc
287 dropEnd acc (m:ms) =
288 case m of
289 Other _ -> acc ++ [m]
290 _ -> dropEnd (acc ++ [m]) ms
293clauseToJS span var (Clause name vars e) = do
294 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
295 s <- matchToJS span $ matchSubst (zip vars vars') e
296 return $ concat [ var, ".ctor===", quoted name, "?", s ]
298jsNil = "_L.Nil"
299jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
300jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
301jsCompare e1 e2 op = parens ("_N.compare(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
303binop (o:p) e1 e2
304 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
305 | otherwise =
306 let ops = ["+","-","*","/","&&","||"] in
307 case o:p of
308 "::" -> jsCons e1 e2
309 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
310 "$" -> e1 ++ parens e2
311 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
312 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
313 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
314 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
315 "<" -> jsCompare e1 e2 "==='LT'"
316 ">" -> jsCompare e1 e2 "==='GT'"
317 "<=" -> jsCompare e1 e2 "!=='GT'"
318 ">=" -> jsCompare e1 e2 "!=='LT'"
319 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
320 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
321 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
322 | otherwise -> concat [ "$op['", o:p, "']"
323 , parens e1, parens e2 ]