git.iko.soy/elk
on be3daf7 help sign in
elk/compiler/Generate/JavaScript.hs
397 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 , varDecl "$moduleName" (string name)
43 ]
45literal :: Literal -> Expression ()
46literal lit =
47 case lit of
48 Chr c -> obj "_U.chr" <| string [c]
49 Str s -> string s
50 IntNum n -> IntLit () n
51 FloatNum n -> NumLit () n
52 Boolean b -> BoolLit () b
54expression :: Expr -> State Int (Expression ())
55expression (A region expr) =
56 case expr of
57 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 "_L.fromArray" <| 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]
262 Case.Other e ->
263 do e' <- expression e
264 return [ ret e' ]
266 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
267 where
268 dropEnd acc [] = acc
269 dropEnd acc (m:ms) =
270 case m of
271 Case.Other _ -> acc ++ [m]
272 _ -> dropEnd (acc ++ [m]) ms
274clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
275clause region variable (Case.Clause value vars mtch) =
276 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
277 where
278 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
279 (isChar, pattern) =
280 case value of
281 Right (Chr c) -> (True, string [c])
282 _ -> (,) False $ case value of
283 Right (Boolean b) -> BoolLit () b
284 Right lit -> literal lit
285 Left name -> string $ case List.elemIndices '.' name of
286 [] -> name
287 is -> drop (last is + 1) name
289flattenLets :: [Def] -> Expr -> ([Def], Expr)
290flattenLets defs lexpr@(A _ expr) =
291 case expr of
292 Let ds body -> flattenLets (defs ++ ds) body
293 _ -> (defs, lexpr)
295generate :: MetadataModule -> String
296generate unsafeModule =
297 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
298 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
299 where
300 modul = MakeSafe.metadataModule unsafeModule
301 thisModule = dotSep ("_elm" : names modul ++ ["values"])
302 programStmts =
303 concat
304 [ [ ExprStmt () $ string "use strict" ]
305 , setup (Just "_elm") (names modul ++ ["values"])
306 , [ IfSingleStmt () thisModule (ret thisModule) ]
307 , [ internalImports (List.intercalate "." (names modul)) ]
308 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
309 , [ assign ["_op"] (ObjectLit () []) ]
310 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
311 , [ jsExports ]
312 , [ ret thisModule ]
313 ]
315 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
316 where
317 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
318 entry x = (prop x, ref x)
320 assign path expr =
321 case path of
322 [x] -> VarDeclStmt () [ varDecl x expr ]
323 _ -> ExprStmt () $
324 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
326 jsImport modul = setup Nothing path ++ [ include ]
327 where
328 path = Help.splitDots modul
329 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
331 setup namespace path = map create paths
332 where
333 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
334 paths = case namespace of
335 Nothing -> tail . init $ List.inits path
336 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
338binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
339binop region op e1 e2 =
340 case op of
341 "Basics.." ->
342 do es <- mapM expression (e1 : collect [] e2)
343 return $ ["$"] ==> foldr (<|) (ref "$") es
344 "Basics.<|" ->
345 do e2' <- expression e2
346 es <- mapM expression (collect [] e1)
347 return $ foldr (<|) e2' es
348 "List.++" ->
349 do e1' <- expression e1
350 e2' <- expression e2
351 return $ obj "_L.append" `call` [e1', e2']
352 "::" -> expression (A region (Data "::" [e1,e2]))
353 _ ->
354 do e1' <- expression e1
355 e2' <- expression e2
356 return $ case Map.lookup op opDict of
357 Just f -> f e1' e2'
358 Nothing -> ref "A2" `call` [ func, e1', e2' ]
359 where
360 collect es e =
361 case e of
362 A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
363 _ -> es ++ [e]
365 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
366 | otherwise = dotSep parts
367 where
368 parts = Help.splitDots op
369 operator = last parts
371 opDict = Map.fromList (infixOps ++ specialOps)
373 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
374 infixOp str op = specialOp str (InfixExpr () op)
376 infixOps = concat
377 [ infixOp "+" OpAdd
378 , infixOp "-" OpSub
379 , infixOp "*" OpMul
380 , infixOp "/" OpDiv
381 , infixOp "&&" OpLAnd
382 , infixOp "||" OpLOr
383 ]
385 specialOps = concat
386 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
387 , specialOp "|>" $ flip (<|)
388 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
389 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
390 , specialOp "<" $ cmp OpLT 0
391 , specialOp ">" $ cmp OpGT 0
392 , specialOp "<=" $ cmp OpLT 1
393 , specialOp ">=" $ cmp OpGT (-1)
394 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
395 ]
397 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)