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