git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #2491 from LiamGoodacre/fix/entails-kinded-type

Unwrap KindedType when instance solving

commit81b58fc4a51c3e5105a602e1e9526e388546af26 authorPhil Freeman <paf31@cantab.net> dateTue 20 Dec 2016, 21:33 (10 years ago) parent612585a92b5f53
2 files changed+21
examples/passing/EntailsKindedType.purs+11 src/Language/PureScript/TypeChecker/Entailment.hs+10
examples/passing/EntailsKindedType.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.Eff.Console
6+
7+test x = show (x :: _ :: *)
8+
9+main = do
10+ when (show (unit :: Unit :: *) == "unit") (log "Done")
11+ when (test unit == "unit") (log "Done")
src/Language/PureScript/TypeChecker/Entailment.hs+10
@@ -146,6 +146,7 @@ entails SolverOptions{..} constraint context hints =
146146 ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn
147147 ctorModules (TypeConstructor (Qualified Nothing _)) = internalError "ctorModules: unqualified type name"
148148 ctorModules (TypeApp ty _) = ctorModules ty
149+ ctorModules (KindedType ty _) = ctorModules ty
149150 ctorModules _ = Nothing
150151
151152 findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict]
@@ -266,6 +267,7 @@ entails SolverOptions{..} constraint context hints =
266267
267268 canBeGeneralized :: Type -> Bool
268269 canBeGeneralized TUnknown{} = True
270+ canBeGeneralized (KindedType t _) = canBeGeneralized t
269271 canBeGeneralized _ = False
270272
271273 -- |
@@ -346,6 +348,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do
346348 -- and return a substitution from type variables to types which makes the type heads unify.
347349 --
348350 typeHeadsAreEqual :: Type -> Type -> (Bool, Matching [Type])
351+ typeHeadsAreEqual (KindedType t1 _) t2 = typeHeadsAreEqual t1 t2
352+ typeHeadsAreEqual t1 (KindedType t2 _) = typeHeadsAreEqual t1 t2
349353 typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (True, M.empty)
350354 typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (True, M.empty)
351355 typeHeadsAreEqual t (TypeVar v) = (True, M.singleton v [t])
@@ -365,6 +369,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do
365369 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
366370
367371 go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type])
372+ go l (KindedType t1 _) r t2 = go l t1 r t2
373+ go l t1 r (KindedType t2 _) = go l t1 r t2
368374 go [] REmpty [] REmpty = (True, M.empty)
369375 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty)
370376 go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty)
@@ -386,6 +392,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do
386392 -- which was _not_ solved, i.e. one which was inferred by a functional
387393 -- dependency.
388394 typesAreEqual :: Type -> Type -> Bool
395+ typesAreEqual (KindedType t1 _) t2 = typesAreEqual t1 t2
396+ typesAreEqual t1 (KindedType t2 _) = typesAreEqual t1 t2
389397 typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = True
390398 typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2
391399 typesAreEqual (TypeVar v1) (TypeVar v2) = v1 == v2
@@ -403,6 +411,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do
403411 in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'
404412 where
405413 go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool
414+ go l (KindedType t1 _) r t2 = go l t1 r t2
415+ go l t1 r (KindedType t2 _) = go l t1 r t2
406416 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True
407417 go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2
408418 go [] REmpty [] REmpty = True