git.iko.soy/elk
on 71bb1c8 help sign in
elk/compiler/Generate/JavaScript.hs
406 lines 15 kB history raw
1module Generate.JavaScript (generate) where
3import Control.Arrow (first,(***))
4import Control.Applicative ((<$>),(<*>))
5import Control.Monad.State
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Set as Set
10import qualified Generate.Cases as Case
11import qualified Generate.Markdown as MD
12import qualified SourceSyntax.Helpers as Help
13import SourceSyntax.Literal
14import SourceSyntax.Pattern
15import SourceSyntax.Location
16import SourceSyntax.Expression
17import SourceSyntax.Module
18import qualified Transform.SortDefinitions as SD
19import Language.ECMAScript3.Syntax
20import Language.ECMAScript3.PrettyPrint
21import qualified Transform.SafeNames as MakeSafe
23split :: String -> [String]
24split = go []
25 where
26 go vars str =
27 case break (=='.') str of
28 (x,'.':rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
29 | otherwise -> go (vars ++ [x]) rest
30 (x,[]) -> vars ++ [x]
32var name = Id () name
33ref name = VarRef () (var name)
34prop name = PropId () (var name)
35f <| x = CallExpr () f [x]
36args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
37function args stmts = FuncExpr () Nothing (map var args) stmts
38call = CallExpr ()
39string = StringLit ()
41dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
42obj = dotSep . split
44varDecl :: String -> Expression () -> VarDecl ()
45varDecl x expr =
46 VarDecl () (var x) (Just expr)
48include alias moduleName =
49 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
51internalImports name =
52 VarDeclStmt ()
53 [ varDecl "N" (obj "Elm.Native")
54 , include "_N" "N.Utils"
55 , include "_L" "N.List"
56 , include "_E" "N.Error"
57 , include "_J" "N.JavaScript"
58 , varDecl "$moduleName" (string name)
59 ]
61literal :: Literal -> Expression ()
62literal lit =
63 case lit of
64 Chr c -> obj "_N.chr" <| string [c]
65 Str s -> string s
66 IntNum n -> IntLit () n
67 FloatNum n -> NumLit () n
68 Boolean b -> BoolLit () b
70expression :: LExpr () () -> State Int (Expression ())
71expression (L span expr) =
72 case expr of
73 Var x -> return $ ref x
74 Literal lit -> return $ literal lit
76 Range lo hi ->
77 do lo' <- expression lo
78 hi' <- expression hi
79 return $ obj "_L.range" `call` [lo',hi']
81 Access e x ->
82 do e' <- expression e
83 return $ DotRef () e' (var x)
85 Remove e x ->
86 do e' <- expression e
87 return $ obj "_N.remove" `call` [string x, e']
89 Insert e x v ->
90 do v' <- expression v
91 e' <- expression e
92 return $ obj "_N.insert" `call` [string x, v', e']
94 Modify e fs ->
95 do e' <- expression e
96 fs' <- forM fs $ \(f,v) -> do
97 v' <- expression v
98 return $ ArrayLit () [string f, v']
99 return $ obj "_N.replace" `call` [ArrayLit () fs', e']
101 Record fields ->
102 do fields' <- forM fields $ \(f,e) -> do
103 (,) f <$> expression e
104 let fieldMap = List.foldl' combine Map.empty fields'
105 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
106 where
107 combine r (k,v) = Map.insertWith (++) k [v] r
108 prop = PropId () . var
109 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
110 Map.toList . Map.filter (not . null) $ Map.map tail fs
111 visible fs = map (first prop) . Map.toList $ Map.map head fs
113 Binop op e1 e2 -> binop span op e1 e2
115 Lambda p e@(L s _) ->
116 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
117 body' <- expression body
118 return $ case length args < 2 || length args > 9 of
119 True -> foldr (==>) body' (map (:[]) args)
120 False -> ref ("F" ++ show (length args)) <| (args ==> body')
121 where
122 depattern (args, body) pattern =
123 case pattern of
124 PVar x -> return (args ++ [x], body)
125 _ -> do arg <- Case.newVar
126 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
128 (patterns, innerBody) = collect [p] e
130 collect patterns lexpr@(L _ expr) =
131 case expr of
132 Lambda p e -> collect (p:patterns) e
133 _ -> (patterns, lexpr)
135 App e1 e2 ->
136 do func' <- expression func
137 args' <- mapM expression args
138 return $ case args' of
139 [arg] -> func' <| arg
140 _ | length args' <= 9 -> ref aN `call` (func':args')
141 | otherwise -> foldl1 (<|) (func':args')
142 where
143 aN = "A" ++ show (length args)
144 (func, args) = getArgs e1 [e2]
145 getArgs func args =
146 case func of
147 (L _ (App f arg)) -> getArgs f (arg : args)
148 _ -> (func, args)
150 Let defs e ->
151 do let (defs',e') = SD.flattenLets defs e
152 stmts <- concat <$> mapM definition defs'
153 exp <- expression e'
154 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
156 MultiIf branches ->
157 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
158 return $ case last branches of
159 (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
160 (L _ (Literal (Boolean True)), _) -> safeIfs branches'
161 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
162 where
163 safeIfs branches = ifs (init branches) (snd (last branches))
164 ifs branches finally = foldr iff finally branches
165 iff (if', then') else' = CondExpr () if' then' else'
167 Case e cases ->
168 do (tempVar,initialMatch) <- Case.toMatch cases
169 (revisedMatch, stmt) <-
170 case e of
171 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
172 _ -> do e' <- expression e
173 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
174 match' <- match span revisedMatch
175 return (function [] (stmt ++ match') `call` [])
177 ExplicitList es ->
178 do es' <- mapM expression es
179 return $ obj "_J.toList" <| ArrayLit () es'
181 Data name es ->
182 do es' <- mapM expression es
183 return $ ObjectLit () (ctor : fields es')
184 where
185 ctor = (prop "ctor", string name)
186 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
188 Markdown uid doc es ->
189 do es' <- mapM expression es
190 return $ obj "Text.markdown" `call` (string md : string uid : es')
191 where
192 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
193 md = pad ++ MD.toHtml doc ++ pad
195definition :: Def () () -> State Int [Statement ()]
196definition def =
197 case def of
198 TypeAnnotation _ _ -> return []
200 Def pattern expr@(L span _) -> do
201 expr' <- expression expr
202 let assign x = varDecl x expr'
203 case pattern of
204 PVar x
205 | Help.isOp x ->
206 let op = LBracket () (ref "_op") (string x) in
207 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
208 | otherwise ->
209 return [ VarDeclStmt () [ assign x ] ]
211 PRecord fields ->
212 let setField f = varDecl f (dotSep ["$",f]) in
213 return [ VarDeclStmt () (assign "$" : map setField fields) ]
215 PData name patterns | vars /= Nothing ->
216 case vars of
217 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
218 where
219 vars = getVars patterns
220 getVars patterns =
221 case patterns of
222 PVar x : rest -> (x:) `fmap` getVars rest
223 [] -> Just []
224 _ -> Nothing
226 decl x n = varDecl x (dotSep ["$","_" ++ show n])
227 setup vars
228 | Help.isTuple name = assign "$" : vars
229 | otherwise = safeAssign : vars
231 safeAssign = varDecl "$" (CondExpr () if' expr' exception)
232 if' = InfixExpr () OpStrictEq (obj "$.ctor") (string name)
233 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
235 _ ->
236 do defs' <- concat <$> mapM toDef vars
237 return (VarDeclStmt () [assign "$"] : defs')
238 where
239 vars = Set.toList $ SD.boundVars pattern
240 mkVar = L span . Var
241 toDef y = definition $
242 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
244match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
245match span mtch =
246 case mtch of
247 Case.Match name clauses mtch' ->
248 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
249 mtch'' <- match span mtch'
250 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
251 where
252 isLiteral p = case p of
253 Case.Clause (Right _) _ _ -> True
254 _ -> False
255 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
256 format isChars e
257 | or isChars = InfixExpr () OpAdd e (string "")
258 | otherwise = e
260 Case.Fail ->
261 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
263 Case.Break -> return [BreakStmt () Nothing]
264 Case.Other e ->
265 do e' <- expression e
266 return [ ReturnStmt () (Just e') ]
267 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
268 where
269 dropEnd acc [] = acc
270 dropEnd acc (m:ms) =
271 case m of
272 Case.Other _ -> acc ++ [m]
273 _ -> dropEnd (acc ++ [m]) ms
275clause span variable (Case.Clause value vars mtch) =
276 (,) isChar . CaseClause () pattern <$> match span (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
290generate :: MetadataModule () () -> String
291generate unsafeModule =
292 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
293 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
294 where
295 modul = MakeSafe.metadataModule unsafeModule
296 thisModule = dotSep ("_elm" : names modul ++ ["values"])
297 programStmts =
298 concat [ setup (Just "_elm") (names modul ++ ["values"])
299 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
300 , [ internalImports (List.intercalate "." (names modul)) ]
301 , concatMap jsImport (imports modul)
302 , checkInPorts (ports modul)
303 , map jsPort (ports modul)
304 , [ assign ["_op"] (ObjectLit () []) ]
305 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
306 , [ jsExports ]
307 , [ ReturnStmt () (Just thisModule) ]
308 ]
310 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
311 where
312 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
313 entry x = (PropId () (var x), ref x)
315 assign path expr =
316 case path of
317 [x] -> VarDeclStmt () [ varDecl x expr ]
318 _ -> ExprStmt () $
319 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
321 jsImport (modul,_) = setup Nothing path ++ [ include ]
322 where
323 path = split modul
324 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
326 setup namespace path = map create paths
327 where
328 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
329 paths = case namespace of
330 Nothing -> tail . init $ List.inits path
331 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
333 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")
335 checkInPorts ports =
336 [ ExprStmt () $ obj "_N.checkPorts" `call` [ref "$moduleName", names] ]
337 where
338 names = ArrayLit () [ string name | (name, _, Nothing) <- ports ]
340 jsPort (name, _, maybe) =
341 case maybe of
342 Nothing -> assign [name] $ dotSep ["_elm","ports_in",name]
343 Just expr -> assign ["_elm","ports_out",name] $ evalState (expression expr) 0
345binop span op e1 e2 =
346 case op of
347 "Basics.." ->
348 do es <- mapM expression (e1 : collect [] e2)
349 return $ ["$"] ==> foldr (<|) (ref "$") es
350 "Basics.<|" ->
351 do e2' <- expression e2
352 es <- mapM expression (collect [] e1)
353 return $ foldr (<|) e2' es
354 "List.++" ->
355 do e1' <- expression e1
356 e2' <- expression e2
357 return $ obj "_L.append" `call` [e1', e2']
358 "::" -> expression (L span (Data "::" [e1,e2]))
359 _ ->
360 do e1' <- expression e1
361 e2' <- expression e2
362 return $ case Map.lookup op opDict of
363 Just f -> f e1' e2'
364 Nothing -> ref "A2" `call` [ func, e1', e2' ]
365 where
366 collect es e =
367 case e of
368 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
369 _ -> es ++ [e]
371 js1 = expression e1
372 js2 = expression e2
374 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
375 | otherwise = dotSep parts
376 where
377 parts = split op
378 operator = last parts
380 opDict = Map.fromList (infixOps ++ specialOps)
382 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
383 infixOp str op = specialOp str (InfixExpr () op)
385 infixOps = concat
386 [ infixOp "+" OpAdd
387 , infixOp "-" OpSub
388 , infixOp "*" OpMul
389 , infixOp "/" OpDiv
390 , infixOp "&&" OpLAnd
391 , infixOp "||" OpLOr
392 ]
394 specialOps = concat
395 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
396 , specialOp "|>" $ flip (<|)
397 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
398 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
399 , specialOp "<" $ cmp OpLT 0
400 , specialOp ">" $ cmp OpGT 0
401 , specialOp "<=" $ cmp OpLT 1
402 , specialOp ">=" $ cmp OpGT (-1)
403 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
404 ]
406 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)