394d398 · elk · git.iko.soy

1module Generate.JavaScript where

2

3import Control.Applicative ((<$>))

4−import Data.Char (isAlpha,isDigit)

4+import Control.Arrow ((***))

5import qualified Data.List as List

6import qualified Data.Map as Map

7import qualified Data.Set as Set

8import Data.Either (partitionEithers)

9

10−import Unique

11import Generate.Cases

10import Generate.Cases

12import SourceSyntax.Everything

11import SourceSyntax.Everything

13import SourceSyntax.Location

12import SourceSyntax.Location

19import Parse.Expression

18import Parse.Expression

20

19

21testExpr str = case iParse expr "" str of

20testExpr str = case iParse expr "" str of

22− Right e -> prettyPrint (expression e)

21+ Right e -> prettyPrint (expression (e :: LExpr () ()))

23 Left err -> error (show err)

22 Left err -> error (show err)

24

23

25var name = Id () (makeSafe name)

24var name = Id () (makeSafe name)

57-- FloatNum n -> NumLit () (float2Double n) -- wrong!!!

56-- FloatNum n -> NumLit () (float2Double n) -- wrong!!!

58 Boolean b -> BoolLit () b

57 Boolean b -> BoolLit () b

59

58

59+expression :: LExpr () () -> Expression ()

60expression (L span expr) =

61 case expr of

62 Var x -> ref x

70 let modify (f,v) = ArrayLit () [ref f, expression e]

71 in dotSep ["_N","replace"] `call` [ArrayLit () (map modify fs), expression e]

72

73−{--

73+ Record fields -> ObjectLit () $ (PropId () (var "_"), hidden) : visible

74− Record fs -> makeRecord fs

75−makeRecord kvs = record `liftM` collect kvs

76− where

74+ where

77− combine r (k,v) = Map.insertWith (++) k v r

75+ combine r (k,v) = Map.insertWith (++) k [v] r

78− collect = liftM (List.foldl' combine Map.empty) . mapM prep

76+ fieldMap = List.foldl' combine Map.empty fields

79− prep (k, e) =

77+ hidden = ObjectLit () . map ((PropId () . var) *** (ArrayLit () . map expression)) .

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

78+ Map.toList . Map.filter (not . null) $ Map.map tail fieldMap

86− record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs

79+ visible = map ((PropId () . var) *** expression) . Map.toList $ Map.map head fieldMap

87−--}

80+

88 Binop op e1 e2 -> binop span op e1 e2

81 Binop op e1 e2 -> binop span op e1 e2

89

82

90 Lambda p e@(L s _) -> fastFunc

83 Lambda p e@(L s _) -> fastFunc

135 ifs branches finally = foldr iff finally branches

128 ifs branches finally = foldr iff finally branches

136 iff (if', then') else' = CondExpr () (expression if') (expression then') else'

129 iff (if', then') else' = CondExpr () (expression if') (expression then') else'

137

130

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+

138 ExplicitList es ->

140 ExplicitList es ->

139 dotSep ["_J","toList"] <| ArrayLit () (map expression es)

141 dotSep ["_J","toList"] <| ArrayLit () (map expression es)

140

142

187 exception = dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]

189 exception = dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]

188

190

189 _ -> BlockStmt () ( VarDeclStmt () [assign "$"] : map toDef vars )

191 _ -> BlockStmt () ( VarDeclStmt () [assign "$"] : map toDef vars )

190− where

192+ where

191− vars = Set.toList $ SD.boundVars pattern

193+ vars = Set.toList $ SD.boundVars pattern

192− mkVar = L span . Var

194+ mkVar = L span . Var

193− toDef y = definition $

195+ toDef y = definition $

194 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])

196 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])

195--}

197--}

196−{--

197

198

198−globalAssign n e = "\n" ++ assign' n e ++ ";"

199+match span mtch =

199−assign' n e = n ++ " = " ++ e

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+{--

200

233

201jsModule :: MetadataModule t v -> String

234jsModule :: MetadataModule t v -> String

202jsModule modul =

235jsModule modul =

266 f '\n' = "\\n"

299 f '\n' = "\\n"

267 f '"' = "\""

300 f '"' = "\""

268 f c = [c]

301 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−

313--}

302--}

314binop span op e1 e2 =

303binop span op e1 e2 =

315 case op of

304 case op of