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