git.iko.soy/elk
on edd4fbb help sign in
elk/compiler/Generate/JavaScript.hs
404 lines 15 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript (generate) where
4import Control.Arrow (first,(***))
5import Control.Applicative ((<$>),(<*>))
6import Control.Monad.State
7import qualified Data.List as List
8import qualified Data.Map as Map
9import qualified Data.Set as Set
11import qualified Generate.Cases as Case
12import qualified Generate.Markdown as MD
13import qualified SourceSyntax.Helpers as Help
14import SourceSyntax.Literal
15import SourceSyntax.Pattern as Pattern
16import SourceSyntax.Location
17import SourceSyntax.Expression
18import SourceSyntax.Module
19import Language.ECMAScript3.Syntax
20import Language.ECMAScript3.PrettyPrint
21import qualified Transform.SafeNames as MakeSafe
23split :: String -> [String]
24split = go []
25 where
26 go vars str =
27 case break (=='.') str of
28 (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
29 | otherwise -> go (vars ++ [x]) rest
30 (x,[]) -> vars ++ [x]
32var name = Id () name
33ref name = VarRef () (var name)
34prop name = PropId () (var name)
35f <| x = CallExpr () f [x]
36args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
37function args stmts = FuncExpr () Nothing (map var args) stmts
38call = CallExpr ()
39string = StringLit ()
41dotSep vars =
42 case vars of
43 x:xs -> foldl (DotRef ()) (ref x) (map var xs)
44 [] -> error "dotSep must be called on a non-empty list of variables"
46obj = dotSep . split
48varDecl :: String -> Expression () -> VarDecl ()
49varDecl x expr =
50 VarDecl () (var x) (Just expr)
52include alias moduleName =
53 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
55internalImports name =
56 VarDeclStmt ()
57 [ varDecl "_N" (obj "Elm.Native")
58 , include "_U" "_N.Utils"
59 , include "_L" "_N.List"
60 , include "_E" "_N.Error"
61 , include "_J" "_N.JavaScript"
62 , varDecl "$moduleName" (string name)
63 ]
65literal :: Literal -> Expression ()
66literal lit =
67 case lit of
68 Chr c -> obj "_U.chr" <| string [c]
69 Str s -> string s
70 IntNum n -> IntLit () n
71 FloatNum n -> NumLit () n
72 Boolean b -> BoolLit () b
74expression :: LExpr -> State Int (Expression ())
75expression (L span expr) =
76 case expr of
77 Var x -> return $ ref x
78 Literal lit -> return $ literal lit
80 Range lo hi ->
81 do lo' <- expression lo
82 hi' <- expression hi
83 return $ obj "_L.range" `call` [lo',hi']
85 Access e x ->
86 do e' <- expression e
87 return $ DotRef () e' (var x)
89 Remove e x ->
90 do e' <- expression e
91 return $ obj "_U.remove" `call` [string x, e']
93 Insert e x v ->
94 do v' <- expression v
95 e' <- expression e
96 return $ obj "_U.insert" `call` [string x, v', e']
98 Modify e fs ->
99 do e' <- expression e
100 fs' <- forM fs $ \(f,v) -> do
101 v' <- expression v
102 return $ ArrayLit () [string f, v']
103 return $ obj "_U.replace" `call` [ArrayLit () fs', e']
105 Record fields ->
106 do fields' <- forM fields $ \(f,e) -> do
107 (,) f <$> expression e
108 let fieldMap = List.foldl' combine Map.empty fields'
109 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
110 where
111 combine r (k,v) = Map.insertWith (++) k [v] r
112 prop = PropId () . var
113 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
114 Map.toList . Map.filter (not . null) $ Map.map tail fs
115 visible fs = map (first prop) . Map.toList $ Map.map head fs
117 Binop op e1 e2 -> binop span op e1 e2
119 Lambda p e@(L s _) ->
120 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
121 body' <- expression body
122 return $ case length args < 2 || length args > 9 of
123 True -> foldr (==>) body' (map (:[]) args)
124 False -> ref ("F" ++ show (length args)) <| (args ==> body')
125 where
126 depattern (args, body) pattern =
127 case pattern of
128 PVar x -> return (args ++ [x], body)
129 _ -> do arg <- Case.newVar
130 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
132 (patterns, innerBody) = collect [p] e
134 collect patterns lexpr@(L _ expr) =
135 case expr of
136 Lambda p e -> collect (p:patterns) e
137 _ -> (patterns, lexpr)
139 App e1 e2 ->
140 do func' <- expression func
141 args' <- mapM expression args
142 return $ case args' of
143 [arg] -> func' <| arg
144 _ | length args' <= 9 -> ref aN `call` (func':args')
145 | otherwise -> foldl1 (<|) (func':args')
146 where
147 aN = "A" ++ show (length args)
148 (func, args) = getArgs e1 [e2]
149 getArgs func args =
150 case func of
151 (L _ (App f arg)) -> getArgs f (arg : args)
152 _ -> (func, args)
154 Let defs e ->
155 do let (defs',e') = flattenLets defs e
156 stmts <- concat <$> mapM definition defs'
157 exp <- expression e'
158 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
160 MultiIf branches ->
161 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
162 return $ case last branches of
163 (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
164 (L _ (Literal (Boolean True)), _) -> safeIfs branches'
165 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
166 where
167 safeIfs branches = ifs (init branches) (snd (last branches))
168 ifs branches finally = foldr iff finally branches
169 iff (if', then') else' = CondExpr () if' then' else'
171 Case e cases ->
172 do (tempVar,initialMatch) <- Case.toMatch cases
173 (revisedMatch, stmt) <-
174 case e of
175 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
176 _ -> do e' <- expression e
177 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
178 match' <- match span revisedMatch
179 return (function [] (stmt ++ match') `call` [])
181 ExplicitList es ->
182 do es' <- mapM expression es
183 return $ obj "_J.toList" <| ArrayLit () es'
185 Data name es ->
186 do es' <- mapM expression es
187 return $ ObjectLit () (ctor : fields es')
188 where
189 ctor = (prop "ctor", string name)
190 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
192 Markdown uid doc es ->
193 do es' <- mapM expression es
194 return $ obj "Text.markdown" `call` (string md : string uid : es')
195 where
196 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
197 md = pad ++ MD.toHtml doc ++ pad
199 GLShader _uid src _tipe ->
200 return . literal $ Str src
202 PortIn name _ _ handler ->
203 do handler' <- expression handler
204 return $ obj "Native.Ports.portIn" `call` [ string name, handler' ]
206 PortOut name _ signal ->
207 do signal' <- expression signal
208 return $ obj "Native.Ports.portOut" `call` [ string name, signal' ]
210definition :: Def -> State Int [Statement ()]
211definition (Definition pattern expr@(L span _) _) = do
212 expr' <- expression expr
213 let assign x = varDecl x expr'
214 case pattern of
215 PVar x
216 | Help.isOp x ->
217 let op = LBracket () (ref "_op") (string x) in
218 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
219 | otherwise ->
220 return [ VarDeclStmt () [ assign x ] ]
222 PRecord fields ->
223 let setField f = varDecl f (dotSep ["$",f]) in
224 return [ VarDeclStmt () (assign "$" : map setField fields) ]
226 PData name patterns | vars /= Nothing ->
227 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
228 where
229 vars = getVars patterns
230 getVars patterns =
231 case patterns of
232 PVar x : rest -> (x:) `fmap` getVars rest
233 [] -> Just []
234 _ -> Nothing
236 decl x n = varDecl x (dotSep ["$","_" ++ show n])
237 setup vars
238 | Help.isTuple name = assign "$" : vars
239 | otherwise = assign "$raw" : safeAssign : vars
241 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
242 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
243 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
245 _ ->
246 do defs' <- concat <$> mapM toDef vars
247 return (VarDeclStmt () [assign "$"] : defs')
248 where
249 vars = Set.toList $ Pattern.boundVars pattern
250 mkVar = L span . Var
251 toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
252 in definition $ Definition (PVar y) expr Nothing
254match :: (Show a) => a -> Case.Match -> State Int [Statement ()]
255match span mtch =
256 case mtch of
257 Case.Match name clauses mtch' ->
258 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
259 mtch'' <- match span mtch'
260 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
261 where
262 isLiteral p = case p of
263 Case.Clause (Right _) _ _ -> True
264 _ -> False
265 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
266 format isChars e
267 | or isChars = InfixExpr () OpAdd e (string "")
268 | otherwise = e
270 Case.Fail ->
271 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
273 Case.Break -> return [BreakStmt () Nothing]
274 Case.Other e ->
275 do e' <- expression e
276 return [ ReturnStmt () (Just e') ]
277 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
278 where
279 dropEnd acc [] = acc
280 dropEnd acc (m:ms) =
281 case m of
282 Case.Other _ -> acc ++ [m]
283 _ -> dropEnd (acc ++ [m]) ms
285clause span variable (Case.Clause value vars mtch) =
286 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
287 where
288 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
289 (isChar, pattern) =
290 case value of
291 Right (Chr c) -> (True, string [c])
292 _ -> (,) False $ case value of
293 Right (Boolean b) -> BoolLit () b
294 Right lit -> literal lit
295 Left name -> string $ case List.elemIndices '.' name of
296 [] -> name
297 is -> drop (last is + 1) name
299flattenLets defs lexpr@(L _ expr) =
300 case expr of
301 Let ds body -> flattenLets (defs ++ ds) body
302 _ -> (defs, lexpr)
304generate :: MetadataModule -> String
305generate unsafeModule =
306 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
307 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
308 where
309 modul = MakeSafe.metadataModule unsafeModule
310 thisModule = dotSep ("_elm" : names modul ++ ["values"])
311 programStmts =
312 concat
313 [ setup (Just "_elm") (names modul ++ ["values"])
314 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
315 , [ internalImports (List.intercalate "." (names modul)) ]
316 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
317 , [ assign ["_op"] (ObjectLit () []) ]
318 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
319 , [ jsExports ]
320 , [ ReturnStmt () (Just thisModule) ]
321 ]
323 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
324 where
325 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
326 entry x = (PropId () (var x), ref x)
328 assign path expr =
329 case path of
330 [x] -> VarDeclStmt () [ varDecl x expr ]
331 _ -> ExprStmt () $
332 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
334 jsImport modul = setup Nothing path ++ [ include ]
335 where
336 path = split modul
337 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
339 setup namespace path = map create paths
340 where
341 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
342 paths = case namespace of
343 Nothing -> tail . init $ List.inits path
344 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
346binop span op e1 e2 =
347 case op of
348 "Basics.." ->
349 do es <- mapM expression (e1 : collect [] e2)
350 return $ ["$"] ==> foldr (<|) (ref "$") es
351 "Basics.<|" ->
352 do e2' <- expression e2
353 es <- mapM expression (collect [] e1)
354 return $ foldr (<|) e2' es
355 "List.++" ->
356 do e1' <- expression e1
357 e2' <- expression e2
358 return $ obj "_L.append" `call` [e1', e2']
359 "::" -> expression (L span (Data "::" [e1,e2]))
360 _ ->
361 do e1' <- expression e1
362 e2' <- expression e2
363 return $ case Map.lookup op opDict of
364 Just f -> f e1' e2'
365 Nothing -> ref "A2" `call` [ func, e1', e2' ]
366 where
367 collect es e =
368 case e of
369 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
370 _ -> es ++ [e]
372 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
373 | otherwise = dotSep parts
374 where
375 parts = split op
376 operator = last parts
378 opDict = Map.fromList (infixOps ++ specialOps)
380 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
381 infixOp str op = specialOp str (InfixExpr () op)
383 infixOps = concat
384 [ infixOp "+" OpAdd
385 , infixOp "-" OpSub
386 , infixOp "*" OpMul
387 , infixOp "/" OpDiv
388 , infixOp "&&" OpLAnd
389 , infixOp "||" OpLOr
390 ]
392 specialOps = concat
393 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
394 , specialOp "|>" $ flip (<|)
395 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
396 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
397 , specialOp "<" $ cmp OpLT 0
398 , specialOp ">" $ cmp OpGT 0
399 , specialOp "<=" $ cmp OpLT 1
400 , specialOp ">=" $ cmp OpGT (-1)
401 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
402 ]
404 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)