90e4d45 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Get Type.Unify compiling / CPS-convert the code

90e4d45Evan Czaplicki9 years ago

src/Type/Unify.hs+176−100

compare with master

unifiedsplit

@@ -1,15 +1,12 @@

1{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE OverloadedStrings, Rank2Types #-}

3module Type.Unify (unify) where

5−import Control.Monad (liftM2, when, zipWithM_)

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

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

6+import Control.Monad.Trans (liftIO)

7import qualified Data.Map.Strict as Map

8−import qualified Data.Maybe as Maybe

9−import Data.Text (Text)

11import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

12−import AST.Type (Super(..))

13import qualified Elm.Name as N

10import qualified Elm.Name as N

14import qualified Reporting.Region as R

11import qualified Reporting.Region as R

15import qualified Reporting.Error.Type as Error

12import qualified Reporting.Error.Type as Error

@@ -23,34 +20,105 @@ import qualified Type.UnionFind as UF

23-- UNIFY

20-- UNIFY

26−unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()

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

27−unify hint region expected actual =

24+unify region actual expected =

28− {-# SCC elm_compiler_type_unify #-}

29− do result <- runExceptT (guardedUnify ExpectedActual expected actual)

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

30− case result of

26+ case answer of

31− Right () ->

27+ Ok ->

32− return ()

28+ return ()

34− Left problem ->

30+ Err problem ->

35− do expectedSrcType <- liftIO $ Type.toSrcType expected

36− actualSrcType <- liftIO $ Type.toSrcType actual

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

32+ expectedSrcType <- liftIO $ Type.toSrcType expected

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

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

38 TS.addError region $

34 TS.addError region $

39 case problem of

35 case problem of

40 Reason hasDecoder maybeReason ->

36 Reason hasDecoder maybeReason ->

41− Error.Mismatch $

37+ Error.MismatchExpr $

42− Error.MismatchInfo hint expectedSrcType actualSrcType hasDecoder maybeReason

38+ Error.MismatchInfo actualSrcType expectedSrcType hasDecoder maybeReason

44 Infinite ->

40 Infinite ->

45− Error.InfiniteType (Left hint) expectedSrcType

41+ Error.InfiniteType actualSrcType

44+data Answer = Ok | Err Problem

45+

46+

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

48+run (Unify k) =

49+ do (vars, answer) <-

50+ liftIO $ k []

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

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

53+ TS.introduce vars

54+ return answer

55+

56+

57+

58+-- CPS UNIFIER

59+

60+

61+newtype Unify a =

62+ Unify (forall r.

63+ [Variable]

64+ -> ([Variable] -> a -> IO r)

65+ -> ([Variable] -> Problem -> IO r)

66+ -> IO r

67+ )

49−-- UNIFICATION HELPERS

70+instance Functor Unify where

71+ fmap func (Unify kv) =

72+ Unify $ \vars ok err ->

73+ let

74+ ok1 vars1 value =

75+ ok vars1 (func value)

76+ in

77+ kv vars ok1 err

52−type Unify =

79+

53− ExceptT Problem TS.Solver

80+instance Applicative Unify where

81+ pure a =

82+ Unify $ \vars ok _ ->

83+ ok vars a

84+

85+ (<*>) (Unify kf) (Unify kv) =

86+ Unify $ \vars ok err ->

87+ let

88+ ok1 vars1 func =

89+ let

90+ ok2 vars2 value =

91+ ok vars2 (func value)

92+ in

93+ kv vars1 ok2 err

94+ in

95+ kf vars ok1 err

96+

97+

98+instance Monad Unify where

99+ return a =

100+ Unify $ \vars ok _ ->

101+ ok vars a

102+

103+ (>>=) (Unify ka) callback =

104+ Unify $ \vars ok err ->

105+ let

106+ ok1 vars1 a =

107+ case callback a of

108+ Unify kb -> kb vars1 ok err

109+ in

110+ ka vars ok1 err

111+

112+

113+register :: IO Variable -> Unify Variable

114+register mkVar =

115+ Unify $ \vars ok _ ->

116+ do var <- mkVar

117+ ok (var:vars) var

118+

119+

120+

121+-- UNIFICATION HELPERS

122

123

56data Context =

124data Context =

@@ -90,30 +158,37 @@ data Problem

158

91mismatch :: Context -> Maybe Error.Reason -> Unify a

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

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

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

161+ Unify $ \vars _ err ->

93− do anyInfinite <- liftIO $ liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)

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

94− when anyInfinite $ throwError Infinite

163+ if anyInfinite

95−

164+ then err vars Infinite

165+ else

96− args1 <- liftIO $ collectArgs [] var1

166+ do args1 <- collectArgs [] var1

97− args2 <- liftIO $ collectArgs [] var2

167+ args2 <- collectArgs [] var2

98−

168+

169+ hasDecoder <-

99− hasDecoder <- liftIO $ or <$> traverse detectDecoder (args1 ++ args2)

170+ or <$> traverse detectDecoder (args1 ++ args2)

100−

171+

101− if length args1 /= length args2

172+ if length args1 /= length args2

102− then

173+ then

103− do lift $ zipWithM_ (\a1 a2 -> runExceptT $ subUnify context a1 a2) args1 args2

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

104− throwError $ Reason hasDecoder $ Just $

175+ err newVars $ Reason hasDecoder $ Just $

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

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

106− else

177+ else

107− throwError $ Reason hasDecoder $

178+ err vars $ Reason hasDecoder $

108− case orientation of

179+ case orientation of

109− ExpectedActual ->

180+ ExpectedActual ->

110− maybeReason

181+ maybeReason

111−

182+

112− ActualExpected ->

183+ ActualExpected ->

113− fmap Error.flipReason maybeReason

184+ fmap Error.flipReason maybeReason

114−

185+

115−

186+

116−

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

188+subUnifyAnyway context vars (arg1, arg2) =

189+ case subUnify context arg1 arg2 of

190+ Unify k ->

191+ k vars (\vs _ -> return vs) (\vs _ -> return vs)

117

192

118

193

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

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

@@ -144,7 +219,8 @@ detectDecoder variable =

144

219

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

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

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

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

222+ Unify $ \vars ok _ ->

147− liftIO $ mergeHelp var1 var2 content (min rank1 rank2)

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

148

224

149

225

150mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()

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

@@ -155,13 +231,8 @@ mergeHelp var1 var2 newContent newRank =

155

231

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

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

157fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =

233fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =

158− do freshVariable <-

159− liftIO $ UF.fresh $

234+ register $ UF.fresh $

160− Descriptor content (min rank1 rank2) noMark Nothing

235+ Descriptor content (min rank1 rank2) noMark Nothing

161−

162− lift $ TS.register freshVariable

163−

164− return freshVariable

165

236

166

237

167

238

@@ -170,13 +241,16 @@ fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content

170

241

171guardedUnify :: Orientation -> Variable -> Variable -> Unify ()

242guardedUnify :: Orientation -> Variable -> Variable -> Unify ()

172guardedUnify orientation left right =

243guardedUnify orientation left right =

244+ Unify $ \vars ok err ->

173− do equivalent <- liftIO $ UF.equivalent left right

245+ do equivalent <- UF.equivalent left right

174− if equivalent

246+ if equivalent

175− then return ()

247+ then ok vars ()

176− else

248+ else

177− do leftDesc <- liftIO $ UF.descriptor left

249+ do leftDesc <- UF.descriptor left

178− rightDesc <- liftIO $ UF.descriptor right

250+ rightDesc <- UF.descriptor right

179− actuallyUnify (Context orientation left leftDesc right rightDesc)

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

252+ Unify k ->

253+ k vars ok err

180

254

181

255

182subUnify :: Context -> Variable -> Variable -> Unify ()

256subUnify :: Context -> Variable -> Variable -> Unify ()

@@ -246,7 +320,7 @@ unifyFlex context otherContent =

246-- UNIFY RIGID VARIABLES

320-- UNIFY RIGID VARIABLES

247

321

248

322

249−unifyRigid :: Context -> Maybe Super -> Text -> Content -> Content -> Unify ()

323+unifyRigid :: Context -> Maybe SuperType -> N.Name -> Content -> Content -> Unify ()

250unifyRigid context maybeSuper name content otherContent =

324unifyRigid context maybeSuper name content otherContent =

251 case otherContent of

325 case otherContent of

252 FlexVar _ ->

326 FlexVar _ ->

@@ -313,7 +387,7 @@ flatTypeToSpecificThing flatType =

313-- UNIFY SUPER VARIABLES

387-- UNIFY SUPER VARIABLES

314

388

315

389

316−unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()

390+unifyFlexSuper :: Context -> SuperType -> Content -> Content -> Unify ()

317unifyFlexSuper context super content otherContent =

391unifyFlexSuper context super content otherContent =

318 case otherContent of

392 case otherContent of

319 Structure flatType ->

393 Structure flatType ->

@@ -369,14 +443,14 @@ unifyFlexSuper context super content otherContent =

369 return ()

443 return ()

370

444

371

445

372−combineRigidSupers :: Super -> Super -> Bool

446+combineRigidSupers :: SuperType -> SuperType -> Bool

373combineRigidSupers rigid flex =

447combineRigidSupers rigid flex =

374 rigid == flex

448 rigid == flex

375 || (rigid == Number && flex == Comparable)

449 || (rigid == Number && flex == Comparable)

376 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))

450 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))

377

451

378

452

379−atomMatchesSuper :: Super -> ModuleName.Canonical -> N.Name -> Bool

453+atomMatchesSuper :: SuperType -> ModuleName.Canonical -> N.Name -> Bool

380atomMatchesSuper super home name =

454atomMatchesSuper super home name =

381 home == ModuleName.basics

455 home == ModuleName.basics

382 &&

456 &&

@@ -398,7 +472,7 @@ atomMatchesSuper super home name =

398 name == N.string

472 name == N.string

399

473

400

474

401−unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()

475+unifyFlexSuperStructure :: Context -> SuperType -> FlatType -> Unify ()

402unifyFlexSuperStructure context super flatType =

476unifyFlexSuperStructure context super flatType =

403 case flatType of

477 case flatType of

404 App1 home name [] ->

478 App1 home name [] ->

@@ -457,20 +531,18 @@ unifyFlexSuperStructure context super flatType =

457-- Do type classes require occurs checks?

531-- Do type classes require occurs checks?

458comparableOccursCheck :: Context -> Unify ()

532comparableOccursCheck :: Context -> Unify ()

459comparableOccursCheck (Context _ _ _ var _) =

533comparableOccursCheck (Context _ _ _ var _) =

534+ Unify $ \vars ok err ->

460− do hasOccurred <- liftIO $ Occurs.occurs var

535+ do hasOccurred <- Occurs.occurs var

461− if hasOccurred

536+ if hasOccurred

462− then throwError Infinite

537+ then err vars Infinite

463− else return ()

538+ else ok vars ()

464

539

465

540

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

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

467unifyComparableRecursive orientation var =

542unifyComparableRecursive orientation var =

468− do compVar <- liftIO $

543+ do compVar <- register $

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

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

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

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

471−

472− lift $ TS.register compVar

473−

474 guardedUnify orientation compVar var

546 guardedUnify orientation compVar var

475

547

476

548

@@ -478,7 +550,7 @@ unifyComparableRecursive orientation var =

478-- UNIFY ALIASES

550-- UNIFY ALIASES

479

551

480

552

481−unifyAlias :: Context -> ModuleName.Canonical -> N.Name -> [(Text, Variable)] -> Variable -> Content -> Unify ()

553+unifyAlias :: Context -> ModuleName.Canonical -> N.Name -> [(N.Name, Variable)] -> Variable -> Content -> Unify ()

482unifyAlias context home name args realVar otherContent =

554unifyAlias context home name args realVar otherContent =

483 case otherContent of

555 case otherContent of

484 FlexVar _ ->

556 FlexVar _ ->

@@ -558,9 +630,12 @@ unifyStructure context flatType content otherContent =

558 subUnify context (_first context) ext

630 subUnify context (_first context) ext

559

631

560 (Record1 fields extension, Record1 otherFields otherExtension) ->

632 (Record1 fields extension, Record1 otherFields otherExtension) ->

633+ Unify $ \vars ok err ->

561− do firstStructure <- liftIO $ gatherFields context fields extension

634+ do firstStructure <- gatherFields context fields extension

562− secondStructure <- liftIO $ gatherFields context otherFields otherExtension

635+ secondStructure <- gatherFields context otherFields otherExtension

563− unifyRecord context firstStructure secondStructure

636+ case unifyRecord context firstStructure secondStructure of

637+ Unify k ->

638+ k vars ok err

564

639

565 _ ->

640 _ ->

566 mismatch context Nothing

641 mismatch context Nothing

@@ -636,32 +711,33 @@ unifyRecord context firstStructure secondStructure =

636

711

637

712

638

713

639−unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()

714+unifySharedFieldsHelp :: Context -> Map.Map N.Name (Variable, Variable) -> Unify ()

640unifySharedFieldsHelp context sharedFields =

715unifySharedFieldsHelp context sharedFields =

641− do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)

716+ do badFields <- Map.traverseMaybeWithKey (unifyField context) sharedFields

642− case Maybe.catMaybes maybeBadFields of

717+ case Map.toList badFields of

643 [] ->

718 [] ->

644 return ()

719 return ()

645

720

646− badFields ->

721+ badFieldPairs ->

647− mismatch context (Just (Error.BadFields (reverse badFields)))

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

648−

649

723

650−unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (Text, Maybe Error.Reason))

651−unifyField context (field, (expected, actual)) =

652− do result <- lift $ runExceptT $ subUnify context expected actual

653− case result of

654− Right () ->

655− return $ Nothing

656

724

657− Left problem ->

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

658− return $ Just $ (,) field $

726+unifyField context _ (actual, expected) =

727+ Unify $ \vars ok _ ->

728+ case subUnify context actual expected of

729+ Unify k ->

730+ k vars

731+ (\vs () -> ok vs Nothing)

659− case problem of

732+ (\vs problem ->

660− Reason _ reason ->

733+ ok vs $ Just $

734+ case problem of

735+ Reason _ reason ->

661− reason

736+ reason

662

737

663− Infinite ->

738+ Infinite ->

664− Nothing

739+ Nothing

740+ )

665

741

666

742

667

743

@@ -670,7 +746,7 @@ unifyField context (field, (expected, actual)) =

670

746

671data RecordStructure =

747data RecordStructure =

672 RecordStructure

748 RecordStructure

673− { _fields :: Map.Map Text Variable

749+ { _fields :: Map.Map N.Name Variable

674 , _extVar :: Variable

750 , _extVar :: Variable

675 , _extStruct :: ExtensionStructure

751 , _extStruct :: ExtensionStructure

676 }

752 }

@@ -681,7 +757,7 @@ data ExtensionStructure

681 | Extension

757 | Extension

682

758

683

759

684−gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure

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

685gatherFields context fields variable =

761gatherFields context fields variable =

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

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

687 case content of

763 case content of