git.iko.soy/elk
on e1e232c help sign in
elk/compiler/Generate/JavaScript.hs
398 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 "_A" "_N.Array"
42 , include "_E" "_N.Error"
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
60 Literal lit -> return $ literal lit
62 Range lo hi ->
63 do lo' <- expression lo
64 hi' <- expression hi
65 return $ obj "_L.range" `call` [lo',hi']
67 Access e x ->
68 do e' <- expression e
69 return $ DotRef () e' (var x)
71 Remove e x ->
72 do e' <- expression e
73 return $ obj "_U.remove" `call` [string x, e']
75 Insert e x v ->
76 do v' <- expression v
77 e' <- expression e
78 return $ obj "_U.insert" `call` [string x, v', e']
80 Modify e fs ->
81 do e' <- expression e
82 fs' <- forM fs $ \(f,v) -> do
83 v' <- expression v
84 return $ ArrayLit () [string f, v']
85 return $ obj "_U.replace" `call` [ArrayLit () fs', e']
87 Record fields ->
88 do fields' <- forM fields $ \(f,e) -> do
89 (,) f <$> expression e
90 let fieldMap = List.foldl' combine Map.empty fields'
91 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
92 where
93 combine r (k,v) = Map.insertWith (++) k [v] r
94 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
95 Map.toList . Map.filter (not . null) $ Map.map tail fs
96 visible fs = map (first prop) . Map.toList $ Map.map head fs
98 Binop op e1 e2 -> binop region op e1 e2
100 Lambda p e@(A ann _) ->
101 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
102 body' <- expression body
103 return $ case length args < 2 || length args > 9 of
104 True -> foldr (==>) body' (map (:[]) args)
105 False -> ref ("F" ++ show (length args)) <| (args ==> body')
106 where
107 depattern (args, body) pattern =
108 case pattern of
109 P.Var x -> return (args ++ [x], body)
110 _ -> do arg <- Case.newVar
111 return ( args ++ [arg]
112 , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
114 (patterns, innerBody) = collect [p] e
116 collect patterns lexpr@(A _ expr) =
117 case expr of
118 Lambda p e -> collect (p:patterns) e
119 _ -> (patterns, lexpr)
121 App e1 e2 ->
122 do func' <- expression func
123 args' <- mapM expression args
124 return $ case args' of
125 [arg] -> func' <| arg
126 _ | length args' <= 9 -> ref aN `call` (func':args')
127 | otherwise -> foldl1 (<|) (func':args')
128 where
129 aN = "A" ++ show (length args)
130 (func, args) = getArgs e1 [e2]
131 getArgs func args =
132 case func of
133 (A _ (App f arg)) -> getArgs f (arg : args)
134 _ -> (func, args)
136 Let defs e ->
137 do let (defs',e') = flattenLets defs e
138 stmts <- concat <$> mapM definition defs'
139 exp <- expression e'
140 return $ function [] (stmts ++ [ ret exp ]) `call` []
142 MultiIf branches ->
143 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
144 return $ case last branches of
145 (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
146 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
147 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
148 where
149 safeIfs branches = ifs (init branches) (snd (last branches))
150 ifs branches finally = foldr iff finally branches
151 iff (if', then') else' = CondExpr () if' then' else'
153 Case e cases ->
154 do (tempVar,initialMatch) <- Case.toMatch cases
155 (revisedMatch, stmt) <-
156 case e of
157 A _ (Var (V.Raw x)) ->
158 return (Case.matchSubst [(tempVar,x)] initialMatch, [])
159 _ ->
160 do e' <- expression e
161 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
162 match' <- match region revisedMatch
163 return (function [] (stmt ++ match') `call` [])
165 ExplicitList es ->
166 do es' <- mapM expression es
167 return $ obj "_L.fromArray" <| ArrayLit () es'
169 Data name es ->
170 do es' <- mapM expression es
171 return $ ObjectLit () (ctor : fields es')
172 where
173 ctor = (prop "ctor", string name)
174 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
176 Markdown uid doc es ->
177 do es' <- mapM expression es
178 return $ obj "Text.markdown" `call` (string md : string uid : es')
179 where
180 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
181 md = pad ++ MD.toHtml doc ++ pad
183 GLShader _uid src _tipe ->
184 return $ ObjectLit () [(PropString () "src", literal (Str src))]
186 PortIn name tipe ->
187 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
189 PortOut name tipe value ->
190 do value' <- expression value
191 return $ obj "Native.Ports.portOut" `call`
192 [ string name, Port.outgoing tipe, value' ]
194definition :: Def -> State Int [Statement ()]
195definition (Definition pattern expr@(A region _) _) = do
196 expr' <- expression expr
197 let assign x = varDecl x expr'
198 case pattern of
199 P.Var x
200 | Help.isOp x ->
201 let op = LBracket () (ref "_op") (string x) in
202 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
203 | otherwise ->
204 return [ VarDeclStmt () [ assign x ] ]
206 P.Record fields ->
207 let setField f = varDecl f (dotSep ["$",f]) in
208 return [ VarDeclStmt () (assign "$" : map setField fields) ]
210 P.Data name patterns | vars /= Nothing ->
211 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
212 where
213 vars = getVars patterns
214 getVars patterns =
215 case patterns of
216 P.Var x : rest -> (x:) `fmap` getVars rest
217 [] -> Just []
218 _ -> Nothing
220 decl x n = varDecl x (dotSep ["$","_" ++ show n])
221 setup vars
222 | Help.isTuple name = assign "$" : vars
223 | otherwise = assign "_raw" : safeAssign : vars
225 safeAssign = varDecl "$" (CondExpr () if' (obj "_raw") exception)
226 if' = InfixExpr () OpStrictEq (obj "_raw.ctor") (string name)
227 exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
229 _ ->
230 do defs' <- concat <$> mapM toDef vars
231 return (VarDeclStmt () [assign "_"] : defs')
232 where
233 vars = P.boundVarList pattern
234 mkVar = A region . rawVar
235 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
236 in definition $ Definition (P.Var y) expr Nothing
238match :: Region -> Case.Match -> State Int [Statement ()]
239match region mtch =
240 case mtch of
241 Case.Match name clauses mtch' ->
242 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
243 mtch'' <- match region mtch'
244 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
245 where
246 isLiteral p = case p of
247 Case.Clause (Right _) _ _ -> True
248 _ -> False
250 access name
251 | any isLiteral clauses = obj name
252 | otherwise = dotSep (split name ++ ["ctor"])
254 format isChars e
255 | or isChars = InfixExpr () OpAdd e (string "")
256 | otherwise = e
258 Case.Fail ->
259 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
261 Case.Break -> return [BreakStmt () Nothing]
263 Case.Other e ->
264 do e' <- expression e
265 return [ ret e' ]
267 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
268 where
269 dropEnd acc [] = acc
270 dropEnd acc (m:ms) =
271 case m of
272 Case.Other _ -> acc ++ [m]
273 _ -> dropEnd (acc ++ [m]) ms
275clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
276clause region variable (Case.Clause value vars mtch) =
277 (,) isChar . CaseClause () pattern <$> match region (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
290flattenLets :: [Def] -> Expr -> ([Def], Expr)
291flattenLets defs lexpr@(A _ expr) =
292 case expr of
293 Let ds body -> flattenLets (defs ++ ds) body
294 _ -> (defs, lexpr)
296generate :: MetadataModule -> String
297generate unsafeModule =
298 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
299 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
300 where
301 modul = MakeSafe.metadataModule unsafeModule
302 thisModule = dotSep ("_elm" : names modul ++ ["values"])
303 programStmts =
304 concat
305 [ [ ExprStmt () $ string "use strict" ]
306 , setup (Just "_elm") (names modul ++ ["values"])
307 , [ IfSingleStmt () thisModule (ret thisModule) ]
308 , [ internalImports (List.intercalate "." (names modul)) ]
309 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
310 , [ assign ["_op"] (ObjectLit () []) ]
311 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
312 , [ jsExports ]
313 , [ ret thisModule ]
314 ]
316 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
317 where
318 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
319 entry x = (prop x, ref x)
321 assign path expr =
322 case path of
323 [x] -> VarDeclStmt () [ varDecl x expr ]
324 _ -> ExprStmt () $
325 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
327 jsImport modul = setup Nothing path ++ [ include ]
328 where
329 path = Help.splitDots modul
330 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
332 setup namespace path = map create paths
333 where
334 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
335 paths = case namespace of
336 Nothing -> tail . init $ List.inits path
337 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
339binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
340binop region op e1 e2 =
341 case op of
342 "Basics.." ->
343 do es <- mapM expression (e1 : collect [] e2)
344 return $ ["$"] ==> foldr (<|) (ref "$") es
345 "Basics.<|" ->
346 do e2' <- expression e2
347 es <- mapM expression (collect [] e1)
348 return $ foldr (<|) e2' es
349 "List.++" ->
350 do e1' <- expression e1
351 e2' <- expression e2
352 return $ obj "_L.append" `call` [e1', e2']
353 "::" -> expression (A region (Data "::" [e1,e2]))
354 _ ->
355 do e1' <- expression e1
356 e2' <- expression e2
357 return $ case Map.lookup op opDict of
358 Just f -> f e1' e2'
359 Nothing -> ref "A2" `call` [ func, e1', e2' ]
360 where
361 collect es e =
362 case e of
363 A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
364 _ -> es ++ [e]
366 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
367 | otherwise = dotSep parts
368 where
369 parts = Help.splitDots op
370 operator = last parts
372 opDict = Map.fromList (infixOps ++ specialOps)
374 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
375 infixOp str op = specialOp str (InfixExpr () op)
377 infixOps = concat
378 [ infixOp "+" OpAdd
379 , infixOp "-" OpSub
380 , infixOp "*" OpMul
381 , infixOp "/" OpDiv
382 , infixOp "&&" OpLAnd
383 , infixOp "||" OpLOr
384 ]
386 specialOps = concat
387 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
388 , specialOp "|>" $ flip (<|)
389 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
390 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
391 , specialOp "<" $ cmp OpLT 0
392 , specialOp ">" $ cmp OpGT 0
393 , specialOp "<=" $ cmp OpLT 1
394 , specialOp ">=" $ cmp OpGT (-1)
395 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
396 ]
398 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)