git.iko.soy/elk
on b01cf1d help sign in
elk/compiler/Generate/JavaScript.hs
392 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 $ ref 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 () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
91 where
92 combine r (k,v) = Map.insertWith (++) k [v] r
93 prop = PropId () . var
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 "_J.toList" <| 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
249 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
250 format isChars e
251 | or isChars = InfixExpr () OpAdd e (string "")
252 | otherwise = e
254 Case.Fail ->
255 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
257 Case.Break -> return [BreakStmt () Nothing]
258 Case.Other e ->
259 do e' <- expression e
260 return [ ret e' ]
261 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
262 where
263 dropEnd acc [] = acc
264 dropEnd acc (m:ms) =
265 case m of
266 Case.Other _ -> acc ++ [m]
267 _ -> dropEnd (acc ++ [m]) ms
269clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
270clause region variable (Case.Clause value vars mtch) =
271 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
272 where
273 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
274 (isChar, pattern) =
275 case value of
276 Right (Chr c) -> (True, string [c])
277 _ -> (,) False $ case value of
278 Right (Boolean b) -> BoolLit () b
279 Right lit -> literal lit
280 Left name -> string $ case List.elemIndices '.' name of
281 [] -> name
282 is -> drop (last is + 1) name
284flattenLets :: [Def] -> Expr -> ([Def], Expr)
285flattenLets defs lexpr@(A _ expr) =
286 case expr of
287 Let ds body -> flattenLets (defs ++ ds) body
288 _ -> (defs, lexpr)
290generate :: MetadataModule -> String
291generate unsafeModule =
292 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
293 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
294 where
295 modul = MakeSafe.metadataModule unsafeModule
296 thisModule = dotSep ("_elm" : names modul ++ ["values"])
297 programStmts =
298 concat
299 [ [ ExprStmt () $ string "use strict" ]
300 , setup (Just "_elm") (names modul ++ ["values"])
301 , [ IfSingleStmt () thisModule (ret thisModule) ]
302 , [ internalImports (List.intercalate "." (names modul)) ]
303 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
304 , [ assign ["_op"] (ObjectLit () []) ]
305 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
306 , [ jsExports ]
307 , [ ret thisModule ]
308 ]
310 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
311 where
312 exs = map entry . filter (not . Help.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 = Help.splitDots 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
333binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
334binop region op e1 e2 =
335 case op of
336 "Basics.." ->
337 do es <- mapM expression (e1 : collect [] e2)
338 return $ ["$"] ==> foldr (<|) (ref "$") es
339 "Basics.<|" ->
340 do e2' <- expression e2
341 es <- mapM expression (collect [] e1)
342 return $ foldr (<|) e2' es
343 "List.++" ->
344 do e1' <- expression e1
345 e2' <- expression e2
346 return $ obj "_L.append" `call` [e1', e2']
347 "::" -> expression (A region (Data "::" [e1,e2]))
348 _ ->
349 do e1' <- expression e1
350 e2' <- expression e2
351 return $ case Map.lookup op opDict of
352 Just f -> f e1' e2'
353 Nothing -> ref "A2" `call` [ func, e1', e2' ]
354 where
355 collect es e =
356 case e of
357 A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
358 _ -> es ++ [e]
360 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
361 | otherwise = dotSep parts
362 where
363 parts = Help.splitDots op
364 operator = last parts
366 opDict = Map.fromList (infixOps ++ specialOps)
368 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
369 infixOp str op = specialOp str (InfixExpr () op)
371 infixOps = concat
372 [ infixOp "+" OpAdd
373 , infixOp "-" OpSub
374 , infixOp "*" OpMul
375 , infixOp "/" OpDiv
376 , infixOp "&&" OpLAnd
377 , infixOp "||" OpLOr
378 ]
380 specialOps = concat
381 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
382 , specialOp "|>" $ flip (<|)
383 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
384 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
385 , specialOp "<" $ cmp OpLT 0
386 , specialOp ">" $ cmp OpGT 0
387 , specialOp "<=" $ cmp OpLT 1
388 , specialOp ">=" $ cmp OpGT (-1)
389 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
390 ]
392 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)