@@ -33,6 +33,7 @@ ref name = VarRef () (var name)
3333prop name = PropId () (var name)
3434f <| x = CallExpr () f [x]
3535args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
36+function args stmts = FuncExpr () Nothing (map var args) stmts
3637call = CallExpr ()
3738string = StringLit ()
3839
@@ -123,10 +124,10 @@ expression (L span expr) =
123124 (L _ (App f arg)) -> getArgs f (arg : args)
124125 _ -> (expression func, map expression args)
125126
126− Let defs e -> FuncExpr () Nothing [] stmts `call` []
127+ Let defs e -> function [] stmts `call` []
127128 where
128129 (defs',e') = SD.flattenLets defs e
129− stmts = map definition defs' ++ [ ReturnStmt () (Just (expression e')) ]
130+ stmts = concatMap definition defs' ++ [ ReturnStmt () (Just (expression e')) ]
130131
131132 MultiIf branches ->
132133 case last branches of
@@ -136,14 +137,13 @@ expression (L span expr) =
136137 ifs branches finally = foldr iff finally branches
137138 iff (if', then') else' = CondExpr () (expression if') (expression then') else'
138139
139− Case e cases -> FuncExpr () Nothing [] (stmt ++ match span revisedMatch) `call` []
140+ Case e cases -> function [] (stmt ++ match span revisedMatch) `call` []
140141 where
141142 (tempVar,initialMatch) = caseToMatch cases
142143 (revisedMatch, stmt) =
143144 case e of
144145 L _ (Var x) -> (matchSubst [(tempVar,x)] initialMatch, [])
145− _ -> let decl = VarDecl () (var tempVar) (Just $ expression e)
146− in (initialMatch, [VarDeclStmt () [decl]])
146+ _ -> (initialMatch, [VarDeclStmt () [varDecl tempVar (expression e)]])
147147
148148 ExplicitList es ->
149149 get "_J.toList" <| ArrayLit () (map expression es)
@@ -161,24 +161,24 @@ expression (L span expr) =
161161
162162definition def =
163163 case def of
164− TypeAnnotation _ _ -> EmptyStmt ()
164+ TypeAnnotation _ _ -> []
165165 Def pattern expr@(L span _) ->
166− let assign x = VarDecl () (var x) (Just (expression expr)) in
166+ let assign x = varDecl x (expression expr) in
167167 case pattern of
168168 PVar x
169169 | isOp x ->
170170 let op = LBracket () (ref "_op") (string x) in
171− ExprStmt () (AssignExpr () OpAssign op (expression expr))
171+ [ ExprStmt () (AssignExpr () OpAssign op (expression expr)) ]
172172 | otherwise ->
173− VarDeclStmt () [ assign x ]
173+ [ VarDeclStmt () [ assign x ] ]
174174
175− PRecord fields -> VarDeclStmt () (assign "$" : map setField fields)
175+ PRecord fields -> [ VarDeclStmt () (assign "$" : map setField fields) ]
176176 where
177− setField f = VarDecl () (var f) (Just $ dotSep ["$",f])
177+ setField f = varDecl f (dotSep ["$",f])
178178
179179 PData name patterns | vars /= Nothing ->
180180 case vars of
181− Just vs -> VarDeclStmt () (setup (zipWith varDecl vs [0..]))
181+ Just vs -> [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
182182 where
183183 vars = getVars patterns
184184 getVars patterns =
@@ -187,16 +187,16 @@ definition def =
187187 [] -> Just []
188188 _ -> Nothing
189189
190− varDecl x n = VarDecl () (var x) (Just (dotSep ["$","_" ++ show n]))
190+ decl x n = varDecl x (dotSep ["$","_" ++ show n])
191191 setup vars
192192 | isTuple name = assign "$" : vars
193193 | otherwise = safeAssign : vars
194194
195− safeAssign = VarDecl () (var "$") (Just $ CondExpr () if' (expression expr) exception)
195+ safeAssign = varDecl "$" (CondExpr () if' (expression expr) exception)
196196 if' = InfixExpr () OpStrictEq (get "$.ctor") (string name)
197197 exception = get "_E.Case" `call` [ref "$moduleName", string (show span)]
198198
199− _ -> BlockStmt () ( VarDeclStmt () [assign "$"] : map toDef vars )
199+ _ -> VarDeclStmt () [assign "$"] : concatMap toDef vars
200200 where
201201 vars = Set.toList $ SD.boundVars pattern
202202 mkVar = L span . Var
@@ -235,62 +235,71 @@ clause span variable (Clause value vars mtch) =
235235 Left name -> string $ case List.elemIndices '.' name of
236236 [] -> name
237237 is -> drop (last is + 1) name
238−--}
239−{--
240−
241−jsModule :: MetadataModule t v -> String
242−jsModule modul =
243− run $ do
244− body <- toJS . fst . SD.flattenLets [] $ program modul
245− foreignImport <- mapM importEvent (foreignImports modul)
246− return $ concat [ setup ("Elm" : names modul)
247− , globalAssign ("Elm." ++ modName)
248− (jsFunc "elm" $ makeProgram body foreignImport) ]
238+
239+jsModule :: MetadataModule () () -> [Statement ()]
240+jsModule modul = setup ("Elm" : names modul) ++
241+ [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]
249242 where
250− modName = dotSep (names modul)
251− makeProgram body foreignImport =
243+ thisModule = dotSep ("elm" : names modul)
244+ programStmts =
252245 concat [ setup ("elm" : names modul)
253− , "\nif (elm." ++ modName ++ ") return elm." ++ modName ++ ";"
254− , "\nvar " ++ usefulFuncs ++ ";"
246+ , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
247+ , [ internalImports (List.intercalate "." (names modul)) ]
255248 , concatMap jsImport (imports modul)
256− , concat foreignImport
257− , assign "_op" "{}"
258− , body
259− , concatMap exportEvent $ foreignExports modul
260− , jsExports
249+ , concatMap importEvent (foreignImports modul)
250+ , [ assign ["_op"] (ObjectLit () []) ]
251+ , concatMap definition . fst . SD.flattenLets [] $ program modul
252+ , map exportEvent $ foreignExports modul
253+ , [ jsExports ]
254+ , [ ReturnStmt () (Just thisModule) ]
261255 ]
262− setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
263− map dotSep . drop 2 . List.inits $ init names
264− usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))
265256
266− jsExports = ret (assign' ("elm." ++ modName) (brackets exs))
257+ jsExports = assign ("elm" : names modul) (ObjectLit () exs)
258+ where
259+ exs = map entry . filter (not . isOp) $ "_op" : exports modul
260+ entry x = (PropId () (var x), ref x)
261+
262+ assign path expr =
263+ ExprStmt () $
264+ flip (AssignExpr () OpAssign) expr $
265+ case path of
266+ [x] -> LVar () x
267+ _ -> LDot () (dotSep (init path)) (last path)
268+
269+ jsImport (modul,_) = setup path ++ [ assign path (dotSep path <| ref "elm") ]
270+ where
271+ path = split modul
272+
273+ setup path = map create paths
267274 where
268− exs = indent . commaSep . concatMap pair $ "_op" : exports modul
269− pair x | isOp x = []
270− | otherwise = ["\n" ++ x ++ " : " ++ x]
275+ create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
276+ paths = drop 2 . init $ List.inits path
271277
278+ addId js = InfixExpr () OpAdd (string (js++"_")) (get "elm.id")
272279
273280 importEvent (js,base,elm,_) =
274− do v <- toJS' base
275− return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
276− , "\ndocument.addEventListener('", js
277− , "_' + elm.id, function(e) { elm.notify(", elm
278− , ".id, e.value); });" ]
281+ [ VarDeclStmt () [ varDecl elm $ get "Signal.constant" <| expression base ]
282+ , ExprStmt () $
283+ get "document.addEventListener" `call`
284+ [ addId js
285+ , function ["e"]
286+ [ ExprStmt () $ get "elm.notify" `call` [dotSep [elm,"id"], get "e.value"] ]
287+ ]
288+ ]
279289
280290 exportEvent (js,elm,_) =
281− concat [ "\nA2( Signal.lift, function(v) { "
282− , "var e = document.createEvent('Event');"
283− , "e.initEvent('", js, "_' + elm.id, true, true);"
284− , "e.value = v;"
285− , "document.dispatchEvent(e); return v; }, ", elm, ");" ]
286−--}
287−jsImport (modul, _) = map (ExprStmt ()) exprs
288− where
289− assign name = AssignExpr () OpAssign (LDot () (dotSep (init name)) (last name))
290− setup name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
291− exprs = map setup (drop 2 . init $ List.inits path) ++
292− [ assign path (dotSep path <| ref "elm") ]
293− path = split modul
291+ ExprStmt () $
292+ ref "A2" `call`
293+ [ get "Signal.lift"
294+ , function ["v"]
295+ [ VarDeclStmt () [varDecl "e" $ get "document.createEvent" <| string "Event"]
296+ , ExprStmt () $
297+ get "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
298+ , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
299+ , ExprStmt () $ get "document.dispatchEvent" <| ref "e"
300+ , ReturnStmt () (Just $ ref "v")
301+ ]
302+ , ref elm ]
294303
295304
296305binop span op e1 e2 =