c04c438 · elk · git.iko.soy

11import qualified Generate.Markdown as MD

12import qualified SourceSyntax.Helpers as Help

13import SourceSyntax.Literal

14−import SourceSyntax.Pattern

14+import SourceSyntax.Pattern as Pattern

15import SourceSyntax.Location

16import SourceSyntax.Expression

17import SourceSyntax.Module

18−import qualified Transform.SortDefinitions as SD

19import Language.ECMAScript3.Syntax

18import Language.ECMAScript3.Syntax

20import Language.ECMAScript3.PrettyPrint

19import Language.ECMAScript3.PrettyPrint

21import qualified Transform.SafeNames as MakeSafe

20import qualified Transform.SafeNames as MakeSafe

67 FloatNum n -> NumLit () n

66 FloatNum n -> NumLit () n

68 Boolean b -> BoolLit () b

67 Boolean b -> BoolLit () b

69

68

70−expression :: LExpr () () -> State Int (Expression ())

69+expression :: LExpr -> State Int (Expression ())

71expression (L span expr) =

70expression (L span expr) =

72 case expr of

71 case expr of

73 Var x -> return $ ref x

72 Var x -> return $ ref x

148 _ -> (func, args)

147 _ -> (func, args)

149

148

150 Let defs e ->

149 Let defs e ->

151− do let (defs',e') = SD.flattenLets defs e

150+ do let (defs',e') = flattenLets defs e

152 stmts <- concat <$> mapM definition defs'

151 stmts <- concat <$> mapM definition defs'

153 exp <- expression e'

152 exp <- expression e'

154 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []

153 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []

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

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

193 md = pad ++ MD.toHtml doc ++ pad

192 md = pad ++ MD.toHtml doc ++ pad

194

193

195−definition :: Def () () -> State Int [Statement ()]

194+definition :: Def -> State Int [Statement ()]

196−definition def =

197− case def of

198− TypeAnnotation _ _ -> return []

199−

200− Def pattern expr@(L span _) -> do

195+definition (Definition pattern expr@(L span _) _) = do

201− expr' <- expression expr

196+ expr' <- expression expr

202− let assign x = varDecl x expr'

197+ let assign x = varDecl x expr'

203− case pattern of

198+ case pattern of

204− PVar x

199+ PVar x

205− | Help.isOp x ->

200+ | Help.isOp x ->

206− let op = LBracket () (ref "_op") (string x) in

201+ let op = LBracket () (ref "_op") (string x) in

207− return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

202+ return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

208− | otherwise ->

203+ | otherwise ->

209− return [ VarDeclStmt () [ assign x ] ]

204+ return [ VarDeclStmt () [ assign x ] ]

210−

205+

211− PRecord fields ->

206+ PRecord fields ->

212− let setField f = varDecl f (dotSep ["$",f]) in

207+ let setField f = varDecl f (dotSep ["$",f]) in

213− return [ VarDeclStmt () (assign "$" : map setField fields) ]

208+ return [ VarDeclStmt () (assign "$" : map setField fields) ]

214−

209+

215− PData name patterns | vars /= Nothing ->

210+ PData name patterns | vars /= Nothing ->

216− case vars of

211+ case vars of

217− Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]

212+ Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]

218− where

213+ where

219− vars = getVars patterns

214+ vars = getVars patterns

220− getVars patterns =

215+ getVars patterns =

221− case patterns of

216+ case patterns of

222− PVar x : rest -> (x:) `fmap` getVars rest

217+ PVar x : rest -> (x:) `fmap` getVars rest

223− [] -> Just []

218+ [] -> Just []

224− _ -> Nothing

219+ _ -> Nothing

225−

220+

226− decl x n = varDecl x (dotSep ["$","_" ++ show n])

221+ decl x n = varDecl x (dotSep ["$","_" ++ show n])

227− setup vars

222+ setup vars

228− | Help.isTuple name = assign "$" : vars

223+ | Help.isTuple name = assign "$" : vars

229− | otherwise = assign "$raw" : safeAssign : vars

224+ | otherwise = assign "$raw" : safeAssign : vars

230−

225+

231− safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)

226+ safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)

232− if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)

227+ if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)

233− exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]

228+ exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]

234−

229+

235− _ ->

230+ _ ->

236− do defs' <- concat <$> mapM toDef vars

231+ do defs' <- concat <$> mapM toDef vars

237− return (VarDeclStmt () [assign "$"] : defs')

232+ return (VarDeclStmt () [assign "$"] : defs')

238− where

233+ where

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

234+ vars = Set.toList $ Pattern.boundVars pattern

240− mkVar = L span . Var

235+ mkVar = L span . Var

241− toDef y = definition $

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

236+ toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]

243−

237+ in definition $ Definition (PVar y) expr Nothing

238+

244−match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]

239+match :: (Show a) => a -> Case.Match -> State Int [Statement ()]

245match span mtch =

240match span mtch =

246 case mtch of

241 case mtch of

247 Case.Match name clauses mtch' ->

242 Case.Match name clauses mtch' ->

286 [] -> name

281 [] -> name

287 is -> drop (last is + 1) name

282 is -> drop (last is + 1) name

288

283

284+flattenLets defs lexpr@(L _ expr) =

285+ case expr of

286+ Let ds body -> flattenLets (defs ++ ds) body

287+ _ -> (defs, lexpr)

289

288

290−generate :: MetadataModule () () -> String

289+generate :: MetadataModule -> String

291generate unsafeModule =

290generate unsafeModule =

292 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

291 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

293 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

292 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

299 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]

298 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]

300 , [ internalImports (List.intercalate "." (names modul)) ]

299 , [ internalImports (List.intercalate "." (names modul)) ]

301 , concatMap jsImport (imports modul)

300 , concatMap jsImport (imports modul)

302− , checkInPorts (ports modul)

301+ , checkInPorts (recvPorts modul)

303− , map jsPort (ports modul)

302+ , map inPort (recvPorts modul)

303+ , map outPort (sendPorts modul)

304 , [ assign ["_op"] (ObjectLit () []) ]

305− , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0

305+ , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0

306 , [ jsExports ]

307 , [ ReturnStmt () (Just thisModule) ]

308 ]

335 checkInPorts ports =

336 [ ExprStmt () $ obj "_N.checkPorts" `call` [ref "$moduleName", names] ]

337 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 ]

339

343

340− jsPort (name, _, maybe) =

344+ outPort (name, expr, _) =

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

345+ let signal = evalState (expression expr) 0 in

346+ assign ["_elm","ports_out",name] signal

344

347

345binop span op e1 e2 =

348binop span op e1 e2 =

346 case op of

349 case op of