afafd36 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

No more schemes / stop using bags to track pattern bindings

afafd36Evan Czaplicki9 years ago

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

compare with master

unifiedsplit

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

1{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3module Type.Constrain.Expression

2module Type.Constrain.Expression

4 ( constrain

3 ( constrain

5 )

4 )

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

17import qualified Reporting.Region as R

16import qualified Reporting.Region as R

18import Type.Constraint

17import Type.Constraint

19import qualified Type.Constrain.Pattern as Pattern

18import qualified Type.Constrain.Pattern as Pattern

19+import qualified Type.Instantiate as Instantiate

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

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

62 Can.Int _ ->

63 do var <- mkFlexNumber

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

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

66 Can.Float _ ->

67 return $ CEqual region Float Type.float expectation

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

74 let numberType = VarN numberVar

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

76 let negateCon = CEqual region Number numberType expectation

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

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

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

80 constrainBinop rtv region op annotation leftExpr rightExpr expectation

82 Can.Lambda args _ body ->

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

83+ constrainLambda rtv region args body expectation

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

85− let lambdaCon = CEqual region Lambda lambdaType expectation

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

88 Can.Call func args ->

85 Can.Call func args ->

89 constrainCall rtv region func args expectation

86 constrainCall rtv region func args expectation

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

95 constrainCase rtv region expr branches expectation

92 constrainCase rtv region expr branches expectation

97 Can.Let def body ->

94 Can.Let def body ->

95+ constrainDef rtv def

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

96+ =<< constrain rtv body expectation

100 Can.LetRec defs body ->

98 Can.LetRec defs body ->

101− error "TODO let rec" defs body

99+ constrainRecursiveDefs rtv defs

100+ =<< constrain rtv body expectation

102

101

103− Can.LetDestruct pattern destructors expr body ->

102+ Can.LetDestruct pattern _ expr body ->

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

103+ constrainDestruct rtv region pattern expr

104+ =<< constrain rtv body expectation

105

106 Can.Accessor field ->

107 do extVar <- mkFlexVar

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

109 let extType = VarN extVar

110 let fieldType = VarN fieldVar

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

112− return $ ex [ fieldVar, extVar ] $

112+ return $ exists [ fieldVar, extVar ] $

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

114

115 Can.Access expr field ->

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

122 recordCon <-

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

124

125− return $ ex [ fieldVar, extVar ] $

125+ return $ exists [ fieldVar, extVar ] $

126 CAnd

127 [ recordCon

128 , CEqual region (Access field) recordType expectation

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

145

146

147

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+

148-- CONSTRAIN CALL

173-- CONSTRAIN CALL

149

174

150

175

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

165 let arityType = foldr FunN resultType argTypes

190 let arityType = foldr FunN resultType argTypes

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

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

167

192

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

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

169 CAnd

194 CAnd

170 [ funcCon

195 [ funcCon

171 , CBranch

196 , CBranch

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

196

221

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

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

198

223

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

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

200

225

201

226

202getFuncName :: Can.Expr -> Maybe FuncName

227getFuncName :: Can.Expr -> Maybe FuncName

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

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

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

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

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

242

267

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

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

244 CAnd

269 CAnd

245 [ opCon

270 [ opCon

246 , leftCon

271 , leftCon

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

262 entryCons <-

287 entryCons <-

263 Index.indexedTraverse (constrainListEntry rtv region entryType) entries

288 Index.indexedTraverse (constrainListEntry rtv region entryType) entries

264

289

265− return $ ex [entryVar] $

290+ return $ exists [entryVar] $

266 CAnd

291 CAnd

267 [ CAnd entryCons

292 [ CAnd entryCons

268 , CEqual region List listType expectation

293 , CEqual region List listType expectation

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

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

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

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

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

305

330

306− return $ ex [branchVar] $

331+ return $ exists [branchVar] $

307 CAnd

332 CAnd

308 [ CAnd condCons

333 [ CAnd condCons

309 , CAnd branchCons

334 , CAnd branchCons

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

328 (PatternExpectation region (PCaseMatch index) ptrnType)

353 (PatternExpectation region (PCaseMatch index) ptrnType)

329 (FromAnnotation name arity (TypedCaseBranch index) tipe)

354 (FromAnnotation name arity (TypedCaseBranch index) tipe)

330

355

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

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

332

357

333 _ ->

358 _ ->

334 do branchVar <- mkFlexVar

359 do branchVar <- mkFlexVar

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

339 (PatternExpectation region (PCaseMatch index) ptrnType)

364 (PatternExpectation region (PCaseMatch index) ptrnType)

340 (FromContext region (CaseBranch index) branchType)

365 (FromContext region (CaseBranch index) branchType)

341

366

342− return $ ex [ptrnVar,branchVar] $

367+ return $ exists [ptrnVar,branchVar] $

343 CAnd

368 CAnd

344 [ exprCon

369 [ exprCon

345 , CAnd branchCons

370 , CAnd branchCons

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

349

374

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

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

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

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

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

352− do scheme <- Pattern.constrain pattern pExpect

378+ Pattern.add pattern pExpect Pattern.emptyState

353− constraint <- constrain rtv expr bExpect

379+

354− return $ CLet [scheme] constraint

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

381+ <$> constrain rtv expr bExpect

355

382

356

383

357

384

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

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

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

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

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

371

398

372− return $ ex vars (CAnd cons)

399+ return $ exists vars (CAnd cons)

373

400

374

401

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

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

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

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

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

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

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

405

432

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

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

407

434

408

435

409

436

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

424 Nothing ->

451 Nothing ->

425 do let tupleType = TupleN aType bType Nothing

452 do let tupleType = TupleN aType bType Nothing

426 let tupleCon = CEqual region Tuple tupleType expectation

453 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 ]

428

455

429 Just c ->

456 Just c ->

430 do cVar <- mkFlexVar

457 do cVar <- mkFlexVar

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

435 let tupleType = TupleN aType bType (Just cType)

462 let tupleType = TupleN aType bType (Just cType)

436 let tupleCon = CEqual region Tuple tupleType expectation

463 let tupleCon = CEqual region Tuple tupleType expectation

437

464

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

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

439

466

440

467

441

468

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

456 , toShaderRecord varyings EmptyRecordN

483 , toShaderRecord varyings EmptyRecordN

457 ]

484 ]

458

485

459− return $ ex [ attrVar, unifVar ] $

486+ return $ exists [ attrVar, unifVar ] $

460 CEqual region Shader shaderType expectation

487 CEqual region Shader shaderType expectation

461

488

462

489

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

481

508

482

509

483

510

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

485

530

486

531

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

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

488constrainDef rtv def bodyCon =

533constrainDef rtv def bodyCon =

489 case def of

534 case def of

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

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

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

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

492− Pattern.constrainArgs args

537+ constrainArgs args

493−

538+

494− defCon <-

539+ exprCon <-

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

540+ constrain rtv expr (NoExpectation resultType)

496−

541+

542+ return $

543+ CLet

544+ { _rigidVars = []

545+ , _flexVars = vars

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

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

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

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+ }

499

557

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

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

501 do let newNames = Map.difference freeVars rtv

559 do let newNames = Map.difference freeVars rtv

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

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

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

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

504

562

505− (lambdaType, resultType, scheme) <-

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

506− Pattern.constrainTypedArgs newRtv typedArgs srcResultType

564+ constrainTypedArgs newRtv name typedArgs srcResultType

507

565

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

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

509− defCon <-

567+ exprCon <-

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

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

511

748

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

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

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

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

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

1{-# OPTIONS_GHC -Wall #-}

2module Type.Constrain.Pattern

3− ( constrain

3+ ( State(..)

4− , constrainArgs

4+ , emptyState

5− , constrainTypedArgs

5+ , add

6 )

7 where

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

14import qualified AST.Canonical as Can

15import qualified AST.Module.Name as ModuleName

16−import qualified Data.Bag as Bag

17import qualified Data.Index as Index

16import qualified Data.Index as Index

18import qualified Elm.Name as N

17import qualified Elm.Name as N

19import qualified Reporting.Annotation as A

18import qualified Reporting.Annotation as A

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

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−

98-- ACTUALLY ADD CONSTRAINTS

26-- ACTUALLY ADD CONSTRAINTS

100

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

104data State =

32data State =

105 State

33 State

106 { _headers :: Header

34 { _headers :: Header

107− , _vars :: Bag.Bag Variable

35+ , _vars :: [Variable]

108 , _revCons :: [Constraint]

36 , _revCons :: [Constraint]

109 }

37 }

110

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

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

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

146

147 let listCon = CPattern region PList listType expectation

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

149

150 Can.PCons headPattern tailPattern ->

78 Can.PCons headPattern tailPattern ->

151 do entryVar <- mkFlexVar

79 do entryVar <- mkFlexVar

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

160 add tailPattern tailExpectation state

88 add tailPattern tailExpectation state

161

162 let listCon = CPattern region PList listType expectation

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

164

165 Can.PRecord fields ->

93 Can.PRecord fields ->

166 do extVar <- mkFlexVar

94 do extVar <- mkFlexVar

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

175 return $

103 return $

176 State

104 State

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

105 { _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

179 , _revCons = recordCon : revCons

107 , _revCons = recordCon : revCons

180 }

108 }

181

109

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

199-- STATE HELPERS

127-- STATE HELPERS

200

128

201

129

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

130+{-# NOINLINE emptyState #-}

203−addToVars var (State headers vars revCons) =

131+emptyState :: State

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

132+emptyState =

133+ State Map.empty [] []

205

134

206

135

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

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

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

250 simpleAdd b bType =<<

179 simpleAdd b bType =<<

251 simpleAdd a aType state

180 simpleAdd a aType state

252

181

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

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

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

255

183

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

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

257

185

258 Just c ->

186 Just c ->

259 do cVar <- mkFlexVar

187 do cVar <- mkFlexVar

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

264 simpleAdd b bType =<<

192 simpleAdd b bType =<<

265 simpleAdd a aType state

193 simpleAdd a aType state

266

194

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

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

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

269

196

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

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

271

198

272

199

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

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

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

294 return $

221 return $

295 State

222 State

296 { _headers = headers

223 { _headers = headers

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

224+ , _vars = map snd varPairs ++ vars

298 , _revCons = ctorCon : revCons

225 , _revCons = ctorCon : revCons

299 }

226 }

300

227

src/Type/Constraint.hs+14−32

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

2{-# LANGUAGE OverloadedStrings #-}

3module Type.Constraint

4 ( Constraint(..)

5+ , exists

5 , Expectation(..)

6 , Expectation(..)

6 , Context(..)

7 , Context(..)

7 , SubContext(..)

8 , SubContext(..)

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

10 , PatternExpectation(..)

11 , PatternExpectation(..)

11 , PatternContext(..)

12 , PatternContext(..)

12 , PatternCategory(..)

13 , PatternCategory(..)

13− , Scheme(..)

14− , monoscheme

15− , ex

16 )

14 )

17 where

15 where

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

39 | CInstance R.Region FuncName Can.Annotation Expectation

37 | CInstance R.Region FuncName Can.Annotation Expectation

40 | CPattern R.Region PatternCategory Type PatternExpectation

38 | CPattern R.Region PatternCategory Type PatternExpectation

41 | CAnd [Constraint]

39 | CAnd [Constraint]

40+ | CLet

41+ { _rigidVars :: [Variable]

42+ , _flexVars :: [Variable]

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

42− | CLet [Scheme] Constraint

44+ , _headerCon :: Constraint

45+ , _bodyCon :: Constraint

46+ }

43 | CBranch

47 | CBranch

44 { _a :: Type

48 { _a :: Type

45 , _b :: Type

49 , _b :: Type

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

48 }

52 }

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

56+exists flexVars constraint =

57+ CLet [] flexVars Map.empty constraint CTrue

58+

59+

52-- EXPRESSION EXPECTATIONS

61-- EXPRESSION EXPECTATIONS

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

70 | BadArity

79 | BadArity

71 | RecordAccess N.Name

80 | RecordAccess N.Name

72 | RecordUpdate

81 | RecordUpdate

82+ | Destructure

75data SubContext

85data SubContext

76 = TypedIfBranch Index.ZeroBased

86 = TypedIfBranch Index.ZeroBased

77− | TypedElseBranch

78 | TypedCaseBranch Index.ZeroBased

87 | TypedCaseBranch Index.ZeroBased

79 | TypedBody

88 | TypedBody

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

129 | PInt

138 | PInt

130 | PStr

139 | PStr

131 | PChr

140 | 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