git.iko.soy/elk
on f70fdaa help sign in
elk/compiler/src/Gen/CompileToJS.hs
324 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 = 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 ++ ".main")))
45globalAssign n e = "\n" ++ assign' n e ++ ";"
46assign' n e = n ++ " = " ++ e
48jsModule (Module names exports imports stmts) =
49 setup ++ parens (jsFunc "" program ++ "()") ++ mainEquals modName
50 where
51 modNames = if null names then ["Elm", "Main"] else "Elm" : names
52 modName = intercalate "." modNames
53 includes = concatMap jsImport imports
54 body = stmtsToJS stmts
55 export = getExports exports stmts
56 exps = if null exports then ["main"] else exports
57 defs = assign "$op" "{}"
58 program = defs ++ includes ++ body ++ globalAssign modName export
59 setup = concatMap (\n -> globalAssign n $ n ++ " || {}") .
60 map (intercalate ".") . drop 2 . inits $
61 take (length modNames - 1) modNames
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 ("Elm.Error.If" ++ parens (quoted (show span))) ps
242 where
243 format base ps =
244 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
245 f (b,e) = do b' <- toJS' b
246 e' <- toJS' e
247 return (b' ++ " ? " ++ e')
249jsLet defs e' = do ds <- jsDefs defs
250 e <- toJS' e'
251 return $ parens (intercalate ", " ds ++ ", " ++ e)
252 where
253 jsDefs defs = mapM toJS (sortBy f defs)
254 f a b = compare (valueOf a) (valueOf b)
255 valueOf (FnDef _ args _) = min 1 (length args)
256 valueOf (OpDef _ _ _ _) = 1
258caseToJS span e ps = do
259 match <- caseToMatch ps
260 e' <- toJS' e
261 (match',stmt) <- case (match,e) of
262 (Match name _ _, C _ _ (Var x)) ->
263 return (matchSubst [(name,x)] match, Nothing)
264 (Match name _ _, _) ->
265 return (match, Just (name ++ " = " ++ e'))
266 _ -> return (match, Nothing) -- Just e'
267 matches <- matchToJS span match'
268 return $ case stmt of
269 Nothing -> matches
270 Just exp -> parens (exp ++ ", " ++ matches)
272matchToJS span match =
273 let sqnc e1 e2 = parens ("e = " ++ e1 ++ " : null, " ++ "e !== null ? e : " ++ e2)
274 in case match of
275 Match name clauses def ->
276 do cases <- intercalate " : " `liftM` mapM (clauseToJS span name) clauses
277 finally <- matchToJS span def
278 return (sqnc cases finally)
279 Fail -> return ("Elm.Error.Case" ++ parens (quoted (show span)))
280 Break -> return "null"
281 Other e -> toJS' e
282 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
283 where dropEnd acc [] = acc
284 dropEnd acc (m:ms) =
285 case m of
286 Other _ -> acc ++ [m]
287 _ -> dropEnd (acc ++ [m]) ms
290clauseToJS span var (Clause name vars e) = do
291 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
292 s <- matchToJS span $ matchSubst (zip vars vars') e
293 return $ concat [ var, ".ctor === ", quoted name, " ? ", s ]
295jsNil = "{ctor:'Nil'}"
296jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"
297jsRange e1 e2 = "Elm.Native.List.range" ++ parens (e1 ++ "," ++ e2)
299binop (o:p) e1 e2
300 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
301 | otherwise =
302 let ops = ["+","-","*","/","&&","||"] in
303 case o:p of
304 "::" -> jsCons e1 e2
305 "++" -> append e1 e2
306 "$" -> e1 ++ parens e2
307 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
308 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
309 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
310 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
311 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ").ctor === 'LT')"
312 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ").ctor === 'GT')"
313 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
314 e2 ++ ").ctor; return ord==='LT' || ord==='EQ'; }()"
315 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
316 e2 ++ ").ctor; return ord==='GT' || ord==='EQ'; }()"
317 "<~" -> "lift" ++ parens e1 ++ parens e2
318 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
319 parens e1 ++ parens e2
320 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
321 | otherwise -> concat [ "$op['", o:p, "']"
322 , parens e1, parens e2 ]
324append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)