966e725 · elk · git.iko.soy

33prop name = PropId () (var name)

34f <| x = CallExpr () f [x]

35args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]

36+function args stmts = FuncExpr () Nothing (map var args) stmts

36call = CallExpr ()

37call = CallExpr ()

37string = StringLit ()

38string = StringLit ()

38

39

123 (L _ (App f arg)) -> getArgs f (arg : args)

124 (L _ (App f arg)) -> getArgs f (arg : args)

124 _ -> (expression func, map expression args)

125 _ -> (expression func, map expression args)

125

126

126− Let defs e -> FuncExpr () Nothing [] stmts `call` []

127+ Let defs e -> function [] stmts `call` []

127 where

128 where

128 (defs',e') = SD.flattenLets defs e

129 (defs',e') = SD.flattenLets defs e

129− stmts = map definition defs' ++ [ ReturnStmt () (Just (expression e')) ]

130+ stmts = concatMap definition defs' ++ [ ReturnStmt () (Just (expression e')) ]

130

131

131 MultiIf branches ->

132 MultiIf branches ->

132 case last branches of

133 case last branches of

136 ifs branches finally = foldr iff finally branches

137 ifs branches finally = foldr iff finally branches

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

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

138

139

139− Case e cases -> FuncExpr () Nothing [] (stmt ++ match span revisedMatch) `call` []

140+ Case e cases -> function [] (stmt ++ match span revisedMatch) `call` []

140 where

141 where

141 (tempVar,initialMatch) = caseToMatch cases

142 (tempVar,initialMatch) = caseToMatch cases

142 (revisedMatch, stmt) =

143 (revisedMatch, stmt) =

143 case e of

144 case e of

144 L _ (Var x) -> (matchSubst [(tempVar,x)] initialMatch, [])

145 L _ (Var x) -> (matchSubst [(tempVar,x)] initialMatch, [])

145− _ -> let decl = VarDecl () (var tempVar) (Just $ expression e)

146− in (initialMatch, [VarDeclStmt () [decl]])

146+ _ -> (initialMatch, [VarDeclStmt () [varDecl tempVar (expression e)]])

147

148 ExplicitList es ->

149 get "_J.toList" <| ArrayLit () (map expression es)

161

162definition def =

163 case def of

164− TypeAnnotation _ _ -> EmptyStmt ()

164+ TypeAnnotation _ _ -> []

165 Def pattern expr@(L span _) ->

166− let assign x = VarDecl () (var x) (Just (expression expr)) in

166+ let assign x = varDecl x (expression expr) in

167 case pattern of

168 PVar x

169 | isOp x ->

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

171− ExprStmt () (AssignExpr () OpAssign op (expression expr))

171+ [ ExprStmt () (AssignExpr () OpAssign op (expression expr)) ]

172 | otherwise ->

173− VarDeclStmt () [ assign x ]

173+ [ VarDeclStmt () [ assign x ] ]

174

175− PRecord fields -> VarDeclStmt () (assign "$" : map setField fields)

175+ PRecord fields -> [ VarDeclStmt () (assign "$" : map setField fields) ]

176 where

177− setField f = VarDecl () (var f) (Just $ dotSep ["$",f])

177+ setField f = varDecl f (dotSep ["$",f])

178

179 PData name patterns | vars /= Nothing ->

180 case vars of

181− Just vs -> VarDeclStmt () (setup (zipWith varDecl vs [0..]))

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

182 where

183 vars = getVars patterns

184 getVars patterns =

187 [] -> Just []

188 _ -> Nothing

189

190− varDecl x n = VarDecl () (var x) (Just (dotSep ["$","_" ++ show n]))

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

191 setup vars

192 | isTuple name = assign "$" : vars

193 | otherwise = safeAssign : vars

194

195− safeAssign = VarDecl () (var "$") (Just $ CondExpr () if' (expression expr) exception)

195+ safeAssign = varDecl "$" (CondExpr () if' (expression expr) exception)

196 if' = InfixExpr () OpStrictEq (get "$.ctor") (string name)

197 exception = get "_E.Case" `call` [ref "$moduleName", string (show span)]

198

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

199+ _ -> VarDeclStmt () [assign "$"] : concatMap toDef vars

200 where

201 vars = Set.toList $ SD.boundVars pattern

202 mkVar = L span . Var

235 Left name -> string $ case List.elemIndices '.' name of

236 [] -> name

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

238−--}

238+

239−{--

240−

241−jsModule :: MetadataModule t v -> String

239+jsModule :: MetadataModule () () -> [Statement ()]

242−jsModule modul =

240+jsModule modul = setup ("Elm" : names modul) ++

243− run $ do

241+ [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]

244− body <- toJS . fst . SD.flattenLets [] $ program modul

245− foreignImport <- mapM importEvent (foreignImports modul)

246− return $ concat [ setup ("Elm" : names modul)

247− , globalAssign ("Elm." ++ modName)

248− (jsFunc "elm" $ makeProgram body foreignImport) ]

249 where

242 where

250− modName = dotSep (names modul)

243+ thisModule = dotSep ("elm" : names modul)

251− makeProgram body foreignImport =

244+ programStmts =

252 concat [ setup ("elm" : names modul)

245 concat [ setup ("elm" : names modul)

253− , "\nif (elm." ++ modName ++ ") return elm." ++ modName ++ ";"

246+ , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]

254− , "\nvar " ++ usefulFuncs ++ ";"

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

255 , concatMap jsImport (imports modul)

248 , concatMap jsImport (imports modul)

256− , concat foreignImport

249+ , concatMap importEvent (foreignImports modul)

257− , assign "_op" "{}"

250+ , [ assign ["_op"] (ObjectLit () []) ]

258− , body

251+ , concatMap definition . fst . SD.flattenLets [] $ program modul

259− , concatMap exportEvent $ foreignExports modul

252+ , map exportEvent $ foreignExports modul

260− , jsExports

253+ , [ jsExports ]

254+ , [ ReturnStmt () (Just thisModule) ]

261 ]

255 ]

262− setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .

263− map dotSep . drop 2 . List.inits $ init names

264− usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))

265

256

266− jsExports = ret (assign' ("elm." ++ modName) (brackets exs))

257+ jsExports = assign ("elm" : names modul) (ObjectLit () exs)

258+ where

259+ exs = map entry . filter (not . isOp) $ "_op" : exports modul

260+ entry x = (PropId () (var x), ref x)

261+

262+ assign path expr =

263+ ExprStmt () $

264+ flip (AssignExpr () OpAssign) expr $

265+ case path of

266+ [x] -> LVar () x

267+ _ -> LDot () (dotSep (init path)) (last path)

268+

269+ jsImport (modul,_) = setup path ++ [ assign path (dotSep path <| ref "elm") ]

270+ where

271+ path = split modul

272+

273+ setup path = map create paths

267 where

274 where

268− exs = indent . commaSep . concatMap pair $ "_op" : exports modul

275+ create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))

269− pair x | isOp x = []

276+ paths = drop 2 . init $ List.inits path

270− | otherwise = ["\n" ++ x ++ " : " ++ x]

271

277

278+ addId js = InfixExpr () OpAdd (string (js++"_")) (get "elm.id")

272

279

273 importEvent (js,base,elm,_) =

280 importEvent (js,base,elm,_) =

274− do v <- toJS' base

281+ [ VarDeclStmt () [ varDecl elm $ get "Signal.constant" <| expression base ]

275− return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"

282+ , ExprStmt () $

276− , "\ndocument.addEventListener('", js

283+ get "document.addEventListener" `call`

284+ [ addId js

277− , "_' + elm.id, function(e) { elm.notify(", elm

285+ , function ["e"]

278− , ".id, e.value); });" ]

286+ [ ExprStmt () $ get "elm.notify" `call` [dotSep [elm,"id"], get "e.value"] ]

287+ ]

288+ ]

279

289

280 exportEvent (js,elm,_) =

290 exportEvent (js,elm,_) =

291+ ExprStmt () $

292+ ref "A2" `call`

281− concat [ "\nA2( Signal.lift, function(v) { "

293+ [ get "Signal.lift"

294+ , function ["v"]

282− , "var e = document.createEvent('Event');"

295+ [ VarDeclStmt () [varDecl "e" $ get "document.createEvent" <| string "Event"]

283− , "e.initEvent('", js, "_' + elm.id, true, true);"

296+ , ExprStmt () $

284− , "e.value = v;"

297+ get "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]

285− , "document.dispatchEvent(e); return v; }, ", elm, ");" ]

286−--}

287−jsImport (modul, _) = map (ExprStmt ()) exprs

288− where

289− assign name = AssignExpr () OpAssign (LDot () (dotSep (init name)) (last name))

298+ , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")

290− setup name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))

299+ , ExprStmt () $ get "document.dispatchEvent" <| ref "e"

291− exprs = map setup (drop 2 . init $ List.inits path) ++

300+ , ReturnStmt () (Just $ ref "v")

292− [ assign path (dotSep path <| ref "elm") ]

301+ ]

293− path = split modul

302+ , ref elm ]

294

303

295

304

296binop span op e1 e2 =

305binop span op e1 e2 =