8b03cb7 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Get rid of Type.State and Solver monad

8b03cb7Evan Czaplicki9 years ago

src/Type/Constrain/Expression.hs+69−69

compare with master

unifiedsplit

@@ -35,73 +35,73 @@ type RTV =

35 Map.Map N.Name Type

38−constrain :: RTV -> Can.Expr -> Expectation -> IO Constraint

38+constrain :: RTV -> Can.Expr -> Expected Type -> IO Constraint

39−constrain rtv (A.At region expression) expectation =

39+constrain rtv (A.At region expression) expected =

40 case expression of

41 Can.VarLocal name ->

42− return (CLookup region name expectation)

42+ return (CLookup region name expected)

44 Can.VarTopLevel _ name ->

45− return (CLookup region name expectation)

45+ return (CLookup region name expected)

47 Can.VarKernel _ _ ->

48 return CTrue

50 Can.VarForeign _ name annotation ->

51− return $ CInstance region (FuncName name) annotation expectation

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

53 Can.VarOperator op _ _ annotation ->

54− return $ CInstance region (OpName op) annotation expectation

54+ return $ CInstance region (OpName op) annotation expected

56 Can.Str _ ->

57− return $ CEqual region String Type.string expectation

57+ return $ CEqual region String Type.string expected

59 Can.Chr _ ->

60− return $ CEqual region Char Type.char expectation

60+ return $ CEqual region Char Type.char expected

62 Can.Int _ ->

63 do var <- mkFlexNumber

64− return $ exists [var] $ CEqual region C.Number (VarN var) expectation

64+ return $ exists [var] $ CEqual region C.Number (VarN var) expected

66 Can.Float _ ->

67− return $ CEqual region Float Type.float expectation

67+ return $ CEqual region Float Type.float expected

69 Can.List elements ->

70− constrainList rtv region elements expectation

70+ constrainList rtv region elements expected

72 Can.Negate expr ->

73 do numberVar <- mkFlexNumber

74 let numberType = VarN numberVar

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

76− let negateCon = CEqual region C.Number numberType expectation

76+ let negateCon = CEqual region C.Number numberType expected

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

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

80− constrainBinop rtv region op annotation leftExpr rightExpr expectation

80+ constrainBinop rtv region op annotation leftExpr rightExpr expected

82 Can.Lambda args _ body ->

83− constrainLambda rtv region args body expectation

83+ constrainLambda rtv region args body expected

85 Can.Call func args ->

86− constrainCall rtv region func args expectation

86+ constrainCall rtv region func args expected

88 Can.If branches finally ->

89− constrainIf rtv region branches finally expectation

89+ constrainIf rtv region branches finally expected

91 Can.Case expr branches ->

92− constrainCase rtv region expr branches expectation

92+ constrainCase rtv region expr branches expected

94 Can.Let def body ->

95 constrainDef rtv def

96− =<< constrain rtv body expectation

96+ =<< constrain rtv body expected

98 Can.LetRec defs body ->

99 constrainRecursiveDefs rtv defs

100− =<< constrain rtv body expectation

100+ =<< constrain rtv body expected

101

102 Can.LetDestruct pattern _ expr body ->

103 constrainDestruct rtv region pattern expr

104− =<< constrain rtv body expectation

104+ =<< constrain rtv body expected

105

106 Can.Accessor field ->

107 do extVar <- mkFlexVar

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

110 let fieldType = VarN fieldVar

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

112 return $ exists [ fieldVar, extVar ] $

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

113+ CEqual region (Accessor field) (FunN recordType fieldType) expected

114

115 Can.Access expr field ->

116 do extVar <- mkFlexVar

@@ -125,31 +125,31 @@ constrain rtv (A.At region expression) expectation =

125 return $ exists [ fieldVar, extVar ] $

126 CAnd

127 [ recordCon

128− , CEqual region (Access field) recordType expectation

128+ , CEqual region (Access field) recordType expected

129 ]

130

131 Can.Update expr fields ->

132− constrainUpdate rtv region expr fields expectation

132+ constrainUpdate rtv region expr fields expected

133

134 Can.Record fields ->

135− constrainRecord rtv region fields expectation

135+ constrainRecord rtv region fields expected

136

137 Can.Unit ->

138− return $ CEqual region Unit UnitN expectation

138+ return $ CEqual region Unit UnitN expected

139

140 Can.Tuple a b maybeC ->

141− constrainTuple rtv region a b maybeC expectation

141+ constrainTuple rtv region a b maybeC expected

142

143 Can.Shader _uid _src glType ->

144− constrainShader region glType expectation

144+ constrainShader region glType expected

145

146

147

148-- CONSTRAIN LAMBDA

149

150

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

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

152−constrainLambda rtv region args body expectation =

152+constrainLambda rtv region args body expected =

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

154 constrainArgs args

155

@@ -165,7 +165,7 @@ constrainLambda rtv region args body expectation =

165 , _headerCon = CAnd (reverse revCons)

166 , _bodyCon = bodyCon

167 }

168− , CEqual region Lambda tipe expectation

168+ , CEqual region Lambda tipe expected

169 ]

170

171

@@ -173,8 +173,8 @@ constrainLambda rtv region args body expectation =

173-- CONSTRAIN CALL

174

175

176−constrainCall :: RTV -> R.Region -> Can.Expr -> [Can.Expr] -> Expectation -> IO Constraint

176+constrainCall :: RTV -> R.Region -> Can.Expr -> [Can.Expr] -> Expected Type -> IO Constraint

177−constrainCall rtv region func args expectation =

177+constrainCall rtv region func args expected =

178 do let maybeFuncName = getFuncName func

179

180 funcVar <- mkFlexVar

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

188 unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeFuncName) args

189

190 let arityType = foldr FunN resultType argTypes

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

191+ let resultCon = CEqual region (CallResult maybeFuncName) resultType expected

192

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

194 CAnd

@@ -250,8 +250,8 @@ getFuncName (A.At _ expr) =

250-- CONSTRAIN BINOP

251

252

253−constrainBinop :: RTV -> R.Region -> N.Name -> Can.Annotation -> Can.Expr -> Can.Expr -> Expectation -> IO Constraint

253+constrainBinop :: RTV -> R.Region -> N.Name -> Can.Annotation -> Can.Expr -> Can.Expr -> Expected Type -> IO Constraint

254−constrainBinop rtv region op annotation leftExpr rightExpr expectation =

254+constrainBinop rtv region op annotation leftExpr rightExpr expected =

255 do leftVar <- mkFlexVar

256 rightVar <- mkFlexVar

257 answerVar <- mkFlexVar

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

270 [ opCon

271 , leftCon

272 , rightCon

273− , CEqual region (CallResult (Just (OpName op))) answerType expectation

273+ , CEqual region (CallResult (Just (OpName op))) answerType expected

274 ]

275

276

@@ -278,8 +278,8 @@ constrainBinop rtv region op annotation leftExpr rightExpr expectation =

278-- CONSTRAIN LISTS

279

280

281−constrainList :: RTV -> R.Region -> [Can.Expr] -> Expectation -> IO Constraint

281+constrainList :: RTV -> R.Region -> [Can.Expr] -> Expected Type -> IO Constraint

282−constrainList rtv region entries expectation =

282+constrainList rtv region entries expected =

283 do entryVar <- mkFlexVar

284 let entryType = VarN entryVar

285 let listType = AppN ModuleName.list N.list [entryType]

@@ -290,7 +290,7 @@ constrainList rtv region entries expectation =

290 return $ exists [entryVar] $

291 CAnd

292 [ CAnd entryCons

293− , CEqual region List listType expectation

293+ , CEqual region List listType expected

294 ]

295

296

@@ -303,15 +303,15 @@ constrainListEntry rtv region tipe index expr =

303-- CONSTRAIN IF EXPRESSIONS

304

305

306−constrainIf :: RTV -> R.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Expectation -> IO Constraint

306+constrainIf :: RTV -> R.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Expected Type -> IO Constraint

307−constrainIf rtv region branches final expectation =

307+constrainIf rtv region branches final expected =

308 do let boolExpect = FromContext region IfCondition Type.bool

309 let (conditions, exprs) = foldr (\(c,e) (cs,es) -> (c:cs,e:es)) ([],[final]) branches

310

311 condCons <-

312 traverse (\c -> constrain rtv c boolExpect) conditions

313

314− case expectation of

314+ case expected of

315 FromAnnotation name arity _ tipe ->

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

317 constrain rtv expr (FromAnnotation name arity (TypedIfBranch index) tipe)

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

332 CAnd

333 [ CAnd condCons

334 , CAnd branchCons

335− , CEqual region If branchType expectation

335+ , CEqual region If branchType expected

336 ]

337

338

@@ -340,17 +340,17 @@ constrainIf rtv region branches final expectation =

340-- CONSTRAIN CASE EXPRESSIONS

341

342

343−constrainCase :: RTV -> R.Region -> Can.Expr -> [Can.CaseBranch] -> Expectation -> IO Constraint

343+constrainCase :: RTV -> R.Region -> Can.Expr -> [Can.CaseBranch] -> Expected Type -> IO Constraint

344−constrainCase rtv region expr branches expectation =

344+constrainCase rtv region expr branches expected =

345 do ptrnVar <- mkFlexVar

346 let ptrnType = VarN ptrnVar

347 exprCon <- constrain rtv expr (NoExpectation ptrnType)

348

349− case expectation of

349+ case expected of

350 FromAnnotation name arity _ tipe ->

351 do branchCons <- Index.indexedForA branches $ \index branch ->

352 constrainCaseBranch rtv branch

353− (PatternExpectation region (PCaseMatch index) ptrnType)

353+ (PFromContext region (PCaseMatch index) ptrnType)

354 (FromAnnotation name arity (TypedCaseBranch index) tipe)

355

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

@@ -361,18 +361,18 @@ constrainCase rtv region expr branches expectation =

361

362 branchCons <- Index.indexedForA branches $ \index branch ->

363 constrainCaseBranch rtv branch

364− (PatternExpectation region (PCaseMatch index) ptrnType)

364+ (PFromContext region (PCaseMatch index) ptrnType)

365 (FromContext region (CaseBranch index) branchType)

366

367 return $ exists [ptrnVar,branchVar] $

368 CAnd

369 [ exprCon

370 , CAnd branchCons

371− , CEqual region Case branchType expectation

371+ , CEqual region Case branchType expected

372 ]

373

374

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

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

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

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

378 Pattern.add pattern pExpect Pattern.emptyState

@@ -385,13 +385,13 @@ constrainCaseBranch rtv (Can.CaseBranch pattern _ expr) pExpect bExpect =

385-- CONSTRAIN RECORD

386

387

388−constrainRecord :: RTV -> R.Region -> Map.Map N.Name Can.Expr -> Expectation -> IO Constraint

388+constrainRecord :: RTV -> R.Region -> Map.Map N.Name Can.Expr -> Expected Type -> IO Constraint

389−constrainRecord rtv region fields expectation =

389+constrainRecord rtv region fields expected =

390 do dict <- traverse (constrainField rtv) fields

391

392 let getType (_, t, _) = t

393 let recordType = RecordN (Map.map getType dict) EmptyRecordN

394− let recordCon = CEqual region Record recordType expectation

394+ let recordCon = CEqual region Record recordType expected

395

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

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

@@ -411,8 +411,8 @@ constrainField rtv expr =

411-- CONSTRAIN RECORD UPDATE

412

413

414−constrainUpdate :: RTV -> R.Region -> Can.Expr -> Map.Map N.Name Can.Expr -> Expectation -> IO Constraint

414+constrainUpdate :: RTV -> R.Region -> Can.Expr -> Map.Map N.Name Can.Expr -> Expected Type -> IO Constraint

415−constrainUpdate rtv region expr fields expectation =

415+constrainUpdate rtv region expr fields expected =

416 do sharedVar <- mkFlexVar

417 let sharedType = VarN sharedVar

418

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

425

426 let getType (_, t, _) = t

427 let newRecordType = RecordN (Map.map getType newDict) sharedType

428− let newCon = CEqual region Record newRecordType expectation

428+ let newCon = CEqual region Record newRecordType expected

429

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

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

@@ -437,8 +437,8 @@ constrainUpdate rtv region expr fields expectation =

437-- CONSTRAIN TUPLE

438

439

440−constrainTuple :: RTV -> R.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Expectation -> IO Constraint

440+constrainTuple :: RTV -> R.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Expected Type -> IO Constraint

441−constrainTuple rtv region a b maybeC expectation =

441+constrainTuple rtv region a b maybeC expected =

442 do aVar <- mkFlexVar

443 bVar <- mkFlexVar

444 let aType = VarN aVar

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

450 case maybeC of

451 Nothing ->

452 do let tupleType = TupleN aType bType Nothing

453− let tupleCon = CEqual region Tuple tupleType expectation

453+ let tupleCon = CEqual region Tuple tupleType expected

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

455

456 Just c ->

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

460 cCon <- constrain rtv c (NoExpectation cType)

461

462 let tupleType = TupleN aType bType (Just cType)

463− let tupleCon = CEqual region Tuple tupleType expectation

463+ let tupleCon = CEqual region Tuple tupleType expected

464

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

466

@@ -469,8 +469,8 @@ constrainTuple rtv region a b maybeC expectation =

469-- CONSTRAIN SHADER

470

471

472−constrainShader :: R.Region -> Shader.Shader -> Expectation -> IO Constraint

472+constrainShader :: R.Region -> Shader.Shader -> Expected Type -> IO Constraint

473−constrainShader region (Shader.Shader attributes uniforms varyings) expectation =

473+constrainShader region (Shader.Shader attributes uniforms varyings) expected =

474 do attrVar <- mkFlexVar

475 unifVar <- mkFlexVar

476 let attrType = VarN attrVar

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

484 ]

485

486 return $ exists [ attrVar, unifVar ] $

487− CEqual region Shader shaderType expectation

487+ CEqual region Shader shaderType expected

488

489

490toShaderRecord :: Map.Map N.Name Shader.Type -> Type -> Type

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

517 let patternType = VarN patternVar

518

519 (Pattern.State headers pvars revCons) <-

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

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

521

522 exprCon <-

523 constrain rtv expr (FromContext region Destructure patternType)

@@ -563,9 +563,9 @@ constrainDef rtv def bodyCon =

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

564 constrainTypedArgs newRtv name typedArgs srcResultType

565

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

566+ let expected = FromAnnotation name (length typedArgs) TypedBody resultType

567 exprCon <-

568− constrain newRtv expr expectation

568+ constrain newRtv expr expected

569

570 return $

571 CLet

@@ -709,7 +709,7 @@ argsHelp args state =

709

710 (Args vars tipe result newState) <-

711 argsHelp otherArgs =<<

712− Pattern.add pattern (NoPatternExpectation argType) state

712+ Pattern.add pattern (PNoExpectation argType) state

713

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

715

@@ -740,10 +740,10 @@ typedArgsHelp rtv name args resultType state =

740

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

742 do argType <- Instantiate.fromSrcType rtv srcType

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

743+ let expected = PFromContext region (PTypedArg name index) argType

744

745 (TypedArgs tipe result newState) <-

746 typedArgsHelp rtv name otherArgs resultType =<<

747− Pattern.add pattern expect state

747+ Pattern.add pattern expected state

748

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

src/Type/Constrain/Pattern.hs+12−12

@@ -40,7 +40,7 @@ data State =

40type Header = Map.Map N.Name (A.Located Type)

43−add :: Can.Pattern -> PatternExpectation -> State -> IO State

43+add :: Can.Pattern -> PExpected Type -> State -> IO State

44add (A.At region pattern) expectation state =

45 case pattern of

46 Can.PAnything ->

@@ -80,8 +80,8 @@ add (A.At region pattern) expectation state =

80 let entryType = VarN entryVar

81 let listType = AppN ModuleName.list N.list [entryType]

83− let headExpectation = NoPatternExpectation entryType

83+ let headExpectation = PNoExpectation entryType

84− let tailExpectation = PatternExpectation region PTail listType

84+ let tailExpectation = PFromContext region PTail listType

86 (State headers vars revCons) <-

87 add headPattern headExpectation =<<

@@ -133,7 +133,7 @@ emptyState =

133 State Map.empty [] []

134

135

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

136+addToHeaders :: R.Region -> N.Name -> PExpected Type -> State -> State

137addToHeaders region name expectation (State headers vars revCons) =

138 let

139 tipe = getType expectation

@@ -142,11 +142,11 @@ addToHeaders region name expectation (State headers vars revCons) =

142 State newHeaders vars revCons

143

144

145−getType :: PatternExpectation -> Type

145+getType :: PExpected Type -> Type

146getType expectation =

147 case expectation of

148− NoPatternExpectation tipe -> tipe

148+ PNoExpectation tipe -> tipe

149− PatternExpectation _ _ tipe -> tipe

149+ PFromContext _ _ tipe -> tipe

150

151

152

@@ -157,7 +157,7 @@ addEntry :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO St

157addEntry listRegion tipe state (index, pattern) =

158 let

159 expectation =

160− PatternExpectation listRegion (PListEntry index) tipe

160+ PFromContext listRegion (PListEntry index) tipe

161 in

162 add pattern expectation state

163

@@ -166,7 +166,7 @@ addEntry listRegion tipe state (index, pattern) =

166-- CONSTRAIN TUPLE

167

168

169−addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> PatternExpectation -> State -> IO State

169+addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> PExpected Type -> State -> IO State

170addTuple region a b maybeC expectation state =

171 do aVar <- mkFlexVar

172 bVar <- mkFlexVar

@@ -199,14 +199,14 @@ addTuple region a b maybeC expectation state =

199

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

201simpleAdd pattern patternType state =

202− add pattern (NoPatternExpectation patternType) state

202+ add pattern (PNoExpectation patternType) state

203

204

205

206-- CONSTRAIN CONSTRUCTORS

207

208

209−addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> PatternExpectation -> State -> IO State

209+addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> PExpected Type -> State -> IO State

210addCtor region home typeName typeVarNames ctorName args expectation state =

211 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames

212 let typePairs = map (second VarN) varPairs

@@ -229,5 +229,5 @@ addCtor region home typeName typeVarNames ctorName args expectation state =

229addCtorArg :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State

230addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =

231 do tipe <- Instantiate.fromSrcType freeVarDict srcType

232− let expectation = PatternExpectation region (PCtorArg ctorName index) tipe

232+ let expectation = PFromContext region (PCtorArg ctorName index) tipe

233 add pattern expectation state

src/Type/Constraint.hs+53−24

@@ -3,14 +3,16 @@

3module Type.Constraint

4 ( Constraint(..)

5 , exists

6− , Expectation(..)

6+ , Expected(..)

7 , Context(..)

8 , SubContext(..)

9 , FuncName(..)

10 , Category(..)

11− , PatternExpectation(..)

11+ , PExpected(..)

12− , PatternContext(..)

12+ , PContext(..)

13− , PatternCategory(..)

13+ , PCategory(..)

14+ , typeReplace

15+ , ptypeReplace

14 )

16 )

15 where

17 where

@@ -31,12 +33,18 @@ import Type.Type (Type, Variable)

32data Constraint

34data Constraint

33 = CTrue

35 = CTrue

34− | CSaveHeaders

36+ | CSaveTheEnvironment

35− | CEqual R.Region Category Type Expectation

37+ | CEqual R.Region Category Type (Expected Type)

36− | CLookup R.Region N.Name Expectation

38+ | CLookup R.Region N.Name (Expected Type)

37− | CInstance R.Region FuncName Can.Annotation Expectation

39+ | CInstance R.Region FuncName Can.Annotation (Expected Type)

38− | CPattern R.Region PatternCategory Type PatternExpectation

40+ | CPattern R.Region PCategory Type (PExpected Type)

39 | CAnd [Constraint]

41 | CAnd [Constraint]

42+ | CBranch

43+ { _a :: Type

44+ , _b :: Type

45+ , _eq :: Constraint

46+ , _neq :: IO Constraint

47+ }

40 | CLet

48 | CLet

41 { _rigidVars :: [Variable]

49 { _rigidVars :: [Variable]

42 , _flexVars :: [Variable]

50 , _flexVars :: [Variable]

@@ -44,12 +52,6 @@ data Constraint

44 , _headerCon :: Constraint

52 , _headerCon :: Constraint

45 , _bodyCon :: Constraint

53 , _bodyCon :: Constraint

46 }

54 }

47− | CBranch

48− { _a :: Type

49− , _b :: Type

50− , _eq :: Constraint

51− , _neq :: IO Constraint

52− }

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

57exists :: [Variable] -> Constraint -> Constraint

@@ -61,10 +63,10 @@ exists flexVars constraint =

61-- EXPRESSION EXPECTATIONS

63-- EXPRESSION EXPECTATIONS

64−data Expectation

66+data Expected tipe

65− = NoExpectation Type

67+ = NoExpectation tipe

66− | FromContext R.Region Context Type

68+ | FromContext R.Region Context tipe

67− | FromAnnotation N.Name Int SubContext Type

69+ | FromAnnotation N.Name Int SubContext tipe

70data Context

72data Context

@@ -116,12 +118,12 @@ data Category

116-- PATTERN EXPECTATIONS

118-- PATTERN EXPECTATIONS

117

119

118

120

119−data PatternExpectation

121+data PExpected tipe

120− = NoPatternExpectation Type

122+ = PNoExpectation tipe

121− | PatternExpectation R.Region PatternContext Type

123+ | PFromContext R.Region PContext tipe

122

124

123

125

124−data PatternContext

126+data PContext

125 = PTypedArg N.Name Index.ZeroBased

127 = PTypedArg N.Name Index.ZeroBased

126 | PCaseMatch Index.ZeroBased

128 | PCaseMatch Index.ZeroBased

127 | PCtorArg N.Name Index.ZeroBased

129 | PCtorArg N.Name Index.ZeroBased

@@ -129,7 +131,7 @@ data PatternContext

129 | PTail

131 | PTail

130

132

131

133

132−data PatternCategory

134+data PCategory

133 = PRecord

135 = PRecord

134 | PUnit

136 | PUnit

135 | PTuple

137 | PTuple

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

138 | PInt

140 | PInt

139 | PStr

141 | PStr

140 | PChr

142 | PChr

143+

144+

145+

146+-- HELPERS

147+

148+

149+typeReplace :: Expected Type -> Can.Type -> Expected Can.Type

150+typeReplace expectation tipe =

151+ case expectation of

152+ NoExpectation _ ->

153+ NoExpectation tipe

154+

155+ FromContext region context _ ->

156+ FromContext region context tipe

157+

158+ FromAnnotation name arity context _ ->

159+ FromAnnotation name arity context tipe

160+

161+

162+ptypeReplace :: PExpected Type -> Can.Type -> PExpected Can.Type

163+ptypeReplace expectation tipe =

164+ case expectation of

165+ PNoExpectation _ ->

166+ PNoExpectation tipe

167+

168+ PFromContext region context _ ->

169+ PFromContext region context tipe

src/Type/Solve.hs+518−141

@@ -1,155 +1,221 @@

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings #-}

3−module Type.Solve (solve) where

3+module Type.Solve

4+ ( run

5+ )

6+ where

5import Control.Monad

9import Control.Monad

6−import Control.Monad.Except (ExceptT, liftIO, throwError)

7import qualified Data.Map.Strict as Map

10import qualified Data.Map.Strict as Map

8−import qualified Data.Text as Text

11+import Data.Map.Strict ((!))

9import qualified Data.Vector as Vector

12import qualified Data.Vector as Vector

10import qualified Data.Vector.Mutable as MVector

13import qualified Data.Vector.Mutable as MVector

12−import qualified AST.Module.Name as ModuleName

15+import qualified AST.Canonical as Can

16+import qualified Elm.Name as N

13import qualified Reporting.Annotation as A

17import qualified Reporting.Annotation as A

14import qualified Reporting.Error.Type as Error

18import qualified Reporting.Error.Type as Error

15import qualified Type.Occurs as Occurs

19import qualified Type.Occurs as Occurs

16−import qualified Type.State as TS

20+import Type.Constraint as Con

17−import Type.Constraint (Constraint(..), Scheme(..))

18import Type.Type as Type

21import Type.Type as Type

19−import Type.Unify

22+import qualified Type.Unify as Unify

20import qualified Type.UnionFind as UF

23import qualified Type.UnionFind as UF

24−-- SOLVER

27+-- RUN

25−

26−

27−solve :: Constraint -> ExceptT [A.Located Error.Error] IO TS.State

28−solve constraint =

29− {-# SCC elm_compiler_type_solve #-}

30− do state <- liftIO (TS.run (actuallySolve constraint))

31− case TS._errors state of

32− [] ->

33− return state

34−

35− errors ->

36− throwError errors

37−

38−

39−actuallySolve :: Constraint -> TS.Solver ()

40−actuallySolve constraint =

41− case constraint of

42− CTrue ->

43− return ()

44−

45− CSaveEnv ->

46− TS.saveLocalEnv

47−

48− CEqual hint region term1 term2 ->

49− do t1 <- TS.flatten term1

50− t2 <- TS.flatten term2

51− unify hint region t1 t2

53− CAnd cs ->

54− mapM_ actuallySolve cs

56− CLet [Scheme [] fqs constraint' _] CTrue ->

30+run :: Constraint -> IO (Either [Error.Error] Env)

57− do oldEnv <- TS.getEnv

31+run constraint =

58− TS.introduce fqs

32+ do pools <- MVector.replicate 16 []

59− actuallySolve constraint'

60− TS.modifyEnv (\_ -> oldEnv)

62− CLet schemes constraint' ->

34+ (State env _ errors) <-

63− do oldEnv <- TS.getEnv

35+ solve Map.empty outermostRank pools emptyState constraint

64− headers <- Map.unions <$> mapM solveScheme schemes

65− TS.modifyEnv $ \env -> Map.union headers env

66− actuallySolve constraint'

67− mapM_ occurs $ Map.toList headers

68− TS.modifyEnv (\_ -> oldEnv)

70− CInstance region name term ->

37+ case errors of

71− do env <- TS.getEnv

38+ [] ->

72− freshCopy <-

39+ return $ Right env

73− case Map.lookup name env of

74− Just (A.A _ tipe) ->

75− TS.copy tipe

76−

77− Nothing ->

78− if ModuleName.isKernel name then

79− liftIO mkFlexVar

81− else

41+ _ ->

82− error ("Could not find `" ++ Text.unpack name ++ "` when solving type constraints.")

42+ return $ Left errors

84− t <- TS.flatten term

85− unify (Error.Instance name) region freshCopy t

46+{-# NOINLINE emptyState #-}

47+emptyState :: State

48+emptyState =

49+ State Map.empty (nextMark noMark) []

89−-- SOLVE SCHEMES

92−solveScheme :: Scheme -> TS.Solver TS.Env

53+-- SOLVER

93−solveScheme scheme =

94− let

95− flatten (A.A region term) =

96− A.A region <$> TS.flatten term

97− in

98− case scheme of

99− Scheme [] [] constraint header ->

100− do actuallySolve constraint

101− traverse flatten header

102−

103− Scheme rigidQuantifiers flexQuantifiers constraint header ->

104− -- work in the next pool for this scheme's constraints

105− solveSchemeHelp rigidQuantifiers flexQuantifiers $

106− do flatHeader <- traverse flatten header

107− actuallySolve constraint

108− return flatHeader

109−

110

111

112−solveSchemeHelp :: [Variable] -> [Variable] -> TS.Solver a -> TS.Solver a

56+type Env =

113−solveSchemeHelp rigidQuantifiers flexQuantifiers (TS.Solver stepState) =

57+ Map.Map N.Name Variable

114− TS.Solver $ \state@(TS.SS _ _ rank oldPools _ _) ->

115− do

116− -- push pool

117− let nextRank = rank + 1

118− let poolsLength = MVector.length oldPools

119

120− pools <-

121− if nextRank < poolsLength

122− then return oldPools

123− else MVector.grow oldPools poolsLength

124

125− -- introduce quantifiers

60+type Pools =

126− let allQuantifiers = rigidQuantifiers ++ flexQuantifiers

61+ MVector.IOVector [Variable]

127− forM_ allQuantifiers $ \var ->

128− UF.modifyDescriptor var $ \(Descriptor content _ mark copy) ->

129− Descriptor content nextRank mark copy

130− MVector.write pools nextRank allQuantifiers

131

132− -- run solver in next pool

133− (value, TS.SS env savedEnv _ _ mark errors) <- stepState (state { TS._rank = nextRank })

134

135− -- pop pool

64+data State =

136− let youngMark = mark

65+ State

137− let visitMark = nextMark mark

66+ { _env :: Env

138− let finalMark = nextMark visitMark

67+ , _mark :: Mark

139− generalize youngMark visitMark nextRank pools

68+ , _errors :: [Error.Error]

140− MVector.write pools nextRank []

69+ }

141

142− -- check that things went well

143− mapM_ isGeneric rigidQuantifiers

144

145− -- return result with pool popped

72+solve :: Env -> Int -> Pools -> State -> Constraint -> IO State

146− return ( value, TS.SS env savedEnv rank pools finalMark errors )

73+solve env rank pools state constraint =

74+ case constraint of

75+ CTrue ->

76+ return state

77+

78+ CSaveTheEnvironment ->

79+ return (state { _env = env })

80+

81+ CEqual region category tipe expectation ->

82+ do actual <- typeToVariable rank pools tipe

83+ expected <- expectedToVariable rank pools expectation

84+ answer <- Unify.unify actual expected

85+ case answer of

86+ Unify.Ok vars ->

87+ do introduce rank pools vars

88+ return state

89+

90+ Unify.Err vars problem actualType expectedType ->

91+ do introduce rank pools vars

92+ return $ addError state $

93+ Error.Mismatch

94+ (Error.BadExpr region category actualType)

95+ (Con.typeReplace expectation expectedType)

96+ problem

97+

98+ CLookup region name expectation ->

99+ do actual <- makeCopy rank pools (env ! name)

100+ expected <- expectedToVariable rank pools expectation

101+ answer <- Unify.unify actual expected

102+ case answer of

103+ Unify.Ok vars ->

104+ do introduce rank pools vars

105+ return state

106+

107+ Unify.Err vars problem actualType expectedType ->

108+ do introduce rank pools vars

109+ return $ addError state $

110+ Error.Mismatch

111+ (Error.BadLocal region name actualType)

112+ (Con.typeReplace expectation expectedType)

113+ problem

114+

115+ CInstance region funcName (Can.Forall freeVars srcType) expectation ->

116+ do actual <- srcTypeToVariable rank pools freeVars srcType

117+ expected <- expectedToVariable rank pools expectation

118+ answer <- Unify.unify actual expected

119+ case answer of

120+ Unify.Ok vars ->

121+ do introduce rank pools vars

122+ return state

123+

124+ Unify.Err vars problem actualType expectedType ->

125+ do introduce rank pools vars

126+ return $ addError state $

127+ Error.Mismatch

128+ (Error.BadForeign region funcName actualType)

129+ (Con.typeReplace expectation expectedType)

130+ problem

131+

132+ CPattern region category tipe expectation ->

133+ do actual <- typeToVariable rank pools tipe

134+ expected <- patternExpectationToVariable rank pools expectation

135+ answer <- Unify.unify actual expected

136+ case answer of

137+ Unify.Ok vars ->

138+ do introduce rank pools vars

139+ return state

140+

141+ Unify.Err vars problem actualType expectedType ->

142+ do introduce rank pools vars

143+ return $ addError state $

144+ Error.BadPattern region category actualType

145+ (Con.ptypeReplace expectation expectedType)

146+ problem

147+

148+ CAnd constraints ->

149+ foldM (solve env rank pools) state constraints

150+

151+ CBranch a b eqCon makeNotEqCon ->

152+ do aVar <- typeToVariable rank pools a

153+ bVar <- typeToVariable rank pools b

154+ answer <- Unify.unify aVar bVar

155+ case answer of

156+ Unify.Ok vars ->

157+ do introduce rank pools vars

158+ solve env rank pools state eqCon

159+

160+ Unify.Err vars _ _ _ ->

161+ do introduce rank pools vars

162+ solve env rank pools state =<< makeNotEqCon

163+

164+ CLet [] flexs _ headerCon CTrue ->

165+ do introduce rank pools flexs

166+ solve env rank pools state headerCon

167+

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)

172+ state2 <- solve newEnv rank pools state1 subCon

173+ foldM occurs state2 $ Map.toList locals

174+

175+ CLet rigids flexs header headerCon subCon ->

176+ do

177+ -- work in the next pool to localize header

178+ let nextRank = rank + 1

179+ let poolsLength = MVector.length pools

180+ nextPools <-

181+ if nextRank < poolsLength

182+ then return pools

183+ else MVector.grow pools poolsLength

184+

185+ -- introduce variables

186+ let vars = rigids ++ flexs

187+ forM_ vars $ \var ->

188+ UF.modify var $ \(Descriptor content _ mark copy) ->

189+ Descriptor content nextRank mark copy

190+ MVector.write nextPools nextRank vars

191+

192+ -- run solver in next pool

193+ locals <- traverse (A.traverse (typeToVariable rank nextPools)) header

194+ (State savedEnv mark errors) <-

195+ solve env nextRank nextPools state headerCon

196+

197+ let youngMark = mark

198+ let visitMark = nextMark youngMark

199+ let finalMark = nextMark visitMark

200+

201+ -- pop pool

202+ generalize youngMark visitMark nextRank nextPools

203+ MVector.write nextPools nextRank []

204+

205+ -- check that things went well

206+ mapM_ isGeneric rigids

207+

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

209+ let tempState = State savedEnv finalMark errors

210+ newState <- solve newEnv nextRank nextPools tempState subCon

211+

212+ foldM occurs newState (Map.toList locals)

147

213

148

214

149-- Check that a variable has rank == noRank, meaning that it can be generalized.

215-- Check that a variable has rank == noRank, meaning that it can be generalized.

150isGeneric :: Variable -> IO ()

216isGeneric :: Variable -> IO ()

151isGeneric var =

217isGeneric var =

152− do (Descriptor _ rank _ _) <- UF.descriptor var

218+ do (Descriptor _ rank _ _) <- UF.get var

153 if rank == noRank

219 if rank == noRank

154 then return ()

220 then return ()

155 else crash "Unable to generalize a type variable. It is not unranked."

221 else crash "Unable to generalize a type variable. It is not unranked."

@@ -165,22 +231,58 @@ crash msg =

165

231

166

232

167

233

168−-- OCCURS CHECK

234+-- EXPECTATIONS TO VARIABLE

235+

236+

237+expectedToVariable :: Int -> Pools -> Expected Type -> IO Variable

238+expectedToVariable rank pools expectation =

239+ typeToVariable rank pools $

240+ case expectation of

241+ NoExpectation tipe ->

242+ tipe

243+

244+ FromContext _ _ tipe ->

245+ tipe

246+

247+ FromAnnotation _ _ _ tipe ->

248+ tipe

249+

250+

251+patternExpectationToVariable :: Int -> Pools -> PExpected Type -> IO Variable

252+patternExpectationToVariable rank pools expectation =

253+ typeToVariable rank pools $

254+ case expectation of

255+ PNoExpectation tipe ->

256+ tipe

257+

258+ PFromContext _ _ tipe ->

259+ tipe

260+

261+

169

262

263+-- ERROR HELPERS

170

264

171−occurs :: (Text.Text, A.Located Variable) -> TS.Solver ()

172−occurs (name, A.A region variable) =

173− {-# SCC elm_compiler_type_occurs #-}

174− do hasOccurred <- liftIO $ Occurs.occurs variable

175− case hasOccurred of

176− False ->

177− return ()

178

265

179− True ->

266+addError :: State -> Error.Error -> State

267+addError (State savedEnv rank errors) err =

268+ State savedEnv rank (err:errors)

269+

270+

271+

272+-- OCCURS CHECK

273+

274+

275+occurs :: State -> (N.Name, A.Located Variable) -> IO State

276+occurs state (_name, A.At _region variable) =

277+ do hasOccurred <- Occurs.occurs variable

278+ if hasOccurred

279+ then

180− do overallType <- liftIO $ Type.toSrcType variable

280+ do overallType <- Type.toSrcType variable

181− (Descriptor _ rank mark copy) <- liftIO $ UF.descriptor variable

281+ (Descriptor _ rank mark copy) <- UF.get variable

182− liftIO $ UF.setDescriptor variable (Descriptor (Error "∞") rank mark copy)

282+ UF.set variable (Descriptor (Error "∞") rank mark copy)

183− TS.addError region (Error.InfiniteType (Right name) overallType)

283+ return $ state { _errors = Error.InfiniteType overallType : _errors state }

284+ else

285+ return state

184

286

185

287

186

288

@@ -190,11 +292,9 @@ occurs (name, A.A region variable) =

190{-| Every variable has rank less than or equal to the maxRank of the pool.

292{-| Every variable has rank less than or equal to the maxRank of the pool.

191This sorts variables into the young and old pools accordingly.

293This sorts variables into the young and old pools accordingly.

192-}

294-}

193−generalize :: Mark -> Mark -> Int -> TS.Pools -> IO ()

295+generalize :: Mark -> Mark -> Int -> Pools -> IO ()

194generalize youngMark visitMark youngRank pools =

296generalize youngMark visitMark youngRank pools =

195− {-# SCC elm_compiler_type_generalize #-}

196− do

197− youngVars <- MVector.read pools youngRank

297+ do youngVars <- MVector.read pools youngRank

198 rankTable <- poolToRankTable youngMark youngRank youngVars

298 rankTable <- poolToRankTable youngMark youngRank youngVars

199

299

200 -- get the ranks right for each entry.

300 -- get the ranks right for each entry.

@@ -210,7 +310,7 @@ generalize youngMark visitMark youngRank pools =

210 if isRedundant

310 if isRedundant

211 then return ()

311 then return ()

212 else

312 else

213− do (Descriptor _ rank _ _) <- UF.descriptor var

313+ do (Descriptor _ rank _ _) <- UF.get var

214 MVector.modify pools (var:) rank

314 MVector.modify pools (var:) rank

215

315

216 -- For variables with rank youngRank

316 -- For variables with rank youngRank

@@ -221,12 +321,10 @@ generalize youngMark visitMark youngRank pools =

221 if isRedundant

321 if isRedundant

222 then return ()

322 then return ()

223 else

323 else

224− do (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var

324+ do (Descriptor content rank mark copy) <- UF.get var

225 if rank < youngRank

325 if rank < youngRank

226− then

227− MVector.modify pools (var:) rank

326+ then MVector.modify pools (var:) rank

228− else

229− UF.setDescriptor var $ Descriptor content noRank mark copy

327+ else UF.set var $ Descriptor content noRank mark copy

230

328

231

329

232poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable])

330poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable])

@@ -235,8 +333,8 @@ poolToRankTable youngMark youngRank youngInhabitants =

235

333

236 -- Sort the youngPool variables into buckets by rank.

334 -- Sort the youngPool variables into buckets by rank.

237 forM_ youngInhabitants $ \var ->

335 forM_ youngInhabitants $ \var ->

238− do (Descriptor content rank _ copy) <- UF.descriptor var

336+ do (Descriptor content rank _ copy) <- UF.get var

239− UF.setDescriptor var (Descriptor content rank youngMark copy)

337+ UF.set var (Descriptor content rank youngMark copy)

240 MVector.modify mutableTable (var:) rank

338 MVector.modify mutableTable (var:) rank

241

339

242 Vector.unsafeFreeze mutableTable

340 Vector.unsafeFreeze mutableTable

@@ -252,12 +350,12 @@ poolToRankTable youngMark youngRank youngInhabitants =

252adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int

350adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int

253adjustRank youngMark visitMark groupRank var =

351adjustRank youngMark visitMark groupRank var =

254 {-# SCC elm_compiler_type_adjust #-}

352 {-# SCC elm_compiler_type_adjust #-}

255− do (Descriptor content rank mark copy) <- UF.descriptor var

353+ do (Descriptor content rank mark copy) <- UF.get var

256 if mark == youngMark then

354 if mark == youngMark then

257 do -- Set the variable as marked first because it may be cyclic.

355 do -- Set the variable as marked first because it may be cyclic.

258− UF.setDescriptor var $ Descriptor content rank visitMark copy

356+ UF.set var $ Descriptor content rank visitMark copy

259 maxRank <- adjustRankContent youngMark visitMark groupRank content

357 maxRank <- adjustRankContent youngMark visitMark groupRank content

260− UF.setDescriptor var $ Descriptor content maxRank visitMark copy

358+ UF.set var $ Descriptor content maxRank visitMark copy

261 return maxRank

359 return maxRank

262

360

263 else if mark == visitMark then

361 else if mark == visitMark then

@@ -266,7 +364,7 @@ adjustRank youngMark visitMark groupRank var =

266 else

364 else

267 do let minRank = min groupRank rank

365 do let minRank = min groupRank rank

268 -- TODO how can minRank ever be groupRank?

366 -- TODO how can minRank ever be groupRank?

269− UF.setDescriptor var $ Descriptor content minRank visitMark copy

367+ UF.set var $ Descriptor content minRank visitMark copy

270 return minRank

368 return minRank

271

369

272

370

@@ -325,3 +423,282 @@ adjustRankContent youngMark visitMark groupRank content =

325 Error _ ->

423 Error _ ->

326 return groupRank

424 return groupRank

327

425

426+

427+

428+-- REGISTER VARIABLES

429+

430+

431+introduce :: Int -> Pools -> [Variable] -> IO ()

432+introduce rank pools variables =

433+ do MVector.modify pools (variables++) rank

434+ forM_ variables $ \var ->

435+ UF.modify var $ \(Descriptor content _ mark copy) ->

436+ Descriptor content rank mark copy

437+

438+

439+

440+-- TYPE TO VARIABLE

441+

442+

443+typeToVariable :: Int -> Pools -> Type -> IO Variable

444+typeToVariable rank pools tipe =

445+ typeToVar rank pools Map.empty tipe

446+

447+

448+typeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Type -> IO Variable

449+typeToVar rank pools aliasDict tipe =

450+ let go = typeToVar rank pools aliasDict in

451+ case tipe of

452+ VarN v ->

453+ return v

454+

455+ AppN home name args ->

456+ do argVars <- traverse go args

457+ register rank pools (Structure (App1 home name argVars))

458+

459+ FunN a b ->

460+ do aVar <- go a

461+ bVar <- go b

462+ register rank pools (Structure (Fun1 aVar bVar))

463+

464+ AliasN home name args aliasType ->

465+ do argVars <- traverse (traverse go) args

466+ aliasVar <- typeToVar rank pools (Map.fromList argVars) aliasType

467+ register rank pools (Alias home name argVars aliasVar)

468+

469+ PlaceHolder name ->

470+ return (aliasDict ! name)

471+

472+ RecordN fields ext ->

473+ do fieldVars <- traverse go fields

474+ extVar <- go ext

475+ register rank pools (Structure (Record1 fieldVars extVar))

476+

477+ EmptyRecordN ->

478+ register rank pools emptyRecord1

479+

480+ UnitN ->

481+ register rank pools unit1

482+

483+ TupleN a b c ->

484+ do aVar <- go a

485+ bVar <- go b

486+ cVar <- traverse go c

487+ register rank pools (Structure (Tuple1 aVar bVar cVar))

488+

489+

490+register :: Int -> Pools -> Content -> IO Variable

491+register rank pools content =

492+ do var <- UF.fresh (Descriptor content rank noMark Nothing)

493+ MVector.modify pools (var:) rank

494+ return var

495+

496+

497+{-# NOINLINE emptyRecord1 #-}

498+emptyRecord1 :: Content

499+emptyRecord1 =

500+ Structure EmptyRecord1

501+

502+

503+{-# NOINLINE unit1 #-}

504+unit1 :: Content

505+unit1 =

506+ Structure Unit1

507+

508+

509+

510+-- SOURCE TYPE TO VARIABLE

511+

512+

513+srcTypeToVariable :: Int -> Pools -> Map.Map N.Name () -> Can.Type -> IO Variable

514+srcTypeToVariable rank pools freeVars srcType =

515+ let

516+ makeVar name _ =

517+ UF.fresh (Descriptor (FlexVar (Just name)) rank noMark Nothing)

518+ in

519+ do flexVars <- Map.traverseWithKey makeVar freeVars

520+ MVector.modify pools (Map.elems flexVars ++) rank

521+ srcTypeToVar rank pools flexVars srcType

522+

523+

524+srcTypeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Can.Type -> IO Variable

525+srcTypeToVar rank pools flexVars srcType =

526+ let go = srcTypeToVar rank pools flexVars in

527+ case srcType of

528+ Can.TLambda argument result ->

529+ do argVar <- go argument

530+ resultVar <- go result

531+ register rank pools (Structure (Fun1 argVar resultVar))

532+

533+ Can.TVar name ->

534+ return (flexVars ! name)

535+

536+ Can.TType home name args ->

537+ do argVars <- traverse go args

538+ register rank pools (Structure (App1 home name argVars))

539+

540+ Can.TRecord fields maybeExt ->

541+ do fieldVars <- traverse go fields

542+ extVar <- maybe (register rank pools emptyRecord1) go maybeExt

543+ register rank pools (Structure (Record1 fieldVars extVar))

544+

545+ Can.TUnit ->

546+ register rank pools unit1

547+

548+ Can.TTuple a b c ->

549+ do aVar <- go a

550+ bVar <- go b

551+ cVar <- traverse go c

552+ register rank pools (Structure (Tuple1 aVar bVar cVar))

553+

554+ Can.TAlias home name args aliasType ->

555+ do argVars <- traverse (traverse go) args

556+ aliasVar <-

557+ case aliasType of

558+ Can.Holey tipe ->

559+ srcTypeToVar rank pools (Map.fromList argVars) tipe

560+

561+ Can.Filled tipe ->

562+ go tipe

563+

564+ register rank pools (Alias home name argVars aliasVar)

565+

566+

567+

568+-- COPY

569+

570+

571+makeCopy :: Int -> Pools -> Variable -> IO Variable

572+makeCopy rank pools var =

573+ do copy <- makeCopyHelp rank pools var

574+ _ <- restore var

575+ return copy

576+

577+

578+makeCopyHelp :: Int -> Pools -> Variable -> IO Variable

579+makeCopyHelp maxRank pools variable =

580+ do (Descriptor content rank _ maybeCopy) <-

581+ UF.get variable

582+

583+ case maybeCopy of

584+ Just copy ->

585+ return copy

586+

587+ Nothing ->

588+ if rank /= noRank then

589+ return variable

590+

591+ else

592+ do let makeDescriptor c = Descriptor c maxRank noMark Nothing

593+ copy <- UF.fresh $ makeDescriptor content

594+ MVector.modify pools (copy:) maxRank

595+

596+ -- Link the original variable to the new variable. This lets us

597+ -- avoid making multiple copies of the variable we are instantiating.

598+ --

599+ -- Need to do this before recursively copying to avoid looping.

600+ UF.set variable $

601+ Descriptor content rank noMark (Just copy)

602+

603+ -- Now we recursively copy the content of the variable.

604+ -- We have already marked the variable as copied, so we

605+ -- will not repeat this work or crawl this variable again.

606+ case content of

607+ Structure term ->

608+ do newTerm <- traverseFlatType (makeCopyHelp maxRank pools) term

609+ UF.set copy $ makeDescriptor (Structure newTerm)

610+ return copy

611+

612+ FlexVar _ ->

613+ return copy

614+

615+ FlexSuper _ _ ->

616+ return copy

617+

618+ RigidVar name ->

619+ do UF.set copy $ makeDescriptor $ FlexVar (Just name)

620+ return copy

621+

622+ RigidSuper super name ->

623+ do UF.set copy $ makeDescriptor $ FlexSuper super (Just name)

624+ return copy

625+

626+ Alias home name args realType ->

627+ do newArgs <- mapM (traverse (makeCopyHelp maxRank pools)) args

628+ newRealType <- makeCopyHelp maxRank pools realType

629+ UF.set copy $ makeDescriptor (Alias home name newArgs newRealType)

630+ return copy

631+

632+ Error _ ->

633+ return copy

634+

635+

636+

637+-- RESTORE

638+

639+

640+restore :: Variable -> IO Variable

641+restore variable =

642+ do (Descriptor content _rank _mark maybeCopy) <- UF.get variable

643+ case maybeCopy of

644+ Nothing ->

645+ return variable

646+

647+ Just _ ->

648+ do restoredContent <- restoreContent content

649+ UF.set variable $

650+ Descriptor restoredContent noRank noMark Nothing

651+ return variable

652+

653+

654+restoreContent :: Content -> IO Content

655+restoreContent content =

656+ case content of

657+ FlexVar _ ->

658+ return content

659+

660+ FlexSuper _ _ ->

661+ return content

662+

663+ RigidVar _ ->

664+ return content

665+

666+ RigidSuper _ _ ->

667+ return content

668+

669+ Structure term ->

670+ Structure <$> traverseFlatType restore term

671+

672+ Alias home name args var ->

673+ Alias home name

674+ <$> mapM (traverse restore) args

675+ <*> restore var

676+

677+ Error _ ->

678+ return content

679+

680+

681+

682+-- TRAVERSE FLAT TYPE

683+

684+

685+traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType

686+traverseFlatType f flatType =

687+ case flatType of

688+ App1 home name args ->

689+ liftM (App1 home name) (traverse f args)

690+

691+ Fun1 a b ->

692+ liftM2 Fun1 (f a) (f b)

693+

694+ EmptyRecord1 ->

695+ pure EmptyRecord1

696+

697+ Record1 fields ext ->

698+ liftM2 Record1 (traverse f fields) (f ext)

699+

700+ Unit1 ->

701+ pure Unit1

702+

703+ Tuple1 a b cs ->

704+ liftM3 Tuple1 (f a) (f b) (traverse f cs)

src/Type/State.hsdeleted−369

@@ -1,369 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Type.State

3− ( Solver(..)

4− , run

5− , State(..)

6− , Pools

7− , Env

8− , modifyEnv

9− , addError

10− , getEnv

11− , saveLocalEnv

12− , register

13− , introduce

14− , flatten

15− , copy

16− )

17− where

18−

19−

20−import Control.Monad (forM_, liftM, liftM2, liftM3)

21−import Control.Monad.Trans (MonadIO, liftIO)

22−import qualified Data.Map.Strict as Map

23−import Data.Map.Strict ((!))

24−import qualified Data.Vector.Mutable as MVector

25−

26−import qualified Elm.Name as N

27−import qualified Reporting.Annotation as A

28−import qualified Reporting.Error.Type as Error

29−import qualified Reporting.Region as R

30−import Type.Type as Type

31−import qualified Type.UnionFind as UF

32−

33−

34−

35−-- SOLVER

36−

37−

38−newtype Solver a =

39− Solver { _solve :: State -> IO (a, State) }

40−

41−

42−data State =

43− SS

44− { _env :: Env

45− , _savedEnv :: Env

46− , _rank :: Int

47− , _pools :: Pools

48− , _mark :: Mark

49− , _errors :: [A.Located Error.Error]

50− }

51−

52−

53−type Pools = MVector.IOVector [Variable]

54−

55−

56−type Env = Map.Map N.Name (A.Located Variable)

57−

58−

59−

60−-- RUN SOLVER

61−

62−

63−run :: Solver () -> IO State

64−run (Solver solver) =

65− do pools <- MVector.replicate 8 []

66− (_, state) <- solver (SS Map.empty Map.empty outermostRank pools (Type.nextMark noMark) [])

67− return state

68−

69−

70−

71−-- HELPERS

72−

73−

74−{-# INLINE modifyEnv #-}

75−modifyEnv :: (Env -> Env) -> Solver ()

76−modifyEnv f =

77− Solver $ \state ->

78− return ( (), state { _env = f (_env state) } )

79−

80−

81−{-# INLINE addError #-}

82−addError :: R.Region -> Error.Error -> Solver ()

83−addError region err =

84− Solver $ \state ->

85− return ( (), state { _errors = A.A region err : _errors state } )

86−

87−

88−{-# INLINE getEnv #-}

89−getEnv :: Solver Env

90−getEnv =

91− Solver $ \state ->

92− return ( _env state, state )

93−

94−

95−{-# INLINE saveLocalEnv #-}

96−saveLocalEnv :: Solver ()

97−saveLocalEnv =

98− Solver $ \state ->

99− return ( (), state { _savedEnv = _env state } )

100−

101−

102−

103−-- REGISTER VARIABLES

104−

105−

106−register :: Variable -> Solver ()

107−register var =

108− Solver $ \state@(SS _ _ maxRank pools _ _) ->

109− {-# SCC elm_compiler_type_register #-}

110− do MVector.modify pools (var:) maxRank

111− return ( (), state )

112−

113−

114−introduce :: [Variable] -> Solver ()

115−introduce variables =

116− Solver $ \state@(SS _ _ maxRank pools _ _) ->

117− {-# SCC elm_compiler_type_introduce #-}

118− do

119− forM_ variables $ \var ->

120− UF.modifyDescriptor var $ \(Descriptor content _ mark cp) ->

121− Descriptor content maxRank mark cp

122−

123− MVector.modify pools (variables++) maxRank

124−

125− return ( (), state )

126−

127−

128−

129−-- FLATTEN

130−

131−

132−flatten :: Type -> Solver Variable

133−flatten tipe =

134− Solver $ \state@(SS _ _ maxRank pools _ _) ->

135− {-# SCC elm_compiler_type_flatten #-}

136− do var <- flattenHelp maxRank pools Map.empty tipe

137− return (var, state)

138−

139−

140−flattenHelp :: Int -> Pools -> Map.Map N.Name Variable -> Type -> IO Variable

141−flattenHelp maxRank pools aliasDict tipe =

142− case tipe of

143− PlaceHolder name ->

144− return (aliasDict ! name)

145−

146− AliasN home name args realType ->

147− do flatArgs <- mapM (traverse (flattenHelp maxRank pools aliasDict)) args

148− flatVar <- flattenHelp maxRank pools (Map.fromList flatArgs) realType

149− registerFlatType maxRank pools (Alias home name flatArgs flatVar)

150−

151− VarN v ->

152− return v

153−

154− AppN home name args ->

155− do flatArgs <- traverse (flattenHelp maxRank pools aliasDict) args

156− registerFlatType maxRank pools (Structure (App1 home name flatArgs))

157−

158− FunN a b ->

159− do flatA <- flattenHelp maxRank pools aliasDict a

160− flatB <- flattenHelp maxRank pools aliasDict b

161− registerFlatType maxRank pools (Structure (Fun1 flatA flatB))

162−

163− EmptyRecordN ->

164− registerFlatType maxRank pools (Structure EmptyRecord1)

165−

166− RecordN fields ext ->

167− do flatFields <- traverse (flattenHelp maxRank pools aliasDict) fields

168− flatExt <- flattenHelp maxRank pools aliasDict ext

169− registerFlatType maxRank pools (Structure (Record1 flatFields flatExt))

170−

171− UnitN ->

172− registerFlatType maxRank pools (Structure Unit1)

173−

174− TupleN a b cs ->

175− do flatA <- flattenHelp maxRank pools aliasDict a

176− flatB <- flattenHelp maxRank pools aliasDict b

177− flatCs <- traverse (flattenHelp maxRank pools aliasDict) cs

178− registerFlatType maxRank pools (Structure (Tuple1 flatA flatB flatCs))

179−

180−

181−registerFlatType :: Int -> Pools -> Content -> IO Variable

182−registerFlatType maxRank pools content =

183− do var <- UF.fresh (Descriptor content maxRank noMark Nothing)

184− MVector.modify pools (var:) maxRank

185− return var

186−

187−

188−

189−-- COPY

190−

191−

192−copy :: Variable -> Solver Variable

193−copy var =

194− Solver $ \state@(SS _ _ maxRank pools _ _) ->

195− {-# SCC elm_compiler_type_copy #-}

196− do copyVar <- copyHelp maxRank pools var

197− _ <- restore var

198− return ( copyVar, state )

199−

200−

201−copyHelp :: Int -> Pools -> Variable -> IO Variable

202−copyHelp maxRank pools variable =

203− do (Descriptor content rank _mark maybeCopy) <- UF.descriptor variable

204− case maybeCopy of

205− Just copiedVariable ->

206− return copiedVariable

207−

208− Nothing ->

209− if rank /= noRank then

210− return variable

211−

212− else

213− do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing

214− newVar <- UF.fresh $ mkCopyDesc content

215− MVector.modify pools (newVar:) maxRank

216−

217− -- Link the original variable to the new variable. This lets us

218− -- avoid making multiple copies of the variable we are instantiating.

219− --

220− -- Need to do this before recursively copying the content of

221− -- the variable to avoid looping on cyclic terms.

222− UF.setDescriptor variable $

223− Descriptor content rank noMark (Just newVar)

224−

225− -- Now we recursively copy the content of the variable.

226− -- We have already marked the variable as copied, so we

227− -- will not repeat this work or crawl this variable again.

228− case content of

229− Structure term ->

230− do newTerm <- traverseFlatType (copyHelp maxRank pools) term

231− UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)

232−

233− FlexVar _ ->

234− return ()

235−

236− FlexSuper _ _ ->

237− return ()

238−

239− RigidVar name ->

240− UF.setDescriptor newVar $ mkCopyDesc $ FlexVar (Just name)

241−

242− RigidSuper super name ->

243− UF.setDescriptor newVar $ mkCopyDesc $ FlexSuper super (Just name)

244−

245− Alias home name args realType ->

246− do newArgs <- mapM (traverse (copyHelp maxRank pools)) args

247− newRealType <- copyHelp maxRank pools realType

248− UF.setDescriptor newVar $ mkCopyDesc (Alias home name newArgs newRealType)

249−

250− Error _ ->

251− return ()

252−

253− return newVar

254−

255−

256−

257−-- RESTORE

258−

259−

260−restore :: Variable -> IO Variable

261−restore variable =

262− do (Descriptor content _rank _mark maybeCopy) <- UF.descriptor variable

263− case maybeCopy of

264− Nothing ->

265− return variable

266−

267− Just _ ->

268− do restoredContent <- restoreContent content

269− UF.setDescriptor variable $

270− Descriptor restoredContent noRank noMark Nothing

271− return variable

272−

273−

274−restoreContent :: Content -> IO Content

275−restoreContent content =

276− case content of

277− FlexVar _ ->

278− return content

279−

280− FlexSuper _ _ ->

281− return content

282−

283− RigidVar _ ->

284− return content

285−

286− RigidSuper _ _ ->

287− return content

288−

289− Structure term ->

290− Structure <$> traverseFlatType restore term

291−

292− Alias home name args var ->

293− Alias home name

294− <$> mapM (traverse restore) args

295− <*> restore var

296−

297− Error _ ->

298− return content

299−

300−

301−

302−-- TRAVERSE FLAT TYPE

303−

304−

305−traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType

306−traverseFlatType f flatType =

307− case flatType of

308− App1 home name args ->

309− liftM (App1 home name) (traverse f args)

310−

311− Fun1 a b ->

312− liftM2 Fun1 (f a) (f b)

313−

314− EmptyRecord1 ->

315− pure EmptyRecord1

316−

317− Record1 fields ext ->

318− liftM2 Record1 (traverse f fields) (f ext)

319−

320− Unit1 ->

321− pure Unit1

322−

323− Tuple1 a b cs ->

324− liftM3 Tuple1 (f a) (f b) (traverse f cs)

325−

326−

327−

328−-- INSTANCES

329−

330−

331−instance Functor Solver where

332− {-# INLINE fmap #-}

333− fmap f (Solver solver) =

334− Solver $ \s1 ->

335− fmap (\(a, s2) -> (f a, s2)) (solver s1)

336−

337−

338−instance Applicative Solver where

339− {-# INLINE pure #-}

340− pure a =

341− Solver $ \s -> return (a, s)

342−

343− {-# INLINE (<*>) #-}

344− Solver solverFunc <*> Solver solverValue =

345− Solver $ \s1 ->

346− do (f, s2) <- solverFunc s1

347− (x, s3) <- solverValue s2

348− return (f x, s3)

349−

350−

351−instance Monad Solver where

352− {-# INLINE (>>=) #-}

353− Solver solver >>= k =

354− Solver $ \s1 ->

355− do (a, s2) <- solver s1

356− (b, s3) <- _solve (k a) s2

357− return (b, s3)

358−

359− {-# INLINE fail #-}

360− fail msg =

361− Solver $ \_ -> fail msg

362−

363−

364−instance MonadIO Solver where

365− {-# INLINE liftIO #-}

366− liftIO io =

367− Solver $ \state ->

368− do a <- io

369− return (a, state)

src/Type/Unify.hs+137−85

@@ -1,17 +1,20 @@

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings, Rank2Types #-}

3−module Type.Unify (unify) where

3+module Type.Unify

4+ ( Answer(..)

5+ , unify

6+ , Problem(..)

7+ )

8+ where

5import Control.Monad (foldM, liftM2, zipWithM_)

11import Control.Monad (foldM, liftM2, zipWithM_)

6−import Control.Monad.Trans (liftIO)

7import qualified Data.Map.Strict as Map

12import qualified Data.Map.Strict as Map

14+import qualified AST.Canonical as Can

9import qualified AST.Module.Name as ModuleName

15import qualified AST.Module.Name as ModuleName

10import qualified Elm.Name as N

16import qualified Elm.Name as N

11−import qualified Reporting.Region as R

12−import qualified Reporting.Error.Type as Error

13import qualified Type.Occurs as Occurs

17import qualified Type.Occurs as Occurs

14−import qualified Type.State as TS

15import Type.Type as Type

18import Type.Type as Type

16import qualified Type.UnionFind as UF

19import qualified Type.UnionFind as UF

@@ -20,38 +23,84 @@ import qualified Type.UnionFind as UF

20-- UNIFY

23-- UNIFY

23−unify :: R.Region -> Variable -> Variable -> TS.Solver ()

26+data Answer

24−unify region actual expected =

27+ = Ok [Variable]

25− do answer <- run (guardedUnify ActualExpected actual expected)

28+ | Err [Variable] Problem Can.Type Can.Type

26− case answer of

27− Ok ->

28− return ()

30− Err problem ->

31− do actualSrcType <- liftIO $ Type.toSrcType actual

32− expectedSrcType <- liftIO $ Type.toSrcType expected

33− liftIO $ mergeHelp actual expected (Error "?") noRank

34− TS.addError region $

35− case problem of

36− Reason hasDecoder maybeReason ->

37− Error.MismatchExpr $

38− Error.MismatchInfo actualSrcType expectedSrcType hasDecoder maybeReason

40− Infinite ->

31+unify :: Variable -> Variable -> IO Answer

41− Error.InfiniteType actualSrcType

32+unify v1 v2 =

33+ case guardedUnify ActualExpected v1 v2 of

34+ Unify k ->

35+ k [] onSuccess $ \vars problem ->

36+ do t1 <- Type.toSrcType v1

37+ t2 <- Type.toSrcType v2

38+ UF.union v1 v2 errorDescriptor

39+ return (Err vars problem t1 t2)

40+

41+

42+

43+onSuccess :: [Variable] -> () -> IO Answer

44+onSuccess vars () =

45+ return (Ok vars)

46+

47+

48+{-# NOINLINE errorDescriptor #-}

49+errorDescriptor :: Descriptor

50+errorDescriptor =

51+ Descriptor (Error "?") noRank noMark Nothing

52+

53+

54+

55+-- PROBLEM

56+

58+data Reason

59+ = BadFields [(N.Name, Maybe Reason)]

60+ | MessyFields [N.Name] [N.Name] [N.Name]

61+ | IntFloat

62+ | MissingArgs Int

63+ | RigidClash N.Name N.Name

64+ | NotPartOfSuper Type.SuperType

65+ | RigidVarTooGeneric N.Name SpecificThing

66+ | RigidSuperTooGeneric Type.SuperType N.Name SpecificThing

44−data Answer = Ok | Err Problem

69+data SpecificThing

70+ = SpecificSuper Type.SuperType

71+ | SpecificType N.Name

72+ | SpecificFunction

73+ | SpecificRecord

74+ | SpecificUnit

75+ | SpecificTuple

47−run :: Unify () -> TS.Solver Answer

77+

48−run (Unify k) =

78+flipReason :: Reason -> Reason

49− do (vars, answer) <-

79+flipReason reason =

50− liftIO $ k []

80+ case reason of

51− (\vars () -> return (vars, Ok))

81+ BadFields fields ->

52− (\vars p -> return (vars, Err p))

82+ BadFields (map (fmap (fmap flipReason)) fields)

53− TS.introduce vars

83+

54− return answer

84+ MessyFields both left right ->

85+ MessyFields both right left

86+

87+ IntFloat ->

88+ IntFloat

89+

90+ MissingArgs num ->

91+ MissingArgs num

92+

93+ RigidClash a b ->

94+ RigidClash b a

95+

96+ NotPartOfSuper super ->

97+ NotPartOfSuper super

98+

99+ RigidVarTooGeneric name specific ->

100+ RigidVarTooGeneric name specific

101+

102+ RigidSuperTooGeneric super name specific ->

103+ RigidSuperTooGeneric super name specific

104

105

106

@@ -67,6 +116,8 @@ newtype Unify a =

67 )

116 )

117

118

119+-- TODO experiment with INLINE on the Unify instances

120+

70instance Functor Unify where

121instance Functor Unify where

71 fmap func (Unify kv) =

122 fmap func (Unify kv) =

72 Unify $ \vars ok err ->

123 Unify $ \vars ok err ->

@@ -152,11 +203,11 @@ reorient (Context orientation var1 desc1 var2 desc2) =

152

203

153

204

154data Problem

205data Problem

155− = Reason Bool (Maybe Error.Reason)

206+ = Reason Bool (Maybe Reason)

156 | Infinite

207 | Infinite

157

208

158

209

159−mismatch :: Context -> Maybe Error.Reason -> Unify a

210+mismatch :: Context -> Maybe Reason -> Unify a

160mismatch context@(Context orientation var1 _ var2 _) maybeReason =

211mismatch context@(Context orientation var1 _ var2 _) maybeReason =

161 Unify $ \vars _ err ->

212 Unify $ \vars _ err ->

162 do anyInfinite <- liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)

213 do anyInfinite <- liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)

@@ -173,7 +224,7 @@ mismatch context@(Context orientation var1 _ var2 _) maybeReason =

173 then

224 then

174 do newVars <- foldM (subUnifyAnyway context) vars (zip args1 args2)

225 do newVars <- foldM (subUnifyAnyway context) vars (zip args1 args2)

175 err newVars $ Reason hasDecoder $ Just $

226 err newVars $ Reason hasDecoder $ Just $

176− Error.MissingArgs (abs (length args2 - length args1))

227+ MissingArgs (abs (length args2 - length args1))

177 else

228 else

178 err vars $ Reason hasDecoder $

229 err vars $ Reason hasDecoder $

179 case orientation of

230 case orientation of

@@ -181,7 +232,7 @@ mismatch context@(Context orientation var1 _ var2 _) maybeReason =

181 maybeReason

232 maybeReason

182

233

183 ActualExpected ->

234 ActualExpected ->

184− fmap Error.flipReason maybeReason

235+ fmap flipReason maybeReason

185

236

186

237

187subUnifyAnyway :: Context -> [Variable] -> (Variable, Variable) -> IO [Variable]

238subUnifyAnyway :: Context -> [Variable] -> (Variable, Variable) -> IO [Variable]

@@ -193,7 +244,7 @@ subUnifyAnyway context vars (arg1, arg2) =

193

244

194collectArgs :: [Variable] -> Variable -> IO [Variable]

245collectArgs :: [Variable] -> Variable -> IO [Variable]

195collectArgs revArgs variable =

246collectArgs revArgs variable =

196− do (Descriptor content _ _ _) <- UF.descriptor variable

247+ do (Descriptor content _ _ _) <- UF.get variable

197 case content of

248 case content of

198 Structure (Fun1 arg returnType) ->

249 Structure (Fun1 arg returnType) ->

199 collectArgs (arg : revArgs) returnType

250 collectArgs (arg : revArgs) returnType

@@ -204,7 +255,7 @@ collectArgs revArgs variable =

204

255

205detectDecoder :: Variable -> IO Bool

256detectDecoder :: Variable -> IO Bool

206detectDecoder variable =

257detectDecoder variable =

207− do (Descriptor content _ _ _) <- UF.descriptor variable

258+ do (Descriptor content _ _ _) <- UF.get variable

208 case content of

259 case content of

209 Structure (App1 home name [_]) ->

260 Structure (App1 home name [_]) ->

210 return (home == ModuleName.jsonDecode && name == "Decoder")

261 return (home == ModuleName.jsonDecode && name == "Decoder")

@@ -220,13 +271,8 @@ detectDecoder variable =

220merge :: Context -> Content -> Unify ()

271merge :: Context -> Content -> Unify ()

221merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =

272merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =

222 Unify $ \vars ok _ ->

273 Unify $ \vars ok _ ->

274+ ok vars =<<

223− ok vars =<< mergeHelp var1 var2 content (min rank1 rank2)

275+ UF.union var1 var2 (Descriptor content (min rank1 rank2) noMark Nothing)

224−

225−

226−mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()

227−mergeHelp var1 var2 newContent newRank =

228− UF.union var1 var2 $

229− Descriptor newContent newRank noMark Nothing

230

276

231

277

232fresh :: Context -> Content -> Unify Variable

278fresh :: Context -> Content -> Unify Variable

@@ -246,8 +292,8 @@ guardedUnify orientation left right =

246 if equivalent

292 if equivalent

247 then ok vars ()

293 then ok vars ()

248 else

294 else

249− do leftDesc <- UF.descriptor left

295+ do leftDesc <- UF.get left

250− rightDesc <- UF.descriptor right

296+ rightDesc <- UF.get right

251 case actuallyUnify (Context orientation left leftDesc right rightDesc) of

297 case actuallyUnify (Context orientation left leftDesc right rightDesc) of

252 Unify k ->

298 Unify k ->

253 k vars ok err

299 k vars ok err

@@ -262,7 +308,7 @@ actuallyUnify :: Context -> Unify ()

262actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =

308actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =

263 case firstContent of

309 case firstContent of

264 FlexVar _ ->

310 FlexVar _ ->

265− unifyFlex context secondContent

311+ unifyFlex context firstContent secondContent

266

312

267 FlexSuper super _ ->

313 FlexSuper super _ ->

268 unifyFlexSuper context super firstContent secondContent

314 unifyFlexSuper context super firstContent secondContent

@@ -289,16 +335,22 @@ actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor

289-- UNIFY FLEXIBLE VARIABLES

335-- UNIFY FLEXIBLE VARIABLES

290

336

291

337

292−unifyFlex :: Context -> Content -> Unify ()

338+unifyFlex :: Context -> Content -> Content -> Unify ()

293−unifyFlex context otherContent =

339+unifyFlex context content otherContent =

294 case otherContent of

340 case otherContent of

295 Error _ ->

341 Error _ ->

296 return ()

342 return ()

297

343

298 -- TODO see if wildcarding makes a noticable perf difference

344 -- TODO see if wildcarding makes a noticable perf difference

299

345

300− FlexVar _ ->

346+ FlexVar maybeName ->

301− merge context otherContent

347+ merge context $

348+ case maybeName of

349+ Nothing ->

350+ content

351+

352+ Just _ ->

353+ otherContent

302

354

303 FlexSuper _ _ ->

355 FlexSuper _ _ ->

304 merge context otherContent

356 merge context otherContent

@@ -333,54 +385,54 @@ unifyRigid context maybeSuper name content otherContent =

333 merge context content

385 merge context content

334 else

386 else

335 mismatch context $ Just $

387 mismatch context $ Just $

336− Error.RigidSuperTooGeneric super name $ Error.SpecificSuper otherSuper

388+ RigidSuperTooGeneric super name $ SpecificSuper otherSuper

337

389

338 Nothing ->

390 Nothing ->

339 mismatch context $ Just $

391 mismatch context $ Just $

340− Error.RigidVarTooGeneric name $ Error.SpecificSuper otherSuper

392+ RigidVarTooGeneric name $ SpecificSuper otherSuper

341

393

342 RigidVar otherName ->

394 RigidVar otherName ->

343 mismatch context $ Just $

395 mismatch context $ Just $

344− Error.RigidClash name otherName

396+ RigidClash name otherName

345

397

346 RigidSuper _ otherName ->

398 RigidSuper _ otherName ->

347 mismatch context $ Just $

399 mismatch context $ Just $

348− Error.RigidClash name otherName

400+ RigidClash name otherName

349

401

350 Alias _ otherName _ _ ->

402 Alias _ otherName _ _ ->

351 mismatch context $ Just $

403 mismatch context $ Just $

352− maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $

404+ maybe RigidVarTooGeneric RigidSuperTooGeneric maybeSuper name $

353− Error.SpecificType otherName

405+ SpecificType otherName

354

406

355 Structure flatType ->

407 Structure flatType ->

356 mismatch context $ Just $

408 mismatch context $ Just $

357− maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $

409+ maybe RigidVarTooGeneric RigidSuperTooGeneric maybeSuper name $

358 flatTypeToSpecificThing flatType

410 flatTypeToSpecificThing flatType

359

411

360 Error _ ->

412 Error _ ->

361 return ()

413 return ()

362

414

363

415

364−flatTypeToSpecificThing :: FlatType -> Error.SpecificThing

416+flatTypeToSpecificThing :: FlatType -> SpecificThing

365flatTypeToSpecificThing flatType =

417flatTypeToSpecificThing flatType =

366 case flatType of

418 case flatType of

367 App1 _ name _ ->

419 App1 _ name _ ->

368− Error.SpecificType name

420+ SpecificType name

369

421

370 Fun1 _ _ ->

422 Fun1 _ _ ->

371− Error.SpecificFunction

423+ SpecificFunction

372

424

373 EmptyRecord1 ->

425 EmptyRecord1 ->

374− Error.SpecificRecord

426+ SpecificRecord

375

427

376 Record1 _ _ ->

428 Record1 _ _ ->

377− Error.SpecificRecord

429+ SpecificRecord

378

430

379 Unit1 ->

431 Unit1 ->

380− Error.SpecificUnit

432+ SpecificUnit

381

433

382 Tuple1 _ _ _ ->

434 Tuple1 _ _ _ ->

383− Error.SpecificTuple

435+ SpecificTuple

384

436

385

437

386

438

@@ -395,14 +447,14 @@ unifyFlexSuper context super content otherContent =

395

447

396 RigidVar name ->

448 RigidVar name ->

397 mismatch context $ Just $

449 mismatch context $ Just $

398− Error.RigidVarTooGeneric name (Error.SpecificSuper super)

450+ RigidVarTooGeneric name (SpecificSuper super)

399

451

400 RigidSuper otherSuper name ->

452 RigidSuper otherSuper name ->

401 if combineRigidSupers otherSuper super then

453 if combineRigidSupers otherSuper super then

402 merge context otherContent

454 merge context otherContent

403 else

455 else

404 mismatch context $ Just $

456 mismatch context $ Just $

405− Error.RigidSuperTooGeneric otherSuper name (Error.SpecificSuper super)

457+ RigidSuperTooGeneric otherSuper name (SpecificSuper super)

406

458

407 FlexVar _ ->

459 FlexVar _ ->

408 merge context content

460 merge context content

@@ -413,7 +465,7 @@ unifyFlexSuper context super content otherContent =

413 case otherSuper of

465 case otherSuper of

414 Number -> merge context content

466 Number -> merge context content

415 Comparable -> merge context content

467 Comparable -> merge context content

416− _ -> mismatch context Nothing -- Error.NumberAppendableClash

468+ _ -> mismatch context Nothing -- NumberAppendableClash

417

469

418 Comparable ->

470 Comparable ->

419 case otherSuper of

471 case otherSuper of

@@ -427,14 +479,14 @@ unifyFlexSuper context super content otherContent =

427 Appendable -> merge context otherContent

479 Appendable -> merge context otherContent

428 Comparable -> merge context (Type.unnamedFlexSuper CompAppend)

480 Comparable -> merge context (Type.unnamedFlexSuper CompAppend)

429 CompAppend -> merge context otherContent

481 CompAppend -> merge context otherContent

430− Number -> mismatch context Nothing -- Error.NumberAppendableClash

482+ Number -> mismatch context Nothing -- NumberAppendableClash

431

483

432 CompAppend ->

484 CompAppend ->

433 case otherSuper of

485 case otherSuper of

434 Comparable -> merge context content

486 Comparable -> merge context content

435 Appendable -> merge context content

487 Appendable -> merge context content

436 CompAppend -> merge context content

488 CompAppend -> merge context content

437− Number -> mismatch context Nothing -- Error.NumberAppendableClash

489+ Number -> mismatch context Nothing -- NumberAppendableClash

438

490

439 Alias _ _ _ realVar ->

491 Alias _ _ _ realVar ->

440 subUnify context (_first context) realVar

492 subUnify context (_first context) realVar

@@ -479,12 +531,12 @@ unifyFlexSuperStructure context super flatType =

479 if atomMatchesSuper super home name then

531 if atomMatchesSuper super home name then

480 merge context (Structure flatType)

532 merge context (Structure flatType)

481 else

533 else

482− mismatch context $ Just $ Error.NotPartOfSuper super

534+ mismatch context $ Just $ NotPartOfSuper super

483

535

484 App1 home name [variable] | home == ModuleName.list && name == N.list ->

536 App1 home name [variable] | home == ModuleName.list && name == N.list ->

485 case super of

537 case super of

486 Number ->

538 Number ->

487− mismatch context $ Just $ Error.NotPartOfSuper super

539+ mismatch context $ Just $ NotPartOfSuper super

488

540

489 Appendable ->

541 Appendable ->

490 merge context (Structure flatType)

542 merge context (Structure flatType)

@@ -502,10 +554,10 @@ unifyFlexSuperStructure context super flatType =

502 Tuple1 a b maybeC ->

554 Tuple1 a b maybeC ->

503 case super of

555 case super of

504 Number ->

556 Number ->

505− mismatch context $ Just $ Error.NotPartOfSuper super

557+ mismatch context $ Just $ NotPartOfSuper super

506

558

507 Appendable ->

559 Appendable ->

508− mismatch context $ Just $ Error.NotPartOfSuper super

560+ mismatch context $ Just $ NotPartOfSuper super

509

561

510 Comparable ->

562 Comparable ->

511 do comparableOccursCheck context

563 do comparableOccursCheck context

@@ -521,10 +573,10 @@ unifyFlexSuperStructure context super flatType =

521 unifyComparableRecursive orientation c

573 unifyComparableRecursive orientation c

522

574

523 CompAppend ->

575 CompAppend ->

524− mismatch context $ Just $ Error.NotPartOfSuper super

576+ mismatch context $ Just $ NotPartOfSuper super

525

577

526 _ ->

578 _ ->

527− mismatch context $ Just $ Error.NotPartOfSuper super

579+ mismatch context $ Just $ NotPartOfSuper super

528

580

529

581

530-- TODO: is there some way to avoid doing this?

582-- TODO: is there some way to avoid doing this?

@@ -541,7 +593,7 @@ comparableOccursCheck (Context _ _ _ var _) =

541unifyComparableRecursive :: Orientation -> Variable -> Unify ()

593unifyComparableRecursive :: Orientation -> Variable -> Unify ()

542unifyComparableRecursive orientation var =

594unifyComparableRecursive orientation var =

543 do compVar <- register $

595 do compVar <- register $

544− do (Descriptor _ rank _ _) <- UF.descriptor var

596+ do (Descriptor _ rank _ _) <- UF.get var

545 UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing

597 UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing

546 guardedUnify orientation compVar var

598 guardedUnify orientation compVar var

547

599

@@ -594,10 +646,10 @@ unifyStructure context flatType content otherContent =

594 unifyFlexSuperStructure (reorient context) super flatType

646 unifyFlexSuperStructure (reorient context) super flatType

595

647

596 RigidVar name ->

648 RigidVar name ->

597− mismatch context $ Just $ Error.RigidVarTooGeneric name (flatTypeToSpecificThing flatType)

649+ mismatch context $ Just $ RigidVarTooGeneric name (flatTypeToSpecificThing flatType)

598

650

599 RigidSuper super name ->

651 RigidSuper super name ->

600− mismatch context $ Just $ Error.RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)

652+ mismatch context $ Just $ RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)

601

653

602 Alias _ _ _ realVar ->

654 Alias _ _ _ realVar ->

603 subUnify context (_first context) realVar

655 subUnify context (_first context) realVar

@@ -610,7 +662,7 @@ unifyStructure context flatType content otherContent =

610 merge context otherContent

662 merge context otherContent

611

663

612 else if isIntFloat home name otherHome otherName then

664 else if isIntFloat home name otherHome otherName then

613− mismatch context (Just Error.IntFloat)

665+ mismatch context (Just IntFloat)

614

666

615 else

667 else

616 mismatch context Nothing

668 mismatch context Nothing

@@ -684,11 +736,11 @@ unifyRecord context firstStructure secondStructure =

684

736

685 (Empty, _, _, False) ->

737 (Empty, _, _, False) ->

686 mismatch context $ Just $

738 mismatch context $ Just $

687− Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)

739+ MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)

688

740

689 (_, False, Empty, _) ->

741 (_, False, Empty, _) ->

690 mismatch context $ Just $

742 mismatch context $ Just $

691− Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)

743+ MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)

692

744

693 (_, False, _, True) ->

745 (_, False, _, True) ->

694 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))

746 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))

@@ -719,10 +771,10 @@ unifySharedFieldsHelp context sharedFields =

719 return ()

771 return ()

720

772

721 badFieldPairs ->

773 badFieldPairs ->

722− mismatch context (Just (Error.BadFields badFieldPairs))

774+ mismatch context (Just (BadFields badFieldPairs))

723

775

724

776

725−unifyField :: Context -> N.Name -> (Variable, Variable) -> Unify (Maybe (Maybe Error.Reason))

777+unifyField :: Context -> N.Name -> (Variable, Variable) -> Unify (Maybe (Maybe Reason))

726unifyField context _ (actual, expected) =

778unifyField context _ (actual, expected) =

727 Unify $ \vars ok _ ->

779 Unify $ \vars ok _ ->

728 case subUnify context actual expected of

780 case subUnify context actual expected of

@@ -759,7 +811,7 @@ data ExtensionStructure

759

811

760gatherFields :: Context -> Map.Map N.Name Variable -> Variable -> IO RecordStructure

812gatherFields :: Context -> Map.Map N.Name Variable -> Variable -> IO RecordStructure

761gatherFields context fields variable =

813gatherFields context fields variable =

762− do (Descriptor content _ _ _) <- UF.descriptor variable

814+ do (Descriptor content _ _ _) <- UF.get variable

763 case content of

815 case content of

764 Structure (Record1 subFields subExt) ->

816 Structure (Record1 subFields subExt) ->

765 gatherFields context (Map.union fields subFields) subExt

817 gatherFields context (Map.union fields subFields) subExt