7552469 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Generate a minimal number of closures

7552469Evan Czaplicki11 years ago

elm-compiler.cabal+2

compare with master

unifiedsplit

@@ -75,6 +75,7 @@ Library

75 Elm.Compiler.Version,

76 Generate.Cases,

77 Generate.JavaScript,

78+ Generate.JavaScript.Crash,

78 Generate.JavaScript.Helpers,

79 Generate.JavaScript.Helpers,

79 Generate.JavaScript.Port,

80 Generate.JavaScript.Port,

80 Generate.JavaScript.Variable,

81 Generate.JavaScript.Variable,

@@ -90,6 +91,7 @@ Library

90 Parse.Pattern,

91 Parse.Pattern,

91 Parse.Type,

92 Parse.Type,

92 Reporting.Annotation,

93 Reporting.Annotation,

94+ Reporting.Crash,

93 Reporting.Error,

95 Reporting.Error,

94 Reporting.Error.Canonicalize,

96 Reporting.Error.Canonicalize,

95 Reporting.Error.Docs,

97 Reporting.Error.Docs,

src/AST/Expression/General.hs+15−3

@@ -16,6 +16,7 @@ import qualified AST.Pattern as Pattern

16import qualified AST.Type as Type

17import qualified AST.Variable as Var

18import qualified Reporting.Annotation as A

19+import qualified Reporting.Crash as Crash

19import qualified Reporting.PrettyPrint as P

20import qualified Reporting.PrettyPrint as P

@@ -48,7 +49,7 @@ data Expr' ann def var typ

48 | Binop var (Expr ann def var typ) (Expr ann def var typ)

49 | Binop var (Expr ann def var typ) (Expr ann def var typ)

49 | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)

50 | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)

50 | App (Expr ann def var typ) (Expr ann def var typ)

51 | App (Expr ann def var typ) (Expr ann def var typ)

51− | MultiIf [(Expr ann def var typ,Expr ann def var typ)]

52+ | MultiIf [(Expr ann def var typ, Expr ann def var typ)] (Expr ann def var typ)

52 | Let [def] (Expr ann def var typ)

53 | Let [def] (Expr ann def var typ)

53 | Case (Expr ann def var typ) [(Pattern.Pattern ann var, Expr ann def var typ)]

54 | Case (Expr ann def var typ) [(Pattern.Pattern ann var, Expr ann def var typ)]

54 | Data String [Expr ann def var typ]

55 | Data String [Expr ann def var typ]

@@ -60,9 +61,9 @@ data Expr' ann def var typ

60 -- for type checking and code gen only

61 -- for type checking and code gen only

61 | Port (PortImpl (Expr ann def var typ) typ)

62 | Port (PortImpl (Expr ann def var typ) typ)

62 | GLShader String String Literal.GLShaderTipe

63 | GLShader String String Literal.GLShaderTipe

64+ | Crash Crash.Details

63 deriving (Show)

65 deriving (Show)

65−

66-- PORTS

67-- PORTS

68data PortImpl expr tipe

69data PortImpl expr tipe

@@ -161,7 +162,15 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

161 func:args =

162 func:args =

162 map (P.pretty dealiaser True) (collectApps expr ++ [arg])

163 map (P.pretty dealiaser True) (collectApps expr ++ [arg])

163

164

165+ MultiIf [(condition, thenBranch)] elseBranch ->

166+ P.parensIf needsParens $ P.sep $

167+ [ P.text "if" <+> P.pretty dealiaser False condition <+> P.text "then"

168+ , P.nest 4 (P.pretty dealiaser False thenBranch)

169+ , P.text "else"

170+ , P.nest 4 (P.pretty dealiaser False elseBranch)

171+ ]

172+

164− MultiIf branches ->

173+ MultiIf branches _finally ->

165 P.parensIf needsParens $

174 P.parensIf needsParens $

166 P.text "if" $$ nest 3 (vcat $ map iff branches)

175 P.text "if" $$ nest 3 (vcat $ map iff branches)

167 where

176 where

@@ -263,6 +272,9 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

263 Port portImpl ->

272 Port portImpl ->

264 P.pretty dealiaser needsParens portImpl

273 P.pretty dealiaser needsParens portImpl

265

274

275+ Crash details ->

276+ P.text ("<crash:" ++ Crash.summary details ++ ">")

277+

266

278

267instance P.Pretty (PortImpl expr tipe) where

279instance P.Pretty (PortImpl expr tipe) where

268 pretty _ _ impl =

280 pretty _ _ impl =

src/Canonicalize.hs+7−2

@@ -367,8 +367,10 @@ expression env (A.A region validExpr) =

367 App func arg ->

368 App <$> go func <*> go arg

369

370− MultiIf branches ->

370+ MultiIf branches finally ->

371+ MultiIf

371− MultiIf <$> T.traverse go' branches

372+ <$> T.traverse go' branches

373+ <*> go finally

372 where

374 where

373 go' (condition, branch) =

375 go' (condition, branch) =

374 (,) <$> go condition <*> go branch

376 (,) <$> go condition <*> go branch

@@ -427,6 +429,9 @@ expression env (A.A region validExpr) =

427 GLShader uid src tipe ->

429 GLShader uid src tipe ->

428 Result.ok (GLShader uid src tipe)

430 Result.ok (GLShader uid src tipe)

429

431

432+ Crash details ->

433+ Result.ok (Crash details)

434+

430

435

431pattern

436pattern

432 :: Env.Environment

437 :: Env.Environment

src/Canonicalize/Sort.hs+17−5

@@ -73,17 +73,26 @@ reorder (A.A ann expression) =

73 App func arg ->

74 App <$> reorder func <*> reorder arg

76− MultiIf branches ->

76+ MultiIf branches finally ->

77+ MultiIf

77− MultiIf <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

78+ <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

79+ <*> reorder finally

79 Access record field ->

81 Access record field ->

82+ Access

80− Access <$> reorder record <*> return field

83+ <$> reorder record

84+ <*> return field

82 Remove record field ->

86 Remove record field ->

87+ Remove

83− Remove <$> reorder record <*> return field

88+ <$> reorder record

89+ <*> return field

85 Insert record field expr ->

91 Insert record field expr ->

92+ Insert

86− Insert <$> reorder record <*> return field <*> reorder expr

93+ <$> reorder record

94+ <*> return field

95+ <*> reorder expr

88 Modify record fields ->

97 Modify record fields ->

89 Modify

98 Modify

@@ -109,6 +118,9 @@ reorder (A.A ann expression) =

109 Task name expr tipe ->

118 Task name expr tipe ->

110 (\e -> Task name e tipe) <$> reorder expr

119 (\e -> Task name e tipe) <$> reorder expr

111

120

121+ Crash _ ->

122+ return expression

123+

112 -- Actually do some reordering

124 -- Actually do some reordering

113 Let defs body ->

125 Let defs body ->

114 do body' <- reorder body

126 do body' <- reorder body

src/Generate/JavaScript.hs+403−220

@@ -1,7 +1,7 @@

1module Generate.JavaScript (generate) where

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

4−import Control.Arrow (first,(***))

4+import Control.Arrow (first, second, (***))

5import Control.Monad.State

6import qualified Data.List as List

7import qualified Data.Map as Map

@@ -21,9 +21,11 @@ import qualified AST.Variable as Var

21import Elm.Utils ((|>))

22import Generate.JavaScript.Helpers as Help

23import qualified Generate.Cases as Case

24+import qualified Generate.JavaScript.Crash as Crash

24import qualified Generate.JavaScript.Port as Port

25import qualified Generate.JavaScript.Port as Port

25import qualified Generate.JavaScript.Variable as Var

26import qualified Generate.JavaScript.Variable as Var

26import qualified Reporting.Annotation as A

27import qualified Reporting.Annotation as A

28+import qualified Reporting.Crash as Crash

27import qualified Reporting.Region as R

29import qualified Reporting.Region as R

@@ -32,7 +34,7 @@ internalImports name =

32 [ varDecl "_N" (obj ["Elm","Native"])

34 [ varDecl "_N" (obj ["Elm","Native"])

33 , include "_U" "Utils"

35 , include "_U" "Utils"

34 , include "_L" "List"

36 , include "_L" "List"

35− , varDecl Help.localModuleName (string (Module.nameToString name))

37+ , varDecl Crash.localModuleName (string (Module.nameToString name))

36 ]

38 ]

37 where

39 where

38 include :: String -> String -> VarDecl ()

40 include :: String -> String -> VarDecl ()

@@ -60,53 +62,111 @@ literal lit =

60 Boolean b -> BoolLit () b

62 Boolean b -> BoolLit () b

65+-- CODE CHUNKS

66+

67+data Code

68+ = JsExpr (Expression ())

69+ | JsBlock [Statement ()]

70+

71+

72+jsExpr :: Expression () -> State Int Code

73+jsExpr exp =

74+ return (JsExpr exp)

75+

76+

77+jsBlock :: [Statement ()] -> State Int Code

78+jsBlock exp =

79+ return (JsBlock exp)

80+

81+

82+isBlock :: Code -> Bool

83+isBlock code =

84+ case code of

85+ JsBlock _ -> True

86+ JsExpr _ -> False

87+

88+

89+toStatementList :: Code -> [Statement ()]

90+toStatementList code =

91+ case code of

92+ JsExpr expr ->

93+ [ ret expr ]

94+ JsBlock stmts ->

95+ stmts

96+

97+

98+toStatement :: Code -> Statement ()

99+toStatement code =

100+ case code of

101+ JsExpr expr ->

102+ ret expr

103+ JsBlock [stmt] ->

104+ stmt

105+ JsBlock stmts ->

106+ BlockStmt () stmts

107+

108+

109+toExpr :: Code -> Expression ()

110+toExpr code =

111+ case code of

112+ JsExpr expr ->

113+ expr

114+ JsBlock stmts ->

115+ function [] stmts `call` []

116+

117+

63-- EXPRESSIONS

118-- EXPRESSIONS

119

65−expression :: Canonical.Expr -> State Int (Expression ())

120+exprToJsExpr :: Canonical.Expr -> State Int (Expression ())

121+exprToJsExpr canonicalExpr =

122+ toExpr <$> exprToCode canonicalExpr

123+

124+

125+exprToCode :: Canonical.Expr -> State Int Code

66−expression annotatedExpr@(A.A region expr) =

126+exprToCode annotatedExpr@(A.A region expr) =

67 case expr of

127 case expr of

68 Var var ->

128 Var var ->

69− return $ Var.canonical var

129+ jsExpr $ Var.canonical var

130

71 Literal lit ->

131 Literal lit ->

72− return $ literal lit

132+ jsExpr $ literal lit

133

74 Range lo hi ->

134 Range lo hi ->

75− do lo' <- expression lo

135+ do lo' <- exprToJsExpr lo

76− hi' <- expression hi

136+ hi' <- exprToJsExpr hi

77− return $ _List "range" `call` [lo',hi']

137+ jsExpr $ _List "range" `call` [lo',hi']

138

79− Access e field ->

139+ Access record field ->

80− do e' <- expression e

140+ do record' <- exprToJsExpr record

81− return $ DotRef () e' (var (Var.varName field))

141+ jsExpr $ DotRef () record' (var (Var.varName field))

142

83− Remove e field ->

143+ Remove record field ->

84− do e' <- expression e

144+ do record' <- exprToJsExpr record

85− return $ _Utils "remove" `call` [ string (Var.varName field), e' ]

145+ jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]

146

87− Insert e field value ->

147+ Insert record field value ->

88− do value' <- expression value

148+ do value' <- exprToJsExpr value

89− e' <- expression e

149+ record' <- exprToJsExpr record

90− return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ]

150+ jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]

151

92− Modify e fields ->

152+ Modify record fields ->

93− do e' <- expression e

153+ do record' <- exprToJsExpr record

94 fields' <-

154 fields' <-

95 forM fields $ \(field, value) ->

155 forM fields $ \(field, value) ->

96− do value' <- expression value

156+ do value' <- exprToJsExpr value

97 return $ ArrayLit () [ string (Var.varName field), value' ]

157 return $ ArrayLit () [ string (Var.varName field), value' ]

158

99− return $ _Utils "replace" `call` [ArrayLit () fields', e']

159+ jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']

100

160

101 Record fields ->

161 Record fields ->

102 do fields' <-

162 do fields' <-

103 forM fields $ \(field, e) ->

163 forM fields $ \(field, e) ->

104− (,) (Var.varName field) <$> expression e

164+ (,) (Var.varName field) <$> exprToJsExpr e

105

165

106 let fieldMap =

166 let fieldMap =

107 List.foldl' combine Map.empty fields'

167 List.foldl' combine Map.empty fields'

108

168

109− return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap

169+ jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap

110 where

170 where

111 combine record (field, value) =

171 combine record (field, value) =

112 Map.insertWith (++) field [value] record

172 Map.insertWith (++) field [value] record

@@ -118,102 +178,80 @@ expression annotatedExpr@(A.A region expr) =

118 visible fs =

178 visible fs =

119 map (first prop) (Map.toList (Map.map head fs))

179 map (first prop) (Map.toList (Map.map head fs))

120

180

121− Binop op e1 e2 ->

181+ Binop op leftExpr rightExpr ->

122− binop region op e1 e2

182+ binop region op leftExpr rightExpr

123

183

124 Lambda _ _ ->

184 Lambda _ _ ->

125 generateFunction (Expr.collectLambdas annotatedExpr)

185 generateFunction (Expr.collectLambdas annotatedExpr)

126

186

127− App e1 e2 ->

187+ App funcExpr argExpr ->

128− do func' <- expression func

188+ do func' <- exprToJsExpr func

129− args' <- mapM expression args

189+ args' <- mapM exprToJsExpr args

130− return $

190+ jsExpr $

131 case args' of

191 case args' of

132 [arg] -> func' <| arg

192 [arg] -> func' <| arg

133 _ | length args' <= 9 -> ref aN `call` (func':args')

193 _ | length args' <= 9 -> ref aN `call` (func':args')

134 | otherwise -> foldl1 (<|) (func':args')

194 | otherwise -> foldl1 (<|) (func':args')

135 where

195 where

136 aN = "A" ++ show (length args)

196 aN = "A" ++ show (length args)

137− (func, args) = getArgs e1 [e2]

197+ (func, args) = getArgs funcExpr [argExpr]

138 getArgs func args =

198 getArgs func args =

139 case func of

199 case func of

140 (A.A _ (App f arg)) -> getArgs f (arg : args)

200 (A.A _ (App f arg)) -> getArgs f (arg : args)

141 _ -> (func, args)

201 _ -> (func, args)

142

202

143 Let defs body ->

203 Let defs body ->

144− do (stmts, bodyExpr) <- generateLetPieces defs body

204+ generateLet defs body

145− return $ function [] (stmts ++ [ ret bodyExpr ]) `call` []

205+

146−

147−

148− MultiIf branches ->

206+ MultiIf branches finally ->

149− do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

150− return $

151− case last branches of

152− (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->

153− safeIfs branches'

154− (A.A _ (Literal (Boolean True)), _) ->

155− safeIfs branches'

156− _ ->

157− ifs branches' (throw "badIf" region)

158− where

159− safeIfs branches = ifs (init branches) (snd (last branches))

160− ifs branches finally = foldr iff finally branches

207+ generateIf branches finally

161− iff (if', then') else' = CondExpr () if' then' else'

208+

162−

209+ Case expr branches ->

163− Case e cases ->

210+ generateCase region expr branches

164− do (tempVar,initialMatch) <- Case.toMatch cases

211+

165− (revisedMatch, stmt) <-

166− case e of

167− A.A _ (Var (Var.Canonical Var.Local x)) ->

168− return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])

169− _ ->

170− do e' <- expression e

171− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])

172− match' <- match region revisedMatch

173− return (function [] (stmt ++ match') `call` [])

174−

175− ExplicitList es ->

212+ ExplicitList elements ->

176− do es' <- mapM expression es

213+ do jsElements <- mapM exprToJsExpr elements

177− return $ _List "fromArray" <| ArrayLit () es'

214+ jsExpr $ _List "fromArray" <| ArrayLit () jsElements

178−

215+

179− Data name es ->

216+ Data tag members ->

180− do es' <- mapM expression es

217+ do jsMembers <- mapM exprToJsExpr members

181− return $ ObjectLit () (ctor : fields es')

218+ jsExpr $ ObjectLit () (ctor : fields jsMembers)

182 where

219 where

183− ctor = (prop "ctor", string name)

220+ ctor = (prop "ctor", string tag)

184 fields =

221 fields =

185 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

222 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

186

223

187 GLShader _uid src _tipe ->

224 GLShader _uid src _tipe ->

188− return $ ObjectLit () [(PropString () "src", literal (Str src))]

225+ jsExpr $ ObjectLit () [(PropString () "src", literal (Str src))]

189

226

190 Port impl ->

227 Port impl ->

191 case impl of

228 case impl of

192 In name portType ->

229 In name portType ->

193− return (Port.inbound name portType)

230+ jsExpr (Port.inbound name portType)

194

231

195 Out name expr portType ->

232 Out name expr portType ->

196− do expr' <- expression expr

233+ do expr' <- exprToJsExpr expr

197− return (Port.outbound name expr' portType)

234+ jsExpr (Port.outbound name expr' portType)

198

235

199 Task name expr portType ->

236 Task name expr portType ->

200− do expr' <- expression expr

237+ do expr' <- exprToJsExpr expr

201− return (Port.task name expr' portType)

238+ jsExpr (Port.task name expr' portType)

239+

240+ Crash details ->

241+ jsExpr $ Crash.crash region details

202

242

203

243

204-- FUNCTIONS

244-- FUNCTIONS

205

245

206−generateFunction

207− :: ([P.CanonicalPattern], Canonical.Expr)

246+generateFunction :: ([P.CanonicalPattern], Canonical.Expr) -> State Int Code

208− -> State Int (Expression ())

209generateFunction (args, initialBody) =

247generateFunction (args, initialBody) =

210 do (argVars, patternDefs) <- destructuredArgs args

248 do (argVars, patternDefs) <- destructuredArgs args

211− (stmts, expr) <- generateLetPieces patternDefs initialBody

249+ code <- generateLet patternDefs initialBody

212− return (generateFunctionWithArity argVars stmts expr)

250+ jsExpr (generateFunctionWithArity argVars code)

213

251

214

252

215−generateFunctionWithArity :: [String] -> [Statement ()] -> Expression () -> Expression ()

253+generateFunctionWithArity :: [String] -> Code -> Expression ()

216−generateFunctionWithArity args stmts expr =

254+generateFunctionWithArity args code =

217 let

255 let

218 arity = length args

256 arity = length args

219 in

257 in

@@ -221,11 +259,11 @@ generateFunctionWithArity args stmts expr =

221 let

259 let

222 fN = "F" ++ show arity

260 fN = "F" ++ show arity

223 in

261 in

224− ref fN <| function args (stmts ++ [ret expr])

262+ ref fN <| function args (toStatementList code)

225 else

263 else

226 let

264 let

227 (lastArg:otherArgs) = reverse args

265 (lastArg:otherArgs) = reverse args

228− innerBody = function [lastArg] (stmts ++ [ret expr])

266+ innerBody = function [lastArg] (toStatementList code)

229 in

267 in

230 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs

268 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs

231

269

@@ -252,70 +290,129 @@ destructPattern pattern@(A.A ann pat) =

252

290

253-- LET EXPRESSIONS

291-- LET EXPRESSIONS

254

292

255−generateLetPieces

293+generateLet

256 :: [Canonical.Def]

294 :: [Canonical.Def]

257 -> Canonical.Expr

295 -> Canonical.Expr

258− -> State Int ([Statement ()], Expression ())

296+ -> State Int Code

259−generateLetPieces givenDefs givenBody =

297+generateLet givenDefs givenBody =

260 do let (defs, body) = flattenLets givenDefs givenBody

298 do let (defs, body) = flattenLets givenDefs givenBody

299+ case defs of

300+ [] ->

301+ exprToCode body

302+

303+ _ ->

261− stmts <- concat <$> mapM definition defs

304+ do stmts <- concat <$> mapM defToStatements defs

262− expr <- expression body

305+ code <- exprToCode body

263− return (stmts, expr)

306+ jsBlock (stmts ++ toStatementList code)

307+

308+

309+-- GENERATE IFS

310+

311+generateIf :: [(Canonical.Expr, Canonical.Expr)] -> Canonical.Expr -> State Int Code

312+generateIf branches finally =

313+ let

314+ convertBranch (condition, expr) =

315+ (,) <$> exprToJsExpr condition <*> exprToCode expr

316+

317+ ifExpression (condition, branch) otherwise =

318+ CondExpr () condition branch otherwise

319+

320+ ifStatement (condition, branch) otherwise =

321+ IfStmt () condition branch otherwise

322+ in

323+ do jsBranches <- mapM convertBranch branches

324+ jsFinally <- exprToCode finally

325+

326+ if any isBlock (jsFinally : map snd jsBranches)

327+ then

328+ jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]

329+ else

330+ jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))

264

331

265

332

266-- DEFINITIONS

333-- DEFINITIONS

267

334

268−definition :: Canonical.Def -> State Int [Statement ()]

335+defToStatements :: Canonical.Def -> State Int [Statement ()]

269−definition (Canonical.Definition annPattern expr@(A.A region _) _) =

336+defToStatements (Canonical.Definition pattern expr _) =

270− do expr' <- expression expr

337+ defToStatementsHelp pattern =<< exprToJsExpr expr

271− let assign x = varDecl x expr'

272− let (A.A patternRegion pattern) = annPattern

273− case pattern of

274− P.Var x

275− | Help.isOp x ->

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

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

278−

279− | otherwise ->

280− return [ VarDeclStmt () [ assign (Var.varName x) ] ]

281−

282− P.Record fields ->

283− let setField f = varDecl f (obj ["$",f]) in

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

285−

286− P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

287− return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

288− where

289− vars = getVars patterns

290− getVars patterns =

291− case patterns of

292− A.A _ (P.Var x) : rest ->

293− (Var.varName x :) `fmap` getVars rest

294− [] ->

295− Just []

296− _ ->

297− Nothing

298−

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

300− setup vars

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

302− | otherwise = assign "_raw" : safeAssign : vars

303−

304− safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

305− if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

306− exception = Help.throw "badCase" region

307

338

308− _ ->

339+

340+defToStatementsHelp :: P.CanonicalPattern -> Expression () -> State Int [Statement ()]

341+defToStatementsHelp annPattern@(A.A patternRegion pattern) jsExpr =

342+ let

343+ define x =

344+ varDecl x jsExpr

345+ in

346+ case pattern of

347+ P.Var x ->

348+ if Help.isOp x then

349+ let

350+ op = LBracket () (ref "_op") (string x)

351+ in

352+ return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]

353+ else

354+ return [ VarDeclStmt () [ define (Var.varName x) ] ]

355+

356+ P.Record fields ->

357+ let

358+ setField name =

359+ varDecl name (obj ["$",name])

360+ in

361+ return [ VarDeclStmt () (define "$" : map setField fields) ]

362+

363+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

364+ return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

365+ where

366+ vars = getVars patterns

367+ getVars patterns =

368+ case patterns of

369+ A.A _ (P.Var x) : rest ->

370+ (Var.varName x :) `fmap` getVars rest

371+ [] ->

372+ Just []

373+ _ ->

374+ Nothing

375+

376+ decl x n = varDecl x (obj ["$","_" ++ show n])

377+ setup vars

378+ | Help.isTuple name = define "$" : vars

379+ | otherwise = define "_raw" : safeAssign : vars

380+

381+ safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

382+ if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

383+ exception = Crash.crash patternRegion Crash.IncompletePatternMatch

384+

385+ _ ->

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

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

310− return (VarDeclStmt () [assign "_"] : defs')

387+ return (VarDeclStmt () [define "_"] : defs')

311− where

388+ where

312− vars = P.boundVarList annPattern

389+ vars = P.boundVarList annPattern

313− mkVar = A.A region . localVar

390+ mkVar = A.A patternRegion . localVar

314− toDef y =

391+ toDef y =

315− let expr = A.A region $ Case (mkVar "_") [(annPattern, mkVar y)]

392+ let expr = A.A patternRegion $ Case (mkVar "_") [(annPattern, mkVar y)]

316− pat = A.A patternRegion (P.Var y)

393+ pat = A.A patternRegion (P.Var y)

317− in

394+ in

318− definition (Canonical.Definition pat expr Nothing)

395+ defToStatements (Canonical.Definition pat expr Nothing)

396+

397+

398+-- CASE EXPRESSIONS

399+

400+generateCase :: R.Region -> Canonical.Expr -> [(P.CanonicalPattern, Canonical.Expr)] -> State Int Code

401+generateCase region expr branches =

402+ do (tempVar, initialMatch) <-

403+ Case.toMatch branches

404+

405+ (revisedMatch, stmt) <-

406+ case expr of

407+ A.A _ (Var (Var.Canonical Var.Local x)) ->

408+ return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])

409+ _ ->

410+ do expr' <- exprToJsExpr expr

411+ return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])

412+

413+ match' <- match region revisedMatch

414+

415+ jsBlock (stmt ++ match')

319

416

320

417

321match :: R.Region -> Case.Match -> State Int [Statement ()]

418match :: R.Region -> Case.Match -> State Int [Statement ()]

@@ -328,26 +425,31 @@ match region mtch =

328 where

425 where

329 isLiteral p =

426 isLiteral p =

330 case p of

427 case p of

331− Case.Clause (Right _) _ _ -> True

428+ Case.Clause (Right _) _ _ ->

429+ True

430+ _ ->

332− _ -> False

431+ False

333−

432+

334− access name

433+ access name =

335− | any isLiteral clauses = obj [name]

434+ if any isLiteral clauses then

435+ obj [name]

436+ else

336− | otherwise = obj (Help.splitDots name ++ ["ctor"])

437+ obj (Help.splitDots name ++ ["ctor"])

337−

438+

338− format isChars e

439+ format isChars expr =

440+ if or isChars then

339− | or isChars = InfixExpr () OpAdd e (string "")

441+ InfixExpr () OpAdd expr (string "")

340− | otherwise = e

442+ else

443+ expr

341

444

342 Case.Fail ->

445 Case.Fail ->

343− return [ ExprStmt () (Help.throw "badCase" region) ]

446+ return [ ExprStmt () (Crash.crash region Crash.IncompletePatternMatch) ]

344

447

345 Case.Break ->

448 Case.Break ->

346 return [BreakStmt () Nothing]

449 return [BreakStmt () Nothing]

347

450

348− Case.Other e ->

451+ Case.Other expr ->

349− do e' <- expression e

452+ toStatementList <$> exprToCode expr

350− return [ ret e' ]

351

453

352 Case.Seq ms ->

454 Case.Seq ms ->

353 concat <$> mapM (match region) (dropEnd [] ms)

455 concat <$> mapM (match region) (dropEnd [] ms)

@@ -434,7 +536,7 @@ generate modul =

434 Module.program (Module.body modul)

536 Module.program (Module.body modul)

435 |> flattenLets []

537 |> flattenLets []

436 |> fst

538 |> fst

437− |> mapM definition

539+ |> mapM defToStatements

438

540

439 setup namespace path =

541 setup namespace path =

440 map create paths

542 map create paths

@@ -471,63 +573,105 @@ generate modul =

471 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

573 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

472

574

473

575

576+-- BINARY OPERATORS

577+

474binop

578binop

475 :: R.Region

579 :: R.Region

476 -> Var.Canonical

580 -> Var.Canonical

477 -> Canonical.Expr

581 -> Canonical.Expr

478 -> Canonical.Expr

582 -> Canonical.Expr

479− -> State Int (Expression ())

583+ -> State Int Code

480−binop region func@(Var.Canonical home op) e1 e2 =

584+binop region func left right

481− case (home, op) of

482− (Var.Module ["Basics"], ">>") ->

483− do es <- mapM expression (collectLeftAssoc [e2] e1)

484− return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es

485−

486− (Var.Module ["Basics"], "<<") ->

487− do es <- mapM expression (e1 : collectRightAssoc [] e2)

488− return $ ["$"] ==> foldr (<|) (ref "$") es

489−

490− (Var.Module ["Basics"], "<|") ->

491− do e2' <- expression e2

492− es <- mapM expression (collectRightAssoc [] e1)

493− return $ foldr (<|) e2' es

494−

495− (Var.BuiltIn, "::") ->

585+ | func == Var.Canonical Var.BuiltIn "::" =

496− expression (A.A region (Data "::" [e1,e2]))

586+ exprToCode (A.A region (Data "::" [left,right]))

497−

498− (Var.Module ["Basics"], _) ->

499− do e1' <- expression e1

500− e2' <- expression e2

501− case Map.lookup op basicOps of

502− Just f ->

503− return (f e1' e2')

504−

505− Nothing ->

506− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])

507

587

508− _ ->

588+ | func == forwardCompose =

509− do e1' <- expression e1

589+ compose (collectLeftAssoc forwardCompose left right)

510− e2' <- expression e2

511− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])

512

590

513− where

591+ | func == backwardCompose =

514− collectRightAssoc es e =

592+ compose (collectRightAssoc backwardCompose left right)

515− case e of

593+

516− A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->

594+ | func == forwardApply =

517− collectRightAssoc (es ++ [e1]) e2

595+ pipe (collectLeftAssoc forwardApply left right)

518− _ -> es ++ [e]

596+

519−

597+ | func == backwardApply =

520− collectLeftAssoc es e =

598+ pipe (collectRightAssoc backwardApply left right)

521− case e of

599+

600+ | otherwise =

601+ do jsLeft <- exprToJsExpr left

602+ jsRight <- exprToJsExpr right

603+ jsExpr (makeExpr func jsLeft jsRight)

604+

605+

606+-- CONTROL FLOW OPERATOR HELPERS

607+

608+apply :: Expression () -> Expression () -> Expression ()

609+apply arg func =

610+ func <| arg

611+

612+

613+compose :: [Canonical.Expr] -> State Int Code

614+compose functions =

615+ do jsFunctions <- mapM exprToJsExpr functions

616+ jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions

617+

618+

619+pipe :: [Canonical.Expr] -> State Int Code

620+pipe expressions =

621+ do (value:functions) <- mapM exprToJsExpr expressions

622+ jsExpr $ List.foldl' apply value functions

623+

624+

625+forwardCompose :: Var.Canonical

626+forwardCompose =

627+ inBasics ">>"

628+

629+

630+backwardCompose :: Var.Canonical

631+backwardCompose =

632+ inBasics "<<"

633+

634+

635+forwardApply :: Var.Canonical

636+forwardApply =

637+ inBasics "|>"

638+

639+

640+backwardApply :: Var.Canonical

641+backwardApply =

642+ inBasics "<|"

643+

644+

645+inBasics :: String -> Var.Canonical

646+inBasics name =

647+ Var.Canonical (Var.Module ["Basics"]) name

648+

649+

650+-- BINARY OPERATOR HELPERS

651+

652+makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())

653+makeExpr qualifiedOp@(Var.Canonical home op) =

654+ let

655+ simpleMake left right =

656+ ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]

657+ in

522− A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->

658+ if home == Var.Module ["Basics"] then

523− collectLeftAssoc (e2 : es) e1

659+ Map.findWithDefault simpleMake op basicOps

524− _ -> e : es

660+ else

525−

661+ simpleMake

662+

663+

664+basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())

526− basicOps =

665+basicOps =

527− Map.fromList (infixOps ++ specialOps)

666+ Map.fromList (infixOps ++ specialOps)

528−

667+

529− infixOps =

668+

669+infixOps :: [(String, Expression () -> Expression () -> Expression ())]

670+infixOps =

671+ let

672+ infixOp str op =

530− let infixOp str op = (str, InfixExpr () op) in

673+ (str, InfixExpr () op)

674+ in

531 [ infixOp "+" OpAdd

675 [ infixOp "+" OpAdd

532 , infixOp "-" OpSub

676 , infixOp "-" OpSub

533 , infixOp "*" OpMul

677 , infixOp "*" OpMul

@@ -536,17 +680,56 @@ binop region func@(Var.Canonical home op) e1 e2 =

536 , infixOp "||" OpLOr

680 , infixOp "||" OpLOr

537 ]

681 ]

538

682

539− specialOps =

540− [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

541− , (,) "|>" $ flip (<|)

542− , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

543− , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

544− , (,) "<" $ cmp OpLT 0

545− , (,) ">" $ cmp OpGT 0

546− , (,) "<=" $ cmp OpLT 1

547− , (,) ">=" $ cmp OpGT (-1)

548− , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

549− ]

550

683

684+specialOps :: [(String, Expression () -> Expression () -> Expression ())]

685+specialOps =

686+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

687+ , (,) "|>" $ flip (<|)

688+ , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

689+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

690+ , (,) "<" $ cmp OpLT 0

691+ , (,) ">" $ cmp OpGT 0

692+ , (,) "<=" $ cmp OpLT 1

693+ , (,) ">=" $ cmp OpGT (-1)

694+ , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

695+ ]

696+

697+

698+cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()

551− cmp op n a b =

699+cmp op n a b =

552− InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)

700+ InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)

701+

702+

703+-- BINARY OPERATOR COLLECTORS

704+

705+-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff

706+collectRightAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]

707+collectRightAssoc desiredOp left right =

708+ collectRightAssocHelp desiredOp [left] right

709+

710+

711+collectRightAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]

712+collectRightAssocHelp desiredOp exprList expr =

713+ case expr of

714+ A.A _ (Binop op left right) | op == desiredOp ->

715+ collectRightAssocHelp desiredOp (left : exprList) right

716+

717+ _ ->

718+ expr : exprList

719+

720+

721+-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff

722+collectLeftAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]

723+collectLeftAssoc desiredOp left right =

724+ collectLeftAssocHelp desiredOp [right] left

725+

726+

727+collectLeftAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]

728+collectLeftAssocHelp desiredOp exprList expr =

729+ case expr of

730+ A.A _ (Binop op left right) | op == desiredOp ->

731+ collectLeftAssocHelp desiredOp (right : exprList) left

732+

733+ _ ->

734+ expr : exprList

735+

src/Generate/JavaScript/Crash.hsnew file+32

@@ -0,0 +1,32 @@

1+module Generate.JavaScript.Crash where

3+import Language.ECMAScript3.Syntax (Expression)

5+import Generate.JavaScript.Helpers (call, obj, ref, string)

6+import qualified Reporting.Crash as Crash

7+import qualified Reporting.Region as R

10+localModuleName :: String

11+localModuleName =

12+ "$moduleName"

13+

14+

15+crash :: R.Region -> Crash.Details -> Expression ()

16+crash region details =

17+ case details of

18+ Crash.IncompleteMultiIf _ ->

19+ obj ["_U","badIf"]

20+ `call`

21+ [ ref localModuleName

22+ , string (R.toString region)

23+ ]

24+

25+ Crash.IncompletePatternMatch ->

26+ obj ["_U","badCase"]

27+ `call`

28+ [ ref localModuleName

29+ , string (R.toString region)

30+ ]

31+

32+

src/Generate/JavaScript/Helpers.hs−19

@@ -2,8 +2,6 @@ module Generate.JavaScript.Helpers where

3import Language.ECMAScript3.Syntax

5−import qualified Reporting.Region as R

6−

8localRuntime :: String

6localRuntime :: String

9localRuntime =

7localRuntime =

@@ -52,23 +50,6 @@ obj vars =

52 [] -> error "dotSep must be called on a non-empty list of variables"

50 [] -> error "dotSep must be called on a non-empty list of variables"

55−-- Specific Utilities

56−

57−localModuleName :: String

58−localModuleName =

59− "$moduleName"

60−

61−

62−throw :: String -> R.Region -> Expression ()

63−throw kind region =

64− let args =

65− [ ref localModuleName

66− , string (R.toString region)

67− ]

68− in

69− obj ["_U",kind] `call` args

70−

71−

72-- Function Calls

53-- Function Calls

74(<|) :: Expression () -> Expression () -> Expression ()

55(<|) :: Expression () -> Expression () -> Expression ()

src/Generate/Substitute.hs+11−8

@@ -15,25 +15,25 @@ subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'

15subst old new expression =

16 let f (A.A a e) = A.A a (subst old new e) in

17 case expression of

18− Range e1 e2 ->

18+ Range lo hi ->

19− Range (f e1) (f e2)

19+ Range (f lo) (f hi)

21 ExplicitList exprs ->

22 ExplicitList (map f exprs)

24− Binop op e1 e2 ->

24+ Binop op left right ->

25− Binop op (f e1) (f e2)

25+ Binop op (f left) (f right)

27 Lambda pattern body ->

28 if Pattern.member old pattern

29 then expression

30 else Lambda pattern (f body)

32− App e1 e2 ->

32+ App func arg ->

33− App (f e1) (f e2)

33+ App (f func) (f arg)

35− MultiIf branches ->

35+ MultiIf branches finally ->

36− MultiIf (map (f *** f) branches)

36+ MultiIf (map (f *** f) branches) (f finally)

38 Let defs body ->

39 if anyShadow

@@ -101,3 +101,6 @@ subst old new expression =

101

102 Task name expr tipe ->

103 Task name (f expr) tipe

104+

105+ Crash _ ->

106+ expression

src/Parse/Expression.hs+27−18

@@ -18,6 +18,8 @@ import qualified AST.Literal as L

18import qualified AST.Pattern as P

19import qualified AST.Variable as Var

20import qualified Reporting.Annotation as A

21+import qualified Reporting.Crash as Crash

22+import qualified Reporting.Region as R

23-------- Basic Terms --------

25-------- Basic Terms --------

@@ -220,7 +222,8 @@ appExpr =

220

222

221expr :: IParser Source.Expr

223expr :: IParser Source.Expr

222expr =

224expr =

223− addLocation (choice [ ifExpr, letExpr, caseExpr ])

225+ addLocation (choice [ letExpr, caseExpr ])

226+ <|> ifExpr

224 <|> lambdaExpr

227 <|> lambdaExpr

225 <|> binaryExpr

228 <|> binaryExpr

226 <?> "an expression"

229 <?> "an expression"

@@ -231,39 +234,45 @@ binaryExpr =

231 Binop.binops appExpr lastExpr anyOp

234 Binop.binops appExpr lastExpr anyOp

232 where

235 where

233 lastExpr =

236 lastExpr =

234− addLocation (choice [ ifExpr, letExpr, caseExpr ])

237+ addLocation (choice [ letExpr, caseExpr ])

238+ <|> ifExpr

235 <|> lambdaExpr

239 <|> lambdaExpr

236 <?> "an expression"

240 <?> "an expression"

237

241

238

242

239−ifExpr :: IParser Source.Expr'

243+ifExpr :: IParser Source.Expr

240ifExpr =

244ifExpr =

245+ do start <- getMyPosition

241− do try (reserved "if")

246+ try (reserved "if")

242 whitespace

247 whitespace

243− normal <|> multiIf

248+ makeExpr <- normal <|> multiIf

249+ end <- getMyPosition

250+ return (makeExpr (R.Region start end))

244 where

251 where

245 normal =

252 normal =

246− do bool <- expr

253+ do condition <- expr

247 padded (reserved "then")

254 padded (reserved "then")

248 thenBranch <- expr

255 thenBranch <- expr

249 whitespace <?> "an 'else' branch"

256 whitespace <?> "an 'else' branch"

250 reserved "else" <?> "an 'else' branch"

257 reserved "else" <?> "an 'else' branch"

251 whitespace

258 whitespace

252 elseBranch <- expr

259 elseBranch <- expr

253− return $ E.MultiIf

260+ return $ \region -> A.A region (E.MultiIf [(condition, thenBranch)] elseBranch)

254− [ (bool, thenBranch)

255− , (A.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)

256− ]

257

261

258 multiIf =

262 multiIf =

259− E.MultiIf <$> spaceSep1 iff

263+ do branches <- spaceSep1 multiBranch

260− where

264+ return $ \region -> A.A region (E.MultiIf branches (crash region))

261− iff =

265+

266+ crash region =

267+ A.A region (E.Crash (Crash.IncompleteMultiIf region))

268+

269+ multiBranch =

262− do string "|"

270+ do string "|"

263− whitespace

271+ whitespace

264− b <- expr

272+ condition <- expr

265− padded rightArrow

273+ padded rightArrow

266− (,) b <$> expr

274+ branch <- expr

275+ return (condition, branch)

267

276

268

277

269lambdaExpr :: IParser Source.Expr

278lambdaExpr :: IParser Source.Expr

src/Reporting/Crash.hsnew file+20

@@ -0,0 +1,20 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Reporting.Crash where

4+import qualified Reporting.Region as R

7+data Details

8+ = IncompleteMultiIf R.Region

9+ | IncompletePatternMatch

10+ deriving (Show)

11+

12+

13+summary :: Details -> String

14+summary details =

15+ case details of

16+ IncompleteMultiIf _ ->

17+ "incomplete-multi-if"

18+

19+ IncompletePatternMatch ->

20+ "incomplete-pattern-match"

src/Reporting/Error/Type.hs+7

@@ -37,6 +37,7 @@ data InfiniteType = InfiniteTypeInfo

37data Hint

38 = CaseBranch Int Region.Region

39 | Case

40+ | IfCondition

40 | IfBranches

41 | IfBranches

41 | MultiIfBranch Int Region.Region

42 | MultiIfBranch Int Region.Region

42 | If

43 | If

@@ -128,6 +129,12 @@ hintToString hint =

128 , Nothing

129 , Nothing

129 )

130 )

130

131

132+ IfCondition ->

133+ ( Nothing

134+ , "This condition does not evaluate to a boolean value, True or False."

135+ , Just "Elm does not have \"truthiness\" such that ints and strings and lists are\nautomatically converted to booleans. Do that conversion explicitly."

136+ )

137+

131 IfBranches ->

138 IfBranches ->

132 ( Nothing

139 ( Nothing

133 , "The branches of this `if` result in different types of values."

140 , "The branches of this `if` result in different types of values."

src/Type/Constrain/Expression.hs+28−11

@@ -2,6 +2,7 @@

2module Type.Constrain.Expression where

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

5+import Control.Arrow (second)

5import qualified Control.Monad as Monad

6import qualified Control.Monad as Monad

6import qualified Data.List as List

7import qualified Data.List as List

7import qualified Data.Map as Map

8import qualified Data.Map as Map

@@ -97,8 +98,8 @@ constrain env annotatedExpr@(A.A region expression) tipe =

97 in

98 in

98 constrainApp env region f args tipe

99 constrainApp env region f args tipe

100

100− E.MultiIf branches ->

101+ E.MultiIf branches finally ->

101− constrainIf env region branches tipe

102+ constrainIf env region branches finally tipe

102

103

103 E.Case expr branches ->

104 E.Case expr branches ->

104 constrainCase env region expr branches tipe

105 constrainCase env region expr branches tipe

@@ -184,6 +185,9 @@ constrain env annotatedExpr@(A.A region expression) tipe =

184 E.Task _ expr _ ->

185 E.Task _ expr _ ->

185 constrain env expr tipe

186 constrain env expr tipe

186

187

188+ E.Crash _ ->

189+ return CTrue

190+

187

191

188-- CONSTRAIN APP

192-- CONSTRAIN APP

189

193

@@ -333,25 +337,38 @@ constrainIf

333 :: Env.Environment

337 :: Env.Environment

334 -> R.Region

338 -> R.Region

335 -> [(Canonical.Expr, Canonical.Expr)]

339 -> [(Canonical.Expr, Canonical.Expr)]

340+ -> Canonical.Expr

336 -> Type

341 -> Type

337 -> IO TypeConstraint

342 -> IO TypeConstraint

338−constrainIf env region branches tipe =

343+constrainIf env region branches finally tipe =

344+ do let (conditions, branchExprs) =

345+ second (++ [finally]) (unzip branches)

346+

347+ (condVars, condCons) <-

348+ unzip <$> mapM constrainCondition conditions

349+

339− do (branchInfo, branchExprCons) <-

350+ (branchInfo, branchExprCons) <-

340− unzip <$> mapM constrainBranch branches

351+ unzip <$> mapM constrainBranch branchExprs

341

352

342 (vars,cons) <- branchCons branchInfo

353 (vars,cons) <- branchCons branchInfo

343

354

344− return $ ex vars (CAnd (branchExprCons ++ cons))

355+ return $ ex (condVars ++ vars) (CAnd (condCons ++ branchExprCons ++ cons))

345 where

356 where

357+ bool =

346− bool = Env.get env Env.types "Bool"

358+ Env.get env Env.types "Bool"

359+

360+ constrainCondition condition@(A.A condRegion _) =

361+ do condVar <- variable Flexible

362+ condCon <- constrain env condition (varN condVar)

363+ let boolCon = CEqual Error.IfCondition condRegion (varN condVar) bool

364+ return (condVar, CAnd [ condCon, boolCon ])

347

365

348− constrainBranch (cond, expr@(A.A branchRegion _)) =

366+ constrainBranch expr@(A.A branchRegion _) =

349 do branchVar <- variable Flexible

367 do branchVar <- variable Flexible

350− condCon <- constrain env cond bool

351 exprCon <- constrain env expr (varN branchVar)

368 exprCon <- constrain env expr (varN branchVar)

352 return

369 return

353 ( (branchVar, branchRegion)

370 ( (branchVar, branchRegion)

354− , condCon /\ exprCon

371+ , exprCon

355 )

372 )

356

373

357 branchCons branchInfo =

374 branchCons branchInfo =

@@ -368,7 +385,7 @@ constrainIf env region branches tipe =

368 pairCons region Error.MultiIfBranch varToCon branchInfo

385 pairCons region Error.MultiIfBranch varToCon branchInfo

369

386

370 varToCon var =

387 varToCon var =

371− CEqual Error.If region tipe (varN var)

388+ CEqual Error.If region (varN var) tipe

372

389

373

390

374-- CONSTRAIN CASE EXPRESSIONS

391-- CONSTRAIN CASE EXPRESSIONS

src/Validate.hs+7−2

@@ -213,8 +213,10 @@ expression (A.A ann sourceExpression) =

213 <$> expression funcExpr

214 <*> expression argExpr

215

216− MultiIf branches ->

216+ MultiIf branches finally ->

217+ MultiIf

217− MultiIf <$> T.traverse both branches

218+ <$> T.traverse both branches

219+ <*> expression finally

218

220

219 Access record field ->

221 Access record field ->

220 Access

222 Access

@@ -263,6 +265,9 @@ expression (A.A ann sourceExpression) =

263 do expr' <- expression expr

265 do expr' <- expression expr

264 return (Task name expr' tipe)

266 return (Task name expr' tipe)

265

267

268+ Crash details ->

269+ return (Crash details)

270+

266

271

267second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)

272second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)

268second (value, expr) =

273second (value, expr) =