git.iko.soy/elk
on f0f84cb help sign in
elk/compiler/Generate/JavaScript.hs
388 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 , include "_J" "_N.JavaScript"
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 $ ref 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 () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
91 where
92 combine r (k,v) = Map.insertWith (++) k [v] r
93 prop = PropId () . var
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 "_J.toList" <| 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
246 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
247 format isChars e
248 | or isChars = InfixExpr () OpAdd e (string "")
249 | otherwise = e
251 Case.Fail ->
252 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
254 Case.Break -> return [BreakStmt () Nothing]
255 Case.Other e ->
256 do e' <- expression e
257 return [ ret e' ]
258 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
259 where
260 dropEnd acc [] = acc
261 dropEnd acc (m:ms) =
262 case m of
263 Case.Other _ -> acc ++ [m]
264 _ -> dropEnd (acc ++ [m]) ms
266clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
267clause region variable (Case.Clause value vars mtch) =
268 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
269 where
270 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
271 (isChar, pattern) =
272 case value of
273 Right (Chr c) -> (True, string [c])
274 _ -> (,) False $ case value of
275 Right (Boolean b) -> BoolLit () b
276 Right lit -> literal lit
277 Left name -> string $ case List.elemIndices '.' name of
278 [] -> name
279 is -> drop (last is + 1) name
281flattenLets :: [Def] -> Expr -> ([Def], Expr)
282flattenLets defs lexpr@(A _ expr) =
283 case expr of
284 Let ds body -> flattenLets (defs ++ ds) body
285 _ -> (defs, lexpr)
287generate :: MetadataModule -> String
288generate unsafeModule =
289 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
290 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
291 where
292 modul = MakeSafe.metadataModule unsafeModule
293 thisModule = dotSep ("_elm" : names modul ++ ["values"])
294 programStmts =
295 concat
296 [ setup (Just "_elm") (names modul ++ ["values"])
297 , [ IfSingleStmt () thisModule (ret thisModule) ]
298 , [ internalImports (List.intercalate "." (names modul)) ]
299 , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
300 , [ assign ["_op"] (ObjectLit () []) ]
301 , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
302 , [ jsExports ]
303 , [ ret thisModule ]
304 ]
306 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
307 where
308 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
309 entry x = (PropId () (var x), ref x)
311 assign path expr =
312 case path of
313 [x] -> VarDeclStmt () [ varDecl x expr ]
314 _ -> ExprStmt () $
315 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
317 jsImport modul = setup Nothing path ++ [ include ]
318 where
319 path = Help.splitDots modul
320 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
322 setup namespace path = map create paths
323 where
324 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
325 paths = case namespace of
326 Nothing -> tail . init $ List.inits path
327 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
329binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
330binop region op e1 e2 =
331 case op of
332 "Basics.." ->
333 do es <- mapM expression (e1 : collect [] e2)
334 return $ ["$"] ==> foldr (<|) (ref "$") es
335 "Basics.<|" ->
336 do e2' <- expression e2
337 es <- mapM expression (collect [] e1)
338 return $ foldr (<|) e2' es
339 "List.++" ->
340 do e1' <- expression e1
341 e2' <- expression e2
342 return $ obj "_L.append" `call` [e1', e2']
343 "::" -> expression (A region (Data "::" [e1,e2]))
344 _ ->
345 do e1' <- expression e1
346 e2' <- expression e2
347 return $ case Map.lookup op opDict of
348 Just f -> f e1' e2'
349 Nothing -> ref "A2" `call` [ func, e1', e2' ]
350 where
351 collect es e =
352 case e of
353 A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
354 _ -> es ++ [e]
356 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
357 | otherwise = dotSep parts
358 where
359 parts = Help.splitDots op
360 operator = last parts
362 opDict = Map.fromList (infixOps ++ specialOps)
364 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
365 infixOp str op = specialOp str (InfixExpr () op)
367 infixOps = concat
368 [ infixOp "+" OpAdd
369 , infixOp "-" OpSub
370 , infixOp "*" OpMul
371 , infixOp "/" OpDiv
372 , infixOp "&&" OpLAnd
373 , infixOp "||" OpLOr
374 ]
376 specialOps = concat
377 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
378 , specialOp "|>" $ flip (<|)
379 , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
380 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
381 , specialOp "<" $ cmp OpLT 0
382 , specialOp ">" $ cmp OpGT 0
383 , specialOp "<=" $ cmp OpLT 1
384 , specialOp ">=" $ cmp OpGT (-1)
385 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
386 ]
388 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)