@@ -11,11 +11,10 @@ import qualified Generate.Cases as Case
1111import qualified Generate.Markdown as MD
1212import qualified SourceSyntax.Helpers as Help
1313import SourceSyntax.Literal
14−import SourceSyntax.Pattern
14+import SourceSyntax.Pattern as Pattern
1515import SourceSyntax.Location
1616import SourceSyntax.Expression
1717import SourceSyntax.Module
18−import qualified Transform.SortDefinitions as SD
1918import Language.ECMAScript3.Syntax
2019import Language.ECMAScript3.PrettyPrint
2120import qualified Transform.SafeNames as MakeSafe
@@ -67,7 +66,7 @@ literal lit =
6766 FloatNum n -> NumLit () n
6867 Boolean b -> BoolLit () b
6968
70−expression :: LExpr () () -> State Int (Expression ())
69+expression :: LExpr -> State Int (Expression ())
7170expression (L span expr) =
7271 case expr of
7372 Var x -> return $ ref x
@@ -148,7 +147,7 @@ expression (L span expr) =
148147 _ -> (func, args)
149148
150149 Let defs e ->
151− do let (defs',e') = SD.flattenLets defs e
150+ do let (defs',e') = flattenLets defs e
152151 stmts <- concat <$> mapM definition defs'
153152 exp <- expression e'
154153 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
@@ -192,56 +191,52 @@ expression (L span expr) =
192191 pad = "<div style=\"height:0;width:0;\"> </div>"
193192 md = pad ++ MD.toHtml doc ++ pad
194193
195−definition :: Def () () -> State Int [Statement ()]
196−definition def =
197− case def of
198− TypeAnnotation _ _ -> return []
199−
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 ] ]
210−
211− PRecord fields ->
212− let setField f = varDecl f (dotSep ["$",f]) in
213− return [ VarDeclStmt () (assign "$" : map setField fields) ]
214−
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
225−
226− decl x n = varDecl x (dotSep ["$","_" ++ show n])
227− setup vars
228− | Help.isTuple name = assign "$" : vars
229− | otherwise = assign "$raw" : safeAssign : vars
230−
231− safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
232− if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
233− exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
234−
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)])
243−
244−match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
194+definition :: Def -> State Int [Statement ()]
195+definition (Definition pattern expr@(L span _) _) = do
196+ expr' <- expression expr
197+ let assign x = varDecl x expr'
198+ case pattern of
199+ PVar x
200+ | Help.isOp x ->
201+ let op = LBracket () (ref "_op") (string x) in
202+ return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
203+ | otherwise ->
204+ return [ VarDeclStmt () [ assign x ] ]
205+
206+ PRecord fields ->
207+ let setField f = varDecl f (dotSep ["$",f]) in
208+ return [ VarDeclStmt () (assign "$" : map setField fields) ]
209+
210+ PData name patterns | vars /= Nothing ->
211+ case vars of
212+ Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
213+ where
214+ vars = getVars patterns
215+ getVars patterns =
216+ case patterns of
217+ PVar x : rest -> (x:) `fmap` getVars rest
218+ [] -> Just []
219+ _ -> Nothing
220+
221+ decl x n = varDecl x (dotSep ["$","_" ++ show n])
222+ setup vars
223+ | Help.isTuple name = assign "$" : vars
224+ | otherwise = assign "$raw" : safeAssign : vars
225+
226+ safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
227+ if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
228+ exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
229+
230+ _ ->
231+ do defs' <- concat <$> mapM toDef vars
232+ return (VarDeclStmt () [assign "$"] : defs')
233+ where
234+ vars = Set.toList $ Pattern.boundVars pattern
235+ mkVar = L span . Var
236+ toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
237+ in definition $ Definition (PVar y) expr Nothing
238+
239+match :: (Show a) => a -> Case.Match -> State Int [Statement ()]
245240match span mtch =
246241 case mtch of
247242 Case.Match name clauses mtch' ->
@@ -286,8 +281,12 @@ clause span variable (Case.Clause value vars mtch) =
286281 [] -> name
287282 is -> drop (last is + 1) name
288283
284+flattenLets defs lexpr@(L _ expr) =
285+ case expr of
286+ Let ds body -> flattenLets (defs ++ ds) body
287+ _ -> (defs, lexpr)
289288
290−generate :: MetadataModule () () -> String
289+generate :: MetadataModule -> String
291290generate unsafeModule =
292291 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
293292 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
@@ -299,10 +298,11 @@ generate unsafeModule =
299298 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
300299 , [ internalImports (List.intercalate "." (names modul)) ]
301300 , concatMap jsImport (imports modul)
302− , checkInPorts (ports modul)
303− , map jsPort (ports modul)
301+ , checkInPorts (recvPorts modul)
302+ , map inPort (recvPorts modul)
303+ , map outPort (sendPorts modul)
304304 , [ assign ["_op"] (ObjectLit () []) ]
305− , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
305+ , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
306306 , [ jsExports ]
307307 , [ ReturnStmt () (Just thisModule) ]
308308 ]
@@ -335,12 +335,15 @@ generate unsafeModule =
335335 checkInPorts ports =
336336 [ ExprStmt () $ obj "_N.checkPorts" `call` [ref "$moduleName", names] ]
337337 where
338− names = ArrayLit () [ string name | (name, _, Nothing) <- ports ]
338+ names = ArrayLit () [ string name | (name, _, _) <- ports ]
339+
340+ inPort (name, expr, _) =
341+ assign [name] $ obj "_N.inPort" `call` [ dotSep ["_elm","ports_in",name]
342+ , evalState (expression expr) 0 ]
339343
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
344+ outPort (name, expr, _) =
345+ let signal = evalState (expression expr) 0 in
346+ assign ["_elm","ports_out",name] signal
344347
345348binop span op e1 e2 =
346349 case op of