7be61fe · rowtype-yoga/purescript-native

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

on golang help sign in

Fix #922, take 3

7be61fePhil Freeman11 years ago

examples/passing/922.pursnew file+20

compare with golang

unifiedsplit

@@ -0,0 +1,20 @@

1+module Main where

3+import Prelude

5+import Control.Monad.Eff.Console

7+class Default a where

8+ def :: a

10+instance defaultString :: Default String where

11+ def = "Done"

12+

13+data I a = I a

14+

15+instance defaultI :: (Default a) => Default (I a) where

16+ def = I def

17+

18+main = do

19+ case def of

20+ I s -> log s

src/Language/PureScript/TypeChecker/Types.hs+30−9

@@ -282,10 +282,10 @@ infer' v@(Constructor c) = do

282 Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty

283 return $ TypedValue True v' ty'

284infer' (Case vals binders) = do

285− ts <- mapM infer vals

285+ (vals', ts) <- instantiateForBinders vals binders

286 ret <- fresh

287− binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders

287+ binders' <- checkBinders ts ret binders

288− return $ TypedValue True (Case ts binders') ret

288+ return $ TypedValue True (Case vals' binders') ret

289infer' (IfThenElse cond th el) = do

290 cond' <- check cond tyBoolean

291 v2@(TypedValue _ _ t2) <- infer th

@@ -376,7 +376,7 @@ inferBinder val (ConstructorBinder ctor binders) = do

376 go [] ty' = case (val, ty') of

377 (TypeConstructor _, TypeApp _ _) -> throwIncorrectArity

378 _ -> do

379− _ <- subsumes Nothing val ty'

379+ _ <- val =?= ty'

380 return M.empty

381 go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =

382 M.union <$> inferBinder obj binder <*> go binders' ret

@@ -408,6 +408,26 @@ inferBinder val (NamedBinder name binder) = do

408inferBinder val (PositionedBinder pos _ binder) =

409 warnAndRethrowWithPosition pos $ inferBinder val binder

410

411+-- | Returns true if a binder requires its argument type to be a monotype.

412+-- | If this is the case, we need to instantiate any polymorphic types before checking binders.

413+binderRequiresMonotype :: Binder -> Bool

414+binderRequiresMonotype NullBinder = False

415+binderRequiresMonotype (VarBinder _) = False

416+binderRequiresMonotype (NamedBinder _ b) = binderRequiresMonotype b

417+binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b

418+binderRequiresMonotype _ = True

419+

420+-- | Instantiate polytypes only when necessitated by a binder.

421+instantiateForBinders :: [Expr] -> [CaseAlternative] -> UnifyT Type Check ([Expr], [Type])

422+instantiateForBinders vals cas = fmap unzip $ zipWithM (\val inst -> do

423+ TypedValue _ val' ty <- infer val

424+ if inst

425+ then instantiatePolyTypeWithUnknowns val' ty

426+ else return (val', ty)) vals shouldInstantiate

427+ where

428+ shouldInstantiate :: [Bool]

429+ shouldInstantiate = map (any binderRequiresMonotype) . transpose . map caseAlternativeBinders $ cas

430+

411-- |

431-- |

412-- Check the types of the return values in a set of binders in a case statement

432-- Check the types of the return values in a set of binders in a case statement

413--

433--

@@ -537,8 +557,7 @@ check' (TypedValue checkType val ty1) ty2 = do

537 val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val

557 val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val

538 return $ TypedValue checkType val''' ty2'

558 return $ TypedValue checkType val''' ty2'

539check' (Case vals binders) ret = do

559check' (Case vals binders) ret = do

540− vals' <- mapM infer vals

560+ (vals', ts) <- instantiateForBinders vals binders

541− let ts = map (\(TypedValue _ _ t) -> t) vals'

542 binders' <- checkBinders ts ret binders

561 binders' <- checkBinders ts ret binders

543 return $ TypedValue True (Case vals' binders') ret

562 return $ TypedValue True (Case vals' binders') ret

544check' (IfThenElse cond th el) ty = do

563check' (IfThenElse cond th el) ty = do

@@ -567,14 +586,16 @@ check' (Accessor prop val) ty = do

567 rest <- fresh

586 rest <- fresh

568 val' <- check val (TypeApp tyObject (RCons prop ty rest))

587 val' <- check val (TypeApp tyObject (RCons prop ty rest))

569 return $ TypedValue True (Accessor prop val') ty

588 return $ TypedValue True (Accessor prop val') ty

570−check' (Constructor c) ty = do

589+check' v@(Constructor c) ty = do

571 env <- getEnv

590 env <- getEnv

572 case M.lookup c (dataConstructors env) of

591 case M.lookup c (dataConstructors env) of

573 Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing

592 Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing

574 Just (_, _, ty1, _) -> do

593 Just (_, _, ty1, _) -> do

575 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

594 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

576− _ <- subsumes Nothing repl ty

595+ mv <- subsumes (Just v) repl ty

596+ case mv of

597+ Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

577− return $ TypedValue True (Constructor c) ty

598+ Just v' -> return $ TypedValue True v' ty

578check' (Let ds val) ty = do

599check' (Let ds val) ty = do

579 (ds', val') <- inferLetBinding [] ds val (`check` ty)

600 (ds', val') <- inferLetBinding [] ds val (`check` ty)

580 return $ TypedValue True (Let ds' val') ty

601 return $ TypedValue True (Let ds' val') ty