c136ea7 · elk · git.iko.soy

1−module CompileToJS (showErr, jsModule) where

1+ module CompileToJS (showErr, jsModule) where

2

3import Control.Arrow (first,second)

4import Control.Monad (liftM,(<=<),join,ap)

99stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)

100 return (vars ++ concat program)

101 where

102− vars = "\nvar " ++ intercalate "," (letBoundVars stmts) ++ ";"

102+ vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"

103 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)

104 valueOf s = case s of

105 Datatype _ _ _ -> 1

116

117instance ToJS Def where

118 toJS (FnDef x [] e) = assign' x `liftM` toJS' e

119− toJS (FnDef f (a:as) e) =

119+ toJS (FnDef f as e) = (assign' f . wrapper . func) `liftM` toJS' e

120− do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e as)

120+ where func body = jsFunc (intercalate ", " as) (ret body)

121− return $ assign' f (jsFunc a (ret body))

121+ wrapper e | length as == 1 = e

122+ | otherwise = 'F' : show (length as) ++ parens e

122 toJS (OpDef op a1 a2 e) =

123 toJS (OpDef op a1 a2 e) =

123− do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e [a1,a2])

124+ do body <- toJS' e

125+ let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))

124− return $ concat [ "\n$op['", op, "'] = ", body, ";" ]

126+ return (globalAssign ("$op['" ++ op ++ "']") func)

125

127

126instance ToJS Statement where

128instance ToJS Statement where

127 toJS stmt =

129 toJS stmt =

203

205

204 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)

206 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)

205

207

206− App (C _ _ (Var "toText")) (C _ _ (Str s)) ->

208+ App e1 e2 -> jsApp e1 e2

207− return $ "toText" ++ parens (quoted s)

208−

209− App (C _ _ (Var "link")) (C _ _ (Str s)) ->

210− return $ "link(" ++ quoted s ++ ")"

211−

212− App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->

213− return $ "plainText(" ++ quoted s ++ ")"

214−

215− App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)

216 Let defs e -> jsLet defs e

209 Let defs e -> jsLet defs e

217 Data name es ->

210 Data name es ->

218 do fs <- mapM toJS' es

211 do fs <- mapM toJS' es

223 where pad = "<div style=\"height:0;width:0;\"> </div>"

216 where pad = "<div style=\"height:0;width:0;\"> </div>"

224 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc

217 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc

225

218

219+jsApp e1 e2 =

220+ do f <- toJS' func

221+ as <- mapM toJS' args

222+ return $ case as of

223+ [a] -> f ++ parens a

224+ _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))

225+ where

226+ (func, args) = go [e2] e1

227+ go args e =

228+ case e of

229+ (C _ _ (App e1 e2)) -> go (e2 : args) e1

230+ _ -> (e, args)

231+

226formatMarkdown = concatMap f

232formatMarkdown = concatMap f

227 where f '\'' = "\\'"

233 where f '\'' = "\\'"

228 f '\n' = "\\n"

234 f '\n' = "\\n"

255 match <- caseToMatch ps

261 match <- caseToMatch ps

256 e' <- toJS' e

262 e' <- toJS' e

257 (match',stmt) <- case (match,e) of

263 (match',stmt) <- case (match,e) of

264+ (Match name _ _, C _ _ (Var x)) ->

258− (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")

265+ return (matchSubst [(name,x)] match, Nothing)

266+ (Match name _ _, _) ->

259− (Match name _ _, _) -> return (match, assign name e')

267+ return (match, Just (name ++ " = " ++ e'))

260− _ -> liftM (\n -> (match, e')) guid

268+ _ -> return (match, Nothing) -- Just e'

261 matches <- matchToJS span match'

269 matches <- matchToJS span match'

262− return $ concat [ "function(){", stmt, matches, "}()" ]

270+ return $ case stmt of

263−

271+ Nothing -> matches

272+ Just exp -> parens (exp ++ ", " ++ matches)

273+

274+matchToJS span match =

275+ let sqnc e1 e2 = parens ("e = " ++ e1 ++ " : null, " ++ "e !== null ? e : " ++ e2)

276+ in case match of

264−matchToJS span (Match name clauses def) = do

277+ Match name clauses def ->

265− cases <- concat `liftM` mapM (clauseToJS span name) clauses

278+ do cases <- intercalate " : " `liftM` mapM (clauseToJS span name) clauses

266− finally <- matchToJS span def

279+ finally <- matchToJS span def

267− return $ concat [ "\nswitch(", name, ".ctor){", indent cases, "\n}", finally ]

280+ return (sqnc cases finally)

268−matchToJS span Fail =

269− return ("\nthrow new Error(\"Non-exhaustive pattern match " ++

281+ Fail -> return ("throw new Error(\"Non-exhaustive pattern match " ++

270− "in case expression (" ++ show span ++ ")\");")

282+ "in case expression (" ++ show span ++ ")\")")

271−matchToJS span Break = return "break;"

283+ Break -> return "null"

272−matchToJS span (Other e) = ret `liftM` toJS' e

284+ Other e -> toJS' e

273−matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms

285+ Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)

286+ where dropEnd acc [] = acc

287+ dropEnd acc (m:ms) =

288+ case m of

289+ Other _ -> acc ++ [m]

290+ _ -> dropEnd (acc ++ [m]) ms

291+

274

292

275clauseToJS span var (Clause name vars e) = do

293clauseToJS span var (Clause name vars e) = do

276− let vars' = map (\n -> var ++ "._" ++ show n) [ 1 .. length vars ]

294+ let vars' = map (\n -> var ++ "._" ++ show n) [0..]

277 s <- matchToJS span $ matchSubst (zip vars vars') e

295 s <- matchToJS span $ matchSubst (zip vars vars') e

278− return $ concat [ "\ncase ", quoted name, ":", s ]

296+ return $ concat [ var, ".ctor === ", quoted name, " ? ", s ]

279

297

280jsNil = "{ctor:'Nil'}"

298jsNil = "{ctor:'Nil'}"

281jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"

299jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"