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