git.iko.soy/elk
on 358f38e help sign in
elk/compiler/Generate/JavaScript.hs
391 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 PortIn name tipe ->
182 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
184 PortOut name tipe value ->
185 do value' <- expression value
186 return $ obj "Native.Ports.portOut" `call`
187 [ string name, Port.outgoing tipe, value' ]
189definition :: Def -> State Int [Statement ()]
190definition (Definition pattern expr@(A region _) _) = do
191 expr' <- expression expr
192 let assign x = varDecl x expr'
193 case pattern of
194 P.Var x
195 | Help.isOp x ->
196 let op = LBracket () (ref "_op") (string x) in
197 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
198 | otherwise ->
199 return [ VarDeclStmt () [ assign x ] ]
201 P.Record fields ->
202 let setField f = varDecl f (dotSep ["$",f]) in
203 return [ VarDeclStmt () (assign "$" : map setField fields) ]
205 P.Data name patterns | vars /= Nothing ->
206 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
207 where
208 vars = getVars patterns
209 getVars patterns =
210 case patterns of
211 P.Var x : rest -> (x:) `fmap` getVars rest
212 [] -> Just []
213 _ -> Nothing
215 decl x n = varDecl x (dotSep ["$","_" ++ show n])
216 setup vars
217 | Help.isTuple name = assign "$" : vars
218 | otherwise = assign "$raw" : safeAssign : vars
220 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
221 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
222 exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
224 _ ->
225 do defs' <- concat <$> mapM toDef vars
226 return (VarDeclStmt () [assign "$"] : defs')
227 where
228 vars = P.boundVarList pattern
229 mkVar = A region . rawVar
230 toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
231 in definition $ Definition (P.Var y) expr Nothing
233match :: Region -> Case.Match -> State Int [Statement ()]
234match region mtch =
235 case mtch of
236 Case.Match name clauses mtch' ->
237 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
238 mtch'' <- match region mtch'
239 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
240 where
241 isLiteral p = case p of
242 Case.Clause (Right _) _ _ -> True
243 _ -> False
245 access name
246 | any isLiteral clauses = obj name
247 | otherwise = dotSep (split name ++ ["ctor"])
249 format isChars e
250 | or isChars = InfixExpr () OpAdd e (string "")
251 | otherwise = e
253 Case.Fail ->
254 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
256 Case.Break -> return [BreakStmt () Nothing]
257 Case.Other e ->
258 do e' <- expression e
259 return [ ret e' ]
260 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
261 where
262 dropEnd acc [] = acc
263 dropEnd acc (m:ms) =
264 case m of
265 Case.Other _ -> acc ++ [m]
266 _ -> dropEnd (acc ++ [m]) ms
268clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
269clause region variable (Case.Clause value vars mtch) =
270 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
271 where
272 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
273 (isChar, pattern) =
274 case value of
275 Right (Chr c) -> (True, string [c])
276 _ -> (,) False $ case value of
277 Right (Boolean b) -> BoolLit () b
278 Right lit -> literal lit
279 Left name -> string $ case List.elemIndices '.' name of
280 [] -> name
281 is -> drop (last is + 1) name
283flattenLets :: [Def] -> Expr -> ([Def], Expr)
284flattenLets defs lexpr@(A _ expr) =
285 case expr of
286 Let ds body -> flattenLets (defs ++ ds) body
287 _ -> (defs, lexpr)
289generate :: MetadataModule -> String
290generate unsafeModule =
291 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
292 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
293 where
294 modul = MakeSafe.metadataModule unsafeModule
295 thisModule = dotSep ("_elm" : names modul ++ ["values"])
296 programStmts =
297 concat
298 [ [ ExprStmt () $ string "use strict" ]
299 , setup (Just "_elm") (names modul ++ ["values"])
300 , [ IfSingleStmt () thisModule (ret thisModule) ]
301 , [ internalImports (List.intercalate "." (names modul)) ]
302 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
303 , [ assign ["_op"] (ObjectLit () []) ]
304 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
305 , [ jsExports ]
306 , [ ret thisModule ]
307 ]
309 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
310 where
311 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
312 entry x = (prop x, ref x)
314 assign path expr =
315 case path of
316 [x] -> VarDeclStmt () [ varDecl x expr ]
317 _ -> ExprStmt () $
318 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
320 jsImport modul = setup Nothing path ++ [ include ]
321 where
322 path = Help.splitDots modul
323 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
325 setup namespace path = map create paths
326 where
327 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
328 paths = case namespace of
329 Nothing -> tail . init $ List.inits path
330 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
332binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
333binop region op e1 e2 =
334 case op of
335 "Basics.." ->
336 do es <- mapM expression (e1 : collect [] e2)
337 return $ ["$"] ==> foldr (<|) (ref "$") es
338 "Basics.<|" ->
339 do e2' <- expression e2
340 es <- mapM expression (collect [] e1)
341 return $ foldr (<|) e2' es
342 "List.++" ->
343 do e1' <- expression e1
344 e2' <- expression e2
345 return $ obj "_L.append" `call` [e1', e2']
346 "::" -> expression (A region (Data "::" [e1,e2]))
347 _ ->
348 do e1' <- expression e1
349 e2' <- expression e2
350 return $ case Map.lookup op opDict of
351 Just f -> f e1' e2'
352 Nothing -> ref "A2" `call` [ func, e1', e2' ]
353 where
354 collect es e =
355 case e of
356 A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
357 _ -> es ++ [e]
359 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
360 | otherwise = dotSep parts
361 where
362 parts = Help.splitDots op
363 operator = last parts
365 opDict = Map.fromList (infixOps ++ specialOps)
367 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
368 infixOp str op = specialOp str (InfixExpr () op)
370 infixOps = concat
371 [ infixOp "+" OpAdd
372 , infixOp "-" OpSub
373 , infixOp "*" OpMul
374 , infixOp "/" OpDiv
375 , infixOp "&&" OpLAnd
376 , infixOp "||" OpLOr
377 ]
379 specialOps = concat
380 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
381 , specialOp "|>" $ flip (<|)
382 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
383 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
384 , specialOp "<" $ cmp OpLT 0
385 , specialOp ">" $ cmp OpGT 0
386 , specialOp "<=" $ cmp OpLT 1
387 , specialOp ">=" $ cmp OpGT (-1)
388 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
389 ]
391 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)