git.iko.soy/elk
on 0691082 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 "_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 PortIn name tipe ->
184 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
186 PortOut name tipe value ->
187 do value' <- expression value
188 return $ obj "Native.Ports.portOut" `call`
189 [ string name, Port.outgoing tipe, value' ]
191definition :: Def -> State Int [Statement ()]
192definition (Definition pattern expr@(A region _) _) = do
193 expr' <- expression expr
194 let assign x = varDecl x expr'
195 case pattern of
196 P.Var x
197 | Help.isOp x ->
198 let op = LBracket () (ref "_op") (string x) in
199 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
200 | otherwise ->
201 return [ VarDeclStmt () [ assign x ] ]
203 P.Record fields ->
204 let setField f = varDecl f (dotSep ["$",f]) in
205 return [ VarDeclStmt () (assign "$" : map setField fields) ]
207 P.Data name patterns | vars /= Nothing ->
208 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
209 where
210 vars = getVars patterns
211 getVars patterns =
212 case patterns of
213 P.Var x : rest -> (x:) `fmap` getVars rest
214 [] -> Just []
215 _ -> Nothing
217 decl x n = varDecl x (dotSep ["$","_" ++ show n])
218 setup vars
219 | Help.isTuple name = assign "$" : vars
220 | otherwise = assign "_raw" : safeAssign : vars
222 safeAssign = varDecl "$" (CondExpr () if' (obj "_raw") exception)
223 if' = InfixExpr () OpStrictEq (obj "_raw.ctor") (string name)
224 exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
226 _ ->
227 do defs' <- concat <$> mapM toDef vars
228 return (VarDeclStmt () [assign "_"] : defs')
229 where
230 vars = P.boundVarList pattern
231 mkVar = A region . rawVar
232 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
233 in definition $ Definition (P.Var y) expr Nothing
235match :: Region -> Case.Match -> State Int [Statement ()]
236match region mtch =
237 case mtch of
238 Case.Match name clauses mtch' ->
239 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
240 mtch'' <- match region mtch'
241 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
242 where
243 isLiteral p = case p of
244 Case.Clause (Right _) _ _ -> True
245 _ -> False
247 access name
248 | any isLiteral clauses = obj name
249 | otherwise = dotSep (split name ++ ["ctor"])
251 format isChars e
252 | or isChars = InfixExpr () OpAdd e (string "")
253 | otherwise = e
255 Case.Fail ->
256 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
258 Case.Break -> return [BreakStmt () Nothing]
260 Case.Other e ->
261 do e' <- expression e
262 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)