92b5f53 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Unwrap KindedType when instance solving

92b5f53Liam Goodacre10 years ago

examples/passing/EntailsKindedType.pursnew file+11

compare with golang

unifiedsplit

@@ -0,0 +1,11 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.Eff.Console

7+test x = show (x :: _ :: *)

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 =

146 ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn

147 ctorModules (TypeConstructor (Qualified Nothing _)) = internalError "ctorModules: unqualified type name"

148 ctorModules (TypeApp ty _) = ctorModules ty

149+ ctorModules (KindedType ty _) = ctorModules ty

149 ctorModules _ = Nothing

150 ctorModules _ = Nothing

150

151

151 findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict]

152 findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict]

@@ -266,6 +267,7 @@ entails SolverOptions{..} constraint context hints =

266

267

267 canBeGeneralized :: Type -> Bool

268 canBeGeneralized :: Type -> Bool

268 canBeGeneralized TUnknown{} = True

269 canBeGeneralized TUnknown{} = True

270+ canBeGeneralized (KindedType t _) = canBeGeneralized t

269 canBeGeneralized _ = False

271 canBeGeneralized _ = False

270

272

271 -- |

273 -- |

@@ -346,6 +348,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do

346 -- and return a substitution from type variables to types which makes the type heads unify.

348 -- and return a substitution from type variables to types which makes the type heads unify.

347 --

349 --

348 typeHeadsAreEqual :: Type -> Type -> (Bool, Matching [Type])

350 typeHeadsAreEqual :: Type -> Type -> (Bool, Matching [Type])

351+ typeHeadsAreEqual (KindedType t1 _) t2 = typeHeadsAreEqual t1 t2

352+ typeHeadsAreEqual t1 (KindedType t2 _) = typeHeadsAreEqual t1 t2

349 typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (True, M.empty)

353 typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (True, M.empty)

350 typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (True, M.empty)

354 typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (True, M.empty)

351 typeHeadsAreEqual t (TypeVar v) = (True, M.singleton v [t])

355 typeHeadsAreEqual t (TypeVar v) = (True, M.singleton v [t])

@@ -365,6 +369,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do

365 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

369 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

366

370

367 go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type])

371 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

368 go [] REmpty [] REmpty = (True, M.empty)

374 go [] REmpty [] REmpty = (True, M.empty)

369 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty)

375 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty)

370 go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty)

376 go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty)

@@ -386,6 +392,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do

386 -- which was _not_ solved, i.e. one which was inferred by a functional

392 -- which was _not_ solved, i.e. one which was inferred by a functional

387 -- dependency.

393 -- dependency.

388 typesAreEqual :: Type -> Type -> Bool

394 typesAreEqual :: Type -> Type -> Bool

395+ typesAreEqual (KindedType t1 _) t2 = typesAreEqual t1 t2

396+ typesAreEqual t1 (KindedType t2 _) = typesAreEqual t1 t2

389 typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = True

397 typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = True

390 typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2

398 typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2

391 typesAreEqual (TypeVar v1) (TypeVar v2) = v1 == v2

399 typesAreEqual (TypeVar v1) (TypeVar v2) = v1 == v2

@@ -403,6 +411,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do

403 in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'

411 in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2'

404 where

412 where

405 go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool

413 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

406 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True

416 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True

407 go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2

417 go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2

408 go [] REmpty [] REmpty = True

418 go [] REmpty [] REmpty = True