git.iko.soy/elk
on c136ea7 help sign in
elk/elm/src/Gen/CompileToJS.hs
327 lines 13 kB history raw
1 module 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 = mainEquals $ "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]
29parens s = "(" ++ s ++ ")"
30brackets s = "{" ++ s ++ "}"
31jsList ss = "["++ intercalate "," ss ++"]"
32jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
33assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
34ret e = "\nreturn "++ e ++";"
35iff a b c = a ++ "?" ++ b ++ ":" ++ c
36quoted s = "'" ++ concatMap f s ++ "'"
37 where f '\n' = "\\n"
38 f '\'' = "\\'"
39 f '\t' = "\\t"
40 f '\"' = "\\\""
41 f '\\' = "\\\\"
42 f c = [c]
44mainEquals s = globalAssign "Elm.main" (jsFunc "" (ret s))
45globalAssign n e = "\n" ++ assign' n e ++ ";"
46assign' n e = n ++ " = " ++ e
48jsModule (Module names exports imports stmts) =
49 concat [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
50 map (intercalate ".") . drop 2 . inits $
51 take (length modNames - 1) modNames
52 , parens (jsFunc "" (defs ++ includes ++ body ++ globalAssign modName export) ++ "()")
53 , mainEquals $ modName ++ ".main" ]
54 where modNames = if null names then ["Elm", "Main"]
55 else "Elm" : names
56 modName = intercalate "." modNames
57 includes = concatMap jsImport imports
58 body = stmtsToJS stmts
59 export = getExports exports stmts
60 exps = if null exports then ["main"] else exports
61 defs = assign "$op" "{}"
63getExports names stmts = brackets . ("\n "++) $
64 intercalate ",\n " (op : map fnPair fns)
65 where exNames n = either derename id n `elem` names
66 exports | null names = concatMap get stmts
67 | otherwise = filter exNames (concatMap get stmts)
69 (fns,ops) = partitionEithers exports
71 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
72 fnPair fn = let fn' = derename fn in fn' ++ ":" ++ fn
74 op = ("$op : "++) . brackets . intercalate ", " $ map opPair ops
76 get' (FnDef x _ _) = Left x
77 get' (OpDef op _ _ _) = Right op
78 get s = case s of Definition d -> [ get' d ]
79 Datatype _ _ tcs -> map (Left . fst) tcs
80 ImportEvent _ _ x _ -> [ Left x ]
81 ExportEvent _ _ _ -> []
82 TypeAlias _ _ _ -> []
83 TypeAnnotation _ _ -> []
86jsImport (modul, how) =
87 case how of
88 As name -> assign name ("Elm." ++ modul)
89 Importing vs ->
90 assign modul ("Elm." ++ modul) ++ concatMap def vs
91 where
92 imprt asgn v = asgn v ("Elm." ++ modul ++ "." ++ v)
93 def (o:p) =
94 if isOp o then imprt globalAssign ("$op['" ++ o:p ++ "']")
95 else imprt assign (deprime (o:p))
98stmtsToJS :: [Statement] -> String
99stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
100 return (vars ++ concat program)
101 where
102 vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"
103 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
104 valueOf s = case s of
105 Datatype _ _ _ -> 1
106 ImportEvent _ _ _ _ -> 2
107 Definition (FnDef f [] _) ->
108 if derename f == "main" then 5 else 4
109 Definition _ -> 3
110 ExportEvent _ _ _ -> 6
111 TypeAlias _ _ _ -> 0
112 TypeAnnotation _ _ -> 0
114class ToJS a where
115 toJS :: a -> GuidCounter String
117instance ToJS Def where
118 toJS (FnDef x [] e) = assign' x `liftM` toJS' e
119 toJS (FnDef f as e) = (assign' f . wrapper . func) `liftM` toJS' e
120 where func body = jsFunc (intercalate ", " as) (ret body)
121 wrapper e | length as == 1 = e
122 | otherwise = 'F' : show (length as) ++ parens e
123 toJS (OpDef op a1 a2 e) =
124 do body <- toJS' e
125 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
126 return (globalAssign ("$op['" ++ op ++ "']") func)
128instance ToJS Statement where
129 toJS stmt =
130 case stmt of
131 Definition d -> (\asgn -> "\n" ++ asgn ++ ";") `liftM` toJS d
132 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
133 where toDef (name,args) =
134 let vars = map (('a':) . show) [1..length args] in
135 Definition . FnDef name vars . noContext $
136 Data (derename name) (map (noContext . Var) vars)
137 ImportEvent js base elm _ ->
138 do v <- toJS' base
139 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
140 , "\nValue.addListener(document, '" ++ js
141 , "', function(e) { Dispatcher.notify(" ++ elm
142 , ".id, e.value); });" ]
143 ExportEvent js elm _ ->
144 return $ concat [ "\nlift(function(v) { "
145 , "var e = document.createEvent('Event');"
146 , "e.initEvent('", js, "', true, true);"
147 , "e.value = v;"
148 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
149 TypeAnnotation _ _ -> return ""
150 TypeAlias n _ t ->
151 case t of
152 RecordT kvs _ -> return $ "\nfunction" ++ args ++ brackets body
153 where fs = Map.keys kvs
154 args = parens (intercalate "," fs)
155 body = ret . brackets . intercalate "," $
156 map (\k -> k ++ ":" ++ k) fs
157 _ -> return ""
159toJS' :: CExpr -> GuidCounter String
160toJS' (C txt span expr) =
161 case expr of
162 MultiIf ps -> multiIfToJS span ps
163 Case e cases -> caseToJS span e cases
164 _ -> toJS expr
166remove x e = "elmRecordRemove('" ++ x ++ "', " ++ e ++ ")"
167addField x v e = "elmRecordInsert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
168setField fs e = "elmRecordReplace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
169 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
170access x e = parens e ++ "." ++ x
171makeRecord kvs = record `liftM` collect kvs
172 where
173 combine r (k,v) = Map.insertWith (++) k v r
174 collect = liftM (foldl' combine Map.empty) . mapM prep
175 prep (k, as, e@(C t s _)) =
176 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
177 return (k,[v])
178 fields fs =
179 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
180 hidden = fields . map (second jsList) .
181 filter (not . null . snd) . Map.toList . Map.map tail
182 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
185instance ToJS Expr where
186 toJS expr =
187 case expr of
188 IntNum n -> return $ show n ++ "|0"
189 FloatNum n -> return $ show n
190 Var x -> return $ x
191 Chr c -> return $ quoted [c]
192 Str s -> return $ "Value.str" ++ parens (quoted s)
193 Boolean b -> return $ if b then "true" else "false"
194 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
195 Access e x -> access x `liftM` toJS' e
196 Remove e x -> remove x `liftM` toJS' e
197 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
198 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
199 setField fs' `liftM` toJS' e
200 Record fs -> makeRecord fs
201 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
203 If eb et ef ->
204 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
206 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
208 App e1 e2 -> jsApp e1 e2
209 Let defs e -> jsLet defs e
210 Data name es ->
211 do fs <- mapM toJS' es
212 let fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
213 return (brackets ("ctor:" ++ show name ++ concatMap (", "++) fields))
215 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
216 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
217 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
219jsApp e1 e2 =
220 do f <- toJS' func
221 as <- mapM toJS' args
222 return $ case as of
223 [a] -> f ++ parens a
224 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
225 where
226 (func, args) = go [e2] e1
227 go args e =
228 case e of
229 (C _ _ (App e1 e2)) -> go (e2 : args) e1
230 _ -> (e, args)
232formatMarkdown = concatMap f
233 where f '\'' = "\\'"
234 f '\n' = "\\n"
235 f '"' = "\""
236 f c = [c]
238multiIfToJS span ps =
239 case last ps of
240 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
241 _ -> format err ps
242 where
243 format base ps =
244 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
245 err = "throw new Error('Non-exhaustive multi-way-if expression (" ++
246 show span ++ ")')"
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) -- Just e'
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 ("throw new Error(\"Non-exhaustive pattern match " ++
282 "in case expression (" ++ 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 = "{ctor:'Nil'}"
299jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"
300jsRange e1 e2 = "Elm.Native.List.range" ++ parens (e1 ++ "," ++ e2)
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 "++" -> append e1 e2
309 "$" -> e1 ++ parens e2
310 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
311 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
312 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
313 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
314 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ").ctor === 'LT')"
315 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ").ctor === 'GT')"
316 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
317 e2 ++ ").ctor; return ord==='LT' || ord==='EQ'; }()"
318 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
319 e2 ++ ").ctor; return ord==='GT' || ord==='EQ'; }()"
320 "<~" -> "lift" ++ parens e1 ++ parens e2
321 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
322 parens e1 ++ parens e2
323 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
324 | otherwise -> concat [ "$op['", o:p, "']"
325 , parens e1, parens e2 ]
327append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)