@@ -1,13 +1,12 @@
11module Generate.JavaScript where
22
33import Control.Applicative ((<$>))
4−import Data.Char (isAlpha,isDigit)
4+import Control.Arrow ((***))
55import qualified Data.List as List
66import qualified Data.Map as Map
77import qualified Data.Set as Set
88import Data.Either (partitionEithers)
99
10−import Unique
1110import Generate.Cases
1211import SourceSyntax.Everything
1312import SourceSyntax.Location
@@ -19,7 +18,7 @@ import Parse.Helpers (makeSafe, iParse)
1918import Parse.Expression
2019
2120testExpr str = case iParse expr "" str of
22− Right e -> prettyPrint (expression e)
21+ Right e -> prettyPrint (expression (e :: LExpr () ()))
2322 Left err -> error (show err)
2423
2524var name = Id () (makeSafe name)
@@ -57,6 +56,7 @@ literal lit =
5756-- FloatNum n -> NumLit () (float2Double n) -- wrong!!!
5857 Boolean b -> BoolLit () b
5958
59+expression :: LExpr () () -> Expression ()
6060expression (L span expr) =
6161 case expr of
6262 Var x -> ref x
@@ -70,21 +70,14 @@ expression (L span expr) =
7070 let modify (f,v) = ArrayLit () [ref f, expression e]
7171 in dotSep ["_N","replace"] `call` [ArrayLit () (map modify fs), expression e]
7272
73−{--
74− Record fs -> makeRecord fs
75−makeRecord kvs = record `liftM` collect kvs
76− where
77− combine r (k,v) = Map.insertWith (++) k v r
78− collect = liftM (List.foldl' combine Map.empty) . mapM prep
79− prep (k, e) =
80− do v <- toJS' e
81− return (k, [v])
82− fields fs =
83− brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
84− hidden = fields . map (second jsList) .
85− filter (not . null . snd) . Map.toList . Map.map tail
86− record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
87−--}
73+ Record fields -> ObjectLit () $ (PropId () (var "_"), hidden) : visible
74+ where
75+ combine r (k,v) = Map.insertWith (++) k [v] r
76+ fieldMap = List.foldl' combine Map.empty fields
77+ hidden = ObjectLit () . map ((PropId () . var) *** (ArrayLit () . map expression)) .
78+ Map.toList . Map.filter (not . null) $ Map.map tail fieldMap
79+ visible = map ((PropId () . var) *** expression) . Map.toList $ Map.map head fieldMap
80+
8881 Binop op e1 e2 -> binop span op e1 e2
8982
9083 Lambda p e@(L s _) -> fastFunc
@@ -135,6 +128,15 @@ makeRecord kvs = record `liftM` collect kvs
135128 ifs branches finally = foldr iff finally branches
136129 iff (if', then') else' = CondExpr () (expression if') (expression then') else'
137130
131+ Case e cases -> FuncExpr () Nothing [] (stmt ++ match span revisedMatch) `call` []
132+ where
133+ (tempVar,initialMatch) = caseToMatch cases
134+ (revisedMatch, stmt) =
135+ case e of
136+ L _ (Var x) -> (matchSubst [(tempVar,x)] initialMatch, [])
137+ _ -> let decl = VarDecl () (var tempVar) (Just $ expression e)
138+ in (initialMatch, [VarDeclStmt () [decl]])
139+
138140 ExplicitList es ->
139141 dotSep ["_J","toList"] <| ArrayLit () (map expression es)
140142
@@ -187,16 +189,47 @@ definition def =
187189 exception = dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]
188190
189191 _ -> BlockStmt () ( VarDeclStmt () [assign "$"] : map toDef vars )
190− where
191− vars = Set.toList $ SD.boundVars pattern
192− mkVar = L span . Var
193− toDef y = definition $
192+ where
193+ vars = Set.toList $ SD.boundVars pattern
194+ mkVar = L span . Var
195+ toDef y = definition $
194196 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
195197--}
196−{--
197198
198−globalAssign n e = "\n" ++ assign' n e ++ ";"
199−assign' n e = n ++ " = " ++ e
199+match span mtch =
200+ case mtch of
201+ Match name clauses mtch' -> SwitchStmt () (access name) clauses' : match span mtch'
202+ where
203+ clauses' = map (clause span name) clauses
204+ isLiteral p = case p of
205+ Clause (Right _) _ _ -> True
206+ _ -> False
207+ access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
208+
209+ Fail -> [ ExprStmt () (dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]) ]
210+ Break -> []
211+ Other e -> [ ReturnStmt () (Just $ expression e) ]
212+ Seq ms -> concatMap (match span) (dropEnd [] ms)
213+ where
214+ dropEnd acc [] = acc
215+ dropEnd acc (m:ms) =
216+ case m of
217+ Other _ -> acc ++ [m]
218+ _ -> dropEnd (acc ++ [m]) ms
219+
220+clause span variable (Clause value vars mtch) =
221+ CaseClause () pattern stmt
222+ where
223+ vars' = map (\n -> variable ++ "._" ++ show n) [0..]
224+ stmt = match span $ matchSubst (zip vars vars') mtch
225+ pattern = case value of
226+ Right (Boolean b) -> BoolLit () b
227+ Right lit -> literal lit
228+ Left name -> string $ case List.elemIndices '.' name of
229+ [] -> name
230+ is -> drop (last is + 1) name
231+--}
232+{--
200233
201234jsModule :: MetadataModule t v -> String
202235jsModule modul =
@@ -266,50 +299,6 @@ formatMarkdown = concatMap f
266299 f '\n' = "\\n"
267300 f '"' = "\""
268301 f c = [c]
269−
270−caseToJS span e ps = do
271− (tempVar,match) <- caseToMatch ps
272− e' <- toJS' e
273− let (match',stmt) = case e of
274− L _ (Var x) -> (matchSubst [(tempVar,x)] match, "")
275− _ -> (match, assign tempVar e')
276− matches <- matchToJS span match'
277− return $ jsFunc "" (stmt ++ matches) ++ "()"
278−
279−matchToJS span match =
280− case match of
281− Match name clauses def ->
282− do cases <- concat `liftM` mapM (clauseToJS span name) clauses
283− finally <- matchToJS span def
284− let isLiteral p = case p of
285− Clause (Right _) _ _ -> True
286− _ -> False
287− access = if any isLiteral clauses then "" else ".ctor"
288− return $ concat [ "\nswitch (", name, access, ") {"
289− , indent cases, "\n}", finally ]
290− Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))
291− Break -> return "break;"
292− Other e -> ret `liftM` toJS' e
293− Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
294− where
295− dropEnd acc [] = acc
296− dropEnd acc (m:ms) =
297− case m of
298− Other _ -> acc ++ [m]
299− _ -> dropEnd (acc ++ [m]) ms
300−
301−clauseToJS span var (Clause value vars e) = do
302− let vars' = map (\n -> var ++ "._" ++ show n) [0..]
303− s <- matchToJS span $ matchSubst (zip vars vars') e
304− pattern <- case value of
305− Right (Boolean True) -> return "true"
306− Right (Boolean False) -> return "false"
307− Right lit -> toJS lit
308− Left name -> return . quoted $ case List.elemIndices '.' name of
309− [] -> name
310− is -> drop (last is + 1) name
311− return $ concat [ "\ncase ", pattern, ":", indent s ]
312−
313302--}
314303binop span op e1 e2 =
315304 case op of