51d0bd4 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Try to produce better errors from unification / fixes / optimizations

51d0bd4Evan Czaplicki9 years ago

src/Type/Unify.hs+234−367

compare with master

unifiedsplit

@@ -3,12 +3,10 @@

3module Type.Unify

4 ( Answer(..)

5 , unify

6− , Problem(..)

7 )

6 )

8 where

7 where

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

12import qualified Data.Map.Strict as Map

10import qualified Data.Map.Strict as Map

14import qualified AST.Canonical as Can

12import qualified AST.Canonical as Can

@@ -25,18 +23,18 @@ import qualified Type.UnionFind as UF

26data Answer

24data Answer

27 = Ok [Variable]

25 = Ok [Variable]

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

26+ | Err [Variable] Can.Type Can.Type

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

29unify :: Variable -> Variable -> IO Answer

32unify v1 v2 =

30unify v1 v2 =

33− case guardedUnify ActualExpected v1 v2 of

31+ case guardedUnify v1 v2 of

34 Unify k ->

32 Unify k ->

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

33+ k [] onSuccess $ \vars () ->

36 do t1 <- Type.toSrcType v1

34 do t1 <- Type.toSrcType v1

37 t2 <- Type.toSrcType v2

35 t2 <- Type.toSrcType v2

38 UF.union v1 v2 errorDescriptor

36 UF.union v1 v2 errorDescriptor

39− return (Err vars problem t1 t2)

37+ return (Err vars t1 t2)

42onSuccess :: [Variable] -> () -> IO Answer

40onSuccess :: [Variable] -> () -> IO Answer

@@ -51,58 +49,6 @@ errorDescriptor =

54−-- PROBLEM

55−

56−

57−data Reason

58− = BadFields [(N.Name, Maybe Reason)]

59− | MessyFields [N.Name] [N.Name] [N.Name]

60− | IntFloat

61− | MissingArgs Int

62− | RigidClash N.Name N.Name

63− | NotPartOfSuper Type.SuperType

64− | RigidVarTooGeneric N.Name SpecificThing

65− | RigidSuperTooGeneric Type.SuperType N.Name SpecificThing

66−

67−

68−data SpecificThing

69− = SpecificSuper Type.SuperType

70− | SpecificType N.Name

71− | SpecificFunction

72− | SpecificRecord

73− | SpecificUnit

74− | SpecificTuple

75−

76−

77−flipReason :: Reason -> Reason

78−flipReason reason =

79− case reason of

80− BadFields fields ->

81− BadFields (map (fmap (fmap flipReason)) fields)

82−

83− MessyFields both left right ->

84− MessyFields both right left

85−

86− IntFloat ->

87− IntFloat

88−

89− MissingArgs num ->

90− MissingArgs num

91−

92− RigidClash a b ->

93− RigidClash b a

94−

95− NotPartOfSuper super ->

96− NotPartOfSuper super

97−

98− RigidVarTooGeneric name specific ->

99− RigidVarTooGeneric name specific

100−

101− RigidSuperTooGeneric super name specific ->

102− RigidSuperTooGeneric super name specific

103−

104−

105−

106-- CPS UNIFIER

52-- CPS UNIFIER

107

108

@@ -110,7 +56,7 @@ newtype Unify a =

110 Unify (forall r.

56 Unify (forall r.

111 [Variable]

57 [Variable]

112 -> ([Variable] -> a -> IO r)

58 -> ([Variable] -> a -> IO r)

113− -> ([Variable] -> Problem -> IO r)

59+ -> ([Variable] -> () -> IO r)

114 -> IO r

60 -> IO r

115 )

61 )

116

@@ -167,100 +113,44 @@ register mkVar =

167 ok (var:vars) var

113 ok (var:vars) var

168

114

169

115

116+mismatch :: Unify a

117+mismatch =

118+ Unify $ \vars _ err ->

119+ err vars ()

120+

121+

122+try2 :: Unify () -> Unify () -> Unify ()

123+try2 (Unify k1) (Unify k2) =

124+ Unify $ \vars ok err ->

125+ let

126+ ok1 vars1 () = k2 vars1 ok err

127+ err1 vars1 () = k2 vars1 err err

128+ in

129+ k1 vars ok1 err1

130+

131+

132+{-# INLINE try3 #-}

133+try3 :: Unify () -> Unify () -> Unify () -> Unify ()

134+try3 u1 u2 u3 =

135+ try2 u1 (try2 u2 u3)

136+

137+

170

138

171-- UNIFICATION HELPERS

139-- UNIFICATION HELPERS

172

140

173

141

174data Context =

142data Context =

175 Context

143 Context

176− { _orientation :: Orientation

177− , _first :: Variable

144+ { _first :: Variable

178 , _firstDesc :: Descriptor

145 , _firstDesc :: Descriptor

179 , _second :: Variable

146 , _second :: Variable

180 , _secondDesc :: Descriptor

147 , _secondDesc :: Descriptor

181 }

148 }

182

149

183

150

184−data Orientation

185− = ExpectedActual

186− | ActualExpected

187−

188−

189reorient :: Context -> Context

151reorient :: Context -> Context

190−reorient (Context orientation var1 desc1 var2 desc2) =

152+reorient (Context var1 desc1 var2 desc2) =

191− let

192− otherOrientation =

193− case orientation of

194− ExpectedActual -> ActualExpected

195− ActualExpected -> ExpectedActual

196− in

197− Context otherOrientation var2 desc2 var1 desc1

153+ Context var2 desc2 var1 desc1

198−

199−

200−

201−-- ERROR MESSAGES

202−

203−

204−data Problem

205− = Reason Bool (Maybe Reason)

206− | Infinite

207−

208−

209−mismatch :: Context -> Maybe Reason -> Unify a

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

211− Unify $ \vars _ err ->

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

213− if anyInfinite

214− then err vars Infinite

215− else

216− do args1 <- collectArgs [] var1

217− args2 <- collectArgs [] var2

218−

219− hasDecoder <-

220− or <$> traverse detectDecoder (args1 ++ args2)

221−

222− if length args1 /= length args2

223− then

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

225− err newVars $ Reason hasDecoder $ Just $

226− MissingArgs (abs (length args2 - length args1))

227− else

228− err vars $ Reason hasDecoder $

229− case orientation of

230− ExpectedActual ->

231− maybeReason

232−

233− ActualExpected ->

234− fmap flipReason maybeReason

235−

236−

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

238−subUnifyAnyway context vars (arg1, arg2) =

239− case subUnify context arg1 arg2 of

240− Unify k ->

241− k vars (\vs _ -> return vs) (\vs _ -> return vs)

242−

243−

244−collectArgs :: [Variable] -> Variable -> IO [Variable]

245−collectArgs revArgs variable =

246− do (Descriptor content _ _ _) <- UF.get variable

247− case content of

248− Structure (Fun1 arg returnType) ->

249− collectArgs (arg : revArgs) returnType

250−

251− _ ->

252− return $ variable : revArgs

253−

254−

255−detectDecoder :: Variable -> IO Bool

256−detectDecoder variable =

257− do (Descriptor content _ _ _) <- UF.get variable

258− case content of

259− Structure (App1 home name [_]) ->

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

261−

262− _ ->

263− return False

264

154

265

155

266

156

@@ -268,14 +158,14 @@ detectDecoder variable =

268

158

269

159

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

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

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

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

272 Unify $ \vars ok _ ->

162 Unify $ \vars ok _ ->

273 ok vars =<<

163 ok vars =<<

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

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

275

165

276

166

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

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

278−fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =

168+fresh (Context _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =

279 register $ UF.fresh $

169 register $ UF.fresh $

280 Descriptor content (min rank1 rank2) noMark Nothing

170 Descriptor content (min rank1 rank2) noMark Nothing

281

171

@@ -284,8 +174,8 @@ fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content

284-- ACTUALLY UNIFY THINGS

174-- ACTUALLY UNIFY THINGS

285

175

286

176

287−guardedUnify :: Orientation -> Variable -> Variable -> Unify ()

177+guardedUnify :: Variable -> Variable -> Unify ()

288−guardedUnify orientation left right =

178+guardedUnify left right =

289 Unify $ \vars ok err ->

179 Unify $ \vars ok err ->

290 do equivalent <- UF.equivalent left right

180 do equivalent <- UF.equivalent left right

291 if equivalent

181 if equivalent

@@ -293,31 +183,18 @@ guardedUnify orientation left right =

293 else

183 else

294 do leftDesc <- UF.get left

184 do leftDesc <- UF.get left

295 rightDesc <- UF.get right

185 rightDesc <- UF.get right

296− putStrLn (toString leftDesc ++ " vs " ++ toString rightDesc)

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

186+ case actuallyUnify (Context left leftDesc right rightDesc) of

298 Unify k ->

187 Unify k ->

299 k vars ok err

188 k vars ok err

300

189

301

190

302−toString :: Descriptor -> String

303−toString (Descriptor content _ _ _) =

304− case content of

305− FlexVar _ -> "FlexVar"

306− FlexSuper _ _ -> "FlexSuper"

307− RigidVar _ -> "RigidVar"

308− RigidSuper _ _ -> "RigidSuper"

309− Alias _ _ _ _ -> "Alias"

310− Structure _ -> "Structure"

311− Error _ -> "Error"

312−

313−

314−subUnify :: Context -> Variable -> Variable -> Unify ()

191+subUnify :: Variable -> Variable -> Unify ()

315−subUnify context var1 var2 =

192+subUnify var1 var2 =

316− guardedUnify (_orientation context) var1 var2

193+ guardedUnify var1 var2

317

194

318

195

319actuallyUnify :: Context -> Unify ()

196actuallyUnify :: Context -> Unify ()

320−actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =

197+actuallyUnify context@(Context _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =

321 case firstContent of

198 case firstContent of

322 FlexVar _ ->

199 FlexVar _ ->

323 unifyFlex context firstContent secondContent

200 unifyFlex context firstContent secondContent

@@ -325,11 +202,11 @@ actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor

325 FlexSuper super _ ->

202 FlexSuper super _ ->

326 unifyFlexSuper context super firstContent secondContent

203 unifyFlexSuper context super firstContent secondContent

327

204

328− RigidVar name ->

205+ RigidVar _ ->

329− unifyRigid context Nothing name firstContent secondContent

206+ unifyRigid context Nothing firstContent secondContent

330

207

331− RigidSuper super name ->

208+ RigidSuper super _ ->

332− unifyRigid context (Just super) name firstContent secondContent

209+ unifyRigid context (Just super) firstContent secondContent

333

210

334 Alias home name args realVar ->

211 Alias home name args realVar ->

335 unifyAlias context home name args realVar secondContent

212 unifyAlias context home name args realVar secondContent

@@ -384,8 +261,8 @@ unifyFlex context content otherContent =

384-- UNIFY RIGID VARIABLES

261-- UNIFY RIGID VARIABLES

385

262

386

263

387−unifyRigid :: Context -> Maybe SuperType -> N.Name -> Content -> Content -> Unify ()

264+unifyRigid :: Context -> Maybe SuperType -> Content -> Content -> Unify ()

388−unifyRigid context maybeSuper name content otherContent =

265+unifyRigid context maybeSuper content otherContent =

389 case otherContent of

266 case otherContent of

390 FlexVar _ ->

267 FlexVar _ ->

391 merge context content

268 merge context content

@@ -396,57 +273,27 @@ unifyRigid context maybeSuper name content otherContent =

396 if combineRigidSupers super otherSuper then

273 if combineRigidSupers super otherSuper then

397 merge context content

274 merge context content

398 else

275 else

399− mismatch context $ Just $

276+ mismatch

400− RigidSuperTooGeneric super name $ SpecificSuper otherSuper

401

277

402 Nothing ->

278 Nothing ->

403− mismatch context $ Just $

279+ mismatch

404− RigidVarTooGeneric name $ SpecificSuper otherSuper

405

280

406− RigidVar otherName ->

281+ RigidVar _ ->

407− mismatch context $ Just $

282+ mismatch

408− RigidClash name otherName

409

283

410− RigidSuper _ otherName ->

284+ RigidSuper _ _ ->

411− mismatch context $ Just $

285+ mismatch

412− RigidClash name otherName

413

286

414− Alias _ otherName _ _ ->

287+ Alias _ _ _ _ ->

415− mismatch context $ Just $

288+ mismatch

416− maybe RigidVarTooGeneric RigidSuperTooGeneric maybeSuper name $

417− SpecificType otherName

418

289

419− Structure flatType ->

290+ Structure _ ->

420− mismatch context $ Just $

291+ mismatch

421− maybe RigidVarTooGeneric RigidSuperTooGeneric maybeSuper name $

422− flatTypeToSpecificThing flatType

423

292

424 Error _ ->

293 Error _ ->

425 return ()

294 return ()

426

295

427

296

428−flatTypeToSpecificThing :: FlatType -> SpecificThing

429−flatTypeToSpecificThing flatType =

430− case flatType of

431− App1 _ name _ ->

432− SpecificType name

433−

434− Fun1 _ _ ->

435− SpecificFunction

436−

437− EmptyRecord1 ->

438− SpecificRecord

439−

440− Record1 _ _ ->

441− SpecificRecord

442−

443− Unit1 ->

444− SpecificUnit

445−

446− Tuple1 _ _ _ ->

447− SpecificTuple

448−

449−

450

297

451-- UNIFY SUPER VARIABLES

298-- UNIFY SUPER VARIABLES

452

299

@@ -457,16 +304,14 @@ unifyFlexSuper context super content otherContent =

457 Structure flatType ->

304 Structure flatType ->

458 unifyFlexSuperStructure context super flatType

305 unifyFlexSuperStructure context super flatType

459

306

460− RigidVar name ->

307+ RigidVar _ ->

461− mismatch context $ Just $

308+ mismatch

462− RigidVarTooGeneric name (SpecificSuper super)

463

309

464− RigidSuper otherSuper name ->

310+ RigidSuper otherSuper _ ->

465 if combineRigidSupers otherSuper super then

311 if combineRigidSupers otherSuper super then

466 merge context otherContent

312 merge context otherContent

467 else

313 else

468− mismatch context $ Just $

314+ mismatch

469− RigidSuperTooGeneric otherSuper name (SpecificSuper super)

470

315

471 FlexVar _ ->

316 FlexVar _ ->

472 merge context content

317 merge context content

@@ -477,7 +322,7 @@ unifyFlexSuper context super content otherContent =

477 case otherSuper of

322 case otherSuper of

478 Number -> merge context content

323 Number -> merge context content

479 Comparable -> merge context content

324 Comparable -> merge context content

480− _ -> mismatch context Nothing -- NumberAppendableClash

325+ _ -> mismatch

481

326

482 Comparable ->

327 Comparable ->

483 case otherSuper of

328 case otherSuper of

@@ -491,17 +336,17 @@ unifyFlexSuper context super content otherContent =

491 Appendable -> merge context otherContent

336 Appendable -> merge context otherContent

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

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

493 CompAppend -> merge context otherContent

338 CompAppend -> merge context otherContent

494− Number -> mismatch context Nothing -- NumberAppendableClash

339+ Number -> mismatch

495

340

496 CompAppend ->

341 CompAppend ->

497 case otherSuper of

342 case otherSuper of

498 Comparable -> merge context content

343 Comparable -> merge context content

499 Appendable -> merge context content

344 Appendable -> merge context content

500 CompAppend -> merge context content

345 CompAppend -> merge context content

501− Number -> mismatch context Nothing -- NumberAppendableClash

346+ Number -> mismatch

502

347

503 Alias _ _ _ realVar ->

348 Alias _ _ _ realVar ->

504− subUnify context (_first context) realVar

349+ subUnify (_first context) realVar

505

350

506 Error _ ->

351 Error _ ->

507 return ()

352 return ()

@@ -543,12 +388,12 @@ unifyFlexSuperStructure context super flatType =

543 if atomMatchesSuper super home name then

388 if atomMatchesSuper super home name then

544 merge context (Structure flatType)

389 merge context (Structure flatType)

545 else

390 else

546− mismatch context $ Just $ NotPartOfSuper super

391+ mismatch

547

392

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

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

549 case super of

394 case super of

550 Number ->

395 Number ->

551− mismatch context $ Just $ NotPartOfSuper super

396+ mismatch

552

397

553 Appendable ->

398 Appendable ->

554 merge context (Structure flatType)

399 merge context (Structure flatType)

@@ -556,58 +401,57 @@ unifyFlexSuperStructure context super flatType =

556 Comparable ->

401 Comparable ->

557 do comparableOccursCheck context

402 do comparableOccursCheck context

558 merge context (Structure flatType)

403 merge context (Structure flatType)

559− unifyComparableRecursive (_orientation context) variable

404+ unifyComparableRecursive variable

560

405

561 CompAppend ->

406 CompAppend ->

562 do comparableOccursCheck context

407 do comparableOccursCheck context

563 merge context (Structure flatType)

408 merge context (Structure flatType)

564− unifyComparableRecursive (_orientation context) variable

409+ unifyComparableRecursive variable

565

410

566 Tuple1 a b maybeC ->

411 Tuple1 a b maybeC ->

567 case super of

412 case super of

568 Number ->

413 Number ->

569− mismatch context $ Just $ NotPartOfSuper super

414+ mismatch

570

415

571 Appendable ->

416 Appendable ->

572− mismatch context $ Just $ NotPartOfSuper super

417+ mismatch

573

418

574 Comparable ->

419 Comparable ->

575 do comparableOccursCheck context

420 do comparableOccursCheck context

576 merge context (Structure flatType)

421 merge context (Structure flatType)

577− let orientation = _orientation context

578− unifyComparableRecursive orientation a

422+ unifyComparableRecursive a

579− unifyComparableRecursive orientation b

423+ unifyComparableRecursive b

580 case maybeC of

424 case maybeC of

581 Nothing ->

425 Nothing ->

582 return ()

426 return ()

583

427

584 Just c ->

428 Just c ->

585− unifyComparableRecursive orientation c

429+ unifyComparableRecursive c

586

430

587 CompAppend ->

431 CompAppend ->

588− mismatch context $ Just $ NotPartOfSuper super

432+ mismatch

589

433

590 _ ->

434 _ ->

591− mismatch context $ Just $ NotPartOfSuper super

435+ mismatch

592

436

593

437

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

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

595-- Do type classes require occurs checks?

439-- Do type classes require occurs checks?

596comparableOccursCheck :: Context -> Unify ()

440comparableOccursCheck :: Context -> Unify ()

597−comparableOccursCheck (Context _ _ _ var _) =

441+comparableOccursCheck (Context _ _ var _) =

598 Unify $ \vars ok err ->

442 Unify $ \vars ok err ->

599 do hasOccurred <- Occurs.occurs var

443 do hasOccurred <- Occurs.occurs var

600 if hasOccurred

444 if hasOccurred

601− then err vars Infinite

445+ then err vars ()

602 else ok vars ()

446 else ok vars ()

603

447

604

448

605−unifyComparableRecursive :: Orientation -> Variable -> Unify ()

449+unifyComparableRecursive :: Variable -> Unify ()

606−unifyComparableRecursive orientation var =

450+unifyComparableRecursive var =

607 do compVar <- register $

451 do compVar <- register $

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

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

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

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

610− guardedUnify orientation compVar var

454+ guardedUnify compVar var

611

455

612

456

613

457

@@ -618,30 +462,60 @@ unifyAlias :: Context -> ModuleName.Canonical -> N.Name -> [(N.Name, Variable)]

618unifyAlias context home name args realVar otherContent =

462unifyAlias context home name args realVar otherContent =

619 case otherContent of

463 case otherContent of

620 FlexVar _ ->

464 FlexVar _ ->

621− merge context (Alias home name args realVar)

465+ merge context (Alias home name args realVar)

622

466

623 FlexSuper _ _ ->

467 FlexSuper _ _ ->

624− subUnify context realVar (_second context)

468+ subUnify realVar (_second context)

625

469

626 RigidVar _ ->

470 RigidVar _ ->

627− subUnify context realVar (_second context)

471+ subUnify realVar (_second context)

628

472

629 RigidSuper _ _ ->

473 RigidSuper _ _ ->

630− subUnify context realVar (_second context)

474+ subUnify realVar (_second context)

631

475

632 Alias otherHome otherName otherArgs otherRealVar ->

476 Alias otherHome otherName otherArgs otherRealVar ->

633− if name == otherName && home == otherHome then

477+ if name == otherName && home == otherHome then

634− do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)

478+ Unify $ \vars ok err ->

479+ let

480+ ok1 vars1 () =

635− merge context otherContent

481+ case merge context otherContent of

482+ Unify k ->

483+ k vars1 ok err

484+ in

485+ unifyAliasArgs vars context args otherArgs ok1 err

636

486

637− else

487+ else

638− subUnify context realVar otherRealVar

488+ subUnify realVar otherRealVar

639

489

640 Structure _ ->

490 Structure _ ->

641− subUnify context realVar (_second context)

491+ subUnify realVar (_second context)

642

492

643 Error _ ->

493 Error _ ->

644− return ()

494+ return ()

495+

496+

497+unifyAliasArgs :: [Variable] -> Context -> [(N.Name,Variable)] -> [(N.Name,Variable)] -> ([Variable] -> () -> IO r) -> ([Variable] -> () -> IO r) -> IO r

498+unifyAliasArgs vars context args1 args2 ok err =

499+ case args1 of

500+ (_,arg1):others1 ->

501+ case args2 of

502+ (_,arg2):others2 ->

503+ case subUnify arg1 arg2 of

504+ Unify k ->

505+ k vars

506+ (\vs () -> unifyAliasArgs vs context others1 others2 ok err)

507+ (\vs () -> unifyAliasArgs vs context others1 others2 err err)

508+

509+ _ ->

510+ err vars ()

511+

512+ [] ->

513+ case args2 of

514+ [] ->

515+ ok vars ()

516+

517+ _ ->

518+ err vars ()

645

519

646

520

647

521

@@ -657,159 +531,161 @@ unifyStructure context flatType content otherContent =

657 FlexSuper super _ ->

531 FlexSuper super _ ->

658 unifyFlexSuperStructure (reorient context) super flatType

532 unifyFlexSuperStructure (reorient context) super flatType

659

533

660− RigidVar name ->

534+ RigidVar _ ->

661− mismatch context $ Just $ RigidVarTooGeneric name (flatTypeToSpecificThing flatType)

535+ mismatch

662

536

663− RigidSuper super name ->

537+ RigidSuper _ _ ->

664− mismatch context $ Just $ RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)

538+ mismatch

665

539

666 Alias _ _ _ realVar ->

540 Alias _ _ _ realVar ->

667− subUnify context (_first context) realVar

541+ subUnify (_first context) realVar

668

542

669 Structure otherFlatType ->

543 Structure otherFlatType ->

670 case (flatType, otherFlatType) of

544 case (flatType, otherFlatType) of

671 (App1 home name args, App1 otherHome otherName otherArgs) ->

545 (App1 home name args, App1 otherHome otherName otherArgs) ->

672 if home == otherHome && name == otherName then

546 if home == otherHome && name == otherName then

673− do zipWithM_ (subUnify context) args otherArgs

547+ Unify $ \vars ok err ->

548+ let

549+ ok1 vars1 () =

674− merge context otherContent

550+ case merge context otherContent of

675−

551+ Unify k ->

676− else if isIntFloat home name otherHome otherName then

552+ k vars1 ok err

677− mismatch context (Just IntFloat)

553+ in

554+ unifyArgs vars context args otherArgs ok1 err

678

555

679 else

556 else

680− mismatch context Nothing

557+ mismatch

681

558

682− (Fun1 arg result, Fun1 otherArg otherResult) ->

559+ (Fun1 arg1 res1, Fun1 arg2 res2) ->

683− do subUnify context arg otherArg

560+ do try2

684− subUnify context result otherResult

561+ (subUnify arg1 arg2)

562+ (subUnify res1 res2)

685 merge context otherContent

563 merge context otherContent

686

564

687 (EmptyRecord1, EmptyRecord1) ->

565 (EmptyRecord1, EmptyRecord1) ->

688 merge context otherContent

566 merge context otherContent

689

567

690 (Record1 fields ext, EmptyRecord1) | Map.null fields ->

568 (Record1 fields ext, EmptyRecord1) | Map.null fields ->

691− subUnify context ext (_second context)

569+ subUnify ext (_second context)

692

570

693 (EmptyRecord1, Record1 fields ext) | Map.null fields ->

571 (EmptyRecord1, Record1 fields ext) | Map.null fields ->

694− subUnify context (_first context) ext

572+ subUnify (_first context) ext

695

573

696− (Record1 fields extension, Record1 otherFields otherExtension) ->

574+ (Record1 fields1 ext1, Record1 fields2 ext2) ->

697 Unify $ \vars ok err ->

575 Unify $ \vars ok err ->

698− do firstStructure <- gatherFields context fields extension

576+ do structure1 <- gatherFields fields1 ext1

699− secondStructure <- gatherFields context otherFields otherExtension

577+ structure2 <- gatherFields fields2 ext2

700− case unifyRecord context firstStructure secondStructure of

578+ case unifyRecord context structure1 structure2 of

701 Unify k ->

579 Unify k ->

702 k vars ok err

580 k vars ok err

703

581

704 (Tuple1 a b Nothing, Tuple1 x y Nothing) ->

582 (Tuple1 a b Nothing, Tuple1 x y Nothing) ->

583+ do try2

705− do subUnify context a x

584+ (subUnify a x)

706− subUnify context b y

585+ (subUnify b y)

586+ merge context otherContent

707

587

708 (Tuple1 a b (Just c), Tuple1 x y (Just z)) ->

588 (Tuple1 a b (Just c), Tuple1 x y (Just z)) ->

589+ do try3

709− do subUnify context a x

590+ (subUnify a x)

710− subUnify context b y

591+ (subUnify b y)

711− subUnify context c z

592+ (subUnify c z)

593+ merge context otherContent

712

594

713 _ ->

595 _ ->

714− mismatch context Nothing

596+ mismatch

715

597

716 Error _ ->

598 Error _ ->

717 return ()

599 return ()

718

600

719

601

720−isIntFloat :: ModuleName.Canonical -> N.Name -> ModuleName.Canonical -> N.Name -> Bool

721−isIntFloat home name otherHome otherName =

722− otherHome == ModuleName.basics

723− && home == ModuleName.basics

724− && (

725− (name == N.int && otherName == N.float)

726− ||

727− (name == N.float && otherName == N.int)

728− )

729

602

603+-- UNIFY ARGS

730

604

731

605

732−-- UNIFY RECORDS

606+unifyArgs :: [Variable] -> Context -> [Variable] -> [Variable] -> ([Variable] -> () -> IO r) -> ([Variable] -> () -> IO r) -> IO r

607+unifyArgs vars context args1 args2 ok err =

608+ case args1 of

609+ arg1:others1 ->

610+ case args2 of

611+ arg2:others2 ->

612+ case subUnify arg1 arg2 of

613+ Unify k ->

614+ k vars

615+ (\vs () -> unifyArgs vs context others1 others2 ok err)

616+ (\vs () -> unifyArgs vs context others1 others2 err err)

733

617

618+ _ ->

619+ err vars ()

734

620

735−unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()

621+ [] ->

736−unifyRecord context firstStructure secondStructure =

622+ case args2 of

737− do let (RecordStructure expFields expVar expStruct) = firstStructure

738− let (RecordStructure actFields actVar actStruct) = secondStructure

739−

740− let sharedFields = Map.intersectionWith (,) expFields actFields

741−

742− -- call after unifying extension, make sure record shape matches before

743− -- looking into whether the particular field types match.

744− let unifySharedFields otherFields ext =

745− do unifySharedFieldsHelp context sharedFields

746− let allFields = Map.union (Map.map fst sharedFields) otherFields

747− merge context (Structure (Record1 allFields ext))

748−

749− let uniqueExpFields = Map.difference expFields actFields

750− let uniqueActFields = Map.difference actFields expFields

751−

752− case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of

753− (_, True, _, True) ->

754− do subUnify context expVar actVar

755− unifySharedFields Map.empty expVar

756−

757− (Empty, _, _, False) ->

758− mismatch context $ Just $

759− MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)

760−

761− (_, False, Empty, _) ->

762− mismatch context $ Just $

763− MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)

764−

765− (_, False, _, True) ->

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

767− subUnify context subRecord actVar

768− unifySharedFields Map.empty subRecord

769−

770− (_, True, _, False) ->

771− do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))

772− subUnify context expVar subRecord

773− unifySharedFields Map.empty subRecord

774−

775− (Extension, False, Extension, False) ->

776− do let subFields = Map.union uniqueExpFields uniqueActFields

777− subExt <- fresh context Type.unnamedFlexVar

778− expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))

779− actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))

780− subUnify context expVar expRecord

781− subUnify context actRecord actVar

782− unifySharedFields subFields subExt

783−

784−

785−

786−unifySharedFieldsHelp :: Context -> Map.Map N.Name (Variable, Variable) -> Unify ()

787−unifySharedFieldsHelp context sharedFields =

788− do badFields <- Map.traverseMaybeWithKey (unifyField context) sharedFields

789− case Map.toList badFields of

790 [] ->

623 [] ->

791− return ()

624+ ok vars ()

625+

626+ _ ->

627+ err vars ()

628+

792

629

793− badFieldPairs ->

630+

794− mismatch context (Just (BadFields badFieldPairs))

631+-- UNIFY RECORDS

795

632

796

633

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

634+unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()

635+unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2) =

636+ let

637+ sharedFields = Map.intersectionWith (,) fields1 fields2

638+ uniqueFields1 = Map.difference fields1 fields2

639+ uniqueFields2 = Map.difference fields2 fields1

640+ in

641+ if Map.null uniqueFields1 then

642+

643+ if Map.null uniqueFields2 then

644+ try2

645+ (subUnify ext1 ext2)

646+ (unifySharedFields context sharedFields Map.empty ext1)

647+

648+ else

649+ do subRecord <- fresh context (Structure (Record1 uniqueFields1 ext1))

650+ try2

651+ (subUnify subRecord ext2)

652+ (unifySharedFields context sharedFields Map.empty subRecord)

653+

654+ else

655+

656+ if Map.null uniqueFields2 then

657+ do subRecord <- fresh context (Structure (Record1 uniqueFields2 ext2))

658+ try2

659+ (subUnify ext1 subRecord)

660+ (unifySharedFields context sharedFields Map.empty subRecord)

661+

662+ else

663+ do let otherFields = Map.union uniqueFields1 uniqueFields2

664+ ext <- fresh context Type.unnamedFlexVar

665+ sub1 <- fresh context (Structure (Record1 uniqueFields1 ext))

666+ sub2 <- fresh context (Structure (Record1 uniqueFields2 ext))

667+ try3

668+ (subUnify ext1 sub2)

669+ (subUnify sub1 ext2)

670+ (unifySharedFields context sharedFields otherFields ext)

671+

672+

673+unifySharedFields :: Context -> Map.Map N.Name (Variable, Variable) -> Map.Map N.Name Variable -> Variable -> Unify ()

674+unifySharedFields context sharedFields otherFields ext =

675+ do matchingFields <- Map.traverseMaybeWithKey unifyField sharedFields

676+ if Map.size sharedFields == Map.size matchingFields

677+ then merge context (Structure (Record1 (Map.union matchingFields otherFields) ext))

678+ else mismatch

679+

680+

681+unifyField :: N.Name -> (Variable, Variable) -> Unify (Maybe Variable)

798−unifyField context _ (actual, expected) =

682+unifyField _ (actual, expected) =

799 Unify $ \vars ok _ ->

683 Unify $ \vars ok _ ->

800− case subUnify context actual expected of

684+ case subUnify actual expected of

801 Unify k ->

685 Unify k ->

802 k vars

686 k vars

687+ (\vs () -> ok vs (Just actual))

803 (\vs () -> ok vs Nothing)

688 (\vs () -> ok vs Nothing)

804− (\vs problem ->

805− ok vs $ Just $

806− case problem of

807− Reason _ reason ->

808− reason

809−

810− Infinite ->

811− Nothing

812− )

813

689

814

690

815

691

@@ -819,30 +695,21 @@ unifyField context _ (actual, expected) =

819data RecordStructure =

695data RecordStructure =

820 RecordStructure

696 RecordStructure

821 { _fields :: Map.Map N.Name Variable

697 { _fields :: Map.Map N.Name Variable

822− , _extVar :: Variable

698+ , _extension :: Variable

823− , _extStruct :: ExtensionStructure

824 }

699 }

825

700

826

701

827−data ExtensionStructure

828− = Empty

829− | Extension

830−

831−

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

702+gatherFields :: Map.Map N.Name Variable -> Variable -> IO RecordStructure

833−gatherFields context fields variable =

703+gatherFields fields variable =

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

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

835 case content of

705 case content of

836 Structure (Record1 subFields subExt) ->

706 Structure (Record1 subFields subExt) ->

837− gatherFields context (Map.union fields subFields) subExt

707+ gatherFields (Map.union fields subFields) subExt

838−

839− Structure EmptyRecord1 ->

840− return (RecordStructure fields variable Empty)

841

708

842 Alias _ _ _ var ->

709 Alias _ _ _ var ->

843 -- TODO may be dropping useful alias info here

710 -- TODO may be dropping useful alias info here

844− gatherFields context fields var

711+ gatherFields fields var

845

712

846 _ ->

713 _ ->

847− return (RecordStructure fields variable Extension)

714+ return (RecordStructure fields variable)

848

715