git.iko.soy/elk
on 35981eb help sign in
elk/compiler/Generate/JavaScript.hs
340 lines 13 kB history raw
1module Generate.JavaScript (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
10import Data.Maybe (maybeToList)
12import Unique
13import Generate.Cases
14import SourceSyntax.Everything hiding (parens)
15import Types.Types ( Type(RecordT) )
17showErr :: String -> String
18showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
19 where msg = show . concatMap (++"<br>") . lines $ err
20 body = "var T = Elm.Text(elm);\n\
21 \return { main : T.text(T.monospace(" ++ msg ++ ")) };"
23indent = concatMap f
24 where f '\n' = "\n "
25 f c = [c]
27internalImports =
28 [ ("N" , "Elm.Native"),
29 ("_N", "N.Utils(elm)"),
30 ("_L", "N.List(elm)"),
31 ("_E", "N.Error(elm)"),
32 ("_str", "N.JavaScript(elm).toString")
33 ]
35parens s = "(" ++ s ++ ")"
36brackets s = "{" ++ s ++ "}"
37jsObj = brackets . intercalate ", "
38jsList ss = "["++ intercalate "," ss ++"]"
39jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
40assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
41ret e = "\nreturn "++ e ++";"
42quoted s = "'" ++ concatMap f s ++ "'"
43 where f '\n' = "\\n"
44 f '\'' = "\\'"
45 f '\t' = "\\t"
46 f '\"' = "\\\""
47 f '\\' = "\\\\"
48 f c = [c]
50globalAssign n e = "\n" ++ assign' n e ++ ";"
51assign' n e = n ++ " = " ++ e
53jsModule (Module names exports imports stmts) =
54 setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
55 where
56 modNames = if null names then ["Main"] else names
57 modName = intercalate "." modNames
58 includes = concatMap jsImport imports
59 body = stmtsToJS stmts
60 defs = assign "$op" "{}"
61 program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
62 setup ("elm":"Native":modNames) ++
63 assign "_" ("elm.Native." ++ modName ++ "||{}") ++
64 getExports exports stmts ++ setup ("elm":modNames) ++
65 ret (assign' ("elm." ++ modName) "_") ++ "\n"
66 setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
67 map (intercalate ".") . drop 2 . inits $ init modNames
68 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
70getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
71 where exNames n = either derename id n `elem` names
72 exports | null names = concatMap get stmts
73 | otherwise = filter exNames (concatMap get stmts)
75 (fns,ops) = partitionEithers exports
77 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
78 fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
80 op = ("_.$op = "++) . jsObj $ map opPair ops
82 get' (FnDef x _ _) = Just (Left x)
83 get' (OpDef op _ _ _) = Just (Right op)
84 get' (TypeAnnotation _ _) = Nothing
85 get s = case s of Definition d -> maybeToList (get' d)
86 Datatype _ _ tcs -> map (Left . fst) tcs
87 ImportEvent _ _ x _ -> [ Left x ]
88 ExportEvent _ _ _ -> []
89 TypeAlias _ _ _ -> []
92jsImport (modul, how) =
93 case how of
94 As name -> assign name ("Elm." ++ modul ++ parens "elm")
95 Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
96 "; for(var k in _){if(k in hiding)continue;" ++
97 "eval('var '+k+'=_[\"'+k+'\"]')}"
98 Importing vs -> include ++ named
99 where
100 imprt v = assign' v ("_." ++ v)
101 def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
102 named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
103 where
104 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
105 setup moduleName = " var " ++ 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 :: [Declaration t v] -> String
120stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
121 return (concat program)
122 where
123 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
124 valueOf s = case s of
125 Datatype _ _ _ -> 1
126 ImportEvent _ _ _ _ -> 2
127 Definition (FnDef f [] _) ->
128 if derename f == "main" then 5 else 4
129 Definition (TypeAnnotation _ _) -> 0
130 Definition _ -> 3
131 ExportEvent _ _ _ -> 6
132 TypeAlias _ _ _ -> 0
134class ToJS a where
135 toJS :: a -> Unique String
137instance ToJS (Def t v) where
138 toJS (FnDef x [] e) = assign x `liftM` toJS' e
139 toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e
140 where
141 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)
148 toJS (TypeAnnotation _ _) = return ""
151instance ToJS (Declaration t v) where
152 toJS stmt =
153 case stmt of
154 Definition d -> toJS d
155 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
156 where toDef (name,args) =
157 let vars = map (('a':) . show) [1..length args] in
158 Definition . FnDef name vars . none $
159 Data (derename name) (map (none . Var) vars)
160 ImportEvent js base elm _ ->
161 do v <- toJS' base
162 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
163 , "\ndocument.addEventListener('", js
164 , "_' + elm.id, function(e) { elm.notify(", elm
165 , ".id, e.value); });" ]
166 ExportEvent js elm _ ->
167 return $ concat [ "\nlift(function(v) { "
168 , "var e = document.createEvent('Event');"
169 , "e.initEvent('", js, "_' + elm.id, true, true);"
170 , "e.value = v;"
171 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
172 TypeAlias n _ t -> return ""
174toJS' :: LExpr t v -> Unique String
175toJS' (L txt span expr) =
176 case expr of
177 MultiIf ps -> multiIfToJS span ps
178 Case e cases -> caseToJS span e cases
179 _ -> toJS expr
181remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
182addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
183setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
184 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
185access x e = e ++ "." ++ x
186makeRecord kvs = record `liftM` collect kvs
187 where
188 combine r (k,v) = Map.insertWith (++) k v r
189 collect = liftM (foldl' combine Map.empty) . mapM prep
190 prep (k, as, e@(L t s _)) =
191 do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)
192 return (k,[v])
193 fields fs =
194 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
195 hidden = fields . map (second jsList) .
196 filter (not . null . snd) . Map.toList . Map.map tail
197 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
200instance ToJS Literal where
201 toJS lit =
202 case lit of
203 Chr c -> return $ quoted [c]
204 Str s -> return $ "_str" ++ parens (quoted s)
205 IntNum n -> return $ show n
206 FloatNum n -> return $ show n
207 Boolean b -> return $ if b then "true" else "false"
210instance ToJS (Expr t v) where
211 toJS expr =
212 case expr of
213 Var x -> return x
214 Literal lit -> toJS lit
215 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
216 Access e x -> access x `liftM` toJS' e
217 Remove e x -> remove x `liftM` toJS' e
218 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
219 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
220 setField fs' `liftM` toJS' e
221 Record fs -> makeRecord fs
222 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
224 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
226 App e1 e2 -> jsApp e1 e2
227 Let defs e -> jsLet defs e
228 Data name es ->
229 do fs <- mapM toJS' es
230 return $ case name of
231 "Nil" -> jsNil
232 "Cons" -> jsCons (head fs) ((head . tail) fs)
233 _ -> jsObj $ ("ctor:" ++ show name) : fields
234 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
236 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
237 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
238 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
240jsApp e1 e2 =
241 do f <- toJS' func
242 as <- mapM toJS' args
243 return $ case as of
244 [a] -> f ++ parens a
245 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
246 where
247 (func, args) = go [e2] e1
248 go args e =
249 case e of
250 (L _ _ (App e1 e2)) -> go (e2 : args) e1
251 _ -> (e, args)
253formatMarkdown = concatMap f
254 where f '\'' = "\\'"
255 f '\n' = "\\n"
256 f '"' = "\""
257 f c = [c]
259multiIfToJS span ps =
260 case last ps of
261 (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
262 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
263 where
264 format base ps =
265 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
266 f (b,e) = do b' <- toJS' b
267 e' <- toJS' e
268 return (b' ++ " ? " ++ e')
270jsLet defs e' = do ds <- jsDefs defs
271 e <- toJS' e'
272 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
273 where
274 jsDefs defs = mapM toJS (sortBy f defs)
275 f a b = compare (valueOf a) (valueOf b)
276 valueOf (FnDef _ [] _) = 2
277 valueOf (FnDef _ _ _) = 1
278 valueOf (OpDef _ _ _ _) = 1
279 valueOf (TypeAnnotation _ _) = 0
281caseToJS span e ps = do
282 match <- caseToMatch ps
283 e' <- toJS' e
284 let (match',stmt) = case (match,e) of
285 (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
286 (Match name _ _, _) -> (match, assign name e')
287 _ -> (match, "")
288 matches <- matchToJS span match'
289 return $ "function(){ " ++ stmt ++ matches ++ " }()"
291matchToJS span match =
292 case match of
293 Match name clauses def ->
294 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
295 finally <- matchToJS span def
296 return $ concat [ "\nswitch (", name, ".ctor) {",
297 indent cases, "\n}", finally ]
298 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
299 Break -> return "break;"
300 Other e -> ret `liftM` toJS' e
301 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
302 where
303 dropEnd acc [] = acc
304 dropEnd acc (m:ms) =
305 case m of
306 Other _ -> acc ++ [m]
307 _ -> dropEnd (acc ++ [m]) ms
309clauseToJS span var (Clause name vars e) = do
310 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
311 s <- matchToJS span $ matchSubst (zip vars vars') e
312 return $ concat [ "\ncase ", quoted name, ":", indent s ]
314jsNil = "_L.Nil"
315jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
316jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
317jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
319binop (o:p) e1 e2
320 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
321 | otherwise =
322 let ops = ["+","-","*","/","&&","||"] in
323 case o:p of
324 "::" -> jsCons e1 e2
325 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
326 "<|" -> e1 ++ parens e2
327 "|>" -> e2 ++ parens e1
328 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
329 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
330 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
331 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
332 "<" -> jsCompare e1 e2 "==='LT'"
333 ">" -> jsCompare e1 e2 "==='GT'"
334 "<=" -> jsCompare e1 e2 "!=='GT'"
335 ">=" -> jsCompare e1 e2 "!=='LT'"
336 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
337 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
338 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
339 | otherwise -> concat [ "$op['", o:p, "']"
340 , parens e1, parens e2 ]