git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Generate/JavaScript.hs
403 lines 15 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript (generate) where
4import Control.Arrow (first,(***))
5import Control.Applicative ((<$>),(<*>))
6import Control.Monad.State
7import qualified Data.List as List
8import qualified Data.Map as Map
9import qualified Data.Set as Set
11import qualified Generate.Cases as Case
12import qualified Generate.Markdown as MD
13import qualified SourceSyntax.Helpers as Help
14import SourceSyntax.Literal
15import SourceSyntax.Pattern as Pattern
16import SourceSyntax.Location
17import SourceSyntax.Expression
18import SourceSyntax.Module
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 vars =
42 case vars of
43 x:xs -> foldl (DotRef ()) (ref x) (map var xs)
44 [] -> error "dotSep must be called on a non-empty list of variables"
46obj = dotSep . split
48varDecl :: String -> Expression () -> VarDecl ()
49varDecl x expr =
50 VarDecl () (var x) (Just expr)
52include alias moduleName =
53 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
55internalImports name =
56 VarDeclStmt ()
57 [ varDecl "_N" (obj "Elm.Native")
58 , include "_U" "_N.Utils"
59 , include "_L" "_N.List"
60 , include "_E" "_N.Error"
61 , include "_J" "_N.JavaScript"
62 , varDecl "$moduleName" (string name)
63 ]
65literal :: Literal -> Expression ()
66literal lit =
67 case lit of
68 Chr c -> obj "_U.chr" <| string [c]
69 Str s -> string s
70 IntNum n -> IntLit () n
71 FloatNum n -> NumLit () n
72 Boolean b -> BoolLit () b
74expression :: LExpr -> State Int (Expression ())
75expression (L span expr) =
76 case expr of
77 Var x -> return $ ref x
78 Literal lit -> return $ literal lit
80 Range lo hi ->
81 do lo' <- expression lo
82 hi' <- expression hi
83 return $ obj "_L.range" `call` [lo',hi']
85 Access e x ->
86 do e' <- expression e
87 return $ DotRef () e' (var x)
89 Remove e x ->
90 do e' <- expression e
91 return $ obj "_U.remove" `call` [string x, e']
93 Insert e x v ->
94 do v' <- expression v
95 e' <- expression e
96 return $ obj "_U.insert" `call` [string x, v', e']
98 Modify e fs ->
99 do e' <- expression e
100 fs' <- forM fs $ \(f,v) -> do
101 v' <- expression v
102 return $ ArrayLit () [string f, v']
103 return $ obj "_U.replace" `call` [ArrayLit () fs', e']
105 Record fields ->
106 do fields' <- forM fields $ \(f,e) -> do
107 (,) f <$> expression e
108 let fieldMap = List.foldl' combine Map.empty fields'
109 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
110 where
111 combine r (k,v) = Map.insertWith (++) k [v] r
112 prop = PropId () . var
113 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
114 Map.toList . Map.filter (not . null) $ Map.map tail fs
115 visible fs = map (first prop) . Map.toList $ Map.map head fs
117 Binop op e1 e2 -> binop span op e1 e2
119 Lambda p e@(L s _) ->
120 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
121 body' <- expression body
122 return $ case length args < 2 || length args > 9 of
123 True -> foldr (==>) body' (map (:[]) args)
124 False -> ref ("F" ++ show (length args)) <| (args ==> body')
125 where
126 depattern (args, body) pattern =
127 case pattern of
128 PVar x -> return (args ++ [x], body)
129 _ -> do arg <- Case.newVar
130 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
132 (patterns, innerBody) = collect [p] e
134 collect patterns lexpr@(L _ expr) =
135 case expr of
136 Lambda p e -> collect (p:patterns) e
137 _ -> (patterns, lexpr)
139 App e1 e2 ->
140 do func' <- expression func
141 args' <- mapM expression args
142 return $ case args' of
143 [arg] -> func' <| arg
144 _ | length args' <= 9 -> ref aN `call` (func':args')
145 | otherwise -> foldl1 (<|) (func':args')
146 where
147 aN = "A" ++ show (length args)
148 (func, args) = getArgs e1 [e2]
149 getArgs func args =
150 case func of
151 (L _ (App f arg)) -> getArgs f (arg : args)
152 _ -> (func, args)
154 Let defs e ->
155 do let (defs',e') = flattenLets defs e
156 stmts <- concat <$> mapM definition defs'
157 exp <- expression e'
158 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
160 MultiIf branches ->
161 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
162 return $ case last branches of
163 (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
164 (L _ (Literal (Boolean True)), _) -> safeIfs branches'
165 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
166 where
167 safeIfs branches = ifs (init branches) (snd (last branches))
168 ifs branches finally = foldr iff finally branches
169 iff (if', then') else' = CondExpr () if' then' else'
171 Case e cases ->
172 do (tempVar,initialMatch) <- Case.toMatch cases
173 (revisedMatch, stmt) <-
174 case e of
175 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
176 _ -> do e' <- expression e
177 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
178 match' <- match span revisedMatch
179 return (function [] (stmt ++ match') `call` [])
181 ExplicitList es ->
182 do es' <- mapM expression es
183 return $ obj "_J.toList" <| ArrayLit () es'
185 Data name es ->
186 do es' <- mapM expression es
187 return $ ObjectLit () (ctor : fields es')
188 where
189 ctor = (prop "ctor", string name)
190 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
192 Markdown uid doc es ->
193 do es' <- mapM expression es
194 return $ obj "Text.markdown" `call` (string md : string uid : es')
195 where
196 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
197 md = pad ++ MD.toHtml doc ++ pad
199 PortIn name _ _ handler ->
200 do handler' <- case handler of
201 Nothing -> return []
202 Just h -> (:[]) `fmap` expression h
203 return $ obj "Native.Ports.portIn" `call` ([ string name ] ++ handler')
205 PortOut name _ signal ->
206 do signal' <- expression signal
207 return $ obj "Native.Ports.portOut" `call` [ string name, signal' ]
209definition :: Def -> State Int [Statement ()]
210definition (Definition pattern expr@(L span _) _) = do
211 expr' <- expression expr
212 let assign x = varDecl x expr'
213 case pattern of
214 PVar x
215 | Help.isOp x ->
216 let op = LBracket () (ref "_op") (string x) in
217 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
218 | otherwise ->
219 return [ VarDeclStmt () [ assign x ] ]
221 PRecord fields ->
222 let setField f = varDecl f (dotSep ["$",f]) in
223 return [ VarDeclStmt () (assign "$" : map setField fields) ]
225 PData name patterns | vars /= Nothing ->
226 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
227 where
228 vars = getVars patterns
229 getVars patterns =
230 case patterns of
231 PVar x : rest -> (x:) `fmap` getVars rest
232 [] -> Just []
233 _ -> Nothing
235 decl x n = varDecl x (dotSep ["$","_" ++ show n])
236 setup vars
237 | Help.isTuple name = assign "$" : vars
238 | otherwise = assign "$raw" : safeAssign : vars
240 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
241 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
242 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
244 _ ->
245 do defs' <- concat <$> mapM toDef vars
246 return (VarDeclStmt () [assign "$"] : defs')
247 where
248 vars = Set.toList $ Pattern.boundVars pattern
249 mkVar = L span . Var
250 toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
251 in definition $ Definition (PVar y) expr Nothing
253match :: (Show a) => a -> Case.Match -> State Int [Statement ()]
254match span mtch =
255 case mtch of
256 Case.Match name clauses mtch' ->
257 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
258 mtch'' <- match span mtch'
259 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
260 where
261 isLiteral p = case p of
262 Case.Clause (Right _) _ _ -> True
263 _ -> False
264 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
265 format isChars e
266 | or isChars = InfixExpr () OpAdd e (string "")
267 | otherwise = e
269 Case.Fail ->
270 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
272 Case.Break -> return [BreakStmt () Nothing]
273 Case.Other e ->
274 do e' <- expression e
275 return [ ReturnStmt () (Just e') ]
276 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
277 where
278 dropEnd acc [] = acc
279 dropEnd acc (m:ms) =
280 case m of
281 Case.Other _ -> acc ++ [m]
282 _ -> dropEnd (acc ++ [m]) ms
284clause span variable (Case.Clause value vars mtch) =
285 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
286 where
287 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
288 (isChar, pattern) =
289 case value of
290 Right (Chr c) -> (True, string [c])
291 _ -> (,) False $ case value of
292 Right (Boolean b) -> BoolLit () b
293 Right lit -> literal lit
294 Left name -> string $ case List.elemIndices '.' name of
295 [] -> name
296 is -> drop (last is + 1) name
298flattenLets defs lexpr@(L _ expr) =
299 case expr of
300 Let ds body -> flattenLets (defs ++ ds) body
301 _ -> (defs, lexpr)
303generate :: MetadataModule -> String
304generate unsafeModule =
305 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
306 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
307 where
308 modul = MakeSafe.metadataModule unsafeModule
309 thisModule = dotSep ("_elm" : names modul ++ ["values"])
310 programStmts =
311 concat
312 [ setup (Just "_elm") (names modul ++ ["values"])
313 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
314 , [ internalImports (List.intercalate "." (names modul)) ]
315 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
316 , [ assign ["_op"] (ObjectLit () []) ]
317 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
318 , [ jsExports ]
319 , [ ReturnStmt () (Just thisModule) ]
320 ]
322 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
323 where
324 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
325 entry x = (PropId () (var x), ref x)
327 assign path expr =
328 case path of
329 [x] -> VarDeclStmt () [ varDecl x expr ]
330 _ -> ExprStmt () $
331 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
333 jsImport modul = setup Nothing path ++ [ include ]
334 where
335 path = split modul
336 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
338 setup namespace path = map create paths
339 where
340 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
341 paths = case namespace of
342 Nothing -> tail . init $ List.inits path
343 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
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 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
372 | otherwise = dotSep parts
373 where
374 parts = split op
375 operator = last parts
377 opDict = Map.fromList (infixOps ++ specialOps)
379 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
380 infixOp str op = specialOp str (InfixExpr () op)
382 infixOps = concat
383 [ infixOp "+" OpAdd
384 , infixOp "-" OpSub
385 , infixOp "*" OpMul
386 , infixOp "/" OpDiv
387 , infixOp "&&" OpLAnd
388 , infixOp "||" OpLOr
389 ]
391 specialOps = concat
392 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
393 , specialOp "|>" $ flip (<|)
394 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
395 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
396 , specialOp "<" $ cmp OpLT 0
397 , specialOp ">" $ cmp OpGT 0
398 , specialOp "<=" $ cmp OpLT 1
399 , specialOp ">=" $ cmp OpGT (-1)
400 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
401 ]
403 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)