@@ -1,13 +1,12 @@
11module Generate.JavaScript where
22
3−import Control.Monad (liftM,(<=<),join,ap)
3+import Control.Applicative ((<$>))
44import Data.Char (isAlpha,isDigit)
55import qualified Data.List as List
66import qualified Data.Map as Map
77import qualified Data.Set as Set
88import Data.Either (partitionEithers)
99
10−
1110import Unique
1211import Generate.Cases
1312import SourceSyntax.Everything
@@ -19,7 +18,9 @@ import Parse.Helpers (makeSafe, iParse)
1918
2019import Parse.Expression
2120
22−testExpr str = (prettyPrint . expression) `fmap` iParse expr "" str
21+testExpr str = case iParse expr "" str of
22+ Right e -> prettyPrint (expression e)
23+ Left err -> error (show err)
2324
2425var name = Id () (makeSafe name)
2526ref name = VarRef () (var name)
@@ -65,14 +66,12 @@ expression (L span expr) =
6566 Access e x -> DotRef () (expression e) (var x)
6667 Remove e x -> dotSep ["_N","remove"] `call` [ref x, expression e]
6768 Insert e x v -> dotSep ["_N","insert"] `call` [ref x, expression v, expression e]
69+ Modify e fs ->
70+ let modify (f,v) = ArrayLit () [ref f, expression e]
71+ in dotSep ["_N","replace"] `call` [ArrayLit () (map modify fs), expression e]
72+
6873{--
69− Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
70− setField fs' `liftM` toJS' e
7174 Record fs -> makeRecord fs
72−
73−addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
74−setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
75− where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
7675makeRecord kvs = record `liftM` collect kvs
7776 where
7877 combine r (k,v) = Map.insertWith (++) k v r
@@ -96,7 +95,7 @@ makeRecord kvs = record `liftM` collect kvs
9695 | otherwise =
9796 ref ("F" ++ show (length args)) <| (args ==> expression body)
9897
99− (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
98+ (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
10099
101100 depattern (pattern,n) (args, body) =
102101 case pattern of
@@ -110,7 +109,7 @@ makeRecord kvs = record `liftM` collect kvs
110109 case expr of
111110 Lambda p e -> collect (p:patterns) e
112111 _ -> (patterns, lexpr)
113−--}
112+
114113 App e1 e2 ->
115114 case args of
116115 [arg] -> func <| arg
@@ -122,9 +121,11 @@ makeRecord kvs = record `liftM` collect kvs
122121 case func of
123122 (L _ (App f arg)) -> getArgs f (arg : args)
124123 _ -> (expression func, map expression args)
125−{--
126− Let defs e -> jsLet $ SD.flattenLets defs e
127−--}
124+
125+ Let defs e -> FuncExpr () Nothing [] stmts `call` []
126+ where
127+ (defs',e') = SD.flattenLets defs e
128+ stmts = map definition defs' ++ [ ReturnStmt () (Just (expression e')) ]
128129
129130 MultiIf branches ->
130131 case last branches of
@@ -148,6 +149,50 @@ makeRecord kvs = record `liftM` collect kvs
148149 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
149150--}
150151
152+definition def =
153+ case def of
154+ TypeAnnotation _ _ -> EmptyStmt ()
155+ Def pattern expr@(L span _) ->
156+ let assign x = VarDecl () (var x) (Just (expression expr)) in
157+ case pattern of
158+ PVar x
159+ | isOp x ->
160+ let op = LBracket () (ref "_op") (string x) in
161+ ExprStmt () (AssignExpr () OpAssign op (expression expr))
162+ | otherwise ->
163+ VarDeclStmt () [ assign x ]
164+
165+ PRecord fields -> VarDeclStmt () (assign "$" : map setField fields)
166+ where
167+ setField f = VarDecl () (var f) (Just (dotSep ["$",f]))
168+
169+ PData name patterns | vars /= Nothing ->
170+ case vars of
171+ Just vs -> VarDeclStmt () (setup (zipWith varDecl vs [0..]))
172+ where
173+ vars = getVars patterns
174+ getVars patterns =
175+ case patterns of
176+ PVar x : rest -> (x:) <$> getVars rest
177+ [] -> Just []
178+ _ -> Nothing
179+
180+ varDecl x n = VarDecl () (var x) (Just (dotSep ["$","_" ++ show n]))
181+ setup vars
182+ | isTuple name = assign "$" : vars
183+ | otherwise = safeAssign : vars
184+
185+ safeAssign = VarDecl () (var "$") (Just $ CondExpr () if' (expression expr) exception)
186+ if' = InfixExpr () OpStrictEq (dotSep ["$","ctor"]) (string name)
187+ exception = dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]
188+
189+ _ -> BlockStmt () ( VarDeclStmt () [assign "$"] : map toDef vars )
190+ where
191+ vars = Set.toList $ SD.boundVars pattern
192+ mkVar = L span . Var
193+ toDef y = definition $
194+ Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
195+--}
151196{--
152197
153198globalAssign n e = "\n" ++ assign' n e ++ ";"
@@ -216,50 +261,12 @@ jsImport (modul, method) =
216261 [] -> (reverse name, [])
217262
218263
219−class ToJS a where
220− toJS :: a -> Unique String
221−
222−
223−instance ToJS (Def t v) where
224−
225− -- TODO: Make this handle patterns besides plain variables
226− toJS (Def (PVar x) e)
227− | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
228− | otherwise = assign x `liftM` toJS' e
229−
230− toJS (Def pattern e@(L s _)) =
231− do n <- guid
232− let x = "_" ++ show n
233− var = L s . Var
234− toDef y = Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
235− stmt <- assign x `liftM` toJS' e
236− vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
237− return (stmt ++ vars)
238−
239− toJS (TypeAnnotation _ _) = return ""
240−
241−
242−instance ToJS a => ToJS [a] where
243− toJS xs = concat `liftM` mapM toJS xs
244−
245−toJS' :: LExpr t v -> Unique String
246−toJS' (L span expr) =
247− case expr of
248− Case e cases -> caseToJS span e cases
249− _ -> toJS expr
250−
251−
252−
253264formatMarkdown = concatMap f
254265 where f '\'' = "\\'"
255266 f '\n' = "\\n"
256267 f '"' = "\""
257268 f c = [c]
258269
259−jsLet (defs,e') = do ds <- mapM toJS defs
260− e <- toJS' e'
261− return $ jsFunc "" (concat ds ++ ret e) ++ "()"
262−
263270caseToJS span e ps = do
264271 (tempVar,match) <- caseToMatch ps
265272 e' <- toJS' e
@@ -303,9 +310,6 @@ clauseToJS span var (Clause value vars e) = do
303310 is -> drop (last is + 1) name
304311 return $ concat [ "\ncase ", pattern, ":", indent s ]
305312
306−jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
307−jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
308−
309313--}
310314binop span op e1 e2 =
311315 case op of
@@ -358,5 +362,4 @@ binop span op e1 e2 =
358362 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
359363 ]
360364
361− cmp op n a b = InfixExpr () op (dotSep ["_N","cmp"] `call` [a,b]) (IntLit () n)
362−--}
365+ cmp op n a b = InfixExpr () op (dotSep ["_N","cmp"] `call` [a,b]) (IntLit () n)