git.iko.soy/elk
on 56ecbbc help sign in
elk/compiler/Generate/JavaScript.hs
420 lines 16 kB history raw
1module Generate.JavaScript where
3import Control.Arrow (first,(***))
4import Control.Applicative ((<$>),(<*>))
5import Control.Monad.State
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Set as Set
9import qualified Text.Pandoc as Pan
11import qualified Generate.Cases as Case
12import SourceSyntax.Everything
13import SourceSyntax.Location
14import qualified Transform.SortDefinitions as SD
15import Language.ECMAScript3.Syntax
16import Language.ECMAScript3.PrettyPrint
17import Parse.Helpers (jsReserveds)
19makeSafe :: String -> String
20makeSafe = List.intercalate "." . map dereserve . split . deprime
21 where
22 deprime = map (\c -> if c == '\'' then '$' else c)
23 dereserve x = case Set.member x jsReserveds of
24 False -> x
25 True -> "$" ++ x
27split = go []
28 where
29 go vars str =
30 case break (=='.') str of
31 (x,'.':rest) | isOp x -> vars ++ [x ++ '.' : rest]
32 | otherwise -> go (vars ++ [x]) rest
33 (x,[]) -> vars ++ [x]
35var name = Id () (makeSafe name)
36ref name = VarRef () (var name)
37prop name = PropId () (var name)
38f <| x = CallExpr () f [x]
39args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
40function args stmts = FuncExpr () Nothing (map var args) stmts
41call = CallExpr ()
42string = StringLit ()
44dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
45obj = dotSep . split
47varDecl x expr =
48 VarDecl () (var x) (Just expr)
50include alias moduleName =
51 varDecl alias (obj (moduleName ++ ".make") <| ref "elm")
53internalImports name =
54 VarDeclStmt ()
55 [ varDecl "N" (obj "Elm.Native")
56 , include "_N" "N.Utils"
57 , include "_L" "N.List"
58 , include "_E" "N.Error"
59 , include "_J" "N.JavaScript"
60 , varDecl "$moduleName" (string name)
61 ]
63literal lit =
64 case lit of
65 Chr c -> obj "_N.chr" <| string [c]
66 Str s -> string s
67 IntNum n -> IntLit () n
68 FloatNum n -> NumLit () n
69 Boolean b -> BoolLit () b
71expression :: LExpr () () -> State Int (Expression ())
72expression (L span expr) =
73 case expr of
74 Var x -> return $ ref x
75 Literal lit -> return $ literal lit
77 Range lo hi ->
78 do lo' <- expression lo
79 hi' <- expression hi
80 return $ obj "_L.range" `call` [lo',hi']
82 Access e x ->
83 do e' <- expression e
84 return $ DotRef () e' (var x)
86 Remove e x ->
87 do e' <- expression e
88 return $ obj "_N.remove" `call` [string x, e']
90 Insert e x v ->
91 do v' <- expression v
92 e' <- expression e
93 return $ obj "_N.insert" `call` [string x, v', e']
95 Modify e fs ->
96 do e' <- expression e
97 fs' <- forM fs $ \(f,v) -> do
98 v' <- expression v
99 return $ ArrayLit () [string f, v']
100 return $ obj "_N.replace" `call` [ArrayLit () fs', e']
102 Record fields ->
103 do fields' <- forM fields $ \(f,e) -> do
104 (,) f <$> expression e
105 let fieldMap = List.foldl' combine Map.empty fields'
106 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
107 where
108 combine r (k,v) = Map.insertWith (++) k [v] r
109 prop = PropId () . var
110 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
111 Map.toList . Map.filter (not . null) $ Map.map tail fs
112 visible fs = map (first prop) . Map.toList $ Map.map head fs
114 Binop op e1 e2 -> binop span op e1 e2
116 Lambda p e@(L s _) ->
117 do body' <- expression body
118 return $ case length args < 2 || length args > 9 of
119 True -> foldr (==>) body' (map (:[]) args)
120 False -> ref ("F" ++ show (length args)) <| (args ==> body')
121 where
122 (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
124 depattern (pattern,n) (args, body) =
125 case pattern of
126 PVar x -> (args ++ [x], body)
127 _ -> let arg = "arg" ++ show n
128 in (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
130 (patterns, innerBody) = collect [p] e
132 collect patterns lexpr@(L _ expr) =
133 case expr of
134 Lambda p e -> collect (p:patterns) e
135 _ -> (patterns, lexpr)
137 App e1 e2 ->
138 do func' <- expression func
139 args' <- mapM expression args
140 return $ case args' of
141 [arg] -> func' <| arg
142 _ | length args' <= 9 -> ref aN `call` (func':args')
143 | otherwise -> foldl1 (<|) (func':args')
144 where
145 aN = "A" ++ show (length args)
146 (func, args) = getArgs e1 [e2]
147 getArgs func args =
148 case func of
149 (L _ (App f arg)) -> getArgs f (arg : args)
150 _ -> (func, args)
152 Let defs e ->
153 do let (defs',e') = SD.flattenLets defs e
154 stmts <- concat <$> mapM definition defs'
155 exp <- expression e'
156 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
158 MultiIf branches ->
159 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
160 return $ case last branches of
161 (L _ (Var "Basics.otherwise"), e) -> ifs (init branches') (snd (last branches'))
162 _ -> ifs branches'
163 (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
164 where
165 ifs branches finally = foldr iff finally branches
166 iff (if', then') else' = CondExpr () if' then' else'
168 Case e cases ->
169 do (tempVar,initialMatch) <- Case.toMatch cases
170 (revisedMatch, stmt) <-
171 case e of
172 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
173 _ -> do e' <- expression e
174 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
175 match' <- match span revisedMatch
176 return (function [] (stmt ++ match') `call` [])
178 ExplicitList es ->
179 do es' <- mapM expression es
180 return $ obj "_J.toList" <| ArrayLit () es'
182 Data name es ->
183 do es' <- mapM expression es
184 return $ ObjectLit () (ctor : fields es')
185 where
186 ctor = (prop "ctor", string (makeSafe name))
187 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
189 Markdown uid doc es ->
190 do es' <- mapM expression es
191 return $ obj "Text.markdown" `call` (string md : string uid : es')
192 where
193 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
194 md = pad ++ Pan.writeHtmlString Pan.def doc ++ pad
196definition :: Def () () -> State Int [Statement ()]
197definition def =
198 case def of
199 TypeAnnotation _ _ -> return []
201 Def pattern expr@(L span _) -> do
202 expr' <- expression expr
203 let assign x = varDecl x expr'
204 case pattern of
205 PVar x
206 | isOp x ->
207 let op = LBracket () (ref "_op") (string x) in
208 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
209 | otherwise ->
210 return [ VarDeclStmt () [ assign x ] ]
212 PRecord fields ->
213 let setField f = varDecl f (dotSep ["$",f]) in
214 return [ VarDeclStmt () (assign "$" : map setField fields) ]
216 PData name patterns | vars /= Nothing ->
217 case vars of
218 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
219 where
220 vars = getVars patterns
221 getVars patterns =
222 case patterns of
223 PVar x : rest -> (x:) `fmap` getVars rest
224 [] -> Just []
225 _ -> Nothing
227 decl x n = varDecl x (dotSep ["$","_" ++ show n])
228 setup vars
229 | isTuple name = assign "$" : vars
230 | otherwise = safeAssign : vars
232 safeAssign = varDecl "$" (CondExpr () if' expr' exception)
233 if' = InfixExpr () OpStrictEq (obj "$.ctor") (string name)
234 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
236 _ ->
237 do defs' <- concat <$> mapM toDef vars
238 return (VarDeclStmt () [assign "$"] : defs')
239 where
240 vars = Set.toList $ SD.boundVars pattern
241 mkVar = L span . Var
242 toDef y = definition $
243 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
245match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
246match span mtch =
247 case mtch of
248 Case.Match name clauses mtch' ->
249 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
250 mtch'' <- match span mtch'
251 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
252 where
253 isLiteral p = case p of
254 Case.Clause (Right _) _ _ -> True
255 _ -> False
256 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
257 format isChars e
258 | or isChars = InfixExpr () OpAdd e (string "")
259 | otherwise = e
261 Case.Fail ->
262 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
264 Case.Break -> return [BreakStmt () Nothing]
265 Case.Other e ->
266 do e' <- expression e
267 return [ ReturnStmt () (Just e') ]
268 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
269 where
270 dropEnd acc [] = acc
271 dropEnd acc (m:ms) =
272 case m of
273 Case.Other _ -> acc ++ [m]
274 _ -> dropEnd (acc ++ [m]) ms
276clause span variable (Case.Clause value vars mtch) =
277 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
278 where
279 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
280 (isChar, pattern) =
281 case value of
282 Right (Chr c) -> (True, string [c])
283 _ -> (,) False $ case value of
284 Right (Boolean b) -> BoolLit () b
285 Right lit -> literal lit
286 Left name -> string $ case List.elemIndices '.' name of
287 [] -> name
288 is -> drop (last is + 1) name
291jsModule :: MetadataModule () () -> String
292jsModule modul =
293 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
294 [ assign ("Elm" : names modul ++ ["make"]) (function ["elm"] programStmts) ]
295 where
296 thisModule = dotSep ("elm" : names modul ++ ["values"])
297 programStmts =
298 concat [ setup (Just "elm") (names modul ++ ["values"])
299 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
300 , [ internalImports (List.intercalate "." (names modul)) ]
301 , concatMap jsImport (imports modul)
302 , concatMap importEvent (foreignImports modul)
303 , [ assign ["_op"] (ObjectLit () []) ]
304 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
305 , map exportEvent $ foreignExports modul
306 , [ jsExports ]
307 , [ ReturnStmt () (Just thisModule) ]
308 ]
310 jsExports = assign ("elm" : names modul ++ ["values"]) (ObjectLit () exs)
311 where
312 exs = map entry . filter (not . isOp) $ "_op" : exports modul
313 entry x = (PropId () (var x), ref x)
315 assign path expr =
316 case path of
317 [x] -> VarDeclStmt () [ varDecl x expr ]
318 _ -> ExprStmt () $
319 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
321 jsImport (modul,_) = setup Nothing path ++ [ include ]
322 where
323 path = split modul
324 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "elm"
326 setup namespace path = map create paths
327 where
328 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
329 paths = case namespace of
330 Nothing -> tail . init $ List.inits path
331 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
333 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
335 importEvent (js,base,elm,_) =
336 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
337 , ExprStmt () $
338 obj "document.addEventListener" `call`
339 [ addId js
340 , function ["e"]
341 [ ExprStmt () $ obj "elm.notify" `call` [dotSep [elm,"id"], obj "e.value"] ]
342 ]
343 ]
345 exportEvent (js,elm,_) =
346 ExprStmt () $
347 ref "A2" `call`
348 [ obj "Signal.lift"
349 , function ["v"]
350 [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
351 , ExprStmt () $
352 obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
353 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
354 , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
355 , ReturnStmt () (Just $ ref "v")
356 ]
357 , ref elm ]
359binop span op e1 e2 =
360 case op of
361 "Basics.." ->
362 do es <- mapM expression (e1 : collect [] e2)
363 return $ ["$"] ==> foldr (<|) (ref "$") es
364 "Basics.<|" ->
365 do e2' <- expression e2
366 es <- mapM expression (collect [] e1)
367 return $ foldr (<|) e2' es
368 "List.++" ->
369 do e1' <- expression e1
370 e2' <- expression e2
371 return $ obj "_L.append" `call` [e1', e2']
372 "::" -> expression (L span (Data "::" [e1,e2]))
373 _ ->
374 do e1' <- expression e1
375 e2' <- expression e2
376 return $ case Map.lookup op opDict of
377 Just f -> f e1' e2'
378 Nothing -> ref "A2" `call` [ func, e1', e2' ]
379 where
380 collect es e =
381 case e of
382 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
383 _ -> es ++ [e]
385 js1 = expression e1
386 js2 = expression e2
388 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
389 | otherwise = dotSep parts
390 where
391 parts = split op
392 operator = last parts
394 opDict = Map.fromList (infixOps ++ specialOps)
396 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
397 infixOp str op = specialOp str (InfixExpr () op)
399 infixOps = concat
400 [ infixOp "+" OpAdd
401 , infixOp "-" OpSub
402 , infixOp "*" OpMul
403 , infixOp "/" OpDiv
404 , infixOp "&&" OpLAnd
405 , infixOp "||" OpLOr
406 ]
408 specialOps = concat
409 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
410 , specialOp "|>" $ flip (<|)
411 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
412 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
413 , specialOp "<" $ cmp OpLT 0
414 , specialOp ">" $ cmp OpGT 0
415 , specialOp "<=" $ cmp OpLT 1
416 , specialOp ">=" $ cmp OpGT (-1)
417 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
418 ]
420 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)