086880c · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Update pattern matches for less caching in canonical AST

086880cEvan Czaplicki9 years ago

src/Nitpick/PatternMatches.hs+12−9

compare with master

unifiedsplit

@@ -210,20 +210,20 @@ checkDecls decls errors =

210checkDef :: Can.Def -> [Error] -> [Error]

211checkDef def errors =

212 case def of

213− Can.Def _ args _ body ->

213+ Can.Def _ args body ->

214 foldr checkArg (checkExpr body errors) args

215

216− Can.TypedDef _ _ args _ body _ ->

216+ Can.TypedDef _ _ args body _ ->

217 foldr checkTypedArg (checkExpr body errors) args

218

219

220−checkArg :: Can.Arg -> [Error] -> [Error]

220+checkArg :: Can.Pattern -> [Error] -> [Error]

221−checkArg (Can.Arg _ pattern@(A.At region _)) errors =

221+checkArg pattern@(A.At region _) errors =

222 checkPatterns region BadArg [pattern] errors

223

224

225−checkTypedArg :: Can.TypedArg -> [Error] -> [Error]

225+checkTypedArg :: (Can.Pattern, tipe) -> [Error] -> [Error]

226−checkTypedArg (Can.TypedArg _ _ pattern@(A.At region _)) errors =

226+checkTypedArg (pattern@(A.At region _), _) errors =

227 checkPatterns region BadArg [pattern] errors

228

229

@@ -246,6 +246,9 @@ checkExpr (A.At region expression) errors =

246 Can.VarForeign _ _ _ ->

247 errors

248

249+ Can.VarDebug _ _ _ ->

250+ errors

251+

249 Can.VarOperator _ _ _ _ ->

252 Can.VarOperator _ _ _ _ ->

250 errors

253 errors

251

254

@@ -271,7 +274,7 @@ checkExpr (A.At region expression) errors =

271 checkExpr left $

274 checkExpr left $

272 checkExpr right errors

275 checkExpr right errors

273

276

274− Can.Lambda args _ body ->

277+ Can.Lambda args body ->

275 foldr checkArg (checkExpr body errors) args

278 foldr checkArg (checkExpr body errors) args

276

279

277 Can.Call func args ->

280 Can.Call func args ->

@@ -286,7 +289,7 @@ checkExpr (A.At region expression) errors =

286 Can.LetRec defs body ->

289 Can.LetRec defs body ->

287 foldr checkDef (checkExpr body errors) defs

290 foldr checkDef (checkExpr body errors) defs

288

291

289− Can.LetDestruct pattern@(A.At reg _) _ expr body ->

292+ Can.LetDestruct pattern@(A.At reg _) expr body ->

290 checkPatterns reg BadDestruct [pattern] $

293 checkPatterns reg BadDestruct [pattern] $

291 checkExpr expr $ checkExpr body errors

294 checkExpr expr $ checkExpr body errors

292

295

@@ -345,7 +348,7 @@ checkCases region branches errors =

345

348

346

349

347checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])

350checkCaseBranch :: Can.CaseBranch -> ([Can.Pattern], [Error]) -> ([Can.Pattern], [Error])

348−checkCaseBranch (Can.CaseBranch pattern _ expr) (patterns, errors) =

351+checkCaseBranch (Can.CaseBranch pattern expr) (patterns, errors) =

349 ( pattern:patterns

352 ( pattern:patterns

350 , checkExpr expr errors

353 , checkExpr expr errors

351 )

354 )

src/Type/Constrain/Expression.hs+20−17

@@ -52,6 +52,9 @@ constrain rtv (A.At region expression) expected =

52 Can.VarForeign _ name annotation ->

53 return $ CInstance region (FuncName name) annotation expected

55+ Can.VarDebug _ name annotation ->

56+ return $ CInstance region (FuncName name) annotation expected

57+

55 Can.VarOperator op _ _ annotation ->

58 Can.VarOperator op _ _ annotation ->

56 return $ CInstance region (OpName op) annotation expected

59 return $ CInstance region (OpName op) annotation expected

@@ -81,7 +84,7 @@ constrain rtv (A.At region expression) expected =

81 Can.Binop op _ _ annotation leftExpr rightExpr ->

84 Can.Binop op _ _ annotation leftExpr rightExpr ->

82 constrainBinop rtv region op annotation leftExpr rightExpr expected

85 constrainBinop rtv region op annotation leftExpr rightExpr expected

84− Can.Lambda args _ body ->

87+ Can.Lambda args body ->

85 constrainLambda rtv region args body expected

88 constrainLambda rtv region args body expected

87 Can.Call func args ->

90 Can.Call func args ->

@@ -101,7 +104,7 @@ constrain rtv (A.At region expression) expected =

101 constrainRecursiveDefs rtv defs

104 constrainRecursiveDefs rtv defs

102 =<< constrain rtv body expected

105 =<< constrain rtv body expected

103

106

104− Can.LetDestruct pattern _ expr body ->

107+ Can.LetDestruct pattern expr body ->

105 constrainDestruct rtv region pattern expr

108 constrainDestruct rtv region pattern expr

106 =<< constrain rtv body expected

109 =<< constrain rtv body expected

107

110

@@ -150,7 +153,7 @@ constrain rtv (A.At region expression) expected =

150-- CONSTRAIN LAMBDA

153-- CONSTRAIN LAMBDA

151

154

152

155

153−constrainLambda :: RTV -> R.Region -> [Can.Arg] -> Can.Expr -> Expected Type -> IO Constraint

156+constrainLambda :: RTV -> R.Region -> [Can.Pattern] -> Can.Expr -> Expected Type -> IO Constraint

154constrainLambda rtv region args body expected =

157constrainLambda rtv region args body expected =

155 do (Args vars tipe resultType (Pattern.State headers pvars revCons)) <-

158 do (Args vars tipe resultType (Pattern.State headers pvars revCons)) <-

156 constrainArgs args

159 constrainArgs args

@@ -375,7 +378,7 @@ constrainCase rtv region expr branches expected =

375

378

376

379

377constrainCaseBranch :: RTV -> Can.CaseBranch -> PExpected Type -> Expected Type -> IO Constraint

380constrainCaseBranch :: RTV -> Can.CaseBranch -> PExpected Type -> Expected Type -> IO Constraint

378−constrainCaseBranch rtv (Can.CaseBranch pattern _ expr) pExpect bExpect =

381+constrainCaseBranch rtv (Can.CaseBranch pattern expr) pExpect bExpect =

379 do (Pattern.State headers pvars revCons) <-

382 do (Pattern.State headers pvars revCons) <-

380 Pattern.add pattern pExpect Pattern.emptyState

383 Pattern.add pattern pExpect Pattern.emptyState

381

384

@@ -534,7 +537,7 @@ constrainDestruct rtv region pattern expr bodyCon =

534constrainDef :: RTV -> Can.Def -> Constraint -> IO Constraint

537constrainDef :: RTV -> Can.Def -> Constraint -> IO Constraint

535constrainDef rtv def bodyCon =

538constrainDef rtv def bodyCon =

536 case def of

539 case def of

537− Can.Def (A.At region name) args _ expr ->

540+ Can.Def (A.At region name) args expr ->

538 do (Args vars tipe resultType (Pattern.State headers pvars revCons)) <-

541 do (Args vars tipe resultType (Pattern.State headers pvars revCons)) <-

539 constrainArgs args

542 constrainArgs args

540

543

@@ -557,7 +560,7 @@ constrainDef rtv def bodyCon =

557 , _bodyCon = bodyCon

560 , _bodyCon = bodyCon

558 }

561 }

559

562

560− Can.TypedDef (A.At region name) freeVars typedArgs _ expr srcResultType ->

563+ Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType ->

561 do let newNames = Map.difference freeVars rtv

564 do let newNames = Map.difference freeVars rtv

562 newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames

565 newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames

563 let newRtv = Map.union rtv (Map.map VarN newRigids)

566 let newRtv = Map.union rtv (Map.map VarN newRigids)

@@ -622,7 +625,7 @@ recDefsHelp rtv defs bodyCon rigidInfo flexInfo =

622

625

623 def : otherDefs ->

626 def : otherDefs ->

624 case def of

627 case def of

625− Can.Def (A.At region name) args _ expr ->

628+ Can.Def (A.At region name) args expr ->

626 do let (Info flexVars flexCons flexHeaders) = flexInfo

629 do let (Info flexVars flexCons flexHeaders) = flexInfo

627

630

628 (Args newFlexVars tipe resultType (Pattern.State headers pvars revCons)) <-

631 (Args newFlexVars tipe resultType (Pattern.State headers pvars revCons)) <-

@@ -647,7 +650,7 @@ recDefsHelp rtv defs bodyCon rigidInfo flexInfo =

647 , _headers = Map.insert name (A.At region tipe) flexHeaders

650 , _headers = Map.insert name (A.At region tipe) flexHeaders

648 }

651 }

649

652

650− Can.TypedDef (A.At region name) freeVars typedArgs _ expr srcResultType ->

653+ Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType ->

651 do let newNames = Map.difference freeVars rtv

654 do let newNames = Map.difference freeVars rtv

652 newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames

655 newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames

653 let newRtv = Map.union rtv (Map.map VarN newRigids)

656 let newRtv = Map.union rtv (Map.map VarN newRigids)

@@ -692,12 +695,12 @@ data Args =

692 }

695 }

693

696

694

697

695−constrainArgs :: [Can.Arg] -> IO Args

698+constrainArgs :: [Can.Pattern] -> IO Args

696constrainArgs args =

699constrainArgs args =

697 argsHelp args Pattern.emptyState

700 argsHelp args Pattern.emptyState

698

701

699

702

700−argsHelp :: [Can.Arg] -> Pattern.State -> IO Args

703+argsHelp :: [Can.Pattern] -> Pattern.State -> IO Args

701argsHelp args state =

704argsHelp args state =

702 case args of

705 case args of

703 [] ->

706 [] ->

@@ -705,7 +708,7 @@ argsHelp args state =

705 let resultType = VarN resultVar

708 let resultType = VarN resultVar

706 return $ Args [resultVar] resultType resultType state

709 return $ Args [resultVar] resultType resultType state

707

710

708− (Can.Arg _ pattern) : otherArgs ->

711+ pattern : otherArgs ->

709 do argVar <- mkFlexVar

712 do argVar <- mkFlexVar

710 let argType = VarN argVar

713 let argType = VarN argVar

711

714

@@ -728,24 +731,24 @@ data TypedArgs =

728 }

731 }

729

732

730

733

731−constrainTypedArgs :: Map.Map N.Name Type -> N.Name -> [Can.TypedArg] -> Can.Type -> IO TypedArgs

734+constrainTypedArgs :: Map.Map N.Name Type -> N.Name -> [(Can.Pattern, Can.Type)] -> Can.Type -> IO TypedArgs

732constrainTypedArgs rtv name args srcResultType =

735constrainTypedArgs rtv name args srcResultType =

733 do resultType <- Instantiate.fromSrcType rtv srcResultType

736 do resultType <- Instantiate.fromSrcType rtv srcResultType

734− typedArgsHelp rtv name args resultType Pattern.emptyState

737+ typedArgsHelp rtv name Index.first args resultType Pattern.emptyState

735

738

736

739

737−typedArgsHelp :: Map.Map N.Name Type -> N.Name -> [Can.TypedArg] -> Type -> Pattern.State -> IO TypedArgs

740+typedArgsHelp :: Map.Map N.Name Type -> N.Name -> Index.ZeroBased -> [(Can.Pattern, Can.Type)] -> Type -> Pattern.State -> IO TypedArgs

738−typedArgsHelp rtv name args resultType state =

741+typedArgsHelp rtv name index args resultType state =

739 case args of

742 case args of

740 [] ->

743 [] ->

741 return $ TypedArgs resultType resultType state

744 return $ TypedArgs resultType resultType state

742

745

743− (Can.TypedArg index srcType pattern@(A.At region _)) : otherArgs ->

746+ (pattern@(A.At region _), srcType) : otherArgs ->

744 do argType <- Instantiate.fromSrcType rtv srcType

747 do argType <- Instantiate.fromSrcType rtv srcType

745 let expected = PFromContext region (PTypedArg name index) argType

748 let expected = PFromContext region (PTypedArg name index) argType

746

749

747 (TypedArgs tipe result newState) <-

750 (TypedArgs tipe result newState) <-

748− typedArgsHelp rtv name otherArgs resultType =<<

751+ typedArgsHelp rtv name (Index.next index) otherArgs resultType =<<

749 Pattern.add pattern expected state

752 Pattern.add pattern expected state

750

753

751 return (TypedArgs (FunN argType tipe) result newState)

754 return (TypedArgs (FunN argType tipe) result newState)

src/Type/Solve.hs+2−2

@@ -168,7 +168,7 @@ solve env rank pools state constraint =

168 CLet [] [] header headerCon subCon ->

169 do state1 <- solve env rank pools state headerCon

170 locals <- traverse (A.traverse (typeToVariable rank pools)) header

171− let newEnv = Map.union env (Map.map A.drop locals)

171+ let newEnv = Map.union env (Map.map A.toValue locals)

172 state2 <- solve newEnv rank pools state1 subCon

173 foldM occurs state2 $ Map.toList locals

174

@@ -205,7 +205,7 @@ solve env rank pools state constraint =

205 -- check that things went well

206 mapM_ isGeneric rigids

207

208− let newEnv = Map.union env (Map.map A.drop locals)

208+ let newEnv = Map.union env (Map.map A.toValue locals)

209 let tempState = State savedEnv finalMark errors

210 newState <- solve newEnv nextRank nextPools tempState subCon

211