086880c · elk · git.iko.soy

git.iko.soy/elk

Update pattern matches for less caching in canonical AST

commit086880c4bf52c54abfa3c226640fc2abc682e4b2 authorEvan Czaplicki <evancz@users.noreply.github.com> dateThu 30 Nov 2017, 15:11 (9 years ago) parent3c00750

3 files changed+34−28

compare with master

unifiedsplit

src/Nitpick/PatternMatches.hs+12−9 src/Type/Constrain/Expression.hs+20−17 src/Type/Solve.hs+2−2

src/Nitpick/PatternMatches.hs+12−9

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

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

211211checkDef def errors =

212212 case def of

213− Can.Def _ args _ body ->

213+ Can.Def _ args body ->

214214 foldr checkArg (checkExpr body errors) args

215215

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

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

217217 foldr checkTypedArg (checkExpr body errors) args

218218

219219

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

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

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

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

222222 checkPatterns region BadArg [pattern] errors

223223

224224

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

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

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

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

227227 checkPatterns region BadArg [pattern] errors

228228

229229

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

246246 Can.VarForeign _ _ _ ->

247247 errors

248248

249+ Can.VarDebug _ _ _ ->

250+ errors

251+

249252 Can.VarOperator _ _ _ _ ->

250253 errors

251254

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

271274 checkExpr left $

272275 checkExpr right errors

273276

274− Can.Lambda args _ body ->

277+ Can.Lambda args body ->

275278 foldr checkArg (checkExpr body errors) args

276279

277280 Can.Call func args ->

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

286289 Can.LetRec defs body ->

287290 foldr checkDef (checkExpr body errors) defs

288291

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

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

290293 checkPatterns reg BadDestruct [pattern] $

291294 checkExpr expr $ checkExpr body errors

292295

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

345348

346349

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

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

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

349352 ( pattern:patterns

350353 , checkExpr expr errors

351354 )

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

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

5252 Can.VarForeign _ name annotation ->

5353 return $ CInstance region (FuncName name) annotation expected

5454

55+ Can.VarDebug _ name annotation ->

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

57+

5558 Can.VarOperator op _ _ annotation ->

5659 return $ CInstance region (OpName op) annotation expected

5760

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

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

8285 constrainBinop rtv region op annotation leftExpr rightExpr expected

8386

84− Can.Lambda args _ body ->

87+ Can.Lambda args body ->

8588 constrainLambda rtv region args body expected

8689

8790 Can.Call func args ->

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

101104 constrainRecursiveDefs rtv defs

102105 =<< constrain rtv body expected

103106

104− Can.LetDestruct pattern _ expr body ->

107+ Can.LetDestruct pattern expr body ->

105108 constrainDestruct rtv region pattern expr

106109 =<< constrain rtv body expected

107110

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

150153-- CONSTRAIN LAMBDA

151154

152155

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

154157constrainLambda rtv region args body expected =

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

156159 constrainArgs args

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

375378

376379

377380constrainCaseBranch :: 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 =

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

380383 Pattern.add pattern pExpect Pattern.emptyState

381384

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

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

535538constrainDef rtv def bodyCon =

536539 case def of

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

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

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

539542 constrainArgs args

540543

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

557560 , _bodyCon = bodyCon

558561 }

559562

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

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

561564 do let newNames = Map.difference freeVars rtv

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

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

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

622625

623626 def : otherDefs ->

624627 case def of

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

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

626629 do let (Info flexVars flexCons flexHeaders) = flexInfo

627630

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

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

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

648651 }

649652

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

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

651654 do let newNames = Map.difference freeVars rtv

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

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

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

692695 }

693696

694697

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

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

696699constrainArgs args =

697700 argsHelp args Pattern.emptyState

698701

699702

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

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

701704argsHelp args state =

702705 case args of

703706 [] ->

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

705708 let resultType = VarN resultVar

706709 return $ Args [resultVar] resultType resultType state

707710

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

711+ pattern : otherArgs ->

709712 do argVar <- mkFlexVar

710713 let argType = VarN argVar

711714

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

728731 }

729732

730733

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

732735constrainTypedArgs rtv name args srcResultType =

733736 do resultType <- Instantiate.fromSrcType rtv srcResultType

734− typedArgsHelp rtv name args resultType Pattern.emptyState

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

735738

736739

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

738−typedArgsHelp rtv name args resultType state =

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

741+typedArgsHelp rtv name index args resultType state =

739742 case args of

740743 [] ->

741744 return $ TypedArgs resultType resultType state

742745

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

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

744747 do argType <- Instantiate.fromSrcType rtv srcType

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

746749

747750 (TypedArgs tipe result newState) <-

748− typedArgsHelp rtv name otherArgs resultType =<<

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

749752 Pattern.add pattern expected state

750753

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

src/Type/Solve.hs+2−2

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

168168 CLet [] [] header headerCon subCon ->

169169 do state1 <- solve env rank pools state headerCon

170170 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)

172172 state2 <- solve newEnv rank pools state1 subCon

173173 foldM occurs state2 $ Map.toList locals

174174

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

205205 -- check that things went well

206206 mapM_ isGeneric rigids

207207

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

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

209209 let tempState = State savedEnv finalMark errors

210210 newState <- solve newEnv nextRank nextPools tempState subCon

211211