git.iko.soy/elk
on 05631f2 help sign in
elk/compiler/src/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 [ ("_Utils", "Elm.Native.Utils(elm)"),
31 ("_insert", "_Utils.insert"),
32 ("_remove", "_Utils.remove"),
33 ("_replace", "_Utils.replace"),
34 ("_eq", "_Utils.eq"),
35 ("_compare", "_Utils.compare"),
36 ("_range", "Elm.Native.List(elm).range"),
37 ("_append", "Elm.Native.List(elm).append"),
38 ("_caseError", "Elm.Native.Error(elm).Case"),
39 ("_ifError", "Elm.Native.Error(elm).If"),
40 ("_str", "Elm.Native.JavaScript(elm).toString")
41 ]
43parens s = "(" ++ s ++ ")"
44brackets s = "{" ++ s ++ "}"
45jsList ss = "["++ intercalate "," ss ++"]"
46jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
47assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
48ret e = "\nreturn "++ e ++";"
49iff a b c = a ++ "?" ++ b ++ ":" ++ c
50quoted s = "'" ++ concatMap f s ++ "'"
51 where f '\n' = "\\n"
52 f '\'' = "\\'"
53 f '\t' = "\\t"
54 f '\"' = "\\\""
55 f '\\' = "\\\\"
56 f c = [c]
58globalAssign n e = "\n" ++ assign' n e ++ ";"
59assign' n e = n ++ " = " ++ e
61jsModule (Module names exports imports stmts) =
62 setup ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
63 where
64 modNames = if null names then ["Main"] else names
65 modName = intercalate "." modNames
66 includes = concatMap jsImport imports
67 body = stmtsToJS stmts
68 export = getExports exports stmts
69 exps = if null exports then ["main"] else exports
70 defs = assign "$op" "{}"
71 program = usefulFuncs ++ defs ++ includes ++ body ++
72 ret ("elm." ++ modName ++ " = " ++ export)
73 setup = concatMap (\n -> globalAssign n $ n ++ " || {}") .
74 map (intercalate ".") . tail . inits $
75 take (length modNames - 1) modNames
76 usefulFuncs =
77 "var " ++ intercalate ", " (map (uncurry assign) internalImports) ++ ";"
79getExports names stmts = brackets . ("\n "++) $
80 intercalate ",\n " (op : map fnPair fns)
81 where exNames n = either derename id n `elem` names
82 exports | null names = concatMap get stmts
83 | otherwise = filter exNames (concatMap get stmts)
85 (fns,ops) = partitionEithers exports
87 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
88 fnPair fn = let fn' = derename fn in fn' ++ ":" ++ fn
90 op = ("$op : "++) . brackets . intercalate ", " $ map opPair ops
92 get' (FnDef x _ _) = Left x
93 get' (OpDef op _ _ _) = Right op
94 get s = case s of Definition d -> [ get' d ]
95 Datatype _ _ tcs -> map (Left . fst) tcs
96 ImportEvent _ _ x _ -> [ Left x ]
97 ExportEvent _ _ _ -> []
98 TypeAlias _ _ _ -> []
99 TypeAnnotation _ _ -> []
102jsImport (modul, how) =
103 case how of
104 As name -> assign name ("Elm." ++ modul ++ parens "elm")
105 Importing vs ->
106 "\nElm." ++ modul ++ parens "elm" ++ ";" ++ concatMap def vs
107 where
108 imprt asgn v = asgn v ("elm." ++ modul ++ "." ++ v)
109 def (o:p) =
110 if isOp o then imprt globalAssign ("$op['" ++ o:p ++ "']")
111 else imprt assign (deprime (o:p))
114stmtsToJS :: [Statement] -> String
115stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
116 return (vars ++ concat program)
117 where
118 vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"
119 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
120 valueOf s = case s of
121 Datatype _ _ _ -> 1
122 ImportEvent _ _ _ _ -> 2
123 Definition (FnDef f [] _) ->
124 if derename f == "main" then 5 else 4
125 Definition _ -> 3
126 ExportEvent _ _ _ -> 6
127 TypeAlias _ _ _ -> 0
128 TypeAnnotation _ _ -> 0
130class ToJS a where
131 toJS :: a -> GuidCounter String
133instance ToJS Def where
134 toJS (FnDef x [] e) = assign' x `liftM` toJS' e
135 toJS (FnDef f as e) = (assign' f . wrapper . func) `liftM` toJS' e
136 where func body = jsFunc (intercalate ", " as) (ret body)
137 wrapper e | length as == 1 = e
138 | otherwise = 'F' : show (length as) ++ parens e
139 toJS (OpDef op a1 a2 e) =
140 do body <- toJS' e
141 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
142 return (globalAssign ("$op['" ++ op ++ "']") func)
144instance ToJS Statement where
145 toJS stmt =
146 case stmt of
147 Definition d -> (\asgn -> "\n" ++ asgn ++ ";") `liftM` toJS d
148 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
149 where toDef (name,args) =
150 let vars = map (('a':) . show) [1..length args] in
151 Definition . FnDef name vars . noContext $
152 Data (derename name) (map (noContext . Var) vars)
153 ImportEvent js base elm _ ->
154 do v <- toJS' base
155 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
156 , "\ndocument.addEventListener('", js
157 , "_' + elm.id, function(e) { elm.notify(", elm
158 , ".id, e.value); });" ]
159 ExportEvent js elm _ ->
160 return $ concat [ "\nlift(function(v) { "
161 , "var e = document.createEvent('Event');"
162 , "e.initEvent('", js, "_' + elm.id, true, true);"
163 , "e.value = v;"
164 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
165 TypeAnnotation _ _ -> return ""
166 TypeAlias n _ t ->
167 case t of
168 RecordT kvs _ -> return $ "\nfunction" ++ args ++ brackets body
169 where fs = Map.keys kvs
170 args = parens (intercalate "," fs)
171 body = ret . brackets . intercalate "," $
172 map (\k -> k ++ ":" ++ k) fs
173 _ -> return ""
175toJS' :: CExpr -> GuidCounter String
176toJS' (C txt span expr) =
177 case expr of
178 MultiIf ps -> multiIfToJS span ps
179 Case e cases -> caseToJS span e cases
180 _ -> toJS expr
182remove x e = "_remove('" ++ x ++ "', " ++ e ++ ")"
183addField x v e = "_insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
184setField fs e = "_replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
185 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
186access x e = parens e ++ "." ++ x
187makeRecord kvs = record `liftM` collect kvs
188 where
189 combine r (k,v) = Map.insertWith (++) k v r
190 collect = liftM (foldl' combine Map.empty) . mapM prep
191 prep (k, as, e@(C t s _)) =
192 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
193 return (k,[v])
194 fields fs =
195 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
196 hidden = fields . map (second jsList) .
197 filter (not . null . snd) . Map.toList . Map.map tail
198 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
201instance ToJS Expr where
202 toJS expr =
203 case expr of
204 IntNum n -> return $ show n
205 FloatNum n -> return $ show n
206 Var x -> return $ x
207 Chr c -> return $ quoted [c]
208 Str s -> return $ "_str" ++ parens (quoted s)
209 Boolean b -> return $ if b then "true" else "false"
210 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
211 Access e x -> access x `liftM` toJS' e
212 Remove e x -> remove x `liftM` toJS' e
213 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
214 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
215 setField fs' `liftM` toJS' e
216 Record fs -> makeRecord fs
217 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
219 If eb et ef ->
220 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
222 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
224 App e1 e2 -> jsApp e1 e2
225 Let defs e -> jsLet defs e
226 Data name es ->
227 do fs <- mapM toJS' es
228 let fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
229 return (brackets ("ctor:" ++ show name ++ concatMap (", "++) fields))
231 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
232 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
233 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
235jsApp e1 e2 =
236 do f <- toJS' func
237 as <- mapM toJS' args
238 return $ case as of
239 [a] -> f ++ parens a
240 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
241 where
242 (func, args) = go [e2] e1
243 go args e =
244 case e of
245 (C _ _ (App e1 e2)) -> go (e2 : args) e1
246 _ -> (e, args)
248formatMarkdown = concatMap f
249 where f '\'' = "\\'"
250 f '\n' = "\\n"
251 f '"' = "\""
252 f c = [c]
254multiIfToJS span ps =
255 case last ps of
256 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
257 _ -> format ("_ifError" ++ parens (quoted (show span))) ps
258 where
259 format base ps =
260 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
261 f (b,e) = do b' <- toJS' b
262 e' <- toJS' e
263 return (b' ++ " ? " ++ e')
265jsLet defs e' = do ds <- jsDefs defs
266 e <- toJS' e'
267 return $ parens (intercalate ", " ds ++ ", " ++ e)
268 where
269 jsDefs defs = mapM toJS (sortBy f defs)
270 f a b = compare (valueOf a) (valueOf b)
271 valueOf (FnDef _ args _) = min 1 (length args)
272 valueOf (OpDef _ _ _ _) = 1
274caseToJS span e ps = do
275 match <- caseToMatch ps
276 e' <- toJS' e
277 (match',stmt) <- case (match,e) of
278 (Match name _ _, C _ _ (Var x)) ->
279 return (matchSubst [(name,x)] match, Nothing)
280 (Match name _ _, _) ->
281 return (match, Just (name ++ " = " ++ e'))
282 _ -> return (match, Nothing)
283 matches <- matchToJS span match'
284 return $ case stmt of
285 Nothing -> matches
286 Just exp -> parens (exp ++ ", " ++ matches)
288matchToJS span match =
289 let sqnc e1 e2 = parens ("e = " ++ e1 ++ " : null, " ++ "e !== null ? e : " ++ e2)
290 in case match of
291 Match name clauses def ->
292 do cases <- intercalate " : " `liftM` mapM (clauseToJS span name) clauses
293 finally <- matchToJS span def
294 return (sqnc cases finally)
295 Fail -> return ("_caseError" ++ parens (quoted (show span)))
296 Break -> return "null"
297 Other e -> toJS' e
298 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
299 where dropEnd acc [] = acc
300 dropEnd acc (m:ms) =
301 case m of
302 Other _ -> acc ++ [m]
303 _ -> dropEnd (acc ++ [m]) ms
306clauseToJS span var (Clause name vars e) = do
307 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
308 s <- matchToJS span $ matchSubst (zip vars vars') e
309 return $ concat [ var, ".ctor === ", quoted name, " ? ", s ]
311jsNil = "{ctor:'Nil'}"
312jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"
313jsRange e1 e2 = "_range" ++ parens (e1 ++ "," ++ e2)
314jsCompare e1 e2 op = parens ("_compare(" ++ e1 ++ "," ++ e2 ++ ").ctor " ++ op)
316binop (o:p) e1 e2
317 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
318 | otherwise =
319 let ops = ["+","-","*","/","&&","||"] in
320 case o:p of
321 "::" -> jsCons e1 e2
322 "++" -> "_append" ++ parens (e1 ++ "," ++ e2)
323 "$" -> e1 ++ parens e2
324 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
325 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
326 "==" -> "_eq(" ++ e1 ++ "," ++ e2 ++ ")"
327 "/=" -> "!_eq(" ++ e1 ++ "," ++ e2 ++ ")"
328 "<" -> jsCompare e1 e2 "=== 'LT'"
329 ">" -> jsCompare e1 e2 "=== 'GT'"
330 "<=" -> jsCompare e1 e2 "!== 'GT'"
331 ">=" -> jsCompare e1 e2 "!== 'LT'"
332 "<~" -> "lift" ++ parens e1 ++ parens e2
333 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
334 parens e1 ++ parens e2
335 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
336 | otherwise -> concat [ "$op['", o:p, "']"
337 , parens e1, parens e2 ]