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