afafd36 · elk · git.iko.soy

git.iko.soy/elk

No more schemes / stop using bags to track pattern bindings

I noticed that every use of CLet had a list like [Scheme] where there was only one scheme. So rather than doing those two extra allocations for no reason, I just collapsed them down into the CLet constructor. This also meant shuffling some code around a bit, from Pattern to Expression. I think the code is clearer even though it means I have access to Pattern.State. I was formerly using bags to track bindings in patterns, but I don’t think it was saving anything. Normally you are just adding one thing which is O(1) with lists and bags (though with less allocation in lists) but sometimes you are adding a list. That case is O(n) for lists and O(1) for bags, except that the Bag implementation crawled over the list to turn it into a bag, making it O(n) as well. Then at the end the bag is converted to a list anyway. So my theory is that going for lists directly will be faster and allocate less.

commitafafd362a3c05bd85151d1a7e509359bd817829f authorEvan Czaplicki <evancz@users.noreply.github.com> dateWed 15 Nov 2017, 18:30 (9 years ago) parent5fcbf86

3 files changed+307−162

compare with master

unifiedsplit

src/Type/Constrain/Expression.hs+279−43 src/Type/Constrain/Pattern.hs+14−87 src/Type/Constraint.hs+14−32

src/Type/Constrain/Expression.hs+279−43

@@ -1,5 +1,4 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

32module Type.Constrain.Expression

43 ( constrain

54 )

@@ -17,6 +16,7 @@ import qualified Reporting.Annotation as A

1716import qualified Reporting.Region as R

1817import Type.Constraint

1918import qualified Type.Constrain.Pattern as Pattern

19+import qualified Type.Instantiate as Instantiate

2020import Type.Type as Type hiding (Descriptor(..))

2121

2222

@@ -61,7 +61,7 @@ constrain rtv (A.A region expression) expectation =

6161

6262 Can.Int _ ->

6363 do var <- mkFlexNumber

64− return $ ex [var] $ CEqual region Number (VarN var) expectation

64+ return $ exists [var] $ CEqual region Number (VarN var) expectation

6565

6666 Can.Float _ ->

6767 return $ CEqual region Float Type.float expectation

@@ -74,16 +74,13 @@ constrain rtv (A.A region expression) expectation =

7474 let numberType = VarN numberVar

7575 numberCon <- constrain rtv expr (FromContext region Negate numberType)

7676 let negateCon = CEqual region Number numberType expectation

77− return $ ex [numberVar] $ CAnd [ numberCon, negateCon ]

77+ return $ exists [numberVar] $ CAnd [ numberCon, negateCon ]

7878

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

8080 constrainBinop rtv region op annotation leftExpr rightExpr expectation

8181

8282 Can.Lambda args _ body ->

83− do (lambdaType, resultType, scheme) <- Pattern.constrainArgs args

84− bodyCon <- constrain rtv body (NoExpectation resultType)

85− let lambdaCon = CEqual region Lambda lambdaType expectation

86− return $ CLet [scheme] $ CAnd [ bodyCon, lambdaCon ]

83+ constrainLambda rtv region args body expectation

8784

8885 Can.Call func args ->

8986 constrainCall rtv region func args expectation

@@ -95,13 +92,16 @@ constrain rtv (A.A region expression) expectation =

9592 constrainCase rtv region expr branches expectation

9693

9794 Can.Let def body ->

98− constrainDef rtv def =<< constrain rtv body expectation

95+ constrainDef rtv def

96+ =<< constrain rtv body expectation

9997

10098 Can.LetRec defs body ->

101− error "TODO let rec" defs body

99+ constrainRecursiveDefs rtv defs

100+ =<< constrain rtv body expectation

102101

103− Can.LetDestruct pattern destructors expr body ->

104− error "TODO let destruct" pattern destructors expr body

102+ Can.LetDestruct pattern _ expr body ->

103+ constrainDestruct rtv region pattern expr

104+ =<< constrain rtv body expectation

105105

106106 Can.Accessor field ->

107107 do extVar <- mkFlexVar

@@ -109,7 +109,7 @@ constrain rtv (A.A region expression) expectation =

109109 let extType = VarN extVar

110110 let fieldType = VarN fieldVar

111111 let recordType = RecordN (Map.singleton field fieldType) extType

112− return $ ex [ fieldVar, extVar ] $

112+ return $ exists [ fieldVar, extVar ] $

113113 CEqual region (Accessor field) (FunN recordType fieldType) expectation

114114

115115 Can.Access expr field ->

@@ -122,7 +122,7 @@ constrain rtv (A.A region expression) expectation =

122122 recordCon <-

123123 constrain rtv expr (FromContext region (RecordAccess field) recordType)

124124

125− return $ ex [ fieldVar, extVar ] $

125+ return $ exists [ fieldVar, extVar ] $

126126 CAnd

127127 [ recordCon

128128 , CEqual region (Access field) recordType expectation

@@ -145,6 +145,31 @@ constrain rtv (A.A region expression) expectation =

145145

146146

147147

148+-- CONSTRAIN LAMBDA

149+

150+

151+constrainLambda :: RTV -> R.Region -> [Can.Arg] -> Can.Expr -> Expectation -> IO Constraint

152+constrainLambda rtv region args body expectation =

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

154+ constrainArgs args

155+

156+ bodyCon <-

157+ constrain rtv body (NoExpectation resultType)

158+

159+ return $ exists vars $

160+ CAnd

161+ [ CLet

162+ { _rigidVars = []

163+ , _flexVars = pvars

164+ , _header = headers

165+ , _headerCon = CAnd (reverse revCons)

166+ , _bodyCon = bodyCon

167+ }

168+ , CEqual region Lambda tipe expectation

169+ ]

170+

171+

172+

148173-- CONSTRAIN CALL

149174

150175

@@ -165,7 +190,7 @@ constrainCall rtv region func args expectation =

165190 let arityType = foldr FunN resultType argTypes

166191 let resultCon = CEqual region (CallResult maybeFuncName) resultType expectation

167192

168− return $ ex (funcVar:resultVar:argVars) $

193+ return $ exists (funcVar:resultVar:argVars) $

169194 CAnd

170195 [ funcCon

171196 , CBranch

@@ -196,7 +221,7 @@ constrainCallBackup rtv region maybeFuncName func args =

196221

197222 funcCon <- constrain rtv func (FromContext region BadArity arityType)

198223

199− return $ ex (resultVar:argVars) $ CAnd [ CAnd argCons, funcCon ]

224+ return $ exists (resultVar:argVars) $ CAnd [ CAnd argCons, funcCon ]

200225

201226

202227getFuncName :: Can.Expr -> Maybe FuncName

@@ -240,7 +265,7 @@ constrainBinop rtv region op annotation leftExpr rightExpr expectation =

240265 leftCon <- constrain rtv leftExpr (FromContext region (OpLeft op) leftType)

241266 rightCon <- constrain rtv rightExpr (FromContext region (OpRight op) rightType)

242267

243− return $ ex [ leftVar, rightVar, answerVar ] $

268+ return $ exists [ leftVar, rightVar, answerVar ] $

244269 CAnd

245270 [ opCon

246271 , leftCon

@@ -262,7 +287,7 @@ constrainList rtv region entries expectation =

262287 entryCons <-

263288 Index.indexedTraverse (constrainListEntry rtv region entryType) entries

264289

265− return $ ex [entryVar] $

290+ return $ exists [entryVar] $

266291 CAnd

267292 [ CAnd entryCons

268293 , CEqual region List listType expectation

@@ -303,7 +328,7 @@ constrainIf rtv region branches final expectation =

303328 branchCons <- Index.indexedForA exprs $ \index expr ->

304329 constrain rtv expr (FromContext region (IfBranch index) branchType)

305330

306− return $ ex [branchVar] $

331+ return $ exists [branchVar] $

307332 CAnd

308333 [ CAnd condCons

309334 , CAnd branchCons

@@ -328,7 +353,7 @@ constrainCase rtv region expr branches expectation =

328353 (PatternExpectation region (PCaseMatch index) ptrnType)

329354 (FromAnnotation name arity (TypedCaseBranch index) tipe)

330355

331− return $ ex [ptrnVar] $ CAnd (exprCon:branchCons)

356+ return $ exists [ptrnVar] $ CAnd (exprCon:branchCons)

332357

333358 _ ->

334359 do branchVar <- mkFlexVar

@@ -339,7 +364,7 @@ constrainCase rtv region expr branches expectation =

339364 (PatternExpectation region (PCaseMatch index) ptrnType)

340365 (FromContext region (CaseBranch index) branchType)

341366

342− return $ ex [ptrnVar,branchVar] $

367+ return $ exists [ptrnVar,branchVar] $

343368 CAnd

344369 [ exprCon

345370 , CAnd branchCons

@@ -349,9 +374,11 @@ constrainCase rtv region expr branches expectation =

349374

350375constrainCaseBranch :: RTV -> Can.CaseBranch -> PatternExpectation -> Expectation -> IO Constraint

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

352− do scheme <- Pattern.constrain pattern pExpect

353− constraint <- constrain rtv expr bExpect

354− return $ CLet [scheme] constraint

377+ do (Pattern.State headers pvars revCons) <-

378+ Pattern.add pattern pExpect Pattern.emptyState

379+

380+ CLet [] pvars headers (CAnd (reverse revCons))

381+ <$> constrain rtv expr bExpect

355382

356383

357384

@@ -369,7 +396,7 @@ constrainRecord rtv region fields expectation =

369396 let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict

370397 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict

371398

372− return $ ex vars (CAnd cons)

399+ return $ exists vars (CAnd cons)

373400

374401

375402constrainField :: RTV -> Can.Expr -> IO (Variable, Type, Constraint)

@@ -403,7 +430,7 @@ constrainUpdate rtv region expr fields expectation =

403430 let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict

404431 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict

405432

406− return $ ex vars (CAnd (oldCon:cons))

433+ return $ exists vars (CAnd (oldCon:cons))

407434

408435

409436

@@ -424,7 +451,7 @@ constrainTuple rtv region a b maybeC expectation =

424451 Nothing ->

425452 do let tupleType = TupleN aType bType Nothing

426453 let tupleCon = CEqual region Tuple tupleType expectation

427− return $ ex [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]

454+ return $ exists [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]

428455

429456 Just c ->

430457 do cVar <- mkFlexVar

@@ -435,7 +462,7 @@ constrainTuple rtv region a b maybeC expectation =

435462 let tupleType = TupleN aType bType (Just cType)

436463 let tupleCon = CEqual region Tuple tupleType expectation

437464

438− return $ ex [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]

465+ return $ exists [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]

439466

440467

441468

@@ -456,7 +483,7 @@ constrainShader region (Shader.Shader attributes uniforms varyings) expectation

456483 , toShaderRecord varyings EmptyRecordN

457484 ]

458485

459− return $ ex [ attrVar, unifVar ] $

486+ return $ exists [ attrVar, unifVar ] $

460487 CEqual region Shader shaderType expectation

461488

462489

@@ -481,33 +508,242 @@ glToType glType =

481508

482509

483510

484−-- CONSTRAIN LET

511+-- CONSTRAIN DESTRUCTURES

512+

513+

514+constrainDestruct :: RTV -> R.Region -> Can.Pattern -> Can.Expr -> Constraint -> IO Constraint

515+constrainDestruct rtv region pattern expr bodyCon =

516+ do patternVar <- mkFlexVar

517+ let patternType = VarN patternVar

518+

519+ (Pattern.State headers pvars revCons) <-

520+ Pattern.add pattern (NoPatternExpectation patternType) Pattern.emptyState

521+

522+ exprCon <-

523+ constrain rtv expr (FromContext region Destructure patternType)

524+

525+ return $ CLet [] pvars headers (CAnd (reverse (exprCon:revCons))) bodyCon

526+

527+

528+

529+-- CONSTRAIN DEF

485530

486531

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

488533constrainDef rtv def bodyCon =

489534 case def of

490535 Can.Def (A.A region name) args _ expr ->

491− do (lambdaType, resultType, scheme) <-

492− Pattern.constrainArgs args

493−

494− defCon <-

495− CLet [scheme] <$> constrain rtv expr (NoExpectation resultType)

496−

497− let headers = Map.singleton name (A.A region lambdaType)

498− return $ CLet [Scheme [] [] headers defCon] bodyCon

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

537+ constrainArgs args

538+

539+ exprCon <-

540+ constrain rtv expr (NoExpectation resultType)

541+

542+ return $

543+ CLet

544+ { _rigidVars = []

545+ , _flexVars = vars

546+ , _header = Map.singleton name (A.A region tipe)

547+ , _headerCon =

548+ CLet

549+ { _rigidVars = []

550+ , _flexVars = pvars

551+ , _header = headers

552+ , _headerCon = CAnd (reverse revCons)

553+ , _bodyCon = exprCon

554+ }

555+ , _bodyCon = bodyCon

556+ }

499557

500558 Can.TypedDef (A.A region name) freeVars typedArgs _ expr srcResultType ->

501559 do let newNames = Map.difference freeVars rtv

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

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

504562

505− (lambdaType, resultType, scheme) <-

506− Pattern.constrainTypedArgs newRtv typedArgs srcResultType

563+ (TypedArgs tipe resultType (Pattern.State headers pvars revCons)) <-

564+ constrainTypedArgs newRtv name typedArgs srcResultType

507565

508566 let expectation = FromAnnotation name (length typedArgs) TypedBody resultType

509− defCon <-

510− CLet [scheme] <$> constrain newRtv expr expectation

567+ exprCon <-

568+ constrain newRtv expr expectation

569+

570+ return $

571+ CLet

572+ { _rigidVars = Map.elems newRigids

573+ , _flexVars = []

574+ , _header = Map.singleton name (A.A region tipe)

575+ , _headerCon =

576+ CLet

577+ { _rigidVars = []

578+ , _flexVars = pvars

579+ , _header = headers

580+ , _headerCon = CAnd (reverse revCons)

581+ , _bodyCon = exprCon

582+ }

583+ , _bodyCon = bodyCon

584+ }

585+

586+

587+

588+-- CONSTRAIN RECURSIVE DEFS

589+

590+

591+data Info =

592+ Info

593+ { _vars :: [Variable]

594+ , _cons :: [Constraint]

595+ , _headers :: Map.Map N.Name (A.Located Type)

596+ }

597+

598+

599+{-# NOINLINE emptyInfo #-}

600+emptyInfo :: Info

601+emptyInfo =

602+ Info [] [] Map.empty

603+

604+

605+constrainRecursiveDefs :: RTV -> [Can.Def] -> Constraint -> IO Constraint

606+constrainRecursiveDefs rtv defs bodyCon =

607+ recDefsHelp rtv defs bodyCon emptyInfo emptyInfo

608+

609+

610+recDefsHelp :: RTV -> [Can.Def] -> Constraint -> Info -> Info -> IO Constraint

611+recDefsHelp rtv defs bodyCon rigidInfo flexInfo =

612+ case defs of

613+ [] ->

614+ do let (Info rigidVars rigidCons rigidHeaders) = rigidInfo

615+ let (Info flexVars flexCons flexHeaders ) = flexInfo

616+ return $

617+ CLet rigidVars [] rigidHeaders CTrue $

618+ CLet [] flexVars flexHeaders (CLet [] [] flexHeaders CTrue (CAnd flexCons)) $

619+ CAnd [ CAnd rigidCons, bodyCon ]

620+

621+ def : otherDefs ->

622+ case def of

623+ Can.Def (A.A region name) args _ expr ->

624+ do let (Info flexVars flexCons flexHeaders) = flexInfo

625+

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

627+ argsHelp args (Pattern.State Map.empty flexVars [])

628+

629+ exprCon <-

630+ constrain rtv expr (NoExpectation resultType)

631+

632+ let defCon =

633+ CLet

634+ { _rigidVars = []

635+ , _flexVars = pvars

636+ , _header = headers

637+ , _headerCon = CAnd (reverse revCons)

638+ , _bodyCon = exprCon

639+ }

640+

641+ recDefsHelp rtv otherDefs bodyCon rigidInfo $

642+ Info

643+ { _vars = newFlexVars

644+ , _cons = defCon : flexCons

645+ , _headers = Map.insert name (A.A region tipe) flexHeaders

646+ }

647+

648+ Can.TypedDef (A.A region name) freeVars typedArgs _ expr srcResultType ->

649+ do let newNames = Map.difference freeVars rtv

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

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

652+

653+ (TypedArgs tipe resultType (Pattern.State headers pvars revCons)) <-

654+ constrainTypedArgs newRtv name typedArgs srcResultType

655+

656+ exprCon <-

657+ constrain newRtv expr $

658+ FromAnnotation name (length typedArgs) TypedBody resultType

659+

660+ let defCon =

661+ CLet

662+ { _rigidVars = []

663+ , _flexVars = pvars

664+ , _header = headers

665+ , _headerCon = CAnd (reverse revCons)

666+ , _bodyCon = exprCon

667+ }

668+

669+ let (Info rigidVars rigidCons rigidHeaders) = rigidInfo

670+ recDefsHelp rtv otherDefs bodyCon

671+ ( Info

672+ { _vars = Map.foldr (:) rigidVars newRigids

673+ , _cons = defCon : rigidCons

674+ , _headers = Map.insert name (A.A region tipe) rigidHeaders

675+ }

676+ )

677+ flexInfo

678+

679+

680+

681+-- CONSTRAIN ARGS

682+

683+

684+data Args =

685+ Args

686+ { _a_vars :: [Variable]

687+ , _a_type :: Type

688+ , _a_result :: Type

689+ , _a_state :: Pattern.State

690+ }

691+

692+

693+constrainArgs :: [Can.Arg] -> IO Args

694+constrainArgs args =

695+ argsHelp args Pattern.emptyState

696+

697+

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

699+argsHelp args state =

700+ case args of

701+ [] ->

702+ do resultVar <- mkFlexVar

703+ let resultType = VarN resultVar

704+ return $ Args [resultVar] resultType resultType state

705+

706+ (Can.Arg _ pattern) : otherArgs ->

707+ do argVar <- mkFlexVar

708+ let argType = VarN argVar

709+

710+ (Args vars tipe result newState) <-

711+ argsHelp otherArgs =<<

712+ Pattern.add pattern (NoPatternExpectation argType) state

713+

714+ return (Args (argVar:vars) (FunN argType tipe) result newState)

715+

716+

717+

718+-- CONSTRAIN TYPED ARGS

719+

720+

721+data TypedArgs =

722+ TypedArgs

723+ { _t_type :: Type

724+ , _t_result :: Type

725+ , _t_state :: Pattern.State

726+ }

727+

728+

729+constrainTypedArgs :: Map.Map N.Name Type -> N.Name -> [Can.TypedArg] -> Can.Type -> IO TypedArgs

730+constrainTypedArgs rtv name args srcResultType =

731+ do resultType <- Instantiate.fromSrcType rtv srcResultType

732+ typedArgsHelp rtv name args resultType Pattern.emptyState

733+

734+

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

736+typedArgsHelp rtv name args resultType state =

737+ case args of

738+ [] ->

739+ return $ TypedArgs resultType resultType state

740+

741+ (Can.TypedArg index srcType pattern@(A.A region _)) : otherArgs ->

742+ do argType <- Instantiate.fromSrcType rtv srcType

743+ let expect = PatternExpectation region (PTypedArg name index) argType

744+

745+ (TypedArgs tipe result newState) <-

746+ typedArgsHelp rtv name otherArgs resultType =<<

747+ Pattern.add pattern expect state

511748

512− let headers = Map.singleton name (A.A region lambdaType)

513− return $ CLet [ Scheme (Map.elems newRigids) [] headers defCon ] bodyCon

749+ return (TypedArgs (FunN argType tipe) result newState)

src/Type/Constrain/Pattern.hs+14−87

@@ -1,8 +1,8 @@

11{-# OPTIONS_GHC -Wall #-}

22module Type.Constrain.Pattern

3− ( constrain

4− , constrainArgs

5− , constrainTypedArgs

3+ ( State(..)

4+ , emptyState

5+ , add

66 )

77 where

@@ -13,7 +13,6 @@ import qualified Data.Map.Strict as Map

1313

1414import qualified AST.Canonical as Can

1515import qualified AST.Module.Name as ModuleName

16−import qualified Data.Bag as Bag

1716import qualified Data.Index as Index

1817import qualified Elm.Name as N

1918import qualified Reporting.Annotation as A

@@ -24,77 +23,6 @@ import Type.Type as T

2423

2524

2625

27−-- CONSTRAIN

28−

29−

30−constrain :: Can.Pattern -> PatternExpectation -> IO Scheme

31−constrain pattern expectation =

32− do (State headers vars revCons) <- add pattern expectation emptyState

33− return $ Scheme [] (Bag.toList vars) headers (CAnd (reverse revCons))

34−

35−

36−{-# NOINLINE emptyState #-}

37−emptyState :: State

38−emptyState =

39− State Map.empty Bag.empty []

40−

41−

42−

43−-- CONSTRAIN ARGS

44−

45−

46−constrainArgs :: [Can.Arg] -> IO (Type, Type, Scheme)

47−constrainArgs args =

48− do resultVar <- mkFlexVar

49− let resultType = VarN resultVar

50− (toLambdaType, State headers varBag revCons) <-

51− foldM argHelp (id, emptyState) args

52−

53− let vars = resultVar : Bag.toList varBag

54− let cons = CAnd (reverse revCons)

55− return

56− ( toLambdaType resultType

57− , resultType

58− , Scheme [] vars headers cons

59− )

60−

61−

62−argHelp :: (Type -> Type, State) -> Can.Arg -> IO (Type -> Type, State)

63−argHelp (toLambdaType, state) (Can.Arg _ pattern) =

64− do argVar <- mkFlexVar

65− let argType = VarN argVar

66− newState <- add pattern (NoPatternExpectation argType) state

67− return (toLambdaType . FunN argType, addToVars argVar newState)

68−

69−

70−

71−-- CONSTRAIN TYPED ARGS

72−

73−

74−constrainTypedArgs :: Map.Map N.Name Type -> [Can.TypedArg] -> Can.Type -> IO (Type, Type, Scheme)

75−constrainTypedArgs rtv args srcResultType =

76− do resultType <- Instantiate.fromSrcType rtv srcResultType

77−

78− (toLambdaType, State headers varBag revCons) <-

79− foldM (typedArgHelp rtv) (id, emptyState) args

80−

81− let vars = Bag.toList varBag

82− let cons = CAnd (reverse revCons)

83− return

84− ( toLambdaType resultType

85− , resultType

86− , Scheme [] vars headers cons

87− )

88−

89−

90−typedArgHelp :: Map.Map N.Name Type -> (Type -> Type, State) -> Can.TypedArg -> IO (Type -> Type, State)

91−typedArgHelp rtv (toLambdaType, state) (Can.TypedArg _ srcType pattern) =

92− do argType <- Instantiate.fromSrcType rtv srcType

93− newState <- add pattern (NoPatternExpectation argType) state

94− return (toLambdaType . FunN argType, newState)

95−

96−

97−

9826-- ACTUALLY ADD CONSTRAINTS

9927

10028

@@ -104,7 +32,7 @@ typedArgHelp rtv (toLambdaType, state) (Can.TypedArg _ srcType pattern) =

10432data State =

10533 State

10634 { _headers :: Header

107− , _vars :: Bag.Bag Variable

35+ , _vars :: [Variable]

10836 , _revCons :: [Constraint]

10937 }

11038

@@ -145,7 +73,7 @@ add (A.A region pattern) expectation state =

14573 foldM (addEntry region entryType) state (Index.indexedMap (,) patterns)

14674

14775 let listCon = CPattern region PList listType expectation

148− return $ State headers (Bag.insert entryVar vars) (listCon:revCons)

76+ return $ State headers (entryVar:vars) (listCon:revCons)

14977

15078 Can.PCons headPattern tailPattern ->

15179 do entryVar <- mkFlexVar

@@ -160,7 +88,7 @@ add (A.A region pattern) expectation state =

16088 add tailPattern tailExpectation state

16189

16290 let listCon = CPattern region PList listType expectation

163− return $ State headers (Bag.insert entryVar vars) (listCon : revCons)

91+ return $ State headers (entryVar:vars) (listCon : revCons)

16492

16593 Can.PRecord fields ->

16694 do extVar <- mkFlexVar

@@ -175,7 +103,7 @@ add (A.A region pattern) expectation state =

175103 return $

176104 State

177105 { _headers = Map.union headers (Map.map (A.A region) fieldTypes)

178− , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))

106+ , _vars = map snd fieldVars ++ extVar : vars

179107 , _revCons = recordCon : revCons

180108 }

181109

@@ -199,9 +127,10 @@ add (A.A region pattern) expectation state =

199127-- STATE HELPERS

200128

201129

202−addToVars :: Variable -> State -> State

203−addToVars var (State headers vars revCons) =

204− State headers (Bag.insert var vars) revCons

130+{-# NOINLINE emptyState #-}

131+emptyState :: State

132+emptyState =

133+ State Map.empty [] []

205134

206135

207136addToHeaders :: R.Region -> N.Name -> PatternExpectation -> State -> State

@@ -250,10 +179,9 @@ addTuple region a b maybeC expectation state =

250179 simpleAdd b bType =<<

251180 simpleAdd a aType state

252181

253− let newVars = Bag.insert aVar (Bag.insert bVar vars)

254182 let tupleCon = CPattern region PTuple (TupleN aType bType Nothing) expectation

255183

256− return $ State headers newVars (tupleCon:revCons)

184+ return $ State headers (aVar:bVar:vars) (tupleCon:revCons)

257185

258186 Just c ->

259187 do cVar <- mkFlexVar

@@ -264,10 +192,9 @@ addTuple region a b maybeC expectation state =

264192 simpleAdd b bType =<<

265193 simpleAdd a aType state

266194

267− let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))

268195 let tupleCon = CPattern region PTuple (TupleN aType bType (Just cType)) expectation

269196

270− return $ State headers newVars (tupleCon:revCons)

197+ return $ State headers (aVar:bVar:cVar:vars) (tupleCon:revCons)

271198

272199

273200simpleAdd :: Can.Pattern -> Type -> State -> IO State

@@ -294,7 +221,7 @@ addCtor region home typeName typeVarNames ctorName args expectation state =

294221 return $

295222 State

296223 { _headers = headers

297− , _vars = Bag.append vars (Bag.fromList snd varPairs)

224+ , _vars = map snd varPairs ++ vars

298225 , _revCons = ctorCon : revCons

299226 }

300227

src/Type/Constraint.hs+14−32

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

22{-# LANGUAGE OverloadedStrings #-}

33module Type.Constraint

44 ( Constraint(..)

5+ , exists

56 , Expectation(..)

67 , Context(..)

78 , SubContext(..)

@@ -10,9 +11,6 @@ module Type.Constraint

1011 , PatternExpectation(..)

1112 , PatternContext(..)

1213 , PatternCategory(..)

13− , Scheme(..)

14− , monoscheme

15− , ex

1614 )

1715 where

1816

@@ -39,7 +37,13 @@ data Constraint

3937 | CInstance R.Region FuncName Can.Annotation Expectation

4038 | CPattern R.Region PatternCategory Type PatternExpectation

4139 | CAnd [Constraint]

42− | CLet [Scheme] Constraint

40+ | CLet

41+ { _rigidVars :: [Variable]

42+ , _flexVars :: [Variable]

43+ , _header :: Map.Map N.Name (A.Located Type)

44+ , _headerCon :: Constraint

45+ , _bodyCon :: Constraint

46+ }

4347 | CBranch

4448 { _a :: Type

4549 , _b :: Type

@@ -48,6 +52,11 @@ data Constraint

4852 }

4953

5054

55+exists :: [Variable] -> Constraint -> Constraint

56+exists flexVars constraint =

57+ CLet [] flexVars Map.empty constraint CTrue

58+

59+

5160

5261-- EXPRESSION EXPECTATIONS

5362

@@ -70,11 +79,11 @@ data Context

7079 | BadArity

7180 | RecordAccess N.Name

7281 | RecordUpdate

82+ | Destructure

7383

7484

7585data SubContext

7686 = TypedIfBranch Index.ZeroBased

77− | TypedElseBranch

7887 | TypedCaseBranch Index.ZeroBased

7988 | TypedBody

8089

@@ -129,30 +138,3 @@ data PatternCategory

129138 | PInt

130139 | PStr

131140 | PChr

132−

133−

134−

135−-- SCHEMES

136−

137−

138−data Scheme =

139− Scheme

140− { _rigidVars :: [Variable]

141− , _flexVars :: [Variable]

142− , _header :: Map.Map N.Name (A.Located Type)

143− , _constraint :: Constraint

144− }

145−

146−

147−monoscheme :: Map.Map N.Name (A.Located Type) -> Scheme

148−monoscheme headers =

149− Scheme [] [] headers CTrue

150−

151−

152−-- ex qs constraint == exists qs. constraint

153−ex :: [Variable] -> Constraint -> Constraint

154−ex flexVars constraint =

155− CLet

156− [ Scheme [] flexVars Map.empty constraint

157− ]

158− CTrue