diff options
| author | Richard Eisenberg <eir@cis.upenn.edu> | 2016-01-13 23:29:17 -0500 |
|---|---|---|
| committer | Richard Eisenberg <eir@cis.upenn.edu> | 2016-01-26 23:33:26 -0500 |
| commit | f338ce60cde1b9e63747cc240f635fe7bf50059a (patch) | |
| tree | 8c6c4c3834851dde04350fac059b19ed6dd08677 | |
| parent | 919597def355708e6fa88d4d43f55e7fd693cec3 (diff) | |
| download | haskell-wip/exp-types.tar.gz | |
Refactor the typechecker to use ExpTypes.wip/exp-types
The idea here is described in [wiki:Typechecker]. Briefly,
this refactor keeps solid track of "synthesis" mode vs
"checking" in GHC's bidirectional type-checking algorithm.
When in synthesis mode, the expected type is just an IORef
to write to.
In addition, this patch does a significant reworking of
RebindableSyntax, allowing much more freedom in the types
of the rebindable operators. For example, we can now have
`negate :: Int -> Bool` and
`(>>=) :: m a -> (forall x. a x -> m b) -> m b`. The magic
is in tcSyntaxOp.
This addresses tickets #11397, #11452, and #11458.
Tests:
typecheck/should_compile/{RebindHR,RebindNegate,T11397,T11458}
th/T11452
130 files changed, 2666 insertions, 1720 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 38626a486a..73f0177342 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -31,6 +31,7 @@ import Id import ConLike import DataCon import Name +import FamInstEnv import TysWiredIn import TyCon import SrcLoc @@ -148,7 +149,8 @@ type PmResult = ( [[LPat Id]] checkSingle :: Id -> Pat Id -> DsM PmResult checkSingle var p = do let lp = [noLoc p] - vec <- liftUs (translatePat p) + fam_insts <- dsGetFamInstEnvs + vec <- liftUs (translatePat fam_insts p) vsa <- initial_uncovered [var] (c,d,us') <- patVectProc False (vec,[]) vsa -- no guards us <- pruneVSA us' @@ -171,7 +173,8 @@ checkMatches oversimplify vars matches return ([], [], missing') go (m:ms) missing = do - clause <- liftUs (translateMatch m) + fam_insts <- dsGetFamInstEnvs + clause <- liftUs (translateMatch fam_insts m) (c, d, us ) <- patVectProc oversimplify clause missing (rs, is, us') <- go ms us return $ case (c,d) of @@ -209,7 +212,8 @@ noFailingGuards clauses = sum [ countPatVecs gvs | (_, gvs) <- clauses ] computeNoGuards :: [LMatch Id (LHsExpr Id)] -> PmM Int computeNoGuards matches = do - matches' <- mapM (liftUs . translateMatch) matches + fam_insts <- dsGetFamInstEnvs + matches' <- mapM (liftUs . translateMatch fam_insts) matches return (noFailingGuards matches') maximum_failing_guards :: Int @@ -264,46 +268,47 @@ mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit } -- ----------------------------------------------------------------------- -- * Transform (Pat Id) into of (PmPat Id) -translatePat :: Pat Id -> UniqSM PatVec -translatePat pat = case pat of +translatePat :: FamInstEnvs -> Pat Id -> UniqSM PatVec +translatePat fam_insts pat = case pat of WildPat ty -> mkPmVarsSM [ty] VarPat id -> return [PmVar (unLoc id)] - ParPat p -> translatePat (unLoc p) + ParPat p -> translatePat fam_insts (unLoc p) LazyPat _ -> mkPmVarsSM [hsPatType pat] -- like a variable -- ignore strictness annotations for now - BangPat p -> translatePat (unLoc p) + BangPat p -> translatePat fam_insts (unLoc p) AsPat lid p -> do -- Note [Translating As Patterns] - ps <- translatePat (unLoc p) + ps <- translatePat fam_insts (unLoc p) let [e] = map valAbsToPmExpr (coercePatVec ps) g = PmGrd [PmVar (unLoc lid)] e return (ps ++ [g]) - SigPatOut p _ty -> translatePat (unLoc p) + SigPatOut p _ty -> translatePat fam_insts (unLoc p) -- See Note [Translate CoPats] CoPat wrapper p ty - | isIdHsWrapper wrapper -> translatePat p - | WpCast co <- wrapper, isReflexiveCo co -> translatePat p + | isIdHsWrapper wrapper -> translatePat fam_insts p + | WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts p | otherwise -> do - ps <- translatePat p + ps <- translatePat fam_insts p (xp,xe) <- mkPmId2FormsSM ty let g = mkGuard ps (HsWrap wrapper (unLoc xe)) return [xp,g] -- (n + k) ===> x (True <- x >= k) (n <- x-k) - NPlusKPat (L _ n) k ge minus -> do - (xp, xe) <- mkPmId2FormsSM (idType n) - let ke = L (getLoc k) (HsOverLit (unLoc k)) - g1 = mkGuard [truePattern] (OpApp xe (noLoc ge) no_fixity ke) - g2 = mkGuard [PmVar n] (OpApp xe (noLoc minus) no_fixity ke) + NPlusKPat (L _ n) k1 k2 ge minus ty -> do + (xp, xe) <- mkPmId2FormsSM ty + let ke1 = L (getLoc k1) (HsOverLit (unLoc k1)) + ke2 = L (getLoc k1) (HsOverLit k2) + g1 = mkGuard [truePattern] (unLoc $ nlHsSyntaxApps ge [xe, ke1]) + g2 = mkGuard [PmVar n] (unLoc $ nlHsSyntaxApps minus [xe, ke2]) return [xp, g1, g2] -- (fun -> pat) ===> x (pat <- fun x) ViewPat lexpr lpat arg_ty -> do - ps <- translatePat (unLoc lpat) + ps <- translatePat fam_insts (unLoc lpat) -- See Note [Guards and Approximation] case all cantFailPattern ps of True -> do @@ -316,15 +321,18 @@ translatePat pat = case pat of -- list ListPat ps ty Nothing -> do - foldr (mkListPatVec ty) [nilPattern ty] <$> translatePatVec (map unLoc ps) + foldr (mkListPatVec ty) [nilPattern ty] <$> translatePatVec fam_insts (map unLoc ps) -- overloaded list ListPat lpats elem_ty (Just (pat_ty, _to_list)) - | Just e_ty <- splitListTyConApp_maybe pat_ty, elem_ty `eqType` e_ty -> + | Just e_ty <- splitListTyConApp_maybe pat_ty + , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty + -- elem_ty is frequently something like `Item [Int]`, but we prefer `Int` + , norm_elem_ty `eqType` e_ty -> -- We have to ensure that the element types are exactly the same. -- Otherwise, one may give an instance IsList [Int] (more specific than -- the default IsList [a]) with a different implementation for `toList' - translatePat (ListPat lpats e_ty Nothing) + translatePat fam_insts (ListPat lpats e_ty Nothing) | otherwise -> do -- See Note [Guards and Approximation] var <- mkPmVarSM pat_ty @@ -345,29 +353,29 @@ translatePat pat = case pat of , pat_tvs = ex_tvs , pat_dicts = dicts , pat_args = ps } -> do - args <- translateConPatVec arg_tys ex_tvs con ps + args <- translateConPatVec fam_insts arg_tys ex_tvs con ps return [PmCon { pm_con_con = con , pm_con_arg_tys = arg_tys , pm_con_tvs = ex_tvs , pm_con_dicts = dicts , pm_con_args = args }] - NPat (L _ ol) mb_neg _eq -> translateNPat ol mb_neg + NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty LitPat lit -- If it is a string then convert it to a list of characters | HsString src s <- lit -> foldr (mkListPatVec charTy) [nilPattern charTy] <$> - translatePatVec (map (LitPat . HsChar src) (unpackFS s)) + translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s)) | otherwise -> return [mkLitPattern lit] PArrPat ps ty -> do - tidy_ps <- translatePatVec (map unLoc ps) + tidy_ps <- translatePatVec fam_insts (map unLoc ps) let fake_con = parrFakeCon (length ps) return [vanillaConPattern fake_con [ty] (concat tidy_ps)] TuplePat ps boxity tys -> do - tidy_ps <- translatePatVec (map unLoc ps) + tidy_ps <- translatePatVec fam_insts (map unLoc ps) let tuple_con = tupleDataCon boxity (length ps) return [vanillaConPattern tuple_con tys (concat tidy_ps)] @@ -378,33 +386,35 @@ translatePat pat = case pat of SigPatIn {} -> panic "Check.translatePat: SigPatIn" -- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs) -translateNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> UniqSM PatVec -translateNPat (OverLit val False _ ty) mb_neg - | isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg - = translatePat (LitPat (HsString src s)) - | isIntTy ty, HsIntegral src i <- val - = translatePat (mk_num_lit HsInt src i) - | isWordTy ty, HsIntegral src i <- val - = translatePat (mk_num_lit HsWordPrim src i) +translateNPat :: FamInstEnvs + -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> UniqSM PatVec +translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty + | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg + = translatePat fam_insts (LitPat (HsString src s)) + | not type_change, isIntTy ty, HsIntegral src i <- val + = translatePat fam_insts (mk_num_lit HsInt src i) + | not type_change, isWordTy ty, HsIntegral src i <- val + = translatePat fam_insts (mk_num_lit HsWordPrim src i) where + type_change = not (outer_ty `eqType` ty) mk_num_lit c src i = LitPat $ case mb_neg of Nothing -> c src i Just _ -> c src (-i) -translateNPat ol mb_neg +translateNPat _ ol mb_neg _ = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }] -- | Translate a list of patterns (Note: each pattern is translated -- to a pattern vector but we do not concatenate the results). -translatePatVec :: [Pat Id] -> UniqSM [PatVec] -translatePatVec pats = mapM translatePat pats +translatePatVec :: FamInstEnvs -> [Pat Id] -> UniqSM [PatVec] +translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats -translateConPatVec :: [Type] -> [TyVar] +translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar] -> DataCon -> HsConPatDetails Id -> UniqSM PatVec -translateConPatVec _univ_tys _ex_tvs _ (PrefixCon ps) - = concat <$> translatePatVec (map unLoc ps) -translateConPatVec _univ_tys _ex_tvs _ (InfixCon p1 p2) - = concat <$> translatePatVec (map unLoc [p1,p2]) -translateConPatVec univ_tys ex_tvs c (RecCon (HsRecFields fs _)) +translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps) + = concat <$> translatePatVec fam_insts (map unLoc ps) +translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2) + = concat <$> translatePatVec fam_insts (map unLoc [p1,p2]) +translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _)) -- Nothing matched. Make up some fresh term variables | null fs = mkPmVarsSM arg_tys -- The data constructor was not defined using record syntax. For the @@ -417,7 +427,7 @@ translateConPatVec univ_tys ex_tvs c (RecCon (HsRecFields fs _)) | matched_lbls `subsetOf` orig_lbls = ASSERT(length orig_lbls == length arg_tys) let translateOne (lbl, ty) = case lookup lbl matched_pats of - Just p -> translatePat p + Just p -> translatePat fam_insts p Nothing -> mkPmVarsSM [ty] in concatMapM translateOne (zip orig_lbls arg_tys) -- The fields that appear are not in the correct order. Make up fresh @@ -426,7 +436,7 @@ translateConPatVec univ_tys ex_tvs c (RecCon (HsRecFields fs _)) | otherwise = do arg_var_pats <- mkPmVarsSM arg_tys translated_pats <- forM matched_pats $ \(x,pat) -> do - pvec <- translatePat pat + pvec <- translatePat fam_insts pat return (x, pvec) let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ] @@ -453,10 +463,10 @@ translateConPatVec univ_tys ex_tvs c (RecCon (HsRecFields fs _)) | x == y = subsetOf xs ys | otherwise = subsetOf (x:xs) ys -translateMatch :: LMatch Id (LHsExpr Id) -> UniqSM (PatVec,[PatVec]) -translateMatch (L _ (Match _ lpats _ grhss)) = do - pats' <- concat <$> translatePatVec pats - guards' <- mapM translateGuards guards +translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> UniqSM (PatVec,[PatVec]) +translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do + pats' <- concat <$> translatePatVec fam_insts pats + guards' <- mapM (translateGuards fam_insts) guards return (pats', guards') where extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id] @@ -469,9 +479,9 @@ translateMatch (L _ (Match _ lpats _ grhss)) = do -- * Transform source guards (GuardStmt Id) to PmPats (Pattern) -- | Translate a list of guard statements to a pattern vector -translateGuards :: [GuardStmt Id] -> UniqSM PatVec -translateGuards guards = do - all_guards <- concat <$> mapM translateGuard guards +translateGuards :: FamInstEnvs -> [GuardStmt Id] -> UniqSM PatVec +translateGuards fam_insts guards = do + all_guards <- concat <$> mapM (translateGuard fam_insts) guards return (replace_unhandled all_guards) -- It should have been (return $ all_guards) but it is too expressive. -- Since the term oracle does not handle all constraints we generate, @@ -509,24 +519,24 @@ cantFailPattern (PmGrd pv _e) cantFailPattern _ = False -- | Translate a guard statement to Pattern -translateGuard :: GuardStmt Id -> UniqSM PatVec -translateGuard (BodyStmt e _ _ _) = translateBoolGuard e -translateGuard (LetStmt binds) = translateLet (unLoc binds) -translateGuard (BindStmt p e _ _) = translateBind p e -translateGuard (LastStmt {}) = panic "translateGuard LastStmt" -translateGuard (ParStmt {}) = panic "translateGuard ParStmt" -translateGuard (TransStmt {}) = panic "translateGuard TransStmt" -translateGuard (RecStmt {}) = panic "translateGuard RecStmt" -translateGuard (ApplicativeStmt {}) = panic "translateGuard ApplicativeLastStmt" +translateGuard :: FamInstEnvs -> GuardStmt Id -> UniqSM PatVec +translateGuard _ (BodyStmt e _ _ _) = translateBoolGuard e +translateGuard _ (LetStmt binds) = translateLet (unLoc binds) +translateGuard fam_insts (BindStmt p e _ _ _) = translateBind fam_insts p e +translateGuard _ (LastStmt {}) = panic "translateGuard LastStmt" +translateGuard _ (ParStmt {}) = panic "translateGuard ParStmt" +translateGuard _ (TransStmt {}) = panic "translateGuard TransStmt" +translateGuard _ (RecStmt {}) = panic "translateGuard RecStmt" +translateGuard _ (ApplicativeStmt {}) = panic "translateGuard ApplicativeLastStmt" -- | Translate let-bindings translateLet :: HsLocalBinds Id -> UniqSM PatVec translateLet _binds = return [] -- | Translate a pattern guard -translateBind :: LPat Id -> LHsExpr Id -> UniqSM PatVec -translateBind (L _ p) e = do - ps <- translatePat p +translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> UniqSM PatVec +translateBind fam_insts (L _ p) e = do + ps <- translatePat fam_insts p return [mkGuard ps (unLoc e)] -- | Translate a boolean guard @@ -600,7 +610,8 @@ below is the *right thing to do*: The case with literals is a bit different. a literal @l@ should be translated to @x (True <- x == from l)@. Since we want to have better warnings for overloaded literals as it is a very common feature, we treat them differently. -They are mainly covered in Note [Undecidable Equality on Overloaded Literals]. +They are mainly covered in Note [Undecidable Equality on Overloaded Literals] +in PmExpr. 4. N+K Patterns & Pattern Synonyms ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -845,9 +856,6 @@ coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys , pm_con_args = coercePatVec args }] coercePmPat (PmGrd {}) = [] -- drop the guards -no_fixity :: a -- TODO: Can we retrieve the fixity from the operator name? -no_fixity = panic "Check: no fixity" - -- Get all constructors in the family (including given) allConstructors :: DataCon -> [DataCon] allConstructors = tyConDataCons . dataConTyCon @@ -1101,7 +1109,7 @@ cMatcher us gvsa (p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps -- CLitLit cMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa = case eqPmLit l1 l2 of - -- See Note [Undecidable Equality for Overloaded Literals] + -- See Note [Undecidable Equality for Overloaded Literals] in PmExpr True -> va `mkCons` covered us gvsa ps vsa -- match False -> Empty -- mismatch @@ -1172,7 +1180,7 @@ uMatcher us gvsa ( p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps -- ULitLit uMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa = case eqPmLit l1 l2 of - -- See Note [Undecidable Equality for Overloaded Literals] + -- See Note [Undecidable Equality for Overloaded Literals] in PmExpr True -> va `mkCons` uncovered us gvsa ps vsa -- match False -> va `mkCons` vsa -- mismatch @@ -1256,7 +1264,7 @@ dMatcher us gvsa (p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps -- DLitLit dMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa = case eqPmLit l1 l2 of - -- See Note [Undecidable Equality for Overloaded Literals] + -- See Note [Undecidable Equality for Overloaded Literals] in PmExpr True -> va `mkCons` divergent us gvsa ps vsa -- match False -> Empty -- mismatch @@ -1331,10 +1339,12 @@ genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee -> [Id] -- MatchVars (should have length 1) -> DsM (Bag SimpleEq) genCaseTmCs2 Nothing _ _ = return emptyBag -genCaseTmCs2 (Just scr) [p] [var] = liftUs $ do - [e] <- map valAbsToPmExpr . coercePatVec <$> translatePat p - let scr_e = lhsExprToPmExpr scr - return $ listToBag [(var, e), (var, scr_e)] +genCaseTmCs2 (Just scr) [p] [var] = do + fam_insts <- dsGetFamInstEnvs + liftUs $ do + [e] <- map valAbsToPmExpr . coercePatVec <$> translatePat fam_insts p + let scr_e = lhsExprToPmExpr scr + return $ listToBag [(var, e), (var, scr_e)] genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase" -- | Generate a simple equality when checking a case expression: diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index b7a578f533..b40f3696eb 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -592,8 +592,9 @@ addTickHsExpr (ExplicitList ty wit es) = (addTickWit wit) (mapM (addTickLHsExpr) es) where addTickWit Nothing = return Nothing - addTickWit (Just fln) = do fln' <- addTickHsExpr fln - return (Just fln') + addTickWit (Just fln) + = do fln' <- addTickSyntaxExpr hpcSrcSpan fln + return (Just fln') addTickHsExpr (ExplicitPArr ty es) = liftM2 ExplicitPArr (return ty) @@ -621,7 +622,7 @@ addTickHsExpr (ArithSeq ty wit arith_seq) = (addTickWit wit) (addTickArithSeqInfo arith_seq) where addTickWit Nothing = return Nothing - addTickWit (Just fl) = do fl' <- addTickHsExpr fl + addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl return (Just fl') -- We might encounter existing ticks (multiple Coverage passes) @@ -732,12 +733,13 @@ addTickStmt _isGuard (LastStmt e noret ret) = do (addTickLHsExpr e) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) -addTickStmt _isGuard (BindStmt pat e bind fail) = do - liftM4 BindStmt +addTickStmt _isGuard (BindStmt pat e bind fail ty) = do + liftM5 BindStmt (addTickLPat pat) (addTickLHsExprRHS e) (addTickSyntaxExpr hpcSrcSpan bind) (addTickSyntaxExpr hpcSrcSpan fail) + (return ty) addTickStmt isGuard (BodyStmt e bind' guard' ty) = do liftM4 BodyStmt (addTick isGuard e) @@ -747,11 +749,12 @@ addTickStmt isGuard (BodyStmt e bind' guard' ty) = do addTickStmt _isGuard (LetStmt (L l binds)) = do liftM (LetStmt . L l) (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do - liftM3 ParStmt +addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do + liftM4 ParStmt (mapM (addTickStmtAndBinders isGuard) pairs) - (addTickSyntaxExpr hpcSrcSpan mzipExpr) + (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) (addTickSyntaxExpr hpcSrcSpan bindExpr) + (return ty) addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do args' <- mapM (addTickApplicativeArg isGuard) args return (ApplicativeStmt args' mb_join body_ty) @@ -765,7 +768,7 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts t_u <- addTickLHsExprRHS using t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr - t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr + L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr) return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } @@ -792,7 +795,7 @@ addTickApplicativeArg isGuard (op, arg) = addTickArg (ApplicativeArgMany stmts ret pat) = ApplicativeArgMany <$> addTickLStmts isGuard stmts - <*> addTickSyntaxExpr hpcSrcSpan ret + <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id @@ -837,9 +840,9 @@ addTickIPBind (IPBind nm e) = -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id) -addTickSyntaxExpr pos x = do +addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do L _ x' <- addTickLHsExpr (L pos x) - return $ x' + return $ syn { syn_expr = x' } -- we do not walk into patterns. addTickLPat :: LPat Id -> TM (LPat Id) addTickLPat pat = return pat @@ -951,12 +954,13 @@ addTickLCmdStmts' lstmts res binders = collectLStmtsBinders lstmts addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id)) -addTickCmdStmt (BindStmt pat c bind fail) = do - liftM4 BindStmt +addTickCmdStmt (BindStmt pat c bind fail ty) = do + liftM5 BindStmt (addTickLPat pat) (addTickLHsCmd c) (return bind) (return fail) + (return ty) addTickCmdStmt (LastStmt c noret ret) = do liftM3 LastStmt (addTickLHsCmd c) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 3691afb524..1738a5d8ba 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -25,7 +25,7 @@ import qualified HsUtils -- So WATCH OUT; check each use of split*Ty functions. -- Sigh. This is a pain. -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr ) import TcType import TcEvidence @@ -465,9 +465,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id) core_if <- case mb_fun of - Just fun -> do { core_fun <- dsExpr fun - ; matchEnvStack env_ids stack_id $ - mkCoreApps core_fun [core_cond, core_left, core_right] } + Just fun -> do { fun_apps <- dsSyntaxExpr fun [core_cond, core_left, core_right] + ; matchEnvStack env_ids stack_id fun_apps } Nothing -> matchEnvStack env_ids stack_id $ mkIfThenElse core_cond core_left core_right @@ -782,7 +781,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do -- It would be simpler and more consistent to do this using second, -- but that's likely to be defined in terms of first. -dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do +dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do let pat_ty = hsLPatType pat (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd let pat_vars = mkVarSet (collectPatBinders pat) @@ -1142,8 +1141,8 @@ collectl (L _ pat) bndrs collectEvBinders ds ++ foldr collectl bndrs (hsConPatArgs ps) go (LitPat _) = bndrs - go (NPat _ _ _) = bndrs - go (NPlusKPat (L _ n) _ _ _) = n : bndrs + go (NPat {}) = bndrs + go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs go (SigPatIn pat _) = collectl pat bndrs go (SigPatOut pat _) = collectl pat bndrs diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index c3c17c7e39..17b46e9cc2 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -8,7 +8,8 @@ Desugaring exporessions. {-# LANGUAGE CPP #-} -module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where +module DsExpr ( dsExpr, dsLExpr, dsLocalBinds + , dsValBinds, dsLit, dsSyntaxExpr ) where #include "HsVersions.h" @@ -221,7 +222,8 @@ dsExpr (HsWrap co_fn e) ; return wrapped_e } dsExpr (NegApp expr neg_expr) - = App <$> dsExpr neg_expr <*> dsLExpr expr + = do { expr' <- dsLExpr expr + ; dsSyntaxExpr neg_expr [expr'] } dsExpr (HsLam a_Match) = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match @@ -354,8 +356,7 @@ dsExpr (HsIf mb_fun guard_expr then_expr else_expr) ; b1 <- dsLExpr then_expr ; b2 <- dsLExpr else_expr ; case mb_fun of - Just fun -> do { core_fun <- dsExpr fun - ; return (mkCoreApps core_fun [pred,b1,b2]) } + Just fun -> dsSyntaxExpr fun [pred, b1, b2] Nothing -> return $ mkIfThenElse pred b1 b2 } dsExpr (HsMultiIf res_ty alts) @@ -398,10 +399,8 @@ dsExpr (ExplicitPArr ty xs) = do dsExpr (ArithSeq expr witness seq) = case witness of Nothing -> dsArithSeq expr seq - Just fl -> do { - ; fl' <- dsExpr fl - ; newArithSeq <- dsArithSeq expr seq - ; return (App fl' newArithSeq)} + Just fl -> do { newArithSeq <- dsArithSeq expr seq + ; dsSyntaxExpr fl [newArithSeq] } dsExpr (PArrSeq expr (FromTo from to)) = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] @@ -741,6 +740,16 @@ dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld" dsExpr (HsTypeOut {}) = panic "dsExpr: tried to desugar a naked type application argument (HsTypeOut)" +------------------------------ +dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr +dsSyntaxExpr (SyntaxExpr { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + arg_exprs + = do { args <- zipWithM dsHsWrapper arg_wraps arg_exprs + ; fun <- dsExpr expr + ; dsHsWrapper res_wrap $ mkApps fun args } + findField :: [LHsRecField Id arg] -> Name -> [arg] findField rbinds sel = [hsRecFieldArg fld | L _ fld <- rbinds @@ -832,10 +841,9 @@ dsExplicitList elt_ty Nothing xs ; return (foldr (App . App (Var c)) folded_suffix prefix) } dsExplicitList elt_ty (Just fln) xs - = do { fln' <- dsExpr fln - ; list <- dsExplicitList elt_ty Nothing xs + = do { list <- dsExplicitList elt_ty Nothing xs ; dflags <- getDynFlags - ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) } + ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] } spanTail :: (a -> Bool) -> [a] -> ([a], [a]) spanTail f xs = (reverse rejected, reverse satisfying) @@ -882,25 +890,21 @@ dsDo stmts go _ (BodyStmt rhs then_expr _ _) stmts = do { rhs2 <- dsLExpr rhs ; warnDiscardedDoBindings rhs (exprType rhs2) - ; then_expr2 <- dsExpr then_expr ; rest <- goL stmts - ; return (mkApps then_expr2 [rhs2, rest]) } + ; dsSyntaxExpr then_expr [rhs2, rest] } go _ (LetStmt (L _ binds)) stmts = do { rest <- goL stmts ; dsLocalBinds binds rest } - go _ (BindStmt pat rhs bind_op fail_op) stmts + go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts = do { body <- goL stmts ; rhs' <- dsLExpr rhs - ; bind_op' <- dsExpr bind_op ; var <- selectSimpleMatchVarL pat - ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 - res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat res1_ty (cantFailMatchResult body) ; match_code <- handle_failure pat match fail_op - ; return (mkApps bind_op' [rhs', Lam var match_code]) } + ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } go _ (ApplicativeStmt args mb_join body_ty) stmts = do { @@ -915,7 +919,6 @@ dsDo stmts arg_tys = map hsLPatType pats ; rhss' <- sequence rhss - ; ops' <- mapM dsExpr (map fst args) ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty @@ -926,30 +929,30 @@ dsDo stmts , mg_origin = Generated } ; fun' <- dsLExpr fun - ; let mk_ap_call l (op,r) = mkApps op [l,r] - expr = foldl mk_ap_call fun' (zip ops' rhss') + ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] + ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') ; case mb_join of Nothing -> return expr - Just join_op -> - do { join_op' <- dsExpr join_op - ; return (App join_op' expr) } } + Just join_op -> dsSyntaxExpr join_op [expr] } go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op + , recS_bind_ty = bind_ty , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } where new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats) mfix_app bind_op noSyntaxExpr -- Tuple cannot fail + bind_ty tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case rec_tup_pats = map nlVarPat tup_ids later_pats = rec_tup_pats rets = map noLoc rec_rets - mfix_app = nlHsApp (noLoc mfix_op) mfix_arg + mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] mfix_arg = noLoc $ HsLam (MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body] , mg_arg_tys = [tup_ty], mg_res_ty = body_ty @@ -957,7 +960,7 @@ dsDo stmts mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats body = noLoc $ HsDo DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty - ret_app = nlHsApp (noLoc return_op) (mkBigLHsTupId rets) + ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] ret_stmt = noLoc $ mkLastStmt ret_app -- This LastStmt will be desugared with dsDo, -- which ignores the return_op in the LastStmt, @@ -971,10 +974,10 @@ handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr -- the monadic 'fail' rather than throwing an exception handle_failure pat match fail_op | matchCanFail match - = do { fail_op' <- dsExpr fail_op - ; dflags <- getDynFlags + = do { dflags <- getDynFlags ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) - ; extractMatchResult match (App fail_op' fail_msg) } + ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] + ; extractMatchResult match fail_expr } | otherwise = extractMatchResult match (error "It can't fail") diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot index 129185d238..cc8b7ea988 100644 --- a/compiler/deSugar/DsExpr.hs-boot +++ b/compiler/deSugar/DsExpr.hs-boot @@ -1,9 +1,10 @@ module DsExpr where -import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) +import HsSyn ( HsExpr, LHsExpr, HsLocalBinds, SyntaxExpr ) import Var ( Id ) import DsMonad ( DsM ) import CoreSyn ( CoreExpr ) dsExpr :: HsExpr Id -> DsM CoreExpr dsLExpr :: LHsExpr Id -> DsM CoreExpr +dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 6b1b342058..d08bd559b2 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -114,7 +114,7 @@ matchGuards (LetStmt (L _ binds) : stmts) ctx rhs rhs_ty = do -- so we can't desugar the bindings without the -- body expression in hand -matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do +matchGuards (BindStmt pat bind_rhs _ _ _ : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty core_rhs <- dsLExpr bind_rhs matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index f6c2b607d8..45320ccd5d 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -12,7 +12,7 @@ module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr ) import HsSyn import TcHsSyn @@ -233,11 +233,11 @@ deListComp (stmt@(TransStmt {}) : quals) list = do (inner_list_expr, pat) <- dsTransStmt stmt deBindComp pat inner_list_expr quals list -deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above +deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above core_list1 <- dsLExpr list1 deBindComp pat core_list1 quals core_list2 -deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list +deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs ; let (exps, qual_tys) = unzip exps_and_qual_tys @@ -339,7 +339,7 @@ dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do -- Anyway, we bind the newly grouped list via the generic binding function dfBindComp c_id n_id (pat, inner_list_expr) quals -dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do +dfListComp c_id n_id (BindStmt pat list1 _ _ _ : quals) = do -- evaluate the two lists core_list1 <- dsLExpr list1 @@ -476,7 +476,7 @@ dsPArrComp :: [ExprStmt Id] -> DsM CoreExpr -- Special case for parallel comprehension -dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals +dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals -- Special case for simple generators: -- @@ -487,7 +487,7 @@ dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals -- <<[:e' | p <- e, qs:]>> = -- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e) -- -dsPArrComp (BindStmt p e _ _ : qs) = do +dsPArrComp (BindStmt p e _ _ _ : qs) = do filterP <- dsDPHBuiltin filterPVar ce <- dsLExpr e let ety'ce = parrElemType ce @@ -546,7 +546,7 @@ dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do -- in -- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) -- -dePArrComp (BindStmt p e _ _ : qs) pa cea = do +dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do filterP <- dsDPHBuiltin filterPVar crossMapP <- dsDPHBuiltin crossMapPVar ce <- dsLExpr e @@ -679,8 +679,7 @@ dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr dsMcStmt (LastStmt body _ ret_op) stmts = ASSERT( null stmts ) do { body' <- dsLExpr body - ; ret_op' <- dsExpr ret_op - ; return (App ret_op' body') } + ; dsSyntaxExpr ret_op [body'] } -- [ .. | let binds, stmts ] dsMcStmt (LetStmt (L _ binds)) stmts @@ -688,9 +687,9 @@ dsMcStmt (LetStmt (L _ binds)) stmts ; dsLocalBinds binds rest } -- [ .. | a <- m, stmts ] -dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts +dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts = do { rhs' <- dsLExpr rhs - ; dsMcBindStmt pat rhs' bind_op fail_op stmts } + ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts } -- Apply `guard` to the `exp` expression -- @@ -698,11 +697,9 @@ dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts -- dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts = do { exp' <- dsLExpr exp - ; guard_exp' <- dsExpr guard_exp - ; then_exp' <- dsExpr then_exp ; rest <- dsMcStmts stmts - ; return $ mkApps then_exp' [ mkApps guard_exp' [exp'] - , rest ] } + ; guard_exp' <- dsSyntaxExpr guard_exp [exp'] + ; dsSyntaxExpr then_exp [guard_exp', rest] } -- Group statements desugar like this: -- @@ -721,6 +718,7 @@ dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs , trS_by = by, trS_using = using , trS_ret = return_op, trS_bind = bind_op + , trS_bind_arg_ty = n_tup_ty' -- n (a,b,c) , trS_fmap = fmap_op, trS_form = form }) stmts_rest = do { let (from_bndrs, to_bndrs) = unzip bndrs @@ -742,10 +740,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs -- Generate the expressions to build the grouped list -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold monads rather than single values - ; bind_op' <- dsExpr bind_op - ; let bind_ty' = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2 - n_tup_ty' = funArgTy $ funArgTy $ funResultTy bind_ty' -- n (a,b,c) - tup_n_ty' = mkBigCoreVarTupTy to_bndrs + ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs ; body <- dsMcStmts stmts_rest ; n_tup_var' <- newSysLocalDs n_tup_ty' @@ -755,7 +750,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs ; let rhs' = mkApps usingExpr' usingArgs' body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr' - ; return (mkApps bind_op' [rhs', Lam n_tup_var' body']) } + ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } -- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel -- statements, for example: @@ -768,7 +763,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs -- mzip :: forall a b. m a -> m b -> m (a,b) -- NB: we need a polymorphic mzip because we call it several times -dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest +dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) ; mzip_op' <- dsExpr mzip_op @@ -782,7 +777,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest mkBoxedTupleTy [t1,t2])) exps_w_tys - ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest } + ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest } where ds_inner (ParStmtBlock stmts bndrs return_op) = do { exp <- dsInnerMonadComp stmts bndrs return_op @@ -806,28 +801,26 @@ dsMcBindStmt :: LPat Id -> CoreExpr -- ^ the desugared rhs of the bind statement -> SyntaxExpr Id -> SyntaxExpr Id + -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T -> [ExprLStmt Id] -> DsM CoreExpr -dsMcBindStmt pat rhs' bind_op fail_op stmts +dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts - ; bind_op' <- dsExpr bind_op ; var <- selectSimpleMatchVarL pat - ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 - res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat res1_ty (cantFailMatchResult body) ; match_code <- handle_failure pat match fail_op - ; return (mkApps bind_op' [rhs', Lam var match_code]) } + ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } where -- In a monad comprehension expression, pattern-match failure just calls -- the monadic `fail` rather than throwing an exception handle_failure pat match fail_op | matchCanFail match - = do { fail_op' <- dsExpr fail_op - ; dflags <- getDynFlags + = do { dflags <- getDynFlags ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) - ; extractMatchResult match (App fail_op' fail_msg) } + ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] + ; extractMatchResult match fail_expr } | otherwise = extractMatchResult match (error "It can't fail") @@ -842,8 +835,8 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts -- [ (a,b,c) | quals ] dsInnerMonadComp :: [ExprLStmt Id] - -> [Id] -- Return a tuple of these variables - -> HsExpr Id -- The monomorphic "return" operator + -> [Id] -- Return a tuple of these variables + -> SyntaxExpr Id -- The monomorphic "return" operator -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)]) @@ -860,7 +853,7 @@ dsInnerMonadComp stmts bndrs ret_op -- , fmap (selN2 :: (t1, t2) -> t2) ys ) mkMcUnzipM :: TransForm - -> SyntaxExpr TcId -- fmap + -> HsExpr TcId -- fmap -> Id -- Of type n (a,b,c) -> [Type] -- [a,b,c] -> DsM CoreExpr -- Of type (n a, n b, n c) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index ca427a4f3e..7a8de3cf0a 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1279,7 +1279,7 @@ repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repLSts stmts = repSts (map unLoc stmts) repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) -repSts (BindStmt p e _ _ : ss) = +repSts (BindStmt p e _ _ _ : ss) = do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { @@ -1297,7 +1297,7 @@ repSts (BodyStmt e _ _ _ : ss) = ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } -repSts (ParStmt stmt_blocks _ _ : ss) = +repSts (ParStmt stmt_blocks _ _ _ : ss) = do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 ss1 = concat ss_s @@ -1463,7 +1463,7 @@ repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } repP (ParPat p) = repLP p repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } -repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p} +repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p} repP (TuplePat ps boxed _) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } @@ -1483,9 +1483,9 @@ repP (ConPatIn dc details) ; MkC p <- repLP (hsRecFieldArg fld) ; rep2 fieldPatName [v,p] } -repP (NPat (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a } repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } -repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) +repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p) repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) -- The problem is to do with scoped type variables. -- To implement them, we have to implement the scoping rules diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index a90c8e6af9..b96b3eb59b 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -239,11 +239,11 @@ seqVar var body = Case (Var var) var (exprType body) mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) --- (mkViewMatchResult var' viewExpr var mr) makes the expression --- let var' = viewExpr var in mr -mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult -mkViewMatchResult var' viewExpr var = - adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs (text "mkView" <+> ppr var') viewExpr (Var var)))) +-- (mkViewMatchResult var' viewExpr mr) makes the expression +-- let var' = viewExpr in mr +mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult +mkViewMatchResult var' viewExpr = + adjustMatchResult (mkCoreLet (NonRec var' viewExpr)) mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult mkEvalMatchResult var ty diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index af07e5b9e4..0128488d62 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -12,7 +12,7 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat #include "HsVersions.h" -import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr) +import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr) import DynFlags import HsSyn @@ -269,7 +269,9 @@ matchView (var:vars) ty (eqns@(eqn1:_)) map (decomposeFirstPat getViewPat) eqns -- compile the view expressions ; viewExpr' <- dsLExpr viewExpr - ; return (mkViewMatchResult var' viewExpr' var match_result) } + ; return (mkViewMatchResult var' + (mkCoreAppDs (text "matchView") viewExpr' (Var var)) + match_result) } matchView _ _ _ = panic "matchView" matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult @@ -280,8 +282,8 @@ matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern - ; e' <- dsExpr e - ; return (mkViewMatchResult var' e' var match_result) } + ; e' <- dsSyntaxExpr e [Var var] + ; return (mkViewMatchResult var' e' match_result) } matchOverloadedList _ _ _ = panic "matchOverloadedList" -- decompose the first pattern and leave the rest alone @@ -457,8 +459,8 @@ tidy1 _ (LitPat lit) = return (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (NPat (L _ lit) mb_neg eq) - = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq) +tidy1 _ (NPat (L _ lit) mb_neg eq ty) + = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty) -- Everything else goes through unchanged... @@ -939,7 +941,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- to ignore them? exp (OpApp l o _ ri) (OpApp l' o' _ ri') = lexp l l' && lexp o o' && lexp ri ri' - exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n' + exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n' exp (SectionL e1 e2) (SectionL e1' e2') = lexp e1 e1' && lexp e2 e2' exp (SectionR e1 e2) (SectionR e1' e2') = @@ -956,6 +958,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp _ _ = False --------- + syn_exp :: SyntaxExpr Id -> SyntaxExpr Id -> Bool + syn_exp (SyntaxExpr { syn_expr = expr1 + , syn_arg_wraps = arg_wraps1 + , syn_res_wrap = res_wrap1 }) + (SyntaxExpr { syn_expr = expr2 + , syn_arg_wraps = arg_wraps2 + , syn_res_wrap = res_wrap2 }) + = exp expr1 expr2 && + and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) && + wrap res_wrap1 res_wrap2 + + --------- tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2 tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 tup_arg _ _ = False @@ -998,8 +1012,8 @@ patGroup _ (ConPatOut { pat_con = L _ con | PatSynCon psyn <- con = PgSyn psyn tys patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat (L _ olit) mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) -patGroup _ (NPlusKPat _ (L _ olit) _ _) = PgNpK (hsOverLitKey olit False) +patGroup _ (NPat (L _ olit) mb_neg _ _) = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup _ (NPlusKPat _ (L _ olit) _ _ _ _)= PgNpK (hsOverLitKey olit False) patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 2fab8750af..b1c82ccb90 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -17,7 +17,7 @@ module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey #include "HsVersions.h" import {-# SOURCE #-} Match ( match ) -import {-# SOURCE #-} DsExpr ( dsExpr ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr ) import DsMonad import DsUtils @@ -105,7 +105,7 @@ dsOverLit lit = do { dflags <- getDynFlags ; dsOverLit' dflags lit } dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr --- Post-typechecker, the SyntaxExpr field of an OverLit contains +-- Post-typechecker, the HsExpr field of an OverLit contains -- (an expression for) the literal value itself dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable , ol_witness = witness, ol_type = ty }) @@ -276,9 +276,9 @@ tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat -- both by Match and by Check, but they tidy LitPats -- slightly differently; and we must desugar -- literals consistently (see Trac #5117) - -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id + -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Type -> Pat Id -tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ +tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty -- False: Take short cuts only if the literal is not using rebindable syntax -- -- Once that is settled, look for cases where the type of the @@ -287,20 +287,25 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ -- NB: Watch out for weird cases like Trac #3382 -- f :: Int -> Int -- f "blah" = 4 - -- which might be ok if we hvae 'instance IsString Int' + -- which might be ok if we have 'instance IsString Int' -- - - | isIntTy ty, Just int_lit <- mb_int_lit + | not type_change, isIntTy ty, Just int_lit <- mb_int_lit = mk_con_pat intDataCon (HsIntPrim "" int_lit) - | isWordTy ty, Just int_lit <- mb_int_lit + | not type_change, isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim "" int_lit) - | isStringTy ty, Just str_lit <- mb_str_lit + | not type_change, isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString "" str_lit) -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 -- If we do convert to the constructor form, we'll generate a case -- expression on a Float# or Double# and that's not allowed in Core; see -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules where + -- Sometimes (like in test case + -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include + -- type-changing wrappers (for example, from Id Int to Int, for the identity + -- type family Id). In these cases, we can't do the short-cut. + type_change = not (outer_ty `eqType` ty) + mk_con_pat :: DataCon -> HsLit -> Pat Id mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] []) @@ -315,8 +320,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ (Nothing, HsIsString _ s) -> Just s _ -> Nothing -tidyNPat _ over_lit mb_neg eq - = NPat (noLoc over_lit) mb_neg eq +tidyNPat _ over_lit mb_neg eq outer_ty + = NPat (noLoc over_lit) mb_neg eq outer_ty {- ************************************************************************ @@ -409,14 +414,12 @@ litValKey (HsIsString _ s) neg = ASSERT( not neg) MachStr matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat (L _ lit) mb_neg eq_chk = firstPat eqn1 + = do { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of - Nothing -> return lit_expr - Just neg -> do { neg_expr <- dsExpr neg - ; return (App neg_expr lit_expr) } - ; eq_expr <- dsExpr eq_chk - ; let pred_expr = mkApps eq_expr [Var var, neg_lit] + Nothing -> return lit_expr + Just neg -> dsSyntaxExpr neg [lit_expr] + ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit] ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) ; return (mkGuardedMatchResult pred_expr match_result) } matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) @@ -442,20 +445,19 @@ We generate: matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat (L _ n1) (L _ lit) ge minus = firstPat eqn1 - ; ge_expr <- dsExpr ge - ; minus_expr <- dsExpr minus - ; lit_expr <- dsOverLit lit - ; let pred_expr = mkApps ge_expr [Var var, lit_expr] - minusk_expr = mkApps minus_expr [Var var, lit_expr] - (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) + = do { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1 + ; lit1_expr <- dsOverLit lit1 + ; lit2_expr <- dsOverLit lit2 + ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] + ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr] + ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) ; match_result <- match vars ty eqns' ; return (mkGuardedMatchResult pred_expr $ mkCoLetMatchResult (NonRec n1 minusk_expr) $ adjustMatchResult (foldr1 (.) wraps) $ match_result) } where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats }) + shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats }) = (wrapBind n n1, eqn { eqn_pats = pats }) -- The wrapBind is a no-op for the first equation shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index 3c5fe280fa..f1f59c1130 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -229,7 +229,7 @@ hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit) hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit) hsExprToPmExpr e@(NegApp _ neg_e) - | PmExprLit (PmOLit False ol) <- hsExprToPmExpr neg_e + | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e = PmExprLit (PmOLit True ol) | otherwise = PmExprOther e hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e @@ -270,6 +270,9 @@ hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle +synExprToPmExpr :: SyntaxExpr Id -> PmExpr +synExprToPmExpr = hsExprToPmExpr . syn_expr -- ignore the wrappers + {- %************************************************************************ %* * diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index e6d703b743..2dca546291 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -1275,10 +1275,6 @@ quantifyType ty = ( filter isTyVar $ where (_tvs, rho) = tcSplitForAllTys ty -unlessM :: Monad m => m Bool -> m () -> m () -unlessM condM acc = condM >>= \c -> unless c acc - - -- Strict application of f at index i appArr :: Ix i => (e -> a) -> Array i e -> Int -> a appArr f a@(Array _ _ _ ptrs#) i@(I# i#) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 5b0b1a4125..213c4f5513 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -908,7 +908,7 @@ cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds ; returnL $ LetStmt (noLoc ds') } -cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr } +cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType } where cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 62b6a680e9..cfc373eeed 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -27,6 +27,7 @@ import HsBinds import TcEvidence import CoreSyn import Var +import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) import Name import BasicTypes import ConLike @@ -78,15 +79,54 @@ noPostTcTable = [] -- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for -- @(>>=)@, and then instantiated by the type checker with its type args -- etc +-- +-- This should desugar to +-- +-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) +-- > (syn_arg_wraps[1] arg1) ... +-- +-- where the actual arguments come from elsewhere in the AST. +-- This could be defined using @PostRn@ and @PostTc@ and such, but it's +-- harder to get it all to work out that way. ('noSyntaxExpr' is hard to +-- write, for example.) +data SyntaxExpr id = SyntaxExpr { syn_expr :: HsExpr id + , syn_arg_wraps :: [HsWrapper] + , syn_res_wrap :: HsWrapper } + deriving (Typeable) +deriving instance (DataId id) => Data (SyntaxExpr id) -type SyntaxExpr id = HsExpr id +-- | This is used for rebindable-syntax pieces that are too polymorphic +-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) +noExpr :: HsExpr id +noExpr = HsLit (HsString "" (fsLit "noExpr")) noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after, -- (if the syntax slot makes no sense) -noSyntaxExpr = HsLit (HsString "" (fsLit "noSyntaxExpr")) - - -type CmdSyntaxTable id = [(Name, SyntaxExpr id)] +noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString "" (fsLit "noSyntaxExpr")) + , syn_arg_wraps = [] + , syn_res_wrap = WpHole } + +-- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the +-- renamer), missing its HsWrappers. +mkRnSyntaxExpr :: Name -> SyntaxExpr Name +mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name + , syn_arg_wraps = [] + , syn_res_wrap = WpHole } + -- don't care about filling in syn_arg_wraps because we're clearly + -- not past the typechecker + +instance OutputableBndr id => Outputable (SyntaxExpr id) where + ppr (SyntaxExpr { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = sdocWithDynFlags $ \ dflags -> + getPprStyle $ \s -> + if debugStyle s || gopt Opt_PrintExplicitCoercions dflags + then ppr expr <> braces (pprWithCommas (pprHsWrapper (text "<>")) arg_wraps) + <> braces (pprHsWrapper (text "<>") res_wrap) + else ppr expr + +type CmdSyntaxTable id = [(Name, HsExpr id)] -- See Note [CmdSyntaxTable] {- @@ -1368,6 +1408,9 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- The fail operator is noSyntaxExpr -- if the pattern match can't fail + (PostTc idR Type) -- result type of the function passed to bind; + -- that is, S in (>>=) :: Q -> (R -> S) -> T + -- | 'ApplicativeStmt' represents an applicative expression built with -- <$> and <*>. It is generated by the renamer, and is desugared into the -- appropriate applicative expression by the desugarer, but it is intended @@ -1396,9 +1439,10 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- ParStmts only occur in a list/monad comprehension | ParStmt [ParStmtBlock idL idR] - (SyntaxExpr idR) -- Polymorphic `mzip` for monad comprehensions + (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions (SyntaxExpr idR) -- The `>>=` operator -- See notes [Monad Comprehensions] + (PostTc idR Type) -- S in (>>=) :: Q -> (R -> S) -> T -- After renaming, the ids are the binders -- bound by the stmts and used after themp @@ -1416,8 +1460,11 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for -- the inner monad comprehensions trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator - trS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring + trS_bind_arg_ty :: PostTc idR Type, -- R in (>>=) :: Q -> (R -> S) -> T + trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring -- Only for 'group' forms + -- Just a simple HsExpr, because it's + -- too polymorphic for tcSyntaxOp } -- See Note [Monad Comprehensions] -- Recursive statement (see Note [How RecStmt works] below) @@ -1442,6 +1489,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) , recS_bind_fn :: SyntaxExpr idR -- The bind function , recS_ret_fn :: SyntaxExpr idR -- The return function , recS_mfix_fn :: SyntaxExpr idR -- The mfix function + , recS_bind_ty :: PostTc idR Type -- S in (>>=) :: Q -> (R -> S) -> T -- These fields are only valid after typechecking , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) @@ -1482,7 +1530,7 @@ data ApplicativeArg idL idR (LHsExpr idL) | ApplicativeArgMany -- do { stmts; return vars } [ExprLStmt idL] -- stmts - (SyntaxExpr idL) -- return (v1,..,vn), or just (v1,..,vn) + (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) (LPat idL) -- (v1,...,vn) deriving( Typeable ) deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR) @@ -1638,10 +1686,10 @@ pprStmt (LastStmt expr ret_stripped _) = ifPprDebug (text "[last]") <+> (if ret_stripped then text "return" else empty) <+> ppr expr -pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, larrow, ppr expr] +pprStmt (BindStmt pat expr _ _ _) = hsep [ppr pat, larrow, ppr expr] pprStmt (LetStmt (L _ binds)) = hsep [text "let", pprBinds binds] pprStmt (BodyStmt expr _ _ _) = ppr expr -pprStmt (ParStmt stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) +pprStmt (ParStmt stmtss _ _ _) = sep (punctuate (text " | ") (map ppr stmtss)) pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) @@ -1672,7 +1720,8 @@ pprStmt (ApplicativeStmt args mb_join _) flattenStmt stmt = [ppr stmt] flattenArg (_, ApplicativeArgOne pat expr) = - [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt idL)] + [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") + :: ExprStmt idL)] flattenArg (_, ApplicativeArgMany stmts _ _) = concatMap flattenStmt stmts @@ -1685,7 +1734,8 @@ pprStmt (ApplicativeStmt args mb_join _) else text "join" <+> parens ap_expr pp_arg (_, ApplicativeArgOne pat expr) = - ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt idL) + ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") + :: ExprStmt idL) pp_arg (_, ApplicativeArgMany stmts return pat) = ppr pat <+> text "<-" <+> diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index bb5142f6ac..7eeddd481d 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -18,28 +18,31 @@ type role HsCmd nominal type role MatchGroup nominal representational type role GRHSs nominal representational type role HsSplice nominal +type role SyntaxExpr nominal data HsExpr (i :: *) data HsCmd (i :: *) data HsSplice (i :: *) data MatchGroup (a :: *) (body :: *) data GRHSs (a :: *) (body :: *) +data SyntaxExpr (i :: *) instance Typeable HsSplice instance Typeable HsExpr instance Typeable MatchGroup instance Typeable GRHSs +instance Typeable SyntaxExpr instance (DataId id) => Data (HsSplice id) instance (DataId id) => Data (HsExpr id) instance (DataId id) => Data (HsCmd id) instance (Data body,DataId id) => Data (MatchGroup id body) instance (Data body,DataId id) => Data (GRHSs id body) +instance (DataId id) => Data (SyntaxExpr id) instance OutputableBndr id => Outputable (HsExpr id) instance OutputableBndr id => Outputable (HsCmd id) type LHsExpr a = Located (HsExpr a) -type SyntaxExpr a = HsExpr a pprLExpr :: (OutputableBndr i) => LHsExpr i -> SDoc diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index b929f86761..4686077d27 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -18,7 +18,7 @@ module HsLit where #include "HsVersions.h" -import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr ) +import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) import BasicTypes ( FractionalLit(..),SourceText ) import Type ( Type ) import Outputable @@ -79,7 +79,7 @@ data HsOverLit id -- An overloaded literal = OverLit { ol_val :: OverLitVal, ol_rebindable :: PostRn id Bool, -- Note [ol_rebindable] - ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses] + ol_witness :: HsExpr id, -- Note [Overloaded literal witnesses] ol_type :: PostTc id Type } deriving (Typeable) deriving instance (DataId id) => Data (HsOverLit id) @@ -111,7 +111,7 @@ Equivalently it's True if Note [Overloaded literal witnesses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -*Before* type checking, the SyntaxExpr in an HsOverLit is the +*Before* type checking, the HsExpr in an HsOverLit is the name of the coercion function, 'fromInteger' or 'fromRational'. *After* type checking, it is a witness for the literal, such as (fromInteger 3) or lit_78 diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 9bb91d21f8..e1ccd63203 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -190,14 +190,22 @@ data Pat id (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative -- patterns, Nothing otherwise (SyntaxExpr id) -- Equality checker, of type t->t->Bool + (PostTc id Type) -- Overall type of pattern. Might be + -- different than the literal's type + -- if (==) or negate changes the type -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ -- For details on above see note [Api annotations] in ApiAnnotation | NPlusKPat (Located id) -- n+k pattern (Located (HsOverLit id)) -- It'll always be an HsIntegral - (SyntaxExpr id) -- (>=) function, of type t->t->Bool + (HsOverLit id) -- See Note [NPlusK patterns] in TcPat + -- NB: This could be (PostTc ...), but that induced a + -- a new hs-boot file. Not worth it. + + (SyntaxExpr id) -- (>=) function, of type t1->t2->Bool (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) + (PostTc id Type) -- Type of overall pattern ------------ Pattern type signatures --------------- -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' @@ -391,9 +399,9 @@ pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprPa pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat pat) = parens (ppr pat) pprPat (LitPat s) = ppr s -pprPat (NPat l Nothing _) = ppr l -pprPat (NPat l (Just _) _) = char '-' <> ppr l -pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] +pprPat (NPat l Nothing _ _) = ppr l +pprPat (NPat l (Just _) _ _) = char '-' <> ppr l +pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k] pprPat (SplicePat splice) = pprSplice splice pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 43f3de6be3..abd7a4bdf3 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -16,6 +16,7 @@ which deal with the instantiated versions are located elsewhere: {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module HsUtils( -- Terms @@ -27,7 +28,8 @@ module HsUtils( mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, isLHsTypeExpr_maybe, isLHsTypeExpr, - nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, + nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, + nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, toLHsSigWcType, @@ -58,7 +60,8 @@ module HsUtils( getLHsInstDeclClass_maybe, -- Stmts - mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt, + mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt, + mkLastStmt, emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, @@ -99,6 +102,7 @@ import RdrName import Var import TyCoRep import Type ( filterOutInvisibleTypes ) +import TysWiredIn ( unitTy ) import TcType import DataCon import Name @@ -223,13 +227,16 @@ mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName -> HsExpr RdrName -mkNPat :: Located (HsOverLit id) -> Maybe (SyntaxExpr id) -> Pat id -mkNPlusKPat :: Located id -> Located (HsOverLit id) -> Pat id +mkNPat :: Located (HsOverLit RdrName) -> Maybe (SyntaxExpr RdrName) -> Pat RdrName +mkNPlusKPat :: Located RdrName -> Located (HsOverLit RdrName) -> Pat RdrName mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) mkBodyStmt :: Located (bodyR RdrName) -> StmtLR idL RdrName (Located (bodyR RdrName)) -mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) +mkBindStmt :: (PostTc idR Type ~ PlaceHolder) + => LPat idL -> Located (bodyR idR) + -> StmtLR idL idR (Located (bodyR idR)) +mkTcBindStmt :: LPat Id -> Located (bodyR Id) -> StmtLR Id Id (Located (bodyR Id)) emptyRecStmt :: StmtLR idL RdrName bodyR emptyRecStmtName :: StmtLR Name Name bodyR @@ -237,9 +244,9 @@ emptyRecStmtId :: StmtLR Id Id bodyR mkRecStmt :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR -mkHsIntegral src i = OverLit (HsIntegral src i) noRebindableInfo noSyntaxExpr -mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr -mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noSyntaxExpr +mkHsIntegral src i = OverLit (HsIntegral src i) noRebindableInfo noExpr +mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noExpr +mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noExpr noRebindableInfo :: PlaceHolder noRebindableInfo = PlaceHolder -- Just another placeholder; @@ -252,24 +259,29 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b -mkNPat lit neg = NPat lit neg noSyntaxExpr -mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr +mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType +mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType -mkTransformStmt :: [ExprLStmt idL] -> LHsExpr idR +mkTransformStmt :: (PostTc idR Type ~ PlaceHolder) + => [ExprLStmt idL] -> LHsExpr idR -> StmtLR idL idR (LHsExpr idL) -mkTransformByStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR +mkTransformByStmt :: (PostTc idR Type ~ PlaceHolder) + => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR (LHsExpr idL) -mkGroupUsingStmt :: [ExprLStmt idL] -> LHsExpr idR +mkGroupUsingStmt :: (PostTc idR Type ~ PlaceHolder) + => [ExprLStmt idL] -> LHsExpr idR -> StmtLR idL idR (LHsExpr idL) -mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR +mkGroupByUsingStmt :: (PostTc idR Type ~ PlaceHolder) + => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR (LHsExpr idL) -emptyTransStmt :: StmtLR idL idR (LHsExpr idR) +emptyTransStmt :: (PostTc idR Type ~ PlaceHolder) => StmtLR idL idR (LHsExpr idR) emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] - , trS_by = Nothing, trS_using = noLoc noSyntaxExpr + , trS_by = Nothing, trS_using = noLoc noExpr , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr - , trS_fmap = noSyntaxExpr } + , trS_bind_arg_ty = PlaceHolder + , trS_fmap = noExpr } mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } @@ -277,8 +289,9 @@ mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = s mkLastStmt body = LastStmt body False noSyntaxExpr mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType -mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr - +mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder +mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy + -- don't use placeHolderTypeTc above, because that panics during zonking emptyRecStmt' :: forall idL idR body. PostTc idR Type -> StmtLR idL idR body @@ -288,12 +301,13 @@ emptyRecStmt' tyVal = , recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr , recS_mfix_fn = noSyntaxExpr - , recS_bind_fn = noSyntaxExpr, recS_later_rets = [] + , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal + , recS_later_rets = [] , recS_rec_rets = [], recS_ret_ty = tyVal } emptyRecStmt = emptyRecStmt' placeHolderType emptyRecStmtName = emptyRecStmt' placeHolderType -emptyRecStmtId = emptyRecStmt' placeHolderTypeTc +emptyRecStmtId = emptyRecStmt' unitTy -- a panic might trigger during zonking mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ------------------------------- @@ -366,6 +380,18 @@ nlLitPat l = noLoc (LitPat l) nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id nlHsApp f x = noLoc (HsApp f x) +nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id +nlHsSyntaxApps (SyntaxExpr { syn_expr = fun + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) args + | [] <- arg_wraps -- in the noSyntaxExpr case + = ASSERT( isIdHsWrapper res_wrap ) + foldl nlHsApp (noLoc fun) args + + | otherwise + = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" + mkLHsWrap arg_wraps args)) + nlHsIntLit :: Integer -> LHsExpr id nlHsIntLit n = noLoc (HsLit (HsInt (show n) n)) @@ -797,11 +823,11 @@ collectLStmtBinders = collectStmtBinders . unLoc collectStmtBinders :: StmtLR idL idR body -> [idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat +collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders +collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders $ [s | ParStmtBlock ss _ _ <- xs, s <- ss] collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss @@ -836,8 +862,8 @@ collect_lpat (L _ pat) bndrs go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) -- See Note [Dictionary binders in ConPatOut] go (LitPat _) = bndrs - go (NPat _ _ _) = bndrs - go (NPlusKPat (L _ n) _ _ _) = n : bndrs + go (NPat {}) = bndrs + go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs go (SigPatIn pat _) = collect_lpat pat bndrs go (SigPatOut pat _) = collect_lpat pat bndrs @@ -1054,14 +1080,14 @@ lStmtsImplicits = hs_lstmts hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet hs_stmt :: StmtLR Name idR (Located (body idR)) -> NameSet - hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat + hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args) where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts hs_stmt (LetStmt binds) = hs_local_binds (unLoc binds) hs_stmt (BodyStmt {}) = emptyNameSet hs_stmt (LastStmt {}) = emptyNameSet - hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] + hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 87736ac3d0..b4e109f045 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -3,7 +3,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} module PlaceHolder where @@ -14,7 +13,7 @@ import NameSet import RdrName import Var import Coercion -import {-# SOURCE #-} ConLike (ConLike) +import ConLike (ConLike) import FieldLabel import SrcLoc (Located) import TcEvidence ( HsWrapper ) @@ -31,18 +30,21 @@ import BasicTypes (Fixity) %************************************************************************ -} +-- NB: These are intentionally open, allowing API consumers (like Haddock) +-- to declare new instances + -- | used as place holder in PostTc and PostRn values data PlaceHolder = PlaceHolder deriving (Data,Typeable) -- | Types that are not defined until after type checking -type family PostTc it ty :: * -- Note [Pass sensitive types] +type family PostTc id ty -- Note [Pass sensitive types] type instance PostTc Id ty = ty type instance PostTc Name ty = PlaceHolder type instance PostTc RdrName ty = PlaceHolder -- | Types that are not defined until after renaming -type family PostRn id ty :: * -- Note [Pass sensitive types] +type family PostRn id ty -- Note [Pass sensitive types] type instance PostRn Id ty = ty type instance PostRn Name ty = ty type instance PostRn RdrName ty = PlaceHolder @@ -86,10 +88,6 @@ pass-specific data types, implemented as a pair of open type families, one for PostTc and one for PostRn. These are then explicitly populated with a PlaceHolder value when they do not yet have meaning. -Since the required bootstrap compiler at this stage does not have -closed type families, an open type family had to be used, which -unfortunately forces the requirement for UndecidableInstances. - In terms of actual usage, we have the following PostTc id Kind diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 477ef88f12..0c17cdea47 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -2446,7 +2446,7 @@ flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr | qs <- qss] - noSyntaxExpr noSyntaxExpr] + noExpr noSyntaxExpr placeHolderType] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 78ab50df9f..372874ab95 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -1162,8 +1162,8 @@ checkCmdLStmt = locMap checkCmdStmt checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName) checkCmdStmt _ (LastStmt e s r) = checkCommand e >>= (\c -> return $ LastStmt c s r) -checkCmdStmt _ (BindStmt pat e b f) = - checkCommand e >>= (\c -> return $ BindStmt pat c b f) +checkCmdStmt _ (BindStmt pat e b f t) = + checkCommand e >>= (\c -> return $ BindStmt pat c b f t) checkCmdStmt _ (BodyStmt e t g ty) = checkCommand e >>= (\c -> return $ BodyStmt c t g ty) checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index d1ec1de6e6..868712b829 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1562,21 +1562,23 @@ lookupIfThenElse ; if not rebindable_on then return (Nothing, emptyFVs) else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) - ; return (Just (HsVar (noLoc ite)), unitFV ite) } } + ; return ( Just (mkRnSyntaxExpr ite) + , unitFV ite ) } } lookupSyntaxName :: Name -- The standard name -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then - return (HsVar (noLoc std_name), emptyFVs) + return (mkRnSyntaxExpr std_name, emptyFVs) else -- Get the similarly named thing from the local environment do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) - ; return (HsVar (noLoc usr_name), unitFV usr_name) } } + ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } } lookupSyntaxNames :: [Name] -- Standard names -> RnM ([HsExpr Name], FreeVars) -- See comments with HsExpr.ReboundNames + -- this works with CmdTop, which wants HsExprs, not SyntaxExprs lookupSyntaxNames std_names = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 66703dfe0e..e88f1e0831 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -12,6 +12,7 @@ free variables. {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} module RnExpr ( rnLExpr, rnExpr, rnStmts @@ -589,7 +590,7 @@ methodNamesLStmt = methodNamesStmt . unLoc methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd -methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BindStmt _ cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt {}) = emptyFVs @@ -776,7 +777,7 @@ rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside then_op guard_op placeHolderType), fv_expr)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } -rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside +rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside = do { (body', fv_expr) <- rnBody body -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName @@ -788,7 +789,8 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (( [(L loc (BindStmt pat' body' bind_op fail_op), fv_expr)] + ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder) + , fv_expr )] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} -- fv_expr shouldn't really be filtered by the rnPatsAndThen @@ -826,12 +828,12 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing) , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } -rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside - = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName +rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside + = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName ; (return_op, fvs3) <- lookupStmtName ctxt returnMName ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside - ; return ( ([(L loc (ParStmt segs' mzip_op bind_op), fvs4)], thing) + ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing) , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form @@ -855,8 +857,8 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for ; (return_op, fvs3) <- lookupStmtName ctxt returnMName ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName ; (fmap_op, fvs5) <- case form of - ThenForm -> return (noSyntaxExpr, emptyFVs) - _ -> lookupStmtName ctxt fmapName + ThenForm -> return (noExpr, emptyFVs) + _ -> lookupStmtNamePoly ctxt fmapName ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4 `plusFV` fvs5 @@ -867,6 +869,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map , trS_by = by', trS_using = using', trS_form = form , trS_ret = return_op, trS_bind = bind_op + , trS_bind_arg_ty = PlaceHolder , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } rnStmt _ _ (L _ ApplicativeStmt{}) _ = @@ -906,26 +909,44 @@ rnParallelStmts ctxt return_op segs thing_inside dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" <+> quotes (ppr (head vs))) -lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) --- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable --- Neither is ArrowExpr, which has its own desugarer in DsArrows +lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars) +-- Like lookupSyntaxName, but respects contexts lookupStmtName ctxt n - = case ctxt of - ListComp -> not_rebindable - PArrComp -> not_rebindable - ArrowExpr -> not_rebindable - PatGuard {} -> not_rebindable - - DoExpr -> rebindable - MDoExpr -> rebindable - MonadComp -> rebindable - GhciStmtCtxt -> rebindable -- I suppose? - - ParStmtCtxt c -> lookupStmtName c n -- Look inside to - TransStmtCtxt c -> lookupStmtName c n -- the parent context + | rebindableContext ctxt + = lookupSyntaxName n + | otherwise + = return (mkRnSyntaxExpr n, emptyFVs) + +lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) +lookupStmtNamePoly ctxt name + | rebindableContext ctxt + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if rebindable_on + then do { fm <- lookupOccRn (nameRdrName name) + ; return (HsVar (noLoc fm), unitFV fm) } + else not_rebindable } + | otherwise + = not_rebindable where - rebindable = lookupSyntaxName n - not_rebindable = return (HsVar (noLoc n), emptyFVs) + not_rebindable = return (HsVar (noLoc name), emptyFVs) + +-- | Is this a context where we respect RebindableSyntax? +-- but ListComp/PArrComp are never rebindable +-- Neither is ArrowExpr, which has its own desugarer in DsArrows +rebindableContext :: HsStmtContext Name -> Bool +rebindableContext ctxt = case ctxt of + ListComp -> False + PArrComp -> False + ArrowExpr -> False + PatGuard {} -> False + + DoExpr -> True + MDoExpr -> True + MonadComp -> True + GhciStmtCtxt -> True -- I suppose? + + ParStmtCtxt c -> rebindableContext c -- Look inside to + TransStmtCtxt c -> rebindableContext c -- the parent context {- Note [Renaming parallel Stmts] @@ -1018,11 +1039,11 @@ rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) rn_rec_stmt_lhs _ (L loc (LastStmt body noret a)) = return [(L loc (LastStmt body noret a), emptyFVs)] -rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b)) +rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t)) = do -- should the ctxt be MDo instead? (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat - return [(L loc (BindStmt pat' body a b), + return [(L loc (BindStmt pat' body a b t), fv_pat)] rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _)))) @@ -1086,7 +1107,7 @@ rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _) ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] } -rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat) +rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat) = do { (body', fv_expr) <- rnBody body ; (bind_op, fvs1) <- lookupSyntaxName bindMName @@ -1098,7 +1119,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat) ; let bndrs = mkNameSet (collectPatBinders pat') fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt pat' body' bind_op fail_op))] } + L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] } rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _) = failWith (badIpBinds (text "an mdo expression") binds) @@ -1438,7 +1459,7 @@ ado _ctxt [] tail _ = return (tail, emptyNameSet) -- In the spec, but we do it here rather than in the desugarer, -- because we need the typechecker to typecheck the <$> form rather than -- the bind form, which would give rise to a Monad constraint. -ado ctxt [(L _ (BindStmt pat rhs _ _),_)] tail _ +ado ctxt [(L _ (BindStmt pat rhs _ _ _),_)] tail _ | isIrrefutableHsPat pat, (False,tail') <- needJoin tail -- WARNING: isIrrefutableHsPat on (HsPat Name) doesn't have enough info -- to know which types have only one constructor. So only @@ -1489,7 +1510,7 @@ adoSegmentArg -> FreeVars -> [(LStmt Name (LHsExpr Name), FreeVars)] -> RnM (ApplicativeArg Name Name, FreeVars) -adoSegmentArg _ _ [(L _ (BindStmt pat exp _ _),_)] = +adoSegmentArg _ _ [(L _ (BindStmt pat exp _ _ _),_)] = return (ApplicativeArgOne pat exp, emptyFVs) adoSegmentArg ctxt tail_fvs stmts = do { let pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) @@ -1498,12 +1519,12 @@ adoSegmentArg ctxt tail_fvs stmts = pat = mkBigLHsVarPatTup pvars tup = mkBigLHsVarTup pvars ; (stmts',fvs2) <- adoSegment ctxt stmts [] pvarset - ; (mb_ret, fvs1) <- case () of - _ | L _ ApplicativeStmt{} <- last stmts' -> - return (unLoc tup, emptyNameSet) - | otherwise -> do - (ret,fvs) <- lookupStmtName ctxt returnMName - return (HsApp (noLoc ret) tup, fvs) + ; (mb_ret, fvs1) <- + if | L _ ApplicativeStmt{} <- last stmts' -> + return (unLoc tup, emptyNameSet) + | otherwise -> do + (ret,fvs) <- lookupStmtNamePoly ctxt returnMName + return (HsApp (noLoc ret) tup, fvs) ; return ( ApplicativeArgMany stmts' mb_ret pat , fvs1 `plusFV` fvs2) } @@ -1573,9 +1594,9 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts where -- If we encounter a BindStmt that doesn't depend on a previous BindStmt -- in this group, then add it to the group. - go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op), fvs) : rest) + go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest) | isEmptyNameSet (bndrs `intersectNameSet` fvs) - = go lets ((L loc (BindStmt pat body bind_op fail_op), fvs) : indep) + = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep) bndrs' rest where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) -- If we encounter a LetStmt that doesn't depend on a BindStmt in this diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index bb82e8f639..eab3090b06 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -385,22 +385,22 @@ rnPatAndThen mk (LitPat lit) where normal_lit = do { liftCps (rnLit lit); return (LitPat lit) } -rnPatAndThen _ (NPat (L l lit) mb_neg _eq) +rnPatAndThen _ (NPat (L l lit) mb_neg _eq _) = do { lit' <- liftCpsFV $ rnOverLit lit ; mb_neg' <- liftCpsFV $ case mb_neg of Nothing -> return (Nothing, emptyFVs) Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName ; return (Just neg, fvs) } ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat (L l lit') mb_neg' eq') } + ; return (NPat (L l lit') mb_neg' eq' placeHolderType) } -rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _) +rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _) = do { new_name <- newPatName mk rdr ; lit' <- liftCpsFV $ rnOverLit lit ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) - (L l lit') ge minus) } + (L l lit') lit' ge minus placeHolderType) } -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat rdr pat) @@ -784,7 +784,8 @@ rnOverLit origLit | otherwise = origLit } ; let std_name = hsOverLitName val - ; (from_thing_name, fvs) <- lookupSyntaxName std_name + ; (SyntaxExpr { syn_expr = from_thing_name }, fvs) + <- lookupSyntaxName std_name ; let rebindable = case from_thing_name of HsVar (L _ v) -> v /= std_name _ -> panic "rnOverLit" diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 43cbb48e75..fe17d52d7a 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -14,7 +14,7 @@ module Inst ( instCall, instDFunType, instStupidTheta, newWanted, newWanteds, - newOverloadedLit, newNonTrivialOverloadedLit, mkOverLit, + newOverloadedLit, mkOverLit, newClsInst, tcGetInsts, tcGetInstEnvs, getOverlapFlag, @@ -156,7 +156,7 @@ deeplySkolemise ty topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -- if topInstantiate ty = (wrap, rho) -- and e :: ty --- then wrap e :: rho +-- then wrap e :: rho (that is, wrap :: ty "->" rho) topInstantiate = top_instantiate True -- | Instantiate all outer 'Invisible' binders @@ -216,6 +216,7 @@ deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -- if deeplyInstantiate ty = (wrap, rho) -- and e :: ty -- then wrap e :: rho +-- That is, wrap :: ty "->" rho deeplyInstantiate orig ty | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty @@ -342,31 +343,27 @@ cases (the rest are caught in lookupInst). -} newOverloadedLit :: HsOverLit Name - -> TcSigmaType -- if nec'y, this type is instantiated... - -> CtOrigin -- ... using this CtOrigin - -> TcM (HsWrapper, HsOverLit TcId) - -- wrapper :: input type "->" type of result + -> ExpRhoType + -> TcM (HsOverLit TcId) newOverloadedLit - lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty res_orig + lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty | not rebindable - -- all built-in overloaded lits are not higher-rank, so skolemise. - -- this is necessary for shortCutLit. - = do { (wrap, insted_ty) <- deeplyInstantiate res_orig res_ty + -- all built-in overloaded lits are tau-types, so we can just + -- tauify the ExpType + = do { res_ty <- expTypeToType res_ty ; dflags <- getDynFlags - ; case shortCutLit dflags val insted_ty of + ; case shortCutLit dflags val res_ty of -- Do not generate a LitInst for rebindable syntax. -- Reason: If we do, tcSimplify will call lookupInst, which -- will call tcSyntaxName, which does unification, -- which tcSimplify doesn't like - Just expr -> return ( wrap - , lit { ol_witness = expr, ol_type = insted_ty - , ol_rebindable = False } ) - Nothing -> (wrap, ) <$> - newNonTrivialOverloadedLit orig lit insted_ty } + Just expr -> return (lit { ol_witness = expr, ol_type = res_ty + , ol_rebindable = False }) + Nothing -> newNonTrivialOverloadedLit orig lit + (mkCheckExpType res_ty) } | otherwise - = do { lit' <- newNonTrivialOverloadedLit orig lit res_ty - ; return (idHsWrapper, lit') } + = newNonTrivialOverloadedLit orig lit res_ty where orig = LiteralOrigin lit @@ -374,21 +371,23 @@ newOverloadedLit -- newOverloadedLit in TcUnify newNonTrivialOverloadedLit :: CtOrigin -> HsOverLit Name - -> TcSigmaType + -> ExpRhoType -> TcM (HsOverLit TcId) newNonTrivialOverloadedLit orig - lit@(OverLit { ol_val = val, ol_witness = meth_name + lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name) , ol_rebindable = rebindable }) res_ty = do { hs_lit <- mkOverLit val ; let lit_ty = hsLitType hs_lit - ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty) - -- Overloaded literals must have liftedTypeKind, because - -- we're instantiating an overloaded function here, - -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2 - -- However this'll be picked up by tcSyntaxOp if necessary - ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit)) - ; return (lit { ol_witness = witness, ol_type = res_ty, - ol_rebindable = rebindable }) } + ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) + [synKnownType lit_ty] res_ty $ + \_ -> return () + ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] + ; res_ty <- readExpType res_ty + ; return (lit { ol_witness = witness + , ol_type = res_ty + , ol_rebindable = rebindable }) } +newNonTrivialOverloadedLit _ lit _ + = pprPanic "newNonTrivialOverloadedLit" (ppr lit) ------------ mkOverLit :: OverLitVal -> TcM HsLit diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index a781c0397e..052c49cb19 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -77,15 +77,16 @@ Note that -} tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr - -> TcRhoType -- Expected type of whole proc expression + -> ExpRhoType -- Expected type of whole proc expression -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion) tcProc pat cmd exp_ty = newArrowScope $ - do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty + do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows + ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ + ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $ tcCmdTop cmd_env cmd (unitTy, res_ty) ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcNomReflCo res_ty)) @@ -144,15 +145,16 @@ tc_cmd env (HsCmdLet (L l binds) (L body_loc body)) res_ty tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do (scrut', scrut_ty) <- tcInferRho scrut - matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty + matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty) return (HsCmdCase scrut' matches') where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } - mc_body body res_ty' = tcCmd env body (stk, res_ty') + mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' + ; tcCmd env body (stk, res_ty') } tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if' - = do { pred' <- tcMonoExpr pred boolTy + = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty ; return (HsCmdIf Nothing pred' b1' b2') @@ -165,11 +167,13 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if -- the return value. ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let r_ty = mkTyVarTy r_tv - ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) (text "Predicate type of `ifThenElse' depends on result type") - ; fun' <- tcSyntaxOp IfOrigin fun if_ty - ; pred' <- tcMonoExpr pred pred_ty + ; (pred', fun') + <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) + (mkCheckExpType r_ty) $ \ _ -> + tcMonoExpr pred (mkCheckExpType pred_ty) + ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty ; return (HsCmdIf (Just fun') pred' b1' b2') @@ -195,9 +199,9 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newOpenFlexiTyVarTy ; let fun_ty = mkCmdArrTy env arg_ty res_ty - ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) + ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty)) - ; arg' <- tcMonoExpr arg arg_ty + ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } where @@ -222,7 +226,7 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newOpenFlexiTyVarTy ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) - ; arg' <- tcMonoExpr arg arg_ty + ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) ; return (HsCmdApp fun' arg') } ------------------------------------------- @@ -241,9 +245,9 @@ tc_cmd env do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats arg_tys $ - tc_grhss grhss cmd_stk' res_ty + ; (pats', grhss') <- setSrcSpan mtch_loc $ + tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $ + tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) ; let match' = L mtch_loc (Match NonFunBindMatch pats' Nothing grhss') arg_tys = map hsLPatType pats' @@ -262,7 +266,8 @@ tc_cmd env tc_grhs stk_ty res_ty (GRHS guards body) = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ - \ res_ty -> tcCmd env body (stk_ty, res_ty) + \ res_ty -> tcCmd env body + (stk_ty, checkingExpType "tc_grhs" res_ty) ; return (GRHS guards' rhs') } ------------------------------------------- @@ -350,11 +355,11 @@ tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside ; thing <- thing_inside res_ty ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } -tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside +tcArrDoStmt env ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside = do { (rhs', pat_ty) <- tc_arr_rhs env rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ thing_inside res_ty - ; return (mkBindStmt pat' rhs', thing) } + ; return (mkTcBindStmt pat' rhs', thing) } tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_rec_ids = rec_names }) res_ty thing_inside @@ -365,7 +370,7 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names { (stmts', tup_rets) <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> -- ToDo: res_ty not really right - zipWithM tcCheckId tup_names tup_elt_tys + zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) ; thing <- thing_inside res_ty -- NB: The rec_ids for the recursive things diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 8adfa357db..e839086082 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -252,7 +252,7 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] - ; expr' <- tcMonoExpr expr ty + ; expr' <- tcMonoExpr expr (mkCheckExpType ty) ; let d = toDict ipClass p ty `fmap` expr' ; return (ip_id, (IPBind (Right ip_id) d)) } tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind" @@ -585,7 +585,7 @@ tcPolyCheck rec_tc prag_fn , sig_loc = loc }) bind = do { ev_vars <- newEvVars theta - ; let skol_info = SigSkol ctxt (mkPhiTy theta tau) + ; let skol_info = SigSkol ctxt (mkCheckExpType $ mkPhiTy theta tau) prag_sigs = lookupPragEnv prag_fn name skol_tvs = map snd skol_prs -- Find the location of the original source type sig, if @@ -780,7 +780,7 @@ mkExport prag_fn qtvs theta -- an ambiguouse type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $ - tcSubType_NC sig_ctxt sel_poly_ty poly_ty + tcSubType_NC sig_ctxt sel_poly_ty (mkCheckExpType poly_ty) ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs ; when warn_missing_sigs $ localSigWarn poly_id mb_sig @@ -1473,17 +1473,17 @@ tcMonoBinds is_rec sig_fn no_gen -- e.g. f = \(x::forall a. a->a) -> <body> -- We want to infer a higher-rank type for f setSrcSpan b_loc $ - do { (rhs_tv, _) <- newOpenReturnTyVar - -- use ReturnTv to allow impredicativity - ; let rhs_ty = mkTyVarTy rhs_tv - ; mono_id <- newNoSigLetBndr no_gen name rhs_ty + do { rhs_ty <- newOpenInferExpType ; (co_fn, matches') - <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $ + <- tcExtendIdBndrs [TcIdBndr_ExpType name rhs_ty NotTopLevel] $ -- We extend the error context even for a non-recursive -- function so that in type error messages we show the -- type of the thing whose rhs we are type checking tcMatchesFun name matches rhs_ty + ; rhs_ty <- readExpType rhs_ty + ; mono_id <- newNoSigLetBndr no_gen name rhs_ty + ; return (unitBag $ L b_loc $ FunBind { fun_id = L nm_loc mono_id, fun_matches = matches', bind_fvs = fvs, @@ -1603,7 +1603,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) tcExtendTyVarEnvForRhs mb_sig $ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) ; (co_fn, matches') <- tcMatchesFun (idName mono_id) - matches (idType mono_id) + matches (mkCheckExpType $ idType mono_id) ; return ( FunBind { fun_id = L loc mono_id , fun_matches = matches' , fun_co_fn = co_fn diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 8a2b0ad6df..663441567d 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -1001,25 +1001,28 @@ mkEqErr1 ctxt ct where t_or_k = ctLocTypeOrKind_maybe loc - KindEqOrigin cty1 cty2 sub_o sub_t_or_k + KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k -> (True, Nothing, msg1 $$ msg2) where sub_what = case sub_t_or_k of Just KindLevel -> text "kinds" _ -> text "types" msg1 = sdocWithDynFlags $ \dflags -> - if not (gopt Opt_PrintExplicitCoercions dflags) && - (cty1 `pickyEqType` cty2) - then text "When matching the kind of" <+> quotes (ppr cty1) - else - hang (text "When matching" <+> sub_what) - 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1) - , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ]) + case mb_cty2 of + Just cty2 + | gopt Opt_PrintExplicitCoercions dflags + || not (cty1 `pickyEqType` cty2) + -> hang (text "When matching" <+> sub_what) + 2 (vcat [ ppr cty1 <+> dcolon <+> + ppr (typeKind cty1) + , ppr cty2 <+> dcolon <+> + ppr (typeKind cty2) ]) + _ -> text "When matching the kind of" <+> quotes (ppr cty1) msg2 = case sub_o of - TypeEqOrigin {} -> + TypeEqOrigin {} + | Just cty2 <- mb_cty2 -> thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k expandSyns) - _ -> - empty + _ -> empty _ -> (True, Nothing, empty) -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint @@ -1392,7 +1395,8 @@ mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool -> (Bool, Maybe SwapFlag, SDoc) -- NotSwapped means (actual, expected), IsSwapped is the reverse -- First return val is whether or not to print a herald above this msg -mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp +mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act + , uo_expected = Check exp , uo_thing = maybe_thing }) m_level printExpanded | KindLevel <- level, occurs_check_error = (True, Nothing, empty) @@ -2110,7 +2114,9 @@ pprSkol implics tv = case skol_info of UnkSkol -> pp_tv <+> text "is an unknown type variable" SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt - (mkSpecForAllTys skol_tvs ty)) + (mkCheckExpType $ + mkSpecForAllTys skol_tvs + (checkingExpType "pprSkol" ty))) _ -> ppr_rigid (pprSkolInfo skol_info) where pp_tv = quotes (ppr tv) @@ -2160,14 +2166,17 @@ relevantBindings want_filtering ctxt ct -- For *kind* errors, report the relevant bindings of the -- enclosing *type* equality, because that's more useful for the programmer extra_tvs = case tidy_orig of - KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2] - _ -> emptyVarSet + KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $ + t1 : maybeToList m_t2 + _ -> emptyVarSet ; traceTc "relevantBindings" $ vcat [ ppr ct , pprCtOrigin (ctLocOrigin loc) , ppr ct_tvs , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) - | TcIdBndr id _ <- tcl_bndrs lcl_env ] ] + | TcIdBndr id _ <- tcl_bndrs lcl_env ] + , pprWithCommas id + [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] ; (tidy_env', docs, discards) <- go env1 ct_tvs (maxRelevantBinds dflags) @@ -2204,34 +2213,49 @@ relevantBindings want_filtering ctxt ct -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out -- because of lack of fuel go tidy_env _ _ _ docs discards [] - = return (tidy_env, reverse docs, discards) - go tidy_env ct_tvs n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs) - = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) - ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty) - ; let id_tvs = tyCoVarsOfType tidy_ty - doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (text "bound at" - <+> ppr (getSrcLoc id)))] - new_seen = tvs_seen `unionVarSet` id_tvs - - ; if (want_filtering && not opt_PprStyle_Debug - && id_tvs `disjointVarSet` ct_tvs) - -- We want to filter out this binding anyway - -- so discard it silently - then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs - - else if isTopLevel top_lvl && not (isNothing n_left) - -- It's a top-level binding and we have not specified - -- -fno-max-relevant-bindings, so discard it silently - then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs - - else if run_out n_left && id_tvs `subVarSet` tvs_seen - -- We've run out of n_left fuel and this binding only - -- mentions aleady-seen type variables, so discard it - then go tidy_env ct_tvs n_left tvs_seen docs True tc_bndrs - - -- Keep this binding, decrement fuel - else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs } + = return (tidy_env, reverse docs, discards) + go tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs) + = case tc_bndr of + TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl + TcIdBndr_ExpType name et top_lvl -> + do { mb_ty <- readExpType_maybe et + -- et really should be filled in by now. But there's a chance + -- it hasn't, if, say, we're reporting a kind error en route to + -- checking a term. See test indexed-types/should_fail/T8129 + ; ty <- case mb_ty of + Just ty -> return ty + Nothing -> do { traceTc "Defaulting an ExpType in relevantBindings" + (ppr et) + ; expTypeToType et } + ; go2 name ty top_lvl } + where + go2 id_name id_type top_lvl + = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type + ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) + ; let id_tvs = tyCoVarsOfType tidy_ty + doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty + , nest 2 (parens (text "bound at" + <+> ppr (getSrcLoc id_name)))] + new_seen = tvs_seen `unionVarSet` id_tvs + + ; if (want_filtering && not opt_PprStyle_Debug + && id_tvs `disjointVarSet` ct_tvs) + -- We want to filter out this binding anyway + -- so discard it silently + then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs + + else if isTopLevel top_lvl && not (isNothing n_left) + -- It's a top-level binding and we have not specified + -- -fno-max-relevant-bindings, so discard it silently + then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs + + else if run_out n_left && id_tvs `subVarSet` tvs_seen + -- We've run out of n_left fuel and this binding only + -- mentions aleady-seen type variables, so discard it + then go tidy_env ct_tvs n_left tvs_seen docs True tc_bndrs + + -- Keep this binding, decrement fuel + else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs } discardMsg :: SDoc discardMsg = text "(Some bindings suppressed;" <+> diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 517e724e69..5dfc7ac4e1 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -9,7 +9,6 @@ module TcEvidence ( (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, mkWpFun, mkWpFuns, idHsWrapper, isIdHsWrapper, pprHsWrapper, - symWrapper_maybe, -- Evidence bindings TcEvBinds(..), EvBindsVar(..), @@ -199,21 +198,25 @@ mkWpFun :: HsWrapper -> HsWrapper -> TcType -- either type of the second wrapper (used only when the -- second wrapper is the identity) -> HsWrapper - -- NB: These optimisations are important, because we need - -- symWrapper_maybe to work in TcUnify.matchExpectedFunTys - -- See that function for more info. mkWpFun WpHole WpHole _ _ = WpHole mkWpFun WpHole (WpCast co2) t1 _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) mkWpFun (WpCast co1) WpHole _ t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) mkWpFun (WpCast co1) (WpCast co2) _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) mkWpFun co1 co2 t1 _ = WpFun co1 co2 t1 --- | @mkWpFuns arg_tys wrap@, where @wrap :: a "->" b@, gives a wrapper from --- @arg_tys -> a@ to @arg_tys -> b@. -mkWpFuns :: [TcType] -> HsWrapper -> HsWrapper -mkWpFuns [] res_wrap = res_wrap -mkWpFuns (arg_ty : arg_tys) res_wrap - = WpFun idHsWrapper (mkWpFuns arg_tys res_wrap) arg_ty +-- | @mkWpFuns [(ty1, wrap1), (ty2, wrap2)] ty_res wrap_res@, +-- where @wrap1 :: ty1 "->" ty1'@ and @wrap2 :: ty2 "->" ty2'@, +-- @wrap3 :: ty3 "->" ty3'@ and @ty_res@ is /either/ @ty3@ or @ty3'@, +-- gives a wrapper @(ty1' -> ty2' -> ty3) "->" (ty1 -> ty2 -> ty3')@. +-- Notice that the result wrapper goes the other way round to all +-- the others. This is a result of sub-typing contravariance. +mkWpFuns :: [(TcType, HsWrapper)] -> TcType -> HsWrapper -> HsWrapper +mkWpFuns args res_ty res_wrap = snd $ go args res_ty res_wrap + where + go [] res_ty res_wrap = (res_ty, res_wrap) + go ((arg_ty, arg_wrap) : args) res_ty res_wrap + = let (tail_ty, tail_wrap) = go args res_ty res_wrap in + (arg_ty `mkFunTy` tail_ty, mkWpFun arg_wrap tail_wrap arg_ty tail_ty) mkWpCastR :: TcCoercionR -> HsWrapper mkWpCastR co @@ -228,21 +231,6 @@ mkWpCastN co WpCast (mkTcSubCo co) -- The mkTcSubCo converts Nominal to Representational --- | In a few limited cases, it is possible to reverse the direction --- of an HsWrapper. This tries to do so. -symWrapper_maybe :: HsWrapper -> Maybe HsWrapper -symWrapper_maybe = go - where - go WpHole = return WpHole - go (WpCompose wp1 wp2) = WpCompose <$> go wp2 <*> go wp1 - go (WpFun {}) = Nothing - go (WpCast co) = return (WpCast (mkTcSymCo co)) - go (WpEvLam {}) = Nothing - go (WpEvApp {}) = Nothing - go (WpTyLam {}) = Nothing - go (WpTyApp {}) = Nothing - go (WpLet {}) = Nothing - mkWpTyApps :: [Type] -> HsWrapper mkWpTyApps tys = mk_co_app_fn WpTyApp tys diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index ad49631f31..8d7ac41b12 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -8,9 +8,10 @@ {-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} -module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, +module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC, tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC, - tcSyntaxOp, tcCheckId, + tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, + tcCheckId, addExprErrCtxt, getFixedTyVars ) where @@ -83,23 +84,28 @@ import qualified Data.Set as Set -} tcPolyExpr, tcPolyExprNC - :: LHsExpr Name -- Expression to type check - -> TcSigmaType -- Expected type (could be a polytype) - -> TcM (LHsExpr TcId) -- Generalised expr with expected type + :: LHsExpr Name -- Expression to type check + -> TcSigmaType -- Expected type (could be a polytype) + -> TcM (LHsExpr TcId) -- Generalised expr with expected type -- tcPolyExpr is a convenient place (frequent but not too frequent) -- place to add context information. -- The NC version does not do so, usually because the caller wants -- to do so himself. -tcPolyExpr expr res_ty +tcPolyExpr expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty) +tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty) + +-- these versions take an ExpType +tc_poly_expr, tc_poly_expr_nc :: LHsExpr Name -> ExpSigmaType -> TcM (LHsExpr TcId) +tc_poly_expr expr res_ty = addExprErrCtxt expr $ - do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty } + do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty } -tcPolyExprNC (L loc expr) res_ty - = do { traceTc "tcPolyExprNC_O" (ppr res_ty) +tc_poly_expr_nc (L loc expr) res_ty + = do { traceTc "tcPolyExprNC" (ppr res_ty) ; (wrap, expr') - <- tcSkolemise GenSigCtxt res_ty $ \ _ res_ty -> + <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> setSrcSpan loc $ -- NB: setSrcSpan *after* skolemising, so we get better -- skolem locations @@ -109,7 +115,7 @@ tcPolyExprNC (L loc expr) res_ty --------------- tcMonoExpr, tcMonoExprNC :: LHsExpr Name -- Expression to type check - -> TcRhoType -- Expected type (could be a type variable) + -> ExpRhoType -- Expected type -- Definitely no foralls at the top -> TcM (LHsExpr TcId) @@ -118,8 +124,7 @@ tcMonoExpr expr res_ty tcMonoExprNC expr res_ty tcMonoExprNC (L loc expr) res_ty - = ASSERT( not (isSigmaTy res_ty) ) - setSrcSpan loc $ + = setSrcSpan loc $ do { expr' <- tcExpr expr res_ty ; return (L loc expr') } @@ -154,7 +159,7 @@ tcInferRhoNC expr NB: The res_ty is always deeply skolemised. -} -tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId) +tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId) tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty tcExpr (HsUnboundVar v) res_ty = tcUnboundId v res_ty @@ -181,15 +186,14 @@ tcExpr (HsCoreAnn src lbl expr) res_ty ; return (HsCoreAnn src lbl expr') } tcExpr (HsOverLit lit) res_ty - = do { (_wrap, lit') <- newOverloadedLit lit res_ty - (Shouldn'tHappenOrigin "HsOverLit") - ; MASSERT( isIdHsWrapper _wrap ) + = do { lit' <- newOverloadedLit lit res_ty ; return (HsOverLit lit') } tcExpr (NegApp expr neg_expr) res_ty - = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr - (mkFunTy res_ty res_ty) - ; expr' <- tcMonoExpr expr res_ty + = do { (expr', neg_expr') + <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ + \[arg_ty] -> + tcMonoExpr expr (mkCheckExpType arg_ty) ; return (NegApp expr' neg_expr') } tcExpr e@(HsIPVar x) res_ty @@ -330,9 +334,11 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty | (L loc (HsVar (L lv op_name))) <- op , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind - ; let arg2_ty = res_ty - ; arg1' <- tcArg op (arg1, arg1_ty, 1) - ; arg2' <- tcArg op (arg2, arg2_ty, 2) + ; let arg2_exp_ty = res_ty + ; arg1' <- tcArg op arg1 arg1_ty 1 + ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $ + tc_poly_expr_nc arg2 arg2_exp_ty + ; arg2_ty <- readExpType arg2_exp_ty ; op_id <- tcLookupId op_name ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar (L lv op_id))) @@ -346,50 +352,46 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; let doc = text "The first argument of ($) takes" orig1 = exprCtOrigin (unLoc arg1) ; (wrap_arg1, [arg2_sigma], op_res_ty) <- - matchActualFunTys doc orig1 1 arg1_ty + matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty -- We have (arg1 $ arg2) -- So: arg1_ty = arg2_ty -> op_res_ty -- where arg2_sigma maybe polymorphic; that's the point - ; arg2' <- tcArg op (arg2, arg2_sigma, 2) + ; arg2' <- tcArg op arg2 arg2_sigma 2 -- Make sure that the argument type has kind '*' -- ($) :: forall (v:Levity) (a:*) (b:TYPE v). (a->b) -> a -> b -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 -- (which gives a seg fault) - -- We do this by unifying with a MetaTv; but of course - -- it must allow foralls in the type it unifies with (hence ReturnTv)! -- -- The *result* type can have any kind (Trac #8739), -- so we don't need to check anything for that - ; a2_tv <- newReturnTyVar liftedTypeKind - ; let a2_ty = mkTyVarTy a2_tv - ; co_a <- unifyType (Just arg2) arg2_sigma a2_ty -- arg2_sigma ~N a2_ty + ; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind + -- ignore the evidence. arg2_sigma must have type * or #, + -- because we know arg2_sigma -> or_res_ty is well-kinded + -- (because otherwise matchActualFunTys would fail) + -- There's no possibility here of, say, a kind family reducing to *. ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty -- op_res -> res ; op_id <- tcLookupId op_name + ; res_ty <- readExpType res_ty ; let op' = L loc (HsWrap (mkWpTyApps [ getLevity "tcExpr ($)" res_ty - , a2_ty + , arg2_sigma , res_ty]) (HsVar (L lv op_id))) -- arg1' :: arg1_ty -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) -- wrap_res :: op_res_ty "->" res_ty - -- co_a :: arg2_sigma ~N a2_ty -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty - -- wrap1 :: arg1_ty "->" (a2_ty -> res_ty) - wrap1 = mkWpFun (mkWpCastN (mkTcSymCo co_a)) - wrap_res a2_ty res_ty <.> wrap_arg1 + -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty) + wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty + <.> wrap_arg1 - -- arg2' :: arg2_sigma - -- wrap_a :: a2_ty "->" arg2_sigma - ; return (OpApp (mkLHsWrap wrap1 arg1') - op' fix - (mkLHsWrapCo co_a arg2')) } + ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') } | (L loc (HsRecFld (Ambiguous lbl _))) <- op , Just sig_ty <- obviousSig (unLoc arg1) @@ -413,10 +415,10 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty tcExpr expr@(SectionR op arg2) res_ty = do { (op', op_ty) <- tcInferFun op ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <- - matchActualFunTys (mk_op_msg op) SectionOrigin 2 op_ty + matchActualFunTys (mk_op_msg op) SectionOrigin (Just op) 2 op_ty ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) (mkFunTy arg1_ty op_res_ty) res_ty - ; arg2' <- tcArg op (arg2, arg2_ty, 2) + ; arg2' <- tcArg op arg2 arg2_ty 2 ; return ( mkHsWrap wrap_res $ SectionR (mkLHsWrap wrap_fun op') arg2' ) } @@ -427,10 +429,11 @@ tcExpr expr@(SectionL arg1 op) res_ty | otherwise = 2 ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) - <- matchActualFunTys (mk_op_msg op) SectionOrigin n_reqd_args op_ty + <- matchActualFunTys (mk_op_msg op) SectionOrigin (Just op) + n_reqd_args op_ty ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) (mkFunTys arg_tys op_res_ty) res_ty - ; arg1' <- tcArg op (arg1, arg1_ty, 1) + ; arg1' <- tcArg op arg1 arg1_ty 1 ; return ( mkHsWrap wrap_res $ SectionL arg1' (mkLHsWrap wrap_fn op') ) } @@ -438,6 +441,7 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty | all tupArgPresent tup_args = do { let arity = length tup_args tup_tc = tupleTyCon boxity arity + ; res_ty <- expTypeToType res_ty ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty -- Unboxed tuples have levity vars, which we -- don't care about here @@ -469,21 +473,26 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty tcExpr (ExplicitList _ witness exprs) res_ty = case witness of - Nothing -> do { (coi, elt_ty) <- matchExpectedListTy res_ty + Nothing -> do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty ; exprs' <- mapM (tc_elt elt_ty) exprs ; return $ mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' } - Just fln -> do { list_ty <- newFlexiTyVarTy liftedTypeKind - ; fln' <- tcSyntaxOp ListOrigin fln (mkFunTys [intTy, list_ty] res_ty) - ; (coi, elt_ty) <- matchExpectedListTy list_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ - mkHsWrapCo coi $ ExplicitList elt_ty (Just fln') exprs' } + Just fln -> do { ((exprs', elt_ty), fln') + <- tcSyntaxOp ListOrigin fln + [synKnownType intTy, SynList] res_ty $ + \ [elt_ty] -> + do { exprs' <- + mapM (tc_elt elt_ty) exprs + ; return (exprs', elt_ty) } + + ; return $ ExplicitList elt_ty (Just fln') exprs' } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty - = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedPArrTy res_ty ; exprs' <- mapM (tc_elt elt_ty) exprs ; return $ mkHsWrapCo coi $ ExplicitPArr elt_ty exprs' } @@ -503,7 +512,7 @@ tcExpr (HsLet (L l binds) expr) res_ty tcMonoExpr expr res_ty ; return (HsLet (L l binds') expr') } -tcExpr (HsCase scrut matches) exp_ty +tcExpr (HsCase scrut matches) res_ty = do { -- We used to typecheck the case alternatives first. -- The case patterns tend to give good type info to use -- when typechecking the scrutinee. For example @@ -516,32 +525,39 @@ tcExpr (HsCase scrut matches) exp_ty (scrut', scrut_ty) <- tcInferRho scrut ; traceTc "HsCase" (ppr scrut_ty) - ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty + ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty ; return (HsCase scrut' matches') } where match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' - = do { pred' <- tcMonoExpr pred boolTy + = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) -- this forces the branches to be fully instantiated -- (See #10619) - ; res_ty <- tauTvForReturnTv res_ty + ; res_ty <- mkCheckExpType <$> expTypeToType res_ty ; b1' <- tcMonoExpr b1 res_ty ; b2' <- tcMonoExpr b2 res_ty ; return (HsIf Nothing pred' b1' b2') } tcExpr (HsIf (Just fun) pred b1 b2) res_ty - -- Note [Rebindable syntax for if] - = do { (wrap, fun', [pred', b1', b2']) - <- tcApp (Just herald) (noLoc fun) [pred, b1, b2] res_ty - ; return ( mkHsWrap wrap $ - HsIf (Just (unLoc fun')) pred' b1' b2' ) } - where - herald = text "Rebindable" <+> quotes (text "if") <+> text "takes" + = do { ((pred', b1', b2'), fun') + <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ + \ [pred_ty, b1_ty, b2_ty] -> + do { pred' <- tcPolyExpr pred pred_ty + ; b1' <- tcPolyExpr b1 b1_ty + ; b2' <- tcPolyExpr b2 b2_ty + ; return (pred', b1', b2') } + ; return (HsIf (Just fun') pred' b1' b2') } tcExpr (HsMultiIf _ alts) res_ty - = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts + = do { res_ty <- if isSingleton alts + then return res_ty + else mkCheckExpType <$> expTypeToType res_ty + -- Just like Note [Case branches must never infer a non-tau type] + -- in TcMatches + ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts + ; res_ty <- readExpType res_ty ; return (HsMultiIf res_ty alts') } where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } @@ -555,6 +571,7 @@ tcExpr (HsProc pat cmd) res_ty tcExpr (HsStatic expr) res_ty = do { staticPtrTyCon <- tcLookupTyCon staticPtrTyConName + ; res_ty <- expTypeToType res_ty ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty ; (expr', lie) <- captureConstraints $ addErrCtxt (hang (text "In the body of a static form:") @@ -576,23 +593,6 @@ tcExpr (HsStatic expr) res_ty } {- -Note [Rebindable syntax for if] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The rebindable syntax for 'if' uses the most flexible possible type -for conditionals: - ifThenElse :: p -> b1 -> b2 -> res -to support expressions like this: - - ifThenElse :: Maybe a -> (a -> b) -> b -> b - ifThenElse (Just a) f _ = f a - ifThenElse Nothing _ e = e - - example :: String - example = if Just 2 - then \v -> show v - else "No value" - - ************************************************************************ * * Record construction and update @@ -930,7 +930,8 @@ tcExpr (ArithSeq _ witness seq) res_ty = tcArithSeq witness seq res_ty tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedPArrTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar @@ -940,7 +941,8 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty mkHsWrapCo coi $ PArrSeq enum_from_to (FromTo expr1' expr2') } tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedPArrTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty @@ -991,52 +993,57 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) ************************************************************************ -} -tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType +tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> ExpRhoType -> TcM (HsExpr TcId) tcArithSeq witness seq@(From expr) res_ty - = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr' <- tcPolyExpr expr elt_ty ; enum_from <- newMethodFromName (ArithSeqOrigin seq) enumFromName elt_ty - ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) } + ; return $ mkHsWrap wrap $ + ArithSeq enum_from wit' (From expr') } tcArithSeq witness seq@(FromThen expr1 expr2) res_ty - = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) enumFromThenName elt_ty - ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) } + ; return $ mkHsWrap wrap $ + ArithSeq enum_from_then wit' (FromThen expr1' expr2') } tcArithSeq witness seq@(FromTo expr1 expr2) res_ty - = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) enumFromToName elt_ty - ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) } + ; return $ mkHsWrap wrap $ + ArithSeq enum_from_to wit' (FromTo expr1' expr2') } tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty - = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (ArithSeqOrigin seq) enumFromThenToName elt_ty - ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) } + ; return $ mkHsWrap wrap $ + ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } ----------------- -arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType - -> TcM (TcCoercionN, TcType, Maybe (SyntaxExpr Id)) +arithSeqEltType :: Maybe (SyntaxExpr Name) -> ExpRhoType + -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr Id)) arithSeqEltType Nothing res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; return (coi, elt_ty, Nothing) } + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; return (mkWpCastN coi, elt_ty, Nothing) } arithSeqEltType (Just fl) res_ty - = do { list_ty <- newFlexiTyVarTy liftedTypeKind - ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty) - ; (coi, elt_ty) <- matchExpectedListTy list_ty - ; return (coi, elt_ty, Just fl') } + = do { (elt_ty, fl') + <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ + \ [elt_ty] -> return elt_ty + ; return (idHsWrapper, elt_ty, Just fl') } {- ************************************************************************ @@ -1049,7 +1056,7 @@ arithSeqEltType (Just fl) res_ty tcApp :: Maybe SDoc -- like "The function `f' is applied to" -- or leave out to get exactly that message -> LHsExpr Name -> [LHsExpr Name] -- Function and args - -> TcRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId]) + -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId]) -- (wrap, fun, args). For an ordinary function application, -- these should be assembled as (wrap (fun args)). -- But OpApp is slightly different, so that's why the caller @@ -1165,10 +1172,10 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald | otherwise -- not a type application. = do { (wrap, [arg_ty], res_ty) - <- matchActualFunTysPart herald fun_orig 1 fun_ty + <- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty acc_args orig_arity -- wrap :: fun_ty "->" arg_ty -> res_ty - ; arg' <- tcArg fun (arg, arg_ty, n) + ; arg' <- tcArg fun arg arg_ty n ; (inner_wrap, args', inner_res_ty) <- go (arg_ty : acc_args) (n+1) res_ty args -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty @@ -1183,11 +1190,13 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald text "to a visible type argument" <+> quotes (ppr arg) } ---------------- -tcArg :: LHsExpr Name -- The function (for error messages) - -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type - -> TcM (LHsExpr TcId) -- Resulting argument -tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) - (tcPolyExprNC arg ty) +tcArg :: LHsExpr Name -- The function (for error messages) + -> LHsExpr Name -- Actual arguments + -> TcRhoType -- expected arg type + -> Int -- # of arugment + -> TcM (LHsExpr TcId) -- Resulting argument +tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $ + tcPolyExprNC arg ty ---------------- tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId] @@ -1199,15 +1208,172 @@ tcTupArgs args tys ; return (L l (Present expr')) } --------------------------- -tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId) --- Typecheck a syntax operator, checking that it has the specified type +-- See TcType.SyntaxOpType also for commentary +tcSyntaxOp :: CtOrigin + -> SyntaxExpr Name + -> [SyntaxOpType] -- ^ shape of syntax operator arguments + -> ExpType -- ^ overall result type + -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments + -> TcM (a, SyntaxExpr TcId) +-- ^ Typecheck a syntax operator -- The operator is always a variable at this stage (i.e. renamer output) --- This version assumes res_ty is a monotype -tcSyntaxOp orig (HsVar (L _ op)) res_ty - = do { (expr, rho) <- tcInferId op - ; tcWrapResultO orig expr rho res_ty } +tcSyntaxOp orig expr arg_tys res_ty + = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) + +-- | Slightly more general version of 'tcSyntaxOp' that allows the caller +-- to specify the shape of the result of the syntax operator +tcSyntaxOpGen :: CtOrigin + -> SyntaxExpr Name + -> [SyntaxOpType] + -> SyntaxOpType + -> ([TcSigmaType] -> TcM a) + -> TcM (a, SyntaxExpr TcId) +tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) }) + arg_tys res_ty thing_inside + = do { (expr, sigma) <- tcInferId op + ; (result, expr_wrap, arg_wraps, res_wrap) + <- tcSynArgA orig sigma arg_tys res_ty $ + thing_inside + ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) } + +tcSyntaxOpGen _ other _ _ _ = pprPanic "tcSyntaxOp" (ppr other) -tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other) +{- +Note [tcSynArg] +~~~~~~~~~~~~~~~ +Because of the rich structure of SyntaxOpType, we must do the +contra-/covariant thing when working down arrows, to get the +instantiation vs. skolemisation decisions correct (and, more +obviously, the orientation of the HsWrappers). We thus have +two tcSynArgs. +-} + +-- works on "expected" types, skolemising where necessary +-- See Note [tcSynArg] +tcSynArgE :: CtOrigin + -> TcSigmaType + -> SyntaxOpType -- ^ shape it is expected to have + -> ([TcSigmaType] -> TcM a) -- ^ check the arguments + -> TcM (a, HsWrapper) + -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) +tcSynArgE orig sigma_ty syn_ty thing_inside + = do { (skol_wrap, (result, ty_wrapper)) + <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty -> + go rho_ty syn_ty + ; return (result, skol_wrap <.> ty_wrapper) } + where + go rho_ty SynAny + = do { result <- thing_inside [rho_ty] + ; return (result, idHsWrapper) } + + go rho_ty SynRho -- same as SynAny, because we skolemise eagerly + = do { result <- thing_inside [rho_ty] + ; return (result, idHsWrapper) } + + go rho_ty SynList + = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty + ; result <- thing_inside [elt_ty] + ; return (result, mkWpCastN list_co) } + + go rho_ty (SynFun arg_shape res_shape) + = do { ( ( ( (result, arg_ty, res_ty) + , res_wrapper ) -- :: res_ty_out "->" res_ty + , arg_wrapper1, [], arg_wrapper2 ) -- :: arg_ty "->" arg_ty_out + , match_wrapper ) -- :: (arg_ty -> res_ty) "->" rho_ty + <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $ + \ [arg_ty] res_ty -> + do { arg_tc_ty <- expTypeToType arg_ty + ; res_tc_ty <- expTypeToType res_ty + + -- another nested arrow is too much for now, + -- but I bet we'll never need this + ; MASSERT2( case arg_shape of + SynFun {} -> False; + _ -> True + , text "Too many nested arrows in SyntaxOpType" $$ + pprCtOrigin orig ) + + ; tcSynArgA orig arg_tc_ty [] arg_shape $ + \ arg_results -> + tcSynArgE orig res_tc_ty res_shape $ + \ res_results -> + do { result <- thing_inside (arg_results ++ res_results) + ; return (result, arg_tc_ty, res_tc_ty) }} + + ; return ( result + , match_wrapper <.> + mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper + arg_ty res_ty ) } + where + herald = text "This rebindable syntax expects a function with" + + go rho_ty (SynType the_ty) + = do { wrap <- tcSubTypeET orig the_ty rho_ty + ; result <- thing_inside [] + ; return (result, wrap) } + +-- works on "actual" types, instantiating where necessary +-- See Note [tcSynArg] +tcSynArgA :: CtOrigin + -> TcSigmaType + -> [SyntaxOpType] -- ^ argument shapes + -> SyntaxOpType -- ^ result shape + -> ([TcSigmaType] -> TcM a) -- ^ check the arguments + -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) + -- ^ returns a wrapper to be applied to the original function, + -- wrappers to be applied to arguments + -- and a wrapper to be applied to the overall expression +tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside + = do { (match_wrapper, arg_tys, res_ty) + <- matchActualFunTys herald orig noThing (length arg_shapes) sigma_ty + -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) + ; ((result, res_wrapper), arg_wrappers) + <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results -> + tc_syn_arg res_ty res_shape $ \ res_results -> + thing_inside (arg_results ++ res_results) + ; return (result, match_wrapper, arg_wrappers, res_wrapper) } + where + herald = text "This rebindable syntax expects a function with" + + tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType] + -> ([TcSigmaType] -> TcM a) + -> TcM (a, [HsWrapper]) + -- the wrappers are for arguments + tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside + = do { ((result, arg_wraps), arg_wrap) + <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results -> + tc_syn_args_e arg_tys arg_shapes $ \ args_results -> + thing_inside (arg1_results ++ args_results) + ; return (result, arg_wrap : arg_wraps) } + tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] + + tc_syn_arg :: TcSigmaType -> SyntaxOpType + -> ([TcSigmaType] -> TcM a) + -> TcM (a, HsWrapper) + -- the wrapper applies to the overall result + tc_syn_arg res_ty SynAny thing_inside + = do { result <- thing_inside [res_ty] + ; return (result, idHsWrapper) } + tc_syn_arg res_ty SynRho thing_inside + = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty + -- inst_wrap :: res_ty "->" rho_ty + ; result <- thing_inside [rho_ty] + ; return (result, inst_wrap) } + tc_syn_arg res_ty SynList thing_inside + = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty + -- inst_wrap :: res_ty "->" rho_ty + ; (list_co, elt_ty) <- matchExpectedListTy rho_ty + -- list_co :: [elt_ty] ~N rho_ty + ; result <- thing_inside [elt_ty] + ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) } + tc_syn_arg _ (SynFun {}) _ + = pprPanic "tcSynArgA hits a SynFun" (ppr orig) + tc_syn_arg res_ty (SynType the_ty) thing_inside + = do { wrap <- tcSubTypeO orig GenSigCtxt res_ty the_ty + ; result <- thing_inside [] + ; return (result, wrap) } {- Note [Push result type in] @@ -1280,7 +1446,8 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguouse type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int - else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma + else tcSubType_NC ExprSigCtxt inferred_sigma + (mkCheckExpType my_sigma) ; let poly_wrap = wrap <.> mkWpTyLams qtvs @@ -1290,7 +1457,7 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr | otherwise = panic "tcExprSig" -- Can't happen where - skol_info = SigSkol ExprSigCtxt (mkPhiTy theta tau) + skol_info = SigSkol ExprSigCtxt (mkCheckExpType $ mkPhiTy theta tau) skol_tvs = map snd skol_prs {- ********************************************************************* @@ -1299,20 +1466,20 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr * * ********************************************************************* -} -tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) +tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId) tcCheckId name res_ty = do { (expr, actual_res_ty) <- tcInferId name ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $ tcWrapResultO (OccurrenceOf name) expr actual_res_ty res_ty } -tcCheckRecSelId :: AmbiguousFieldOcc Name -> TcRhoType -> TcM (HsExpr TcId) +tcCheckRecSelId :: AmbiguousFieldOcc Name -> ExpRhoType -> TcM (HsExpr TcId) tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty = do { (expr, actual_res_ty) <- tcInferRecSelId f ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $ tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty } tcCheckRecSelId (Ambiguous lbl _) res_ty - = case tcSplitFunTy_maybe res_ty of + = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of Nothing -> ambiguousSelector lbl Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty } @@ -1404,7 +1571,7 @@ tc_infer_id lbl id_name | otherwise = return () -tcUnboundId :: OccName -> TcRhoType -> TcM (HsExpr TcId) +tcUnboundId :: OccName -> ExpRhoType -> TcM (HsExpr TcId) -- Typechedk an occurrence of an unbound Id -- -- Some of these started life as a true hole "_". Others might simply @@ -1478,7 +1645,7 @@ the users that complain. -} tcSeq :: SrcSpan -> Name -> [LHsExpr Name] - -> TcRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId]) + -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId]) -- (seq e1 e2) :: res_ty -- We need a special typing rule because res_ty can be unboxed -- See Note [Typing rule for seq] @@ -1493,21 +1660,20 @@ tcSeq loc fun_name args res_ty _ -> do { arg_ty1 <- newFlexiTyVarTy liftedTypeKind ; return (arg_ty1, args) } - ; (arg1, arg2) <- case args1 of + ; (arg1, arg2, arg2_exp_ty) <- case args1 of [ty_arg_expr2, term_arg1, term_arg2] | Just hs_ty_arg2 <- isLHsTypeExpr_maybe ty_arg_expr2 -> do { lev_ty <- newFlexiTyVarTy levityTy ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE lev_ty) -- see Note [Typing rule for seq] - ; _ <- unifyType noThing ty_arg2 res_ty - ; return (term_arg1, term_arg2) } - [term_arg1, term_arg2] -> return (term_arg1, term_arg2) + ; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg2 res_ty + ; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) } + [term_arg1, term_arg2] -> return (term_arg1, term_arg2, res_ty) _ -> too_many_args - ; arg1' <- tcMonoExpr arg1 arg1_ty - ; res_ty <- zonkTcType res_ty -- just in case we learned something - -- interesting about it - ; arg2' <- tcMonoExpr arg2 res_ty + ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty) + ; arg2' <- tcMonoExpr arg2 arg2_exp_ty + ; res_ty <- readExpType res_ty -- by now, it's surely filled in ; let fun' = L loc (HsWrap ty_args (HsVar (L loc fun))) ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty ; return (idHsWrapper, fun', [arg1', arg2']) } @@ -1519,7 +1685,7 @@ tcSeq loc fun_name args res_ty 2 (sep (map pprParendExpr args)) -tcTagToEnum :: SrcSpan -> Name -> [LHsExpr Name] -> TcRhoType +tcTagToEnum :: SrcSpan -> Name -> [LHsExpr Name] -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId]) -- tagToEnum# :: forall a. Int# -> a -- See Note [tagToEnum#] Urgh! @@ -1530,15 +1696,17 @@ tcTagToEnum loc fun_name args res_ty [ty_arg_expr, term_arg] | Just hs_ty_arg <- isLHsTypeExpr_maybe ty_arg_expr -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind - ; _ <- unifyType noThing ty_arg res_ty + ; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg res_ty -- other than influencing res_ty, we just -- don't care about a type arg passed in. -- So drop the evidence. ; return term_arg } - [term_arg] -> return term_arg + [term_arg] -> do { _ <- expTypeToType res_ty + ; return term_arg } _ -> too_many_args - ; ty' <- zonkTcType res_ty + ; res_ty <- readExpType res_ty + ; ty' <- zonkTcType res_ty -- Check that the type is algebraic ; let mb_tc_app = tcSplitTyConApp_maybe ty' @@ -1555,7 +1723,7 @@ tcTagToEnum loc fun_name args res_ty ; checkTc (isEnumerationTyCon rep_tc) (mk_error ty' doc2) - ; arg' <- tcMonoExpr arg intPrimTy + ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy) ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun))) rep_ty = mkTyConApp rep_tc rep_args @@ -1819,7 +1987,7 @@ ambiguousSelector (L _ rdr) -- Disambiguate the fields in a record update. -- See Note [Disambiguating record fields] disambiguateRecordBinds :: LHsExpr Name -> TcRhoType - -> [LHsRecUpdField Name] -> Type + -> [LHsRecUpdField Name] -> ExpRhoType -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Are all the fields unambiguous? @@ -1864,7 +2032,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Multiple possible parents: try harder to disambiguate -- Can we get a parent TyCon from the pushed-in type? - _:_ | Just p <- tyConOf fam_inst_envs res_ty -> return (RecSelData p) + _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p) -- Does the expression being updated have a type signature? -- If so, try to extract a parent TyCon from it @@ -1914,15 +2082,19 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Extract the outermost TyCon of a type, if there is one; for -- data families this is the representation tycon (because that's --- where the fields live). Look inside sigma-types, so that --- tyConOf _ (forall a. Q => T a) = T -tyConOf :: FamInstEnvs -> Type -> Maybe TyCon -tyConOf fam_inst_envs ty0 = case tcSplitTyConApp_maybe ty of - Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) - Nothing -> Nothing +-- where the fields live). +tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon +tyConOf fam_inst_envs ty0 + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) + Nothing -> Nothing where (_, _, ty) = tcSplitSigmaTy ty0 +-- Variant of tyConOf that works for ExpTypes +tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon +tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 + -- For an ambiguous record field, find all the candidate record -- selectors (as GlobalRdrElts) and their parents. lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)] @@ -2098,7 +2270,7 @@ fieldCtxt field_name = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") addFunResCtxt :: Bool -- There is at least one argument - -> HsExpr Name -> TcType -> TcType + -> HsExpr Name -> TcType -> ExpRhoType -> TcM a -> TcM a -- When we have a mis-match in the return type of a function -- try to give a helpful message about too many/few arguments @@ -2110,8 +2282,16 @@ addFunResCtxt has_args fun fun_res_ty env_ty -- doesn't suppress some more useful context where mk_msg - = do { fun_res' <- zonkTcType fun_res_ty - ; env' <- zonkTcType env_ty + = do { mb_env_ty <- readExpType_maybe env_ty + -- by the time the message is rendered, the ExpType + -- will be filled in (except if we're debugging) + ; fun_res' <- zonkTcType fun_res_ty + ; env' <- case mb_env_ty of + Just env_ty -> zonkTcType env_ty + Nothing -> + do { dumping <- doptM Opt_D_dump_tc_trace + ; MASSERT( dumping ) + ; newFlexiTyVarTy liftedTypeKind } ; let (_, _, fun_tau) = tcSplitSigmaTy fun_res' (_, _, env_tau) = tcSplitSigmaTy env' (args_fun, res_fun) = tcSplitFunTys fun_tau diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot index 8d60ba4662..78b8bc1df9 100644 --- a/compiler/typecheck/TcExpr.hs-boot +++ b/compiler/typecheck/TcExpr.hs-boot @@ -1,7 +1,7 @@ module TcExpr where -import HsSyn ( HsExpr, LHsExpr ) +import HsSyn ( HsExpr, LHsExpr, SyntaxExpr ) import Name ( Name ) -import TcType ( TcType, TcRhoType, TcSigmaType ) +import TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) import TcRnTypes( TcM, TcId, CtOrigin ) tcPolyExpr :: @@ -11,7 +11,7 @@ tcPolyExpr :: tcMonoExpr, tcMonoExprNC :: LHsExpr Name - -> TcRhoType + -> ExpRhoType -> TcM (LHsExpr TcId) tcInferSigma, tcInferSigmaNC :: @@ -23,8 +23,18 @@ tcInferRho :: -> TcM (LHsExpr TcId, TcRhoType) tcSyntaxOp :: CtOrigin - -> HsExpr Name - -> TcType - -> TcM (HsExpr TcId) + -> SyntaxExpr Name + -> [SyntaxOpType] -- ^ shape of syntax operator arguments + -> ExpType -- ^ overall result type + -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments + -> TcM (a, SyntaxExpr TcId) -tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) +tcSyntaxOpGen :: CtOrigin + -> SyntaxExpr Name + -> [SyntaxOpType] + -> SyntaxOpType + -> ([TcSigmaType] -> TcM a) + -> TcM (a, SyntaxExpr TcId) + + +tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 218c0a4991..9feb2668a8 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1322,7 +1322,7 @@ gen_Data_binds dflags loc rep_tc | otherwise = prefix_RDR ------------ gfoldl - gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons) + gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons) gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], @@ -1334,10 +1334,10 @@ gen_Data_binds dflags loc rep_tc mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) ------------ gunfold - gunfold_bind = mk_FunBind loc - gunfold_RDR - [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], - gunfold_rhs)] + gunfold_bind = mk_HRFunBind 2 loc + gunfold_RDR + [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], + gunfold_rhs)] gunfold_rhs | one_constr = mk_unfold_rhs (head data_cons) -- No need for case @@ -2143,13 +2143,26 @@ mkParentType tc mk_FunBind :: SrcSpan -> RdrName -> [([LPat RdrName], LHsExpr RdrName)] -> LHsBind RdrName -mk_FunBind loc fun pats_and_exprs - = mkRdrFunBind (L loc fun) matches +mk_FunBind = mk_HRFunBind 0 -- by using mk_FunBind and not mk_HRFunBind, + -- the caller says that the Void case needs no + -- patterns + +-- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before +-- the "=" in the empty-data-decl case. This is necessary if the function +-- has a higher-rank type, like foldl. (See deriving/should_compile/T4302) +mk_HRFunBind :: Arity -> SrcSpan -> RdrName + -> [([LPat RdrName], LHsExpr RdrName)] + -> LHsBind RdrName +mk_HRFunBind arity loc fun pats_and_exprs + = mkHRRdrFunBind arity (L loc fun) matches where matches = [mkMatch p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs] mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName -mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') +mkRdrFunBind = mkHRRdrFunBind 0 + +mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName +mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') where -- Catch-all eqn looks like -- fmap = error "Void fmap" @@ -2157,7 +2170,8 @@ mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') -- which can happen with -XEmptyDataDecls -- See Trac #4302 matches' = if null matches - then [mkMatch [] (error_Expr str) (noLoc emptyLocalBinds)] + then [mkMatch (replicate arity nlWildPat) + (error_Expr str) (noLoc emptyLocalBinds)] else matches str = "Void " ++ occNameString (rdrNameOcc fun_rdr) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index f055197ede..42890351b7 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -60,6 +60,7 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Data.List ( partition ) +import Control.Arrow ( second ) {- ************************************************************************ @@ -91,8 +92,8 @@ hsPatType (TuplePat _ bx tys) = mkTupleTy bx tys hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) = conLikeResTy con tys hsPatType (SigPatOut _ ty) = ty -hsPatType (NPat (L _ lit) _ _) = overLitType lit -hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) +hsPatType (NPat _ _ _ ty) = ty +hsPatType (NPlusKPat _ _ _ _ _ ty) = ty hsPatType (CoPat _ _ ty) = ty hsPatType p = pprPanic "hsPatType" (ppr p) @@ -613,8 +614,8 @@ zonkExpr env (OpApp e1 op fixity e2) return (OpApp new_e1 new_op fixity new_e2) zonkExpr env (NegApp expr op) - = do new_expr <- zonkLExpr env expr - new_op <- zonkExpr env op + = do (env', new_op) <- zonkSyntaxExpr env op + new_expr <- zonkLExpr env' expr return (NegApp new_expr new_op) zonkExpr env (HsPar e) @@ -645,12 +646,18 @@ zonkExpr env (HsCase expr ms) new_ms <- zonkMatchGroup env zonkLExpr ms return (HsCase new_expr new_ms) -zonkExpr env (HsIf e0 e1 e2 e3) - = do { new_e0 <- fmapMaybeM (zonkExpr env) e0 - ; new_e1 <- zonkLExpr env e1 - ; new_e2 <- zonkLExpr env e2 - ; new_e3 <- zonkLExpr env e3 - ; return (HsIf new_e0 new_e1 new_e2 new_e3) } +zonkExpr env (HsIf Nothing e1 e2 e3) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + new_e3 <- zonkLExpr env e3 + return (HsIf Nothing new_e1 new_e2 new_e3) + +zonkExpr env (HsIf (Just fun) e1 e2 e3) + = do (env1, new_fun) <- zonkSyntaxExpr env fun + new_e1 <- zonkLExpr env1 e1 + new_e2 <- zonkLExpr env1 e2 + new_e3 <- zonkLExpr env1 e3 + return (HsIf (Just new_fun) new_e1 new_e2 new_e3) zonkExpr env (HsMultiIf ty alts) = do { alts' <- mapM (wrapLocM zonk_alt) alts @@ -672,13 +679,12 @@ zonkExpr env (HsDo do_or_lc (L l stmts) ty) return (HsDo do_or_lc (L l new_stmts) new_ty) zonkExpr env (ExplicitList ty wit exprs) - = do new_ty <- zonkTcTypeToType env ty - new_wit <- zonkWit env wit - new_exprs <- zonkLExprs env exprs + = do (env1, new_wit) <- zonkWit env wit + new_ty <- zonkTcTypeToType env1 ty + new_exprs <- zonkLExprs env1 exprs return (ExplicitList new_ty new_wit new_exprs) - where zonkWit _ Nothing = return Nothing - zonkWit env (Just fln) = do new_fln <- zonkExpr env fln - return (Just new_fln) + where zonkWit env Nothing = return (env, Nothing) + zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln zonkExpr env (ExplicitPArr ty exprs) = do new_ty <- zonkTcTypeToType env ty @@ -708,13 +714,12 @@ zonkExpr env (ExprWithTySigOut e ty) ; return (ExprWithTySigOut e' ty) } zonkExpr env (ArithSeq expr wit info) - = do new_expr <- zonkExpr env expr - new_wit <- zonkWit env wit - new_info <- zonkArithSeq env info + = do (env1, new_wit) <- zonkWit env wit + new_expr <- zonkExpr env expr + new_info <- zonkArithSeq env1 info return (ArithSeq new_expr new_wit new_info) - where zonkWit _ Nothing = return Nothing - zonkWit env (Just fln) = do new_fln <- zonkExpr env fln - return (Just new_fln) + where zonkWit env Nothing = return (env, Nothing) + zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln zonkExpr env (PArrSeq expr info) = do new_expr <- zonkExpr env expr @@ -758,6 +763,40 @@ zonkExpr _ e@(HsTypeOut {}) = return e zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) ------------------------------------------------------------------------- +{- +Note [Skolems in zonkSyntaxExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider rebindable syntax with something like + + (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' + +The x and y become skolems that are in scope when type-checking the +arguments to the bind. This means that we must extend the ZonkEnv with +these skolems when zonking the arguments to the bind. But the skolems +are different between the two arguments, and so we should theoretically +carry around different environments to use for the different arguments. + +However, this becomes a logistical nightmare, especially in dealing with +the more exotic Stmt forms. So, we simplify by making the critical +assumption that the uniques of the skolems are different. (This assumption +is justified by the use of newUnique in TcMType.instSkolTyCoVarX.) +Now, we can safely just extend one environment. +-} + +-- See Note [Skolems in zonkSyntaxExpr] +zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr TcId + -> TcM (ZonkEnv, SyntaxExpr Id) +zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = do { (env0, res_wrap') <- zonkCoFn env res_wrap + ; expr' <- zonkExpr env0 expr + ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps + ; return (env1, SyntaxExpr { syn_expr = expr' + , syn_arg_wraps = arg_wraps' + , syn_res_wrap = res_wrap' }) } + +------------------------------------------------------------------------- zonkLCmd :: ZonkEnv -> LHsCmd TcId -> TcM (LHsCmd Id) zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id) @@ -798,11 +837,14 @@ zonkCmd env (HsCmdCase expr ms) return (HsCmdCase new_expr new_ms) zonkCmd env (HsCmdIf eCond ePred cThen cElse) - = do { new_eCond <- fmapMaybeM (zonkExpr env) eCond - ; new_ePred <- zonkLExpr env ePred - ; new_cThen <- zonkLCmd env cThen - ; new_cElse <- zonkLCmd env cElse + = do { (env1, new_eCond) <- zonkWit env eCond + ; new_ePred <- zonkLExpr env1 ePred + ; new_cThen <- zonkLCmd env1 cThen + ; new_cElse <- zonkLCmd env1 cElse ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) } + where + zonkWit env Nothing = return (env, Nothing) + zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w zonkCmd env (HsCmdLet (L l binds) cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds @@ -896,70 +938,81 @@ zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody zonkStmt :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id))) -zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op) - = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs +zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty) + = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op + ; new_bind_ty <- zonkTcTypeToType env1 bind_ty + ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs] - env1 = extendIdZonkEnvRec env new_binders - ; new_mzip <- zonkExpr env1 mzip_op - ; new_bind <- zonkExpr env1 bind_op - ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) } + env2 = extendIdZonkEnvRec env1 new_binders + ; new_mzip <- zonkExpr env2 mzip_op + ; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) } where - zonk_branch (ParStmtBlock stmts bndrs return_op) - = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts - ; new_return <- zonkExpr env1 return_op - ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) } + zonk_branch env1 (ParStmtBlock stmts bndrs return_op) + = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts + ; (env3, new_return) <- zonkSyntaxExpr env2 return_op + ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) } zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs - , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id + , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id + , recS_bind_fn = bind_id, recS_bind_ty = bind_ty , recS_later_rets = later_rets, recS_rec_rets = rec_rets , recS_ret_ty = ret_ty }) - = do { new_rvs <- zonkIdBndrs env rvs - ; new_lvs <- zonkIdBndrs env lvs - ; new_ret_ty <- zonkTcTypeToType env ret_ty - ; new_ret_id <- zonkExpr env ret_id - ; new_mfix_id <- zonkExpr env mfix_id - ; new_bind_id <- zonkExpr env bind_id - ; let env1 = extendIdZonkEnvRec env new_rvs - ; (env2, new_segStmts) <- zonkStmts env1 zBody segStmts + = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id + ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id + ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id + ; new_bind_ty <- zonkTcTypeToType env3 bind_ty + ; new_rvs <- zonkIdBndrs env3 rvs + ; new_lvs <- zonkIdBndrs env3 lvs + ; new_ret_ty <- zonkTcTypeToType env3 ret_ty + ; let env4 = extendIdZonkEnvRec env3 new_rvs + ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt - ; new_later_rets <- mapM (zonkExpr env2) later_rets - ; new_rec_rets <- mapM (zonkExpr env2) rec_rets - ; return (extendIdZonkEnvRec env new_lvs, -- Only the lvs are needed + ; new_later_rets <- mapM (zonkExpr env5) later_rets + ; new_rec_rets <- mapM (zonkExpr env5) rec_rets + ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id + , recS_bind_ty = new_bind_ty , recS_later_rets = new_later_rets , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) } zonkStmt env zBody (BodyStmt body then_op guard_op ty) - = do new_body <- zBody env body - new_then <- zonkExpr env then_op - new_guard <- zonkExpr env guard_op - new_ty <- zonkTcTypeToType env ty - return (env, BodyStmt new_body new_then new_guard new_ty) + = do (env1, new_then_op) <- zonkSyntaxExpr env then_op + (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op + new_body <- zBody env2 body + new_ty <- zonkTcTypeToType env2 ty + return (env2, BodyStmt new_body new_then_op new_guard_op new_ty) zonkStmt env zBody (LastStmt body noret ret_op) - = do new_body <- zBody env body - new_ret <- zonkExpr env ret_op + = do (env1, new_ret) <- zonkSyntaxExpr env ret_op + new_body <- zBody env1 body return (env, LastStmt new_body noret new_ret) zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_form = form, trS_using = using - , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) - = do { (env', stmts') <- zonkStmts env zonkLExpr stmts - ; binderMap' <- mapM (zonkBinderMapEntry env') binderMap - ; by' <- fmapMaybeM (zonkLExpr env') by - ; using' <- zonkLExpr env using - ; return_op' <- zonkExpr env' return_op - ; bind_op' <- zonkExpr env' bind_op - ; liftM_op' <- zonkExpr env' liftM_op - ; let env'' = extendIdZonkEnvRec env' (map snd binderMap') - ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_bind_arg_ty = bind_arg_ty + , trS_fmap = liftM_op }) + = do { + ; (env1, bind_op') <- zonkSyntaxExpr env bind_op + ; bind_arg_ty' <- zonkTcTypeToType env1 bind_arg_ty + ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts + ; by' <- fmapMaybeM (zonkLExpr env2) by + ; using' <- zonkLExpr env2 using + + ; (env3, return_op') <- zonkSyntaxExpr env2 return_op + ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap + ; liftM_op' <- zonkExpr env3 liftM_op + ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap') + ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' , trS_by = by', trS_form = form, trS_using = using' - , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) } + , trS_ret = return_op', trS_bind = bind_op' + , trS_bind_arg_ty = bind_arg_ty' + , trS_fmap = liftM_op' }) } where - zonkBinderMapEntry env (oldBinder, newBinder) = do + zonkBinderMapEntry env (oldBinder, newBinder) = do let oldBinder' = zonkIdOcc env oldBinder newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') @@ -968,35 +1021,55 @@ zonkStmt env _ (LetStmt (L l binds)) = do (env1, new_binds) <- zonkLocalBinds env binds return (env1, LetStmt (L l new_binds)) -zonkStmt env zBody (BindStmt pat body bind_op fail_op) - = do { new_body <- zBody env body - ; (env1, new_pat) <- zonkPat env pat - ; new_bind <- zonkExpr env bind_op - ; new_fail <- zonkExpr env fail_op - ; return (env1, BindStmt new_pat new_body new_bind new_fail) } +zonkStmt env zBody (BindStmt pat body bind_op fail_op bind_ty) + = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op + ; new_bind_ty <- zonkTcTypeToType env1 bind_ty + ; new_body <- zBody env1 body + ; (env2, new_pat) <- zonkPat env1 pat + ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op + ; return (env2, BindStmt new_pat new_body new_bind new_fail new_bind_ty) } +-- Scopes: join > ops (in reverse order) > pats (in forward order) +-- > rest of stmts zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty) - = do { (env', args') <- zonk_args env args - ; new_mb_join <- traverse (zonkExpr env) mb_join - ; new_body_ty <- zonkTcTypeToType env' body_ty - ; return (env', ApplicativeStmt args' new_mb_join new_body_ty) } + = do { (env1, new_mb_join) <- zonk_join env mb_join + ; (env2, new_args) <- zonk_args env1 args + ; new_body_ty <- zonkTcTypeToType env2 body_ty + ; return (env2, ApplicativeStmt new_args new_mb_join new_body_ty) } where - zonk_args env [] = return (env, []) - zonk_args env ((op, arg) : groups) - = do { (env1, arg') <- zonk_arg env arg - ; op' <- zonkExpr env1 op - ; (env2, ss) <- zonk_args env1 groups - ; return (env2, (op', arg') : ss) } - - zonk_arg env (ApplicativeArgOne pat expr) - = do { (env1, new_pat) <- zonkPat env pat - ; new_expr <- zonkLExpr env expr - ; return (env1, ApplicativeArgOne new_pat new_expr) } - zonk_arg env (ApplicativeArgMany stmts ret pat) - = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts - ; new_ret <- zonkExpr env1 ret - ; (env2, new_pat) <- zonkPat env pat - ; return (env2, ApplicativeArgMany new_stmts new_ret new_pat) } + zonk_join env Nothing = return (env, Nothing) + zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j + + get_pat (_, ApplicativeArgOne pat _) = pat + get_pat (_, ApplicativeArgMany _ _ pat) = pat + + replace_pat pat (op, ApplicativeArgOne _ a) + = (op, ApplicativeArgOne pat a) + replace_pat pat (op, ApplicativeArgMany a b _) + = (op, ApplicativeArgMany a b pat) + + zonk_args env args + = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args) + ; (env2, new_pats) <- zonkPats env1 (map get_pat args) + ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) } + + -- these need to go backward, because if any operators are higher-rank, + -- later operators may introduce skolems that are in scope for earlier + -- arguments + zonk_args_rev env ((op, arg) : args) + = do { (env1, new_op) <- zonkSyntaxExpr env op + ; new_arg <- zonk_arg env1 arg + ; (env2, new_args) <- zonk_args_rev env1 args + ; return (env2, (new_op, new_arg) : new_args) } + zonk_args_rev env [] = return (env, []) + + zonk_arg env (ApplicativeArgOne pat expr) + = do { new_expr <- zonkLExpr env expr + ; return (ApplicativeArgOne pat new_expr) } + zonk_arg env (ApplicativeArgMany stmts ret pat) + = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts + ; new_ret <- zonkExpr env1 ret + ; return (ApplicativeArgMany new_stmts new_ret pat) } ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) @@ -1078,11 +1151,11 @@ zonk_pat env (ListPat pats ty Nothing) ; return (env', ListPat pats' ty' Nothing) } zonk_pat env (ListPat pats ty (Just (ty2,wit))) - = do { wit' <- zonkExpr env wit - ; ty2' <- zonkTcTypeToType env ty2 - ; ty' <- zonkTcTypeToType env ty - ; (env', pats') <- zonkPats env pats - ; return (env', ListPat pats' ty' (Just (ty2',wit'))) } + = do { (env', wit') <- zonkSyntaxExpr env wit + ; ty2' <- zonkTcTypeToType env' ty2 + ; ty' <- zonkTcTypeToType env' ty + ; (env'', pats') <- zonkPats env' pats + ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) } zonk_pat env (PArrPat pats ty) = do { ty' <- zonkTcTypeToType env ty @@ -1121,19 +1194,25 @@ zonk_pat env (SigPatOut pat ty) ; (env', pat') <- zonkPat env pat ; return (env', SigPatOut pat' ty') } -zonk_pat env (NPat (L l lit) mb_neg eq_expr) - = do { lit' <- zonkOverLit env lit - ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg - ; eq_expr' <- zonkExpr env eq_expr - ; return (env, NPat (L l lit') mb_neg' eq_expr') } - -zonk_pat env (NPlusKPat (L loc n) (L l lit) e1 e2) - = do { n' <- zonkIdBndr env n - ; lit' <- zonkOverLit env lit - ; e1' <- zonkExpr env e1 - ; e2' <- zonkExpr env e2 - ; return (extendIdZonkEnv1 env n', - NPlusKPat (L loc n') (L l lit') e1' e2') } +zonk_pat env (NPat (L l lit) mb_neg eq_expr ty) + = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr + ; (env2, mb_neg') <- case mb_neg of + Nothing -> return (env1, Nothing) + Just n -> second Just <$> zonkSyntaxExpr env1 n + + ; lit' <- zonkOverLit env2 lit + ; ty' <- zonkTcTypeToType env2 ty + ; return (env2, NPat (L l lit') mb_neg' eq_expr' ty') } + +zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty) + = do { (env1, e1') <- zonkSyntaxExpr env e1 + ; (env2, e2') <- zonkSyntaxExpr env1 e2 + ; n' <- zonkIdBndr env2 n + ; lit1' <- zonkOverLit env2 lit1 + ; lit2' <- zonkOverLit env2 lit2 + ; ty' <- zonkTcTypeToType env2 ty + ; return (extendIdZonkEnv1 env2 n', + NPlusKPat (L loc n') (L l lit1') lit2' e1' e2' ty') } zonk_pat env (CoPat co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index c752dba6a0..e438df5beb 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -854,7 +854,7 @@ tcInstBinderX mb_kind_info subst binder -- This is the *only* constraint currently handled in types. | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty = do { let origin = TypeEqOrigin { uo_actual = k1 - , uo_expected = k2 + , uo_expected = mkCheckExpType k2 , uo_thing = Nothing } ; co <- case role of Nominal -> unifyKind noThing k1 k2 @@ -938,7 +938,7 @@ checkExpectedKind :: TcType -- the type whose kind we're checking checkExpectedKind ty act_kind exp_kind = do { (ty', act_kind') <- instantiate ty act_kind exp_kind ; let origin = TypeEqOrigin { uo_actual = act_kind' - , uo_expected = exp_kind + , uo_expected = mkCheckExpType exp_kind , uo_thing = Just $ mkTypeErrorThing ty' } ; co_k <- uType origin KindLevel act_kind' exp_kind @@ -2011,7 +2011,7 @@ tcHsPatSigType ctxt sig_ty tcPatSig :: Bool -- True <=> pattern binding -> LHsSigWcType Name - -> TcSigmaType + -> ExpSigmaType -> TcM (TcType, -- The type to use for "inside" the signature [TcTyVar], -- The new bit of type environment, binding -- the scoped type variables @@ -2027,7 +2027,7 @@ tcPatSig in_pat_bind sig res_ty ; if null sig_tvs then do { -- Just do the subsumption check and return wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubType_NC PatSigCtxt res_ty sig_ty + tcSubTypeET_NC PatSigCtxt res_ty sig_ty ; return (sig_ty, [], sig_wcs, wrap) } else do -- Type signature binds at least one scoped type variable @@ -2050,7 +2050,7 @@ tcPatSig in_pat_bind sig res_ty -- Now do a subsumption check of the pattern signature against res_ty ; wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubType_NC PatSigCtxt res_ty sig_ty + tcSubTypeET_NC PatSigCtxt res_ty sig_ty -- Phew! ; return (sig_ty, sig_tvs, sig_wcs, wrap) @@ -2058,6 +2058,7 @@ tcPatSig in_pat_bind sig res_ty where mk_msg sig_ty tidy_env = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty + ; res_ty <- readExpType res_ty -- should be filled in by now ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty ; let msg = vcat [ hang (text "When checking that the pattern signature:") 4 (ppr sig_ty) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 241e1f1ec5..50850ae16c 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1379,7 +1379,8 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys meth_ty = idType local_meth_id ; tc_sig <- instTcTySig ctxt lhs_ty sig_ty (idName local_meth_id) ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty meth_ty) $ - tcSubType ctxt (Just global_meth_id) sig_ty meth_ty + tcSubType ctxt (Just global_meth_id) sig_ty + (mkCheckExpType meth_ty) ; return (tc_sig, hs_wrap) } ; Nothing -> do { tc_sig <- instTcTySigFromId local_meth_id diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index b7fe68c53c..3d9e57c682 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -20,17 +20,20 @@ module TcMType ( newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] newOpenFlexiTyVarTy, - newReturnTyVar, newReturnTyVarTy, - newOpenReturnTyVar, newMetaKindVar, newMetaKindVars, cloneMetaTyVar, newFmvTyVar, newFskTyVar, - tauTvForReturnTv, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar, -------------------------------- + -- Expected types + ExpType(..), ExpSigmaType, ExpRhoType, + mkCheckExpType, newOpenInferExpType, readExpType, readExpType_maybe, + writeExpType, expTypeToType, checkingExpType_maybe, checkingExpType, + + -------------------------------- -- Creating fresh type variables for pm checking genInstSkolTyVarsX, @@ -105,6 +108,7 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Maybes import Data.List ( mapAccumL, partition ) +import Control.Arrow ( second ) {- ************************************************************************ @@ -271,6 +275,137 @@ checkCoercionHole co h r t1 t2 | otherwise = return co +{- +************************************************************************ +* + Expected types +* +************************************************************************ + +Note [ExpType] +~~~~~~~~~~~~~~ + +An ExpType is used as the "expected type" when type-checking an expression. +An ExpType can hold a "hole" that can be filled in by the type-checker. +This allows us to have one tcExpr that works in both checking mode and +synthesis mode (that is, bidirectional type-checking). Previously, this +was achieved by using ordinary unification variables, but we don't need +or want that generality. (For example, #11397 was caused by doing the +wrong thing with unification variables.) Instead, we observe that these +holes should + +1. never be nested +2. never appear as the type of a variable +3. be used linearly (never be duplicated) + +By defining ExpType, separately from Type, we can achieve goals 1 and 2 +statically. + +See also [wiki:Typechecking] + +Note [TcLevel of ExpType] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data G a where + MkG :: G Bool + + foo MkG = True + +This is a classic untouchable-variable / ambiguous GADT return type +scenario. But, with ExpTypes, we'll be inferring the type of the RHS. +And, because there is only one branch of the case, we won't trigger +Note [Case branches must never infer a non-tau type] of TcMatches. +We thus must track a TcLevel in an Inferring ExpType. If we try to +fill the ExpType and find that the TcLevels don't work out, we +fill the ExpType with a tau-tv at the low TcLevel, hopefully to +be worked out later by some means. This is triggered in +test gadt/gadt-escape1. + +-} + +-- actual data definition is in TcType + +-- | Make an 'ExpType' suitable for inferring a type of kind * or #. +newOpenInferExpType :: TcM ExpType +newOpenInferExpType + = do { lev <- newFlexiTyVarTy levityTy + ; u <- newUnique + ; tclvl <- getTcLevel + ; let ki = tYPE lev + ; traceTc "newOpenInferExpType" (ppr u <+> dcolon <+> ppr ki) + ; ref <- newMutVar Nothing + ; return (Infer u tclvl ki ref) } + +-- | Extract a type out of an ExpType, if one exists. But one should always +-- exist. Unless you're quite sure you know what you're doing. +readExpType_maybe :: ExpType -> TcM (Maybe TcType) +readExpType_maybe (Check ty) = return (Just ty) +readExpType_maybe (Infer _ _ _ ref) = readMutVar ref + +-- | Extract a type out of an ExpType. Otherwise, panics. +readExpType :: ExpType -> TcM TcType +readExpType exp_ty + = do { mb_ty <- readExpType_maybe exp_ty + ; case mb_ty of + Just ty -> return ty + Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) } + +-- | Write into an 'ExpType'. It must be an 'Infer'. +writeExpType :: ExpType -> TcType -> TcM () +writeExpType (Infer u tc_lvl ki ref) ty + | debugIsOn + = do { ki1 <- zonkTcType (typeKind ty) + ; ki2 <- zonkTcType ki + ; MASSERT2( ki1 `eqType` ki2, ppr ki1 $$ ppr ki2 $$ ppr u ) + ; lvl_now <- getTcLevel + ; MASSERT2( tc_lvl == lvl_now, ppr u $$ ppr tc_lvl $$ ppr lvl_now ) + ; cts <- readTcRef ref + ; case cts of + Just already_there -> pprPanic "writeExpType" + (vcat [ ppr u + , ppr ty + , ppr already_there ]) + Nothing -> write } + | otherwise + = write + where + write = do { traceTc "Filling ExpType" $ + ppr u <+> text ":=" <+> ppr ty + ; writeTcRef ref (Just ty) } +writeExpType (Check ty1) ty2 = pprPanic "writeExpType" (ppr ty1 $$ ppr ty2) + +-- | Returns the expected type when in checking mode. +checkingExpType_maybe :: ExpType -> Maybe TcType +checkingExpType_maybe (Check ty) = Just ty +checkingExpType_maybe _ = Nothing + +-- | Returns the expected type when in checking mode. Panics if in inference +-- mode. +checkingExpType :: String -> ExpType -> TcType +checkingExpType _ (Check ty) = ty +checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et) + +-- | Extracts the expected type if there is one, or generates a new +-- TauTv if there isn't. +expTypeToType :: ExpType -> TcM TcType +expTypeToType (Check ty) = return ty +expTypeToType (Infer u tc_lvl ki ref) + = do { uniq <- newUnique + ; tv_ref <- newMutVar Flexi + ; let details = MetaTv { mtv_info = TauTv + , mtv_ref = tv_ref + , mtv_tclvl = tc_lvl } + name = mkMetaTyVarName uniq (fsLit "t") + tau_tv = mkTcTyVar name ki details + tau = mkTyVarTy tau_tv + -- can't use newFlexiTyVarTy because we need to set the tc_lvl + -- See also Note [TcLevel of ExpType] + + ; writeMutVar ref (Just tau) + ; traceTc "Forcing ExpType to be monomorphic:" + (ppr u <+> dcolon <+> ppr ki <+> text ":=" <+> ppr tau) + ; return tau } {- ************************************************************************ @@ -391,7 +526,8 @@ instSkolTyCoVarsX mk_tcv = mapAccumLM (instSkolTyCoVarX mk_tcv) instSkolTyCoVarX :: (Unique -> Name -> Kind -> TyCoVar) -> TCvSubst -> TyCoVar -> TcRnIf gbl lcl (TCvSubst, TyCoVar) instSkolTyCoVarX mk_tcv subst tycovar - = do { uniq <- newUnique + = do { uniq <- newUnique -- using a new unique is critical. See + -- Note [Skolems in zonkSyntaxExpr] in TcHsSyn ; let new_tv = mk_tcv uniq old_name kind ; return (extendTCvSubst (extendTCvInScope subst new_tv) tycovar (mk_ty_co new_tv) @@ -575,23 +711,6 @@ genInstSkolTyVarsX loc subst tvs = instSkolTyCoVarsX (mkTcSkolTyVar loc False) s * * ************************************************************************ -Note [Sort-polymorphic tyvars accept foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is a common paradigm: - foo :: (forall a. a -> a) -> Int - foo = error "urk" -To make this work we need to instantiate 'error' with a polytype. -A similar case is - bar :: Bool -> (forall a. a->a) -> Int - bar True = \x. (x 3) - bar False = error "urk" -Here we need to instantiate 'error' with a polytype. - -But 'error' has an sort-polymorphic type variable, precisely so that -we can instantiate it with Int#. So we also allow such type variables -to be instantiate with foralls. It's a bit of a hack, but seems -straightforward. - Note [Never need to instantiate coercion variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With coercion variables sloshing around in types, it might seem that we @@ -612,7 +731,6 @@ newAnonMetaTyVar meta_info kind = do { uniq <- newUnique ; let name = mkMetaTyVarName uniq s s = case meta_info of - ReturnTv -> fsLit "r" TauTv -> fsLit "t" FlatMetaTv -> fsLit "fmv" SigTv -> fsLit "a" @@ -630,43 +748,12 @@ newFlexiTyVarTy kind = do newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) -newReturnTyVar :: Kind -> TcM TcTyVar -newReturnTyVar kind = newAnonMetaTyVar ReturnTv kind - -newReturnTyVarTy :: Kind -> TcM TcType -newReturnTyVarTy kind = mkTyVarTy <$> newReturnTyVar kind - -- | Create a tyvar that can be a lifted or unlifted type. newOpenFlexiTyVarTy :: TcM TcType newOpenFlexiTyVarTy = do { lev <- newFlexiTyVarTy levityTy ; newFlexiTyVarTy (tYPE lev) } --- | Create a *return* tyvar that can be a lifted or unlifted type. -newOpenReturnTyVar :: TcM (TcTyVar, TcKind) -newOpenReturnTyVar - = do { lev <- newFlexiTyVarTy levityTy -- this doesn't need ReturnTv - ; let k = tYPE lev - ; tv <- newReturnTyVar k - ; return (tv, k) } - --- | If the type is a ReturnTv, fill it with a new meta-TauTv. Otherwise, --- no change. This function can look through ReturnTvs and returns a partially --- zonked type as an optimisation. -tauTvForReturnTv :: TcType -> TcM TcType -tauTvForReturnTv ty - | Just tv <- tcGetTyVar_maybe ty - , isReturnTyVar tv - = do { contents <- readMetaTyVar tv - ; case contents of - Flexi -> do { tau_ty <- newFlexiTyVarTy (tyVarKind tv) - ; writeMetaTyVar tv tau_ty - ; return tau_ty } - Indirect ty -> tauTvForReturnTv ty } - | otherwise - = ASSERT( all (not . isReturnTyVar) (tyCoVarsOfTypeList ty) ) - return ty - newMetaSigTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) newMetaSigTyVars = mapAccumLM newMetaSigTyVarX emptyTCvSubst @@ -685,10 +772,7 @@ newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -- an existing TyVar. We substitute kind variables in the kind. newMetaTyVarX subst tyvar = do { uniq <- newUnique - -- See Note [Levity polymorphic variables accept foralls] - ; let info | isLevityPolymorphic (tyVarKind tyvar) = ReturnTv - | otherwise = TauTv - ; details <- newMetaDetails info + ; details <- newMetaDetails TauTv ; let name = mkSystemName uniq (getOccName tyvar) -- See Note [Name of an instantiated type variable] kind = substTyUnchecked subst (tyVarKind tyvar) @@ -715,23 +799,6 @@ newMetaSigTyVarX subst tyvar At the moment we give a unification variable a System Name, which influences the way it is tidied; see TypeRep.tidyTyVarBndr. -Note [Levity polymorphic variables accept foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is a common paradigm: - foo :: (forall a. a -> a) -> Int - foo = error "urk" -To make this work we need to instantiate 'error' with a polytype. -A similar case is - bar :: Bool -> (forall a. a->a) -> Int - bar True = \x. (x 3) - bar False = error "urk" -Here we need to instantiate 'error' with a polytype. - -But 'error' has a levity polymorphic type variable, precisely so that -we can instantiate it with Int#. So we also allow such type variables -to be instantiated with foralls. It's a bit of a hack, but seems -straightforward. - ************************************************************************ * * Quantification @@ -1103,8 +1170,9 @@ zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) ; return (ctev { ctev_pred = pred' }) } zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo -zonkSkolemInfo (SigSkol cx ty) = do { ty' <- zonkTcType ty - ; return (SigSkol cx ty') } +zonkSkolemInfo (SigSkol cx ty) = do { ty <- readExpType ty + ; ty' <- zonkTcType ty + ; return (SigSkol cx (mkCheckExpType ty')) } zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys ; return (InferSkol ntys') } where @@ -1222,16 +1290,22 @@ zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act , uo_expected = exp , uo_thing = m_thing }) = do { (env1, act') <- zonkTidyTcType env act - ; (env2, exp') <- zonkTidyTcType env1 exp + ; mb_exp <- readExpType_maybe exp -- it really should be filled in. + -- unless we're debugging. + ; (env2, exp') <- case mb_exp of + Just ty -> second mkCheckExpType <$> zonkTidyTcType env1 ty + Nothing -> return (env1, exp) ; (env3, m_thing') <- zonkTidyErrorThing env2 m_thing ; return ( env3, orig { uo_actual = act' , uo_expected = exp' , uo_thing = m_thing' }) } -zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k) - = do { (env1, ty1') <- zonkTidyTcType env ty1 - ; (env2, ty2') <- zonkTidyTcType env1 ty2 - ; (env3, orig') <- zonkTidyOrigin env2 orig - ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } +zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k) + = do { (env1, ty1') <- zonkTidyTcType env ty1 + ; (env2, m_ty2') <- case m_ty2 of + Just ty2 -> second Just <$> zonkTidyTcType env1 ty2 + Nothing -> return (env1, Nothing) + ; (env3, orig') <- zonkTidyOrigin env2 orig + ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) } zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2) = do { (env1, p1') <- zonkTidyTcType env p1 ; (env2, p2') <- zonkTidyTcType env1 p2 @@ -1278,7 +1352,9 @@ tidyEvVar env var = setVarType var (tidyType env (varType var)) ---------------- tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty) +tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (mkCheckExpType $ + tidyType env $ + checkingExpType "tidySkolemInfo" ty) tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) tidySkolemInfo _ info = info diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index f4d2e12951..e7da8adeab 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -45,6 +45,7 @@ import qualified GHC.LanguageExtensions as LangExt import MkCore import Control.Monad +import Control.Arrow ( second ) #include "HsVersions.h" @@ -69,7 +70,7 @@ See Note [sig_tau may be polymorphic] in TcPat. tcMatchesFun :: Name -> MatchGroup Name (LHsExpr Name) - -> TcSigmaType -- Expected type of function + -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) -- Returns type of body tcMatchesFun fun_name matches exp_ty @@ -82,13 +83,17 @@ tcMatchesFun fun_name matches exp_ty traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) ; checkArgs fun_name matches - ; exp_ty <- tauifyMultipleMatches matches exp_ty ; (wrap_gen, (wrap_fun, group)) - <- tcSkolemise (FunSigCtxt fun_name True) exp_ty $ \ _ exp_rho -> + <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho -> -- Note [Polymorphic expected type for tcMatchesFun] - do { (wrap_fun, pat_tys, rhs_ty) - <- matchExpectedFunTys herald arity exp_rho - ; matches' <- tcMatches match_ctxt pat_tys rhs_ty matches + do { (matches', wrap_fun) + <- matchExpectedFunTys herald arity exp_rho $ + \ pat_tys rhs_ty -> + -- See Note [Case branches must never infer a non-tau type] + do { rhs_ty : pat_tys + <- mapM (tauifyMultipleMatches matches) + (rhs_ty : pat_tys) + ; tcMatches match_ctxt pat_tys rhs_ty matches } ; return (wrap_fun, matches') } ; return (wrap_gen <.> wrap_fun, group) } where @@ -106,25 +111,30 @@ tcMatchesCase :: (Outputable (body Name)) => TcMatchCtxt body -- Case context -> TcSigmaType -- Type of scrutinee -> MatchGroup Name (Located (body Name)) -- The case alternatives - -> TcRhoType -- Type of whole case expressions + -> ExpRhoType -- Type of whole case expressions -> TcM (MatchGroup TcId (Located (body TcId))) -- Translated alternatives -- wrapper goes from MatchGroup's ty to expected ty tcMatchesCase ctxt scrut_ty matches res_ty = do { res_ty <- tauifyMultipleMatches matches res_ty - ; tcMatches ctxt [scrut_ty] res_ty matches } + ; tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches } tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify -> TcMatchCtxt HsExpr -> MatchGroup Name (LHsExpr Name) - -> TcRhoType -- deeply skolemised + -> ExpRhoType -- deeply skolemised -> TcM (HsWrapper, [TcSigmaType], MatchGroup TcId (LHsExpr TcId)) -- also returns the argument types tcMatchLambda herald match_ctxt match res_ty - = do { res_ty <- tauifyMultipleMatches match res_ty - ; (wrap, pat_tys, rhs_ty) <- matchExpectedFunTys herald n_pats res_ty - ; match' <- tcMatches match_ctxt pat_tys rhs_ty match + = do { ((match', pat_tys), wrap) + <- matchExpectedFunTys herald n_pats res_ty $ + \ pat_tys rhs_ty -> + do { rhs_ty : pat_tys <- mapM (tauifyMultipleMatches match) + (rhs_ty : pat_tys) + ; match' <- tcMatches match_ctxt pat_tys rhs_ty match + ; pat_tys <- mapM readExpType pat_tys + ; return (match', pat_tys) } ; return (wrap, pat_tys, match') } where n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case @@ -135,7 +145,7 @@ tcMatchLambda herald match_ctxt match res_ty tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType -> TcM (GRHSs TcId (LHsExpr TcId)) -- Used for pattern bindings -tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty +tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty) where match_ctxt = MC { mc_what = PatBindRhs, mc_body = tcBody } @@ -147,8 +157,8 @@ tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty * * ************************************************************************ -Note [Case branches must be taus] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Case branches must never infer a non-tau type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider case ... of @@ -159,16 +169,17 @@ Should that type-check? The problem is that, if we check the second branch first, then we'll get a type (b -> b) for the branches, which won't unify with the polytype in the first branch. If we check the first branch first, then everything is OK. This order-dependency is terrible. So we want only -proper tau-types in branches. This is what tauTvForReturnsTv ensures: -it gets rid of those pesky ReturnTvs that might unify with polytypes. +proper tau-types in branches (unless a sigma-type is pushed down). +This is what expTypeToType ensures: it replaces an Infer with a fresh +tau-type. An even trickier case looks like f x True = x undefined f x False = x () -Here, we see that the arguments must also be non-ReturnTvs. Thus, we must -tauify before calling matchFunTys. +Here, we see that the arguments must also be non-Infer. Thus, we must +use expTypeToType on the output of matchExpectedFunTys, not the input. But we make a special case for a one-branch case. This is so that @@ -177,25 +188,28 @@ But we make a special case for a one-branch case. This is so that still gets assigned a polytype. -} --- | When the MatchGroup has multiple RHSs, convert any ReturnTvs in the +-- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the -- expected type into TauTvs. --- See Note [Case branches must be taus] +-- See Note [Case branches must never infer a non-tau type] tauifyMultipleMatches :: MatchGroup id body - -> TcType - -> TcM TcType + -> ExpType + -> TcM ExpType tauifyMultipleMatches group exp_ty | isSingletonMatchGroup group = return exp_ty | otherwise - = tauTvForReturnTv exp_ty + = mkCheckExpType <$> expTypeToType exp_ty + -- NB: This also ensures that an empty match still fills in the + -- ExpType -- | Type-check a MatchGroup. If there are multiple RHSs, the expected type --- must already be tauified. See Note [Case branches must be taus] and --- tauifyMultipleMatches +-- must already be tauified. +-- See Note [Case branches must never infer a non-tau type] +-- about tauifyMultipleMatches tcMatches :: (Outputable (body Name)) => TcMatchCtxt body - -> [TcSigmaType] -- Expected pattern types - -> TcRhoType -- Expected result-type of the Match. + -> [ExpSigmaType] -- Expected pattern types + -> ExpRhoType -- Expected result-type of the Match. -> MatchGroup Name (Located (body Name)) -> TcM (MatchGroup TcId (Located (body TcId))) @@ -203,12 +217,14 @@ data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is mc_body :: Located (body Name) -- Type checker for a body of -- an alternative - -> TcRhoType + -> ExpRhoType -> TcM (Located (body TcId)) } tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches , mg_origin = origin }) = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches + ; pat_tys <- mapM readExpType pat_tys + ; rhs_ty <- readExpType rhs_ty ; return (MG { mg_alts = L l matches' , mg_arg_tys = pat_tys , mg_res_ty = rhs_ty @@ -216,8 +232,8 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches ------------- tcMatch :: (Outputable (body Name)) => TcMatchCtxt body - -> [TcSigmaType] -- Expected pattern types - -> TcRhoType -- Expected result-type of the Match. + -> [ExpSigmaType] -- Expected pattern types + -> ExpRhoType -- Expected result-type of the Match. -> LMatch Name (Located (body Name)) -> TcM (LMatch TcId (Located (body TcId))) @@ -245,7 +261,7 @@ tcMatch ctxt pat_tys rhs_ty match m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside ------------- -tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> TcRhoType +tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> ExpRhoType -> TcM (GRHSs TcId (Located (body TcId))) -- Notice that we pass in the full res_ty, so that we get @@ -262,7 +278,7 @@ tcGRHSs ctxt (GRHSs grhss (L l binds)) res_ty ; return (GRHSs grhss' (L l binds')) } ------------- -tcGRHS :: TcMatchCtxt body -> TcRhoType -> GRHS Name (Located (body Name)) +tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS Name (Located (body Name)) -> TcM (GRHS TcId (Located (body TcId))) tcGRHS ctxt res_ty (GRHS guards rhs) @@ -283,35 +299,42 @@ tcGRHS ctxt res_ty (GRHS guards rhs) tcDoStmts :: HsStmtContext Name -> Located [LStmt Name (LHsExpr Name)] - -> TcRhoType + -> ExpRhoType -> TcM (HsExpr TcId) -- Returns a HsDo tcDoStmts ListComp (L l stmts) res_ty - = do { (co, elt_ty) <- matchExpectedListTy res_ty + = do { res_ty <- expTypeToType res_ty + ; (co, elt_ty) <- matchExpectedListTy res_ty ; let list_ty = mkListTy elt_ty - ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty + ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts + (mkCheckExpType elt_ty) ; return $ mkHsWrapCo co (HsDo ListComp (L l stmts') list_ty) } tcDoStmts PArrComp (L l stmts) res_ty - = do { (co, elt_ty) <- matchExpectedPArrTy res_ty + = do { res_ty <- expTypeToType res_ty + ; (co, elt_ty) <- matchExpectedPArrTy res_ty ; let parr_ty = mkPArrTy elt_ty - ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty + ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts + (mkCheckExpType elt_ty) ; return $ mkHsWrapCo co (HsDo PArrComp (L l stmts') parr_ty) } tcDoStmts DoExpr (L l stmts) res_ty = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty + ; res_ty <- readExpType res_ty ; return (HsDo DoExpr (L l stmts') res_ty) } tcDoStmts MDoExpr (L l stmts) res_ty = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty + ; res_ty <- readExpType res_ty ; return (HsDo MDoExpr (L l stmts') res_ty) } tcDoStmts MonadComp (L l stmts) res_ty = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty + ; res_ty <- readExpType res_ty ; return (HsDo MonadComp (L l stmts') res_ty) } tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) -tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) +tcBody :: LHsExpr Name -> ExpRhoType -> TcM (LHsExpr TcId) tcBody body res_ty = do { traceTc "tcBody" (ppr res_ty) ; tcMonoExpr body res_ty @@ -325,20 +348,20 @@ tcBody body res_ty ************************************************************************ -} -type TcExprStmtChecker = TcStmtChecker HsExpr -type TcCmdStmtChecker = TcStmtChecker HsCmd +type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType +type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType -type TcStmtChecker body +type TcStmtChecker body rho_type = forall thing. HsStmtContext Name -> Stmt Name (Located (body Name)) - -> TcRhoType -- Result type for comprehension - -> (TcRhoType -> TcM thing) -- Checker for what follows the stmt + -> rho_type -- Result type for comprehension + -> (rho_type -> TcM thing) -- Checker for what follows the stmt -> TcM (Stmt TcId (Located (body TcId)), thing) tcStmts :: (Outputable (body Name)) => HsStmtContext Name - -> TcStmtChecker body -- NB: higher-rank type + -> TcStmtChecker body rho_type -- NB: higher-rank type -> [LStmt Name (Located (body Name))] - -> TcRhoType + -> rho_type -> TcM [LStmt TcId (Located (body TcId))] tcStmts ctxt stmt_chk stmts res_ty = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ @@ -346,10 +369,10 @@ tcStmts ctxt stmt_chk stmts res_ty ; return stmts' } tcStmtsAndThen :: (Outputable (body Name)) => HsStmtContext Name - -> TcStmtChecker body -- NB: higher-rank type + -> TcStmtChecker body rho_type -- NB: higher-rank type -> [LStmt Name (Located (body Name))] - -> TcRhoType - -> (TcRhoType -> TcM thing) + -> rho_type + -> (rho_type -> TcM thing) -> TcM ([LStmt TcId (Located (body TcId))], thing) -- Note the higher-rank type. stmt_chk is applied at different @@ -394,17 +417,17 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside tcGuardStmt :: TcExprStmtChecker tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside - = do { guard' <- tcMonoExpr guard boolTy + = do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy) ; thing <- thing_inside res_ty ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) } -tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside +tcGuardStmt ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferSigmaNC rhs -- Stmt has a context already ; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (exprCtOrigin (unLoc rhs)) - pat rhs_ty $ + pat (mkCheckExpType rhs_ty) $ thing_inside res_ty - ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + ; return (mkTcBindStmt pat' rhs', thing) } tcGuardStmt _ stmt _ _ = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) @@ -433,23 +456,23 @@ tcLcStmt _ _ (LastStmt body noret _) elt_ty thing_inside ; return (LastStmt body' noret noSyntaxExpr, thing) } -- A generator, pat <- rhs -tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside +tcLcStmt m_tc ctxt (BindStmt pat rhs _ _ _) elt_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty]) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + ; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty]) + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ thing_inside elt_ty - ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + ; return (mkTcBindStmt pat' rhs', thing) } -- A boolean guard tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside - = do { rhs' <- tcMonoExpr rhs boolTy + = do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy) ; thing <- thing_inside elt_ty ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } -- ParStmt: See notes with tcMcStmt -tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _) elt_ty thing_inside +tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside = do { (pairs', thing) <- loop bndr_stmts_s - ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr, thing) } + ; return (ParStmt pairs' noExpr noSyntaxExpr unitTy, thing) } where -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing) loop [] = do { thing <- thing_inside elt_ty @@ -518,9 +541,13 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts -- these new binders and return the result ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) - ; return (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' - , trS_by = fmap fst by', trS_using = final_using - , trS_form = form }, thing) } + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = fmap fst by', trS_using = final_using + , trS_ret = noSyntaxExpr + , trS_bind = noSyntaxExpr + , trS_fmap = noExpr + , trS_bind_arg_ty = unitTy + , trS_form = form }, thing) } tcLcStmt _ _ stmt _ _ = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) @@ -534,10 +561,10 @@ tcLcStmt _ _ stmt _ _ tcMcStmt :: TcExprStmtChecker tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside - = do { a_ty <- newFlexiTyVarTy liftedTypeKind - ; return_op' <- tcSyntaxOp MCompOrigin return_op - (a_ty `mkFunTy` res_ty) - ; body' <- tcMonoExprNC body a_ty + = do { (body', return_op') + <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ + \ [a_ty] -> + tcMonoExprNC body (mkCheckExpType a_ty) ; thing <- thing_inside (panic "tcMcStmt: thing_inside") ; return (LastStmt body' noret return_op', thing) } @@ -547,24 +574,22 @@ tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside -- q :: a -- -tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside - = do { rhs_ty <- newFlexiTyVarTy liftedTypeKind - ; pat_ty <- newFlexiTyVarTy liftedTypeKind - ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - +tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - ; bind_op' <- tcSyntaxOp MCompOrigin bind_op - (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty) - - ; rhs' <- tcMonoExprNC rhs rhs_ty - - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ - thing_inside new_res_ty + = do { ((rhs', pat', thing, new_res_ty), bind_op') + <- tcSyntaxOp MCompOrigin bind_op + [SynRho, SynFun SynAny SynRho] res_ty $ + \ [rhs_ty, pat_ty, new_res_ty] -> + do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat + (mkCheckExpType pat_ty) $ + thing_inside (mkCheckExpType new_res_ty) + ; return (rhs', pat', thing, new_res_ty) } -- If (but only if) the pattern can fail, typecheck the 'fail' operator ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty - ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } + ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) } -- Boolean expressions. -- @@ -575,15 +600,16 @@ tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside -- guard_op :: test_ty -> rhs_ty -- then_op :: rhs_ty -> new_res_ty -> res_ty -- Where test_ty is, for example, Bool - test_ty <- newFlexiTyVarTy liftedTypeKind - ; rhs_ty <- newFlexiTyVarTy liftedTypeKind - ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcMonoExpr rhs test_ty - ; guard_op' <- tcSyntaxOp MCompOrigin guard_op - (mkFunTy test_ty rhs_ty) - ; then_op' <- tcSyntaxOp MCompOrigin then_op - (mkFunTys [rhs_ty, new_res_ty] res_ty) - ; thing <- thing_inside new_res_ty + ; ((thing, rhs', rhs_ty, guard_op'), then_op') + <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $ + \ [rhs_ty, new_res_ty] -> + do { (rhs', guard_op') + <- tcSyntaxOp MCompOrigin guard_op [SynAny] + (mkCheckExpType rhs_ty) $ + \ [test_ty] -> + tcMonoExpr rhs (mkCheckExpType test_ty) + ; thing <- thing_inside (mkCheckExpType new_res_ty) + ; return (thing, rhs', rhs_ty, guard_op') } ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) } -- Grouping statements @@ -638,31 +664,36 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- We don't know what tuple_ty is yet, so we use a variable ; let (bndr_names, n_bndr_names) = unzip bindersMap ; (stmts', (bndr_ids, by', return_op')) <- - tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do + tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts + (mkCheckExpType using_arg_ty) $ \res_ty' -> do { by' <- case by of Nothing -> return Nothing - Just e -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') } + Just e -> do { e' <- tcMonoExpr e + (mkCheckExpType by_e_ty) + ; return (Just e') } -- Find the Ids (and hence types) of all old binders ; bndr_ids <- tcLookupLocalIds bndr_names -- 'return' is only used for the binders, so we know its type. -- return :: (a,b,c,..) -> m (a,b,c,..) - ; return_op' <- tcSyntaxOp MCompOrigin return_op $ - (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty' + ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op + [synKnownType (mkBigCoreVarTupTy bndr_ids)] + res_ty' $ \ _ -> return () ; return (bndr_ids, by', return_op') } --------------- Typecheck the 'bind' function ------------- -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ - using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty) - `mkFunTy` res_ty + ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op + [ synKnownType using_res_ty + , synKnownType (n_app tup_ty `mkFunTy` new_res_ty) ] + res_ty $ \ _ -> return () --------------- Typecheck the 'fmap' function ------------- ; fmap_op' <- case form of - ThenForm -> return noSyntaxExpr + ThenForm -> return noExpr _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ mkNamedForAllTy alphaTyVar Invisible $ mkNamedForAllTy betaTyVar Invisible $ @@ -688,11 +719,13 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- Type check the thing in the environment with -- these new binders and return the result - ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside new_res_ty) + ; thing <- tcExtendIdEnv n_bndr_ids $ + thing_inside (mkCheckExpType new_res_ty) ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' , trS_by = by', trS_using = final_using , trS_ret = return_op', trS_bind = bind_op' + , trS_bind_arg_ty = n_app tup_ty , trS_fmap = fmap_op', trS_form = form }, thing) } -- A parallel set of comprehensions @@ -724,7 +757,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call -- -> m (st1, (st2, st3)) -- -tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op) res_ty thing_inside +tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind ; m_ty <- newFlexiTyVarTy star_star_kind @@ -736,41 +769,53 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op) res_ty thing_inside (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty - ; (blocks', thing) <- loop m_ty bndr_stmts_s + -- type dummies since we don't know all binder types yet + ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) + [ names | ParStmtBlock _ names _ <- bndr_stmts_s ] -- Typecheck bind: - ; let tys = [ mkBigCoreVarTupTy bs | ParStmtBlock _ bs _ <- blocks'] - tuple_ty = mk_tuple_ty tys + ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ] + tuple_ty = mk_tuple_ty tup_tys - ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ - (m_ty `mkAppTy` tuple_ty) - `mkFunTy` (tuple_ty `mkFunTy` res_ty) - `mkFunTy` res_ty + ; (((blocks', thing), inner_res_ty), bind_op') + <- tcSyntaxOp MCompOrigin bind_op + [ synKnownType (m_ty `mkAppTy` tuple_ty) + , SynFun (synKnownType tuple_ty) SynRho ] res_ty $ + \ [inner_res_ty] -> + do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) + tup_tys bndr_stmts_s + ; return (stuff, inner_res_ty) } - ; return (ParStmt blocks' mzip_op' bind_op', thing) } + ; return (ParStmt blocks' mzip_op' bind_op' inner_res_ty, thing) } where mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys -- loop :: Type -- m_ty - -- -> [([LStmt Name], [Name])] + -- -> ExpRhoType -- inner_res_ty + -- -> [TcType] -- tup_tys + -- -> [ParStmtBlock Name] -- -> TcM ([([LStmt TcId], [TcId])], thing) - loop _ [] = do { thing <- thing_inside res_ty - ; return ([], thing) } -- matching in the branches + loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty + ; return ([], thing) } + -- matching in the branches - loop m_ty (ParStmtBlock stmts names return_op : pairs) - = do { -- type dummy since we don't know all binder types yet - id_tys <- mapM (const (newFlexiTyVarTy liftedTypeKind)) names - ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreTupTy id_tys + loop m_ty inner_res_ty (tup_ty_in : tup_tys_in) + (ParStmtBlock stmts names return_op : pairs) + = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in ; (stmts', (ids, return_op', pairs', thing)) - <- tcStmtsAndThen ctxt tcMcStmt stmts m_tup_ty $ \m_tup_ty' -> + <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ + \m_tup_ty' -> do { ids <- tcLookupLocalIds names ; let tup_ty = mkBigCoreVarTupTy ids - ; return_op' <- tcSyntaxOp MCompOrigin return_op - (tup_ty `mkFunTy` m_tup_ty') - ; (pairs', thing) <- loop m_ty pairs + ; (_, return_op') <- + tcSyntaxOp MCompOrigin return_op + [synKnownType tup_ty] m_tup_ty' $ + \ _ -> return () + ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs ; return (ids, return_op', pairs', thing) } ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) } + loop _ _ _ _ = panic "tcMcStmt.loop" tcMcStmt _ stmt _ _ = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) @@ -788,58 +833,47 @@ tcDoStmt _ (LastStmt body noret _) res_ty thing_inside ; thing <- thing_inside (panic "tcDoStmt: thing_inside") ; return (LastStmt body' noret noSyntaxExpr, thing) } -tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside +tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside = do { -- Deal with rebindable syntax: -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty -- This level of generality is needed for using do-notation -- in full generality; see Trac #1537 - -- I'd like to put this *after* the tcSyntaxOp - -- (see Note [Treat rebindable syntax first], but that breaks - -- the rigidity info for GADTs. When we move to the new story - -- for GADTs, we can move this after tcSyntaxOp - rhs_ty <- newFlexiTyVarTy liftedTypeKind - ; pat_ty <- newFlexiTyVarTy liftedTypeKind - ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - ; bind_op' <- tcSyntaxOp DoOrigin bind_op - (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty) - - ; rhs' <- tcMonoExprNC rhs rhs_ty - - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ - thing_inside new_res_ty + ((rhs', pat', new_res_ty, thing), bind_op') + <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $ + \ [rhs_ty, pat_ty, new_res_ty] -> + do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat + (mkCheckExpType pat_ty) $ + thing_inside (mkCheckExpType new_res_ty) + ; return (rhs', pat', new_res_ty, thing) } -- If (but only if) the pattern can fail, typecheck the 'fail' operator ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty - ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } + ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) } tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside - = do { - ; (mb_join', rhs_ty) <- case mb_join of - Nothing -> return (Nothing, res_ty) + = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ + thing_inside . mkCheckExpType + ; ((pairs', body_ty, thing), mb_join') <- case mb_join of + Nothing -> (, Nothing) <$> tc_app_stmts res_ty Just join_op -> - do { rhs_ty <- newFlexiTyVarTy liftedTypeKind - ; join_op' <- tcSyntaxOp DoOrigin join_op - (mkFunTy rhs_ty res_ty) - ; return (Just join_op', rhs_ty) } - - ; (pairs', body_ty, thing) <- - tcApplicativeStmts ctxt pairs rhs_ty thing_inside + second Just <$> + (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ + \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty)) ; return (ApplicativeStmt pairs' mb_join' body_ty, thing) } tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside = do { -- Deal with rebindable syntax; -- (>>) :: rhs_ty -> new_res_ty -> res_ty - -- See also Note [Treat rebindable syntax first] - rhs_ty <- newFlexiTyVarTy liftedTypeKind - ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - ; then_op' <- tcSyntaxOp DoOrigin then_op - (mkFunTys [rhs_ty, new_res_ty] res_ty) - - ; rhs' <- tcMonoExprNC rhs rhs_ty - ; thing <- thing_inside new_res_ty + ; ((rhs', rhs_ty, thing), then_op') + <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ + \ [rhs_ty, new_res_ty] -> + do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) + ; thing <- thing_inside (mkCheckExpType new_res_ty) + ; return (rhs', rhs_ty, thing) } ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) } tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names @@ -852,24 +886,35 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names tup_ty = mkBigCoreTupTy tup_elt_tys ; tcExtendIdEnv tup_ids $ do - { stmts_ty <- newFlexiTyVarTy liftedTypeKind + { stmts_ty <- newOpenInferExpType ; (stmts', (ret_op', tup_rets)) - <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty -> - do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys + <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ + \ inner_res_ty -> + do { tup_rets <- zipWithM tcCheckId tup_names + (map mkCheckExpType tup_elt_tys) -- Unify the types of the "final" Ids (which may -- be polymorphic) with those of "knot-tied" Ids - ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty) + ; (_, ret_op') + <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] + inner_res_ty $ \_ -> return () ; return (ret_op', tup_rets) } - - ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind - ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op - (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty) - - ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - ; bind_op' <- tcSyntaxOp DoOrigin bind_op - (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty) - - ; thing <- thing_inside new_res_ty + ; stmts_ty <- readExpType stmts_ty + + ; mfix_res_ty <- newOpenInferExpType + ; (_, mfix_op') + <- tcSyntaxOp DoOrigin mfix_op + [synKnownType (mkFunTy tup_ty stmts_ty)] mfix_res_ty $ + \ _ -> return () + ; mfix_res_ty <- readExpType mfix_res_ty + + ; ((thing, new_res_ty), bind_op') + <- tcSyntaxOp DoOrigin bind_op + [ synKnownType mfix_res_ty + , synKnownType tup_ty `SynFun` SynRho ] + res_ty $ + \ [new_res_ty] -> + do { thing <- thing_inside (mkCheckExpType new_res_ty) + ; return (thing, new_res_ty) } ; let rec_ids = takeList rec_names tup_ids ; later_ids <- tcLookupLocalIds later_names @@ -878,6 +923,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' + , recS_bind_ty = new_res_ty , recS_later_rets = [], recS_rec_rets = tup_rets , recS_ret_ty = stmts_ty }, thing) }} @@ -887,20 +933,6 @@ tcDoStmt _ stmt _ _ -{- -Note [Treat rebindable syntax first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking - do { bar; ... } :: IO () -we want to typecheck 'bar' in the knowledge that it should be an IO thing, -pushing info from the context into the RHS. To do this, we check the -rebindable syntax first, and push that information into (tcMonoExprNC rhs). -Otherwise the error shows up when cheking the rebindable syntax, and -the expected/inferred stuff is back to front (see Trac #3613). --} - - - --------------------------------------------------- -- MonadFail Proposal warnings --------------------------------------------------- @@ -912,9 +944,9 @@ the expected/inferred stuff is back to front (see Trac #3613). tcMonadFailOp :: CtOrigin -> LPat TcId - -> HsExpr Name -- The fail op + -> SyntaxExpr Name -- The fail op -> TcType -- Type of the whole do-expression - -> TcRn (HsExpr TcId) -- Typechecked fail op + -> TcRn (SyntaxExpr TcId) -- Typechecked fail op -- Get a 'fail' operator expression, to use if the pattern -- match fails. If the pattern is irrefutatable, just return -- noSyntaxExpr; it won't be used @@ -935,7 +967,8 @@ tcMonadFailOp orig pat fail_op res_ty -> return () -- Get the fail op itself - ; tcSyntaxOp orig fail_op (mkFunTy stringTy res_ty) } + ; snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] + (mkCheckExpType res_ty) $ \_ -> return ()) } emitMonadFailConstraint :: LPat TcId -> TcType -> TcRn () emitMonadFailConstraint pat res_ty @@ -959,6 +992,16 @@ warnRebindableClash pattern = addWarnAt (getLoc pattern) text "compile with -Wno-missing-monadfail-instances.")) {- +Note [Treat rebindable syntax first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking + do { bar; ... } :: IO () +we want to typecheck 'bar' in the knowledge that it should be an IO thing, +pushing info from the context into the RHS. To do this, we check the +rebindable syntax first, and push that information into (tcMonoExprNC rhs). +Otherwise the error shows up when cheking the rebindable syntax, and +the expected/inferred stuff is back to front (see Trac #3613). + Note [typechecking ApplicativeStmt] join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en) @@ -978,15 +1021,15 @@ join :: tn -> res_ty -} tcApplicativeStmts :: HsStmtContext Name - -> [(HsExpr Name, ApplicativeArg Name Name)] - -> Type -- rhs_ty - -> (Type -> TcM t) -- thing_inside - -> TcM ([(HsExpr TcId, ApplicativeArg TcId TcId)], Type, t) + -> [(SyntaxExpr Name, ApplicativeArg Name Name)] + -> ExpRhoType -- rhs_ty + -> (TcRhoType -> TcM t) -- thing_inside + -> TcM ([(SyntaxExpr TcId, ApplicativeArg TcId TcId)], Type, t) tcApplicativeStmts ctxt pairs rhs_ty thing_inside = do { body_ty <- newFlexiTyVarTy liftedTypeKind ; let arity = length pairs - ; ts <- replicateM (arity-1) $ newFlexiTyVarTy liftedTypeKind + ; ts <- replicateM (arity-1) $ newOpenInferExpType ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind ; let fun_ty = mkFunTys pat_tys body_ty @@ -1003,7 +1046,11 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside where goOps _ [] = return [] goOps t_left ((op,t_i,exp_ty) : ops) - = do { op' <- tcSyntaxOp DoOrigin op (mkFunTys [t_left, exp_ty] t_i) + = do { (_, op') + <- tcSyntaxOp DoOrigin op + [synKnownType t_left, synKnownType exp_ty] t_i $ + \ _ -> return () + ; t_i <- readExpType t_i ; ops' <- goOps t_i ops ; return (op' : ops') } @@ -1018,12 +1065,12 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside } goArgs ((ApplicativeArgOne pat rhs, pat_ty, exp_ty) : rest) thing_inside = do { let stmt :: ExprStmt Name - stmt = BindStmt pat rhs noSyntaxExpr noSyntaxExpr + stmt = mkBindStmt pat rhs ; setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ addErrCtxt (pprStmtInCtxt ctxt stmt) $ - do { rhs' <- tcMonoExprNC rhs exp_ty + do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty) ; (pat',(pairs, thing)) <- - tcPat (StmtCtxt ctxt) pat pat_ty $ + tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ popErrCtxt $ goArgs rest thing_inside ; return (ApplicativeArgOne pat' rhs' : pairs, thing) } } @@ -1031,10 +1078,11 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside goArgs ((ApplicativeArgMany stmts ret pat, pat_ty, exp_ty) : rest) thing_inside = do { (stmts', (ret',pat',rest',thing)) <- - tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \res_ty -> do + tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ + \res_ty -> do { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty ; (pat',(rest', thing)) <- - tcPat (StmtCtxt ctxt) pat pat_ty $ + tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ goArgs rest thing_inside ; return (ret', pat', rest', thing) } diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot index 5fea21d53d..a45cbbed91 100644 --- a/compiler/typecheck/TcMatches.hs-boot +++ b/compiler/typecheck/TcMatches.hs-boot @@ -2,7 +2,7 @@ module TcMatches where import HsSyn ( GRHSs, MatchGroup, LHsExpr ) import TcEvidence( HsWrapper ) import Name ( Name ) -import TcType ( TcRhoType ) +import TcType ( ExpRhoType, TcRhoType ) import TcRnTypes( TcM, TcId ) --import SrcLoc ( Located ) @@ -12,5 +12,5 @@ tcGRHSsPat :: GRHSs Name (LHsExpr Name) tcMatchesFun :: Name -> MatchGroup Name (LHsExpr Name) - -> TcRhoType + -> ExpRhoType -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 42581a6c5d..fc93f1cf01 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -6,7 +6,7 @@ TcPat: Typechecking patterns -} -{-# LANGUAGE CPP, RankNTypes #-} +{-# LANGUAGE CPP, RankNTypes, TupleSections #-} module TcPat ( tcLetPat , TcPragEnv, lookupPragEnv, emptyPragEnv @@ -16,7 +16,7 @@ module TcPat ( tcLetPat #include "HsVersions.h" -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferSigma ) +import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) import HsSyn import TcHsSyn @@ -49,6 +49,7 @@ import Outputable import Maybes( orElse ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad +import Control.Arrow ( second ) {- ************************************************************************ @@ -59,7 +60,7 @@ import Control.Monad -} tcLetPat :: TcSigFun -> LetBndrSpec - -> LPat Name -> TcSigmaType + -> LPat Name -> ExpSigmaType -> TcM a -> TcM (LPat TcId, a) tcLetPat sig_fn no_gen pat pat_ty thing_inside @@ -72,7 +73,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside ----------------- tcPats :: HsMatchContext Name -> [LPat Name] -- Patterns, - -> [TcSigmaType] -- and their types + -> [ExpSigmaType] -- and their types -> TcM a -- and the checker for the body -> TcM ([LPat TcId], a) @@ -93,7 +94,7 @@ tcPats ctxt pats pat_tys thing_inside penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } tcPat :: HsMatchContext Name - -> LPat Name -> TcSigmaType + -> LPat Name -> ExpSigmaType -> TcM a -- Checker for body -> TcM (LPat TcId, a) tcPat ctxt = tcPat_O ctxt PatOrigin @@ -101,7 +102,7 @@ tcPat ctxt = tcPat_O ctxt PatOrigin -- | A variant of 'tcPat' that takes a custom origin tcPat_O :: HsMatchContext Name -> CtOrigin -- ^ origin to use if the type needs inst'ing - -> LPat Name -> TcSigmaType + -> LPat Name -> ExpSigmaType -> TcM a -- Checker for body -> TcM (LPat TcId, a) tcPat_O ctxt orig pat pat_ty thing_inside @@ -157,7 +158,7 @@ lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] * * ********************************************************************* -} -tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (TcCoercionN, TcId) +tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (TcCoercionN, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) -- @@ -172,12 +173,14 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty ; return (co, bndr_id) } | otherwise - = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty + = do { pat_ty <- expTypeToType pat_ty + ; bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty ; traceTc "tcPatBndr(no-sig)" (ppr bndr_id $$ ppr (idType bndr_id)) ; return (mkTcNomReflCo pat_ty, bndr_id) } tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty - = return (mkTcNomReflCo pat_ty, mkLocalId bndr_name pat_ty) + = do { pat_ty <- expTypeToType pat_ty + ; return (mkTcNomReflCo pat_ty, mkLocalId bndr_name pat_ty) } -- whether or not there is a sig is irrelevant, as this -- is local @@ -298,7 +301,7 @@ tcMultiple tc_pat args penv thing_inside -------------------- tc_lpat :: LPat Name - -> TcSigmaType + -> ExpSigmaType -> PatEnv -> TcM a -> TcM (LPat TcId, a) @@ -309,7 +312,7 @@ tc_lpat (L span pat) pat_ty penv thing_inside ; return (L span pat', res) } tc_lpats :: PatEnv - -> [LPat Name] -> [TcSigmaType] + -> [LPat Name] -> [ExpSigmaType] -> TcM a -> TcM ([LPat TcId], a) tc_lpats penv pats tys thing_inside @@ -321,7 +324,7 @@ tc_lpats penv pats tys thing_inside -------------------- tc_pat :: PatEnv -> Pat Name - -> TcSigmaType -- Fully refined result type + -> ExpSigmaType -- Fully refined result type -> TcM a -- Thing inside -> TcM (Pat TcId, -- Translated pattern a) -- Result of thing inside @@ -329,6 +332,7 @@ tc_pat :: PatEnv tc_pat penv (VarPat (L l name)) pat_ty thing_inside = do { (co, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside + ; pat_ty <- readExpType pat_ty ; return (mkHsWrapPatCo co (VarPat (L l id)) pat_ty, res) } tc_pat penv (ParPat pat) pat_ty thing_inside @@ -354,19 +358,21 @@ tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside lazyUnliftedPatErr lpat -- Check that the expected pattern type is itself lifted - ; pat_ty' <- newFlexiTyVarTy liftedTypeKind - ; _ <- unifyType noThing pat_ty pat_ty' + ; pat_ty <- readExpType pat_ty + ; _ <- unifyType noThing (typeKind pat_ty) liftedTypeKind ; return (LazyPat pat', res) } tc_pat _ (WildPat _) pat_ty thing_inside = do { res <- thing_inside + ; pat_ty <- expTypeToType pat_ty ; return (WildPat pat_ty, res) } tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside = do { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ - tc_lpat pat (idType bndr_id) penv thing_inside + tc_lpat pat (mkCheckExpType $ idType bndr_id) + penv thing_inside -- NB: if we do inference on: -- \ (y@(x::forall a. a->a)) = e -- we'll fail. The as-pattern infers a monotype for 'y', which then @@ -374,6 +380,7 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside -- perhaps be fixed, but only with a bit more work. -- -- If you fix it, don't forget the bindInstsOfPatIds! + ; pat_ty <- readExpType pat_ty ; return (mkHsWrapPatCo co (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside @@ -382,15 +389,27 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside -- where overall_pat_ty is an instance of OPT'. ; (expr',expr'_inferred) <- tcInferSigma expr - -- next, we check that expr is coercible to `overall_pat_ty -> pat_ty` - ; (expr_wrap, pat_ty) <- tcInfer $ \ pat_ty -> - tcSubTypeDS_O (exprCtOrigin (unLoc expr)) GenSigCtxt (Just expr) - expr'_inferred - (mkFunTy overall_pat_ty pat_ty) - - -- pattern must have pat_ty - ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside - + -- expression must be a function + ; let expr_orig = exprCtOrigin (unLoc expr) + herald = text "A view pattern expression expects" + ; (expr_wrap1, [inf_arg_ty], inf_res_ty) + <- matchActualFunTys herald expr_orig (Just expr) 1 expr'_inferred + -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty) + + -- check that overall pattern is more polymorphic than arg type + ; let pat_origin = GivenOrigin (SigSkol GenSigCtxt overall_pat_ty) + ; expr_wrap2 <- tcSubTypeET pat_origin overall_pat_ty inf_arg_ty + -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty + + -- pattern must have inf_res_ty + ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside + + ; overall_pat_ty <- readExpType overall_pat_ty + ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper + overall_pat_ty inf_res_ty + -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->" + -- (overall_pat_ty -> inf_res_ty) + expr_wrap = expr_wrap2' <.> expr_wrap1 ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) } -- Type signatures in patterns @@ -400,31 +419,37 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside sig_ty pat_ty ; (pat', res) <- tcExtendTyVarEnv2 wcs $ tcExtendTyVarEnv tv_binds $ - tc_lpat pat inner_ty penv thing_inside + tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside + ; pat_ty <- readExpType pat_ty ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } ------------------------ -- Lists, tuples, arrays tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty - ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty) + ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside + ; pat_ty <- readExpType pat_ty ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res) } tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside - = do { list_pat_ty <- newFlexiTyVarTy liftedTypeKind - ; e' <- tcSyntaxOp ListOrigin e (mkFunTy pat_ty list_pat_ty) - ; (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv list_pat_ty - ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty) - pats penv thing_inside - ; return (mkHsWrapPat coi (ListPat pats' elt_ty (Just (pat_ty,e'))) list_pat_ty, res) + = do { tau_pat_ty <- expTypeToType pat_ty + ; ((pats', res, elt_ty), e') + <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] + SynList $ + \ [elt_ty] -> + do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) + pats penv thing_inside + ; return (pats', res, elt_ty) } + ; return (ListPat pats' elt_ty (Just (tau_pat_ty,e')), res) } tc_pat penv (PArrPat pats _) pat_ty thing_inside = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy penv pat_ty - ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty) + ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside + ; pat_ty <- readExpType pat_ty ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res) } @@ -437,7 +462,8 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside -- See Note [Unboxed tuple levity vars] in TyCon ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys Boxed -> arg_tys - ; (pats', res) <- tc_lpats penv pats con_arg_tys thing_inside + ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys) + thing_inside ; dflags <- getDynFlags @@ -453,6 +479,7 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside isBoxed boxity = LazyPat (noLoc unmangled_result) | otherwise = unmangled_result + ; pat_ty <- readExpType pat_ty ; ASSERT( length con_arg_tys == length pats ) -- Syntactically enforced return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) } @@ -469,58 +496,120 @@ tc_pat _ (LitPat simple_lit) pat_ty thing_inside ; co <- unifyPatType simple_lit lit_ty pat_ty -- coi is of kind: pat_ty ~ lit_ty ; res <- thing_inside + ; pat_ty <- readExpType pat_ty ; return ( mkHsWrapPatCo co (LitPat simple_lit) pat_ty , res) } ------------------------ -- Overloaded patterns: n, and n+k -tc_pat (PE { pe_orig = pat_orig }) - (NPat (L l over_lit) mb_neg eq) pat_ty thing_inside + +-- In the case of a negative literal (the more complicated case), +-- we get +-- +-- case v of (-5) -> blah +-- +-- becoming +-- +-- if v == (negate (fromInteger 5)) then blah else ... +-- +-- There are two bits of rebindable syntax: +-- (==) :: pat_ty -> neg_lit_ty -> Bool +-- negate :: lit_ty -> neg_lit_ty +-- where lit_ty is the type of the overloaded literal 5. +-- +-- When there is no negation, neg_lit_ty and lit_ty are the same +tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit - ; (wrap, lit') <- newOverloadedLit over_lit pat_ty pat_orig - ; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy) - ; mb_neg' <- case mb_neg of - Nothing -> return Nothing -- Positive literal - Just neg -> -- Negative literal - -- The 'negate' is re-mappable syntax - do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty) - ; return (Just neg') } + ; ((lit', mb_neg'), eq') + <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] + (mkCheckExpType boolTy) $ + \ [neg_lit_ty] -> + let new_over_lit lit_ty = newOverloadedLit over_lit + (mkCheckExpType lit_ty) + in case mb_neg of + Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty + Just neg -> -- Negative literal + -- The 'negate' is re-mappable syntax + second Just <$> + (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ + \ [lit_ty] -> new_over_lit lit_ty) + ; res <- thing_inside - ; return (mkHsWrapPat wrap (NPat (L l lit') mb_neg' eq') pat_ty, res) } + ; pat_ty <- readExpType pat_ty + ; return (NPat (L l lit') mb_neg' eq' pat_ty, res) } -tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) ge minus) pat_ty thing_inside - = do { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) - ; let pat_ty' = idType bndr_id - orig = LiteralOrigin lit - ; (wrap_lit, lit') <- newOverloadedLit lit pat_ty' (pe_orig penv) - - -- The '>=' and '-' parts are re-mappable syntax - ; ge' <- tcSyntaxOp orig ge (mkFunTys [pat_ty', pat_ty'] boolTy) - ; minus' <- tcSyntaxOp orig minus (mkFunTys [pat_ty', pat_ty'] pat_ty') - ; let pat' = mkHsWrapPat wrap_lit - (NPlusKPat (L nm_loc bndr_id) - (L loc lit') - ge' minus') - pat_ty +{- +Note [NPlusK patterns] +~~~~~~~~~~~~~~~~~~~~~~ +From + + case v of x + 5 -> blah + +we get + + if v >= 5 then (\x -> blah) (v - 5) else ... + +There are two bits of rebindable syntax: + (>=) :: pat_ty -> lit1_ty -> Bool + (-) :: pat_ty -> lit2_ty -> var_ty + +lit1_ty and lit2_ty could conceivably be different. +var_ty is the type inferred for x, the variable in the pattern. + +If the pushed-down pattern type isn't a tau-type, the two pat_ty's above +could conceivably be different specializations. But this is very much +like the situation in Note [Case branches must be taus] in TcMatches. +So we tauify the pat_ty before proceeding. + +Note that we need to type-check the literal twice, because it is used +twice, and may be used at different types. The second HsOverLit stored in the +AST is used for the subtraction operation. +-} + +-- See Note [NPlusK patterns] +tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_inside + = do { pat_ty <- expTypeToType pat_ty + ; let orig = LiteralOrigin lit + ; (lit1', ge') + <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho] + (mkCheckExpType boolTy) $ + \ [lit1_ty] -> + newOverloadedLit lit (mkCheckExpType lit1_ty) + ; ((lit2', minus_wrap, bndr_id), minus') + <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $ + \ [lit2_ty, var_ty] -> + do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) + ; (co, bndr_id) <- setSrcSpan nm_loc $ + tcPatBndr penv name (mkCheckExpType var_ty) + -- co :: var_ty ~ idType bndr_id + + -- minus_wrap is applicable to minus' + ; return (lit2', mkWpCastN co, bndr_id) } -- The Report says that n+k patterns must be in Integral - -- We may not want this when using re-mappable syntax, though (ToDo?) - ; icls <- tcLookupClass integralClassName - ; instStupidTheta orig [mkClassPred icls [pat_ty']] + -- but it's silly to insist on this in the RebindableSyntax case + ; unlessM (xoptM LangExt.RebindableSyntax) $ + do { icls <- tcLookupClass integralClassName + ; instStupidTheta orig [mkClassPred icls [pat_ty]] } ; res <- tcExtendIdEnv1 name bndr_id thing_inside - ; return (mkHsWrapPatCo co pat' pat_ty, res) } + + ; let minus'' = minus' { syn_res_wrap = + minus_wrap <.> syn_res_wrap minus' } + pat' = NPlusKPat (L nm_loc bndr_id) (L loc lit1') lit2' + ge' minus'' pat_ty + ; return (pat', res) } tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut ---------------- -unifyPatType :: Outputable a => a -> TcType -> TcType -> TcM TcCoercion +unifyPatType :: Outputable a => a -> TcType -> ExpSigmaType -> TcM TcCoercion -- In patterns we want a coercion from the -- context type (expected) to the actual pattern type -- But we don't want to reverse the args to unifyType because -- that controls the actual/expected stuff in error messages unifyPatType thing actual_ty expected_ty - = do { coi <- unifyType (Just thing) actual_ty expected_ty + = do { coi <- unifyExpType (Just thing) actual_ty expected_ty ; return (mkTcSymCo coi) } {- @@ -613,7 +702,7 @@ to express the local scope of GADT refinements. -- with scrutinee of type (T ty) tcConPat :: PatEnv -> Located Name - -> TcRhoType -- Type of the pattern + -> ExpSigmaType -- Type of the pattern -> HsConPatDetails Name -> TcM a -> TcM (Pat TcId, a) tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside @@ -626,7 +715,7 @@ tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside } tcDataConPat :: PatEnv -> Located Name -> DataCon - -> TcRhoType -- Type of the pattern + -> ExpSigmaType -- Type of the pattern -> HsConPatDetails Name -> TcM a -> TcM (Pat TcId, a) tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside @@ -640,6 +729,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside -- This may involve doing a family-instance coercion, -- and building a wrapper ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty + ; pat_ty <- readExpType pat_ty -- Add the stupid theta ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys @@ -709,7 +799,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside } } tcPatSynPat :: PatEnv -> Located Name -> PatSyn - -> TcRhoType -- Type of the pattern + -> ExpSigmaType -- Type of the pattern -> HsConPatDetails Name -> TcM a -> TcM (Pat TcId, a) tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside @@ -725,7 +815,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside prov_theta' = substTheta tenv prov_theta req_theta' = substTheta tenv req_theta - ; wrap <- mkWpCastN <$> unifyType noThing ty' pat_ty + ; wrap <- tcSubTypeO (pe_orig penv) GenSigCtxt ty' pat_ty ; traceTc "tcPatSynPat" (ppr pat_syn $$ ppr pat_ty $$ ppr ty' $$ @@ -756,16 +846,18 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside pat_args = arg_pats', pat_arg_tys = mkTyVarTys univ_tvs', pat_wrap = req_wrap } + ; pat_ty <- readExpType pat_ty ; return (mkHsWrapPat wrap res_pat pat_ty, res) } ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a)) - -> PatEnv -> TcSigmaType -> TcM (HsWrapper, a) + -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a) -- See Note [Matching polytyped patterns] -- Returns a wrapper : pat_ty ~R inner_ty matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty - = do { (wrap, pat_rho) <- topInstantiate orig pat_ty + = do { pat_ty <- expTypeToType pat_ty + ; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (co, res) <- inner_match pat_rho ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap) ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) } @@ -776,9 +868,9 @@ matchExpectedConTy :: PatEnv -- constructor actually returns -- In the case of a data family this is -- the /representation/ TyCon - -> TcSigmaType -- The type of the pattern; in the case - -- of a data family this would mention - -- the /family/ TyCon + -> ExpSigmaType -- The type of the pattern; in the case + -- of a data family this would mention + -- the /family/ TyCon -> TcM (HsWrapper, [TcSigmaType]) -- See Note [Matching constructor patterns] -- Returns a wrapper : pat_ty "->" T ty1 ... tyn @@ -786,7 +878,8 @@ matchExpectedConTy (PE { pe_orig = orig }) data_tc pat_ty | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc -- Comments refer to Note [Matching constructor patterns] -- co_tc :: forall a. T [a] ~ T7 a - = do { (wrap, pat_ty) <- topInstantiate orig pat_ty + = do { pat_ty <- expTypeToType pat_ty + ; (wrap, pat_ty) <- topInstantiate orig pat_ty ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc) -- tys = [ty1,ty2] @@ -808,7 +901,8 @@ matchExpectedConTy (PE { pe_orig = orig }) data_tc pat_ty , tys') } | otherwise - = do { (wrap, pat_rho) <- topInstantiate orig pat_ty + = do { pat_ty <- expTypeToType pat_ty + ; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } @@ -904,7 +998,7 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside tcConArg :: Checker (LPat Name, TcSigmaType) (LPat Id) tcConArg (arg_pat, arg_ty) penv thing_inside - = tc_lpat arg_pat arg_ty penv thing_inside + = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside addDataConStupidTheta :: DataCon -> [TcType] -> TcM () -- Instantiate the "stupid theta" of the data con, and throw diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 03cbf6762f..461fea3620 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -187,12 +187,13 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, ; tcCheckPatSynPat lpat ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details - ; (tclvl, wanted, (lpat', (args, pat_ty))) + ; (tclvl, wanted, ((lpat', args), pat_ty)) <- pushLevelAndCaptureConstraints $ - do { pat_ty <- newOpenFlexiTyVarTy - ; tcPat PatSyn lpat pat_ty $ - do { args <- mapM tcLookupId arg_names - ; return (args, pat_ty) } } + do { pat_ty <- newOpenInferExpType + ; stuff <- tcPat PatSyn lpat pat_ty $ + mapM tcLookupId arg_names + ; pat_ty <- readExpType pat_ty + ; return (stuff, pat_ty) } ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args @@ -222,7 +223,8 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details , patsig_arg_tys = arg_tys, patsig_body_ty = pat_ty } = addPatSynCtxt lname $ do { let origin = PatOrigin -- TODO - skol_info = SigSkol (PatSynCtxt name) (mkFunTys arg_tys pat_ty) + skol_info = SigSkol (PatSynCtxt name) (mkCheckExpType $ + mkFunTys arg_tys pat_ty) decl_arity = length arg_names ty_arity = length arg_tys (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details @@ -241,9 +243,9 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details ; req_dicts <- newEvVars req_theta ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <- ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys ) - pushLevelAndCaptureConstraints $ - tcExtendTyVarEnv univ_tvs $ - tcPat PatSyn lpat pat_ty $ + pushLevelAndCaptureConstraints $ + tcExtendTyVarEnv univ_tvs $ + tcPat PatSyn lpat (mkCheckExpType pat_ty) $ do { (subst, ex_tvs') <- if isUnidirectional dir then newMetaTyVars ex_tvs else newMetaSigTyVars ex_tvs @@ -830,8 +832,8 @@ tcPatToExpr args = go ; return $ ExplicitTuple (map (noLoc . Present) exprs) box } go1 (LitPat lit) = return $ HsLit lit - go1 (NPat (L _ n) Nothing _) = return $ HsOverLit n - go1 (NPat (L _ n) (Just neg) _) = return $ noLoc neg `HsApp` noLoc (HsOverLit n) + go1 (NPat (L _ n) Nothing _ _) = return $ HsOverLit n + go1 (NPat (L _ n) (Just neg) _ _)= return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)] go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" go1 (SigPatOut{}) = panic "SigPatOut in output of renamer" go1 (CoPat{}) = panic "CoPat in output of renamer" @@ -862,7 +864,7 @@ tcCollectEx pat = go pat goConDetails $ pat_args con go1 (SigPatOut p _) = go p go1 (CoPat _ p _) = go1 p - go1 (NPlusKPat n k geq subtract) + go1 (NPlusKPat n k _ geq subtract _) = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract go1 _ = mempty diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index efb703c953..d56c2c6d99 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1476,7 +1476,8 @@ check_main dflags tcg_env explicit_mod_hdr ; main_expr <- addErrCtxt mainCtxt $ tcMonoExpr (L loc (HsVar (L loc main_name))) - (mkTyConApp ioTyCon [res_ty]) + (mkCheckExpType $ + mkTyConApp ioTyCon [res_ty]) -- See Note [Root-main Id] -- Construct the binding @@ -1791,12 +1792,13 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) -- [it <- e] bind_stmt = L loc $ BindStmt (L loc (VarPat (L loc fresh_it))) (nlHsApp ghciStep rn_expr) - (HsVar (L loc bindIOName)) + (mkRnSyntaxExpr bindIOName) noSyntaxExpr + PlaceHolder -- [; print it] print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) - (HsVar (L loc thenIOName)) + (mkRnSyntaxExpr thenIOName) noSyntaxExpr placeHolderType -- The plans are: @@ -1842,8 +1844,8 @@ tcUserStmt rdr_stmt@(L loc _) ; ghciStep <- getGhciStepIO ; let gi_stmt - | (L loc (BindStmt pat expr op1 op2)) <- rn_stmt - = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2 + | (L loc (BindStmt pat expr op1 op2 ty)) <- rn_stmt + = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2 ty | otherwise = rn_stmt ; opt_pr_flag <- goptM Opt_PrintBindResult @@ -1866,7 +1868,7 @@ tcUserStmt rdr_stmt@(L loc _) ; return stuff } where print_v = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar (L loc thenIOName)) noSyntaxExpr + (mkRnSyntaxExpr thenIOName) noSyntaxExpr placeHolderType -- | Typecheck the statements given and then return the results of the @@ -1878,7 +1880,8 @@ tcGhciStmts stmts let { ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts io_ret_ty ; + tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts + (mkCheckExpType io_ret_ty) ; names = collectLStmtsBinders stmts ; } ; diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 692e9f3f43..8cf0d748e3 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -1270,7 +1270,7 @@ captureConstraints thing_inside pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) pushLevelAndCaptureConstraints thing_inside = do { env <- getLclEnv - ; lie_var <- newTcRef emptyWC ; + ; lie_var <- newTcRef emptyWC ; let tclvl' = pushTcLevel (tcl_tclvl env) ; res <- setLclEnv (env { tcl_tclvl = tclvl' , tcl_lie = lie_var }) @@ -1279,7 +1279,7 @@ pushLevelAndCaptureConstraints thing_inside ; return (tclvl', lie, res) } pushTcLevelM_ :: TcM a -> TcM a -pushTcLevelM_ = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) +pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x pushTcLevelM :: TcM a -> TcM (a, TcLevel) pushTcLevelM thing_inside diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index ba07cf161d..9ede73d1b1 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -758,9 +758,15 @@ data TcIdBinder TopLevelFlag -- Tells whether the bindind is syntactically top-level -- (The monomorphic Ids for a recursive group count -- as not-top-level for this purpose.) + | TcIdBndr_ExpType -- Variant that allows the type to be specified as + -- an ExpType + Name + ExpType + TopLevelFlag instance Outputable TcIdBinder where - ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) + ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) + ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl) --------------------------- -- Template Haskell stages and levels @@ -2496,8 +2502,8 @@ mkGivenLoc tclvl skol_info env mkKindLoc :: TcType -> TcType -- original *types* being compared -> CtLoc -> CtLoc mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc) - (KindEqOrigin s1 s2 (ctLocOrigin loc) - (ctLocTypeOrKind_maybe loc)) + (KindEqOrigin s1 (Just s2) (ctLocOrigin loc) + (ctLocTypeOrKind_maybe loc)) -- | Take a CtLoc and moves it to the kind level toKindLoc :: CtLoc -> CtLoc @@ -2555,7 +2561,7 @@ pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) -- b) an implication constraint is generated data SkolemInfo = SigSkol UserTypeCtxt -- A skolem that is created by instantiating - Type -- a programmer-supplied type signature + ExpType -- a programmer-supplied type signature -- Location of the binding site is on the TyVar | ClsSkol Class -- Bound at a class decl @@ -2627,7 +2633,7 @@ pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty -- For Insts, these cases should not happen pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol" -pprSigSkolInfo :: UserTypeCtxt -> Type -> SDoc +pprSigSkolInfo :: UserTypeCtxt -> ExpType -> SDoc pprSigSkolInfo ctxt ty = case ctxt of FunSigCtxt f _ -> pp_sig f @@ -2671,13 +2677,13 @@ data CtOrigin -- function or instance | TypeEqOrigin { uo_actual :: TcType - , uo_expected :: TcType + , uo_expected :: ExpType , uo_thing :: Maybe ErrorThing -- ^ The thing that has type "actual" } | KindEqOrigin - TcType TcType -- A kind equality arising from unifying these two types + TcType (Maybe TcType) -- A kind equality arising from unifying these two types CtOrigin -- originally arising from this (Maybe TypeOrKind) -- the level of the eq this arises from @@ -2801,7 +2807,7 @@ exprCtOrigin (SectionL _ _) = SectionOrigin exprCtOrigin (SectionR _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" exprCtOrigin (HsCase _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf (Just syn) _ _ _) = exprCtOrigin syn +exprCtOrigin (HsIf (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ (L _ e)) = exprCtOrigin e @@ -2884,10 +2890,14 @@ pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) , hang (text "instance" <+> quotes (ppr pred2)) 2 (text "at" <+> ppr loc2) ]) -pprCtOrigin (KindEqOrigin t1 t2 _ _) +pprCtOrigin (KindEqOrigin t1 (Just t2) _ _) = hang (ctoHerald <+> text "a kind equality arising from") 2 (sep [ppr t1, char '~', ppr t2]) +pprCtOrigin (KindEqOrigin t1 Nothing _ _) + = hang (ctoHerald <+> text "a kind equality when matching") + 2 (ppr t1) + pprCtOrigin (UnboundOccurrenceOf name) = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name) diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index fe6561c306..55c8446da1 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -76,7 +76,8 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) tcExtendIdEnv id_bndrs $ do { -- See Note [Solve order for RULES] ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) - ; (rhs', rhs_wanted) <- captureConstraints (tcMonoExpr rhs rule_ty) + ; (rhs', rhs_wanted) <- captureConstraints $ + tcMonoExpr rhs (mkCheckExpType rule_ty) ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) } ; traceTc "tcRule 1" (vcat [ pprFullRuleName name diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index ac7e1b707d..4a39ee8de1 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -49,6 +49,8 @@ import THNames import TcUnify import TcEnv +import Control.Monad + #ifdef GHCI import GHCi.Message import GHCi.RemoteTypes @@ -138,9 +140,9 @@ import GHC.Exts ( unsafeCoerce# ) ************************************************************************ -} -tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) -tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId) -tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) +tcTypedBracket :: HsBracket Name -> ExpRhoType -> TcM (HsExpr TcId) +tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) +tcSpliceExpr :: HsSplice Name -> ExpRhoType -> TcM (HsExpr TcId) -- None of these functions add constraints to the LIE -- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) @@ -184,7 +186,7 @@ tcTypedBracket brack@(TExpBr expr) res_ty tcTypedBracket other_brack _ = pprPanic "tcTypedBracket" (ppr other_brack) --- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId) +-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) tcUntypedBracket brack ps res_ty = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) ; ps' <- mapM tcPendingSplice ps @@ -207,7 +209,7 @@ tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr" tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice tcPendingSplice (PendingRnSplice flavour splice_name expr) = do { res_ty <- tcMetaTy meta_ty_name - ; expr' <- tcMonoExpr expr res_ty + ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty) ; return (PendingTcSplice splice_name expr') } where meta_ty_name = case flavour of @@ -217,12 +219,18 @@ tcPendingSplice (PendingRnSplice flavour splice_name expr) UntypedDeclSplice -> decsQTyConName --------------- --- Takes a type tau and returns the type Q (TExp tau) +-- Takes a tau and returns the type Q (TExp tau) tcTExpTy :: TcType -> TcM TcType -tcTExpTy tau - = do { q <- tcLookupTyCon qTyConName +tcTExpTy exp_ty + = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty) + ; q <- tcLookupTyCon qTyConName ; texp <- tcLookupTyCon tExpTyConName - ; return (mkTyConApp q [mkTyConApp texp [tau]]) } + ; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) } + where + err_msg ty + = vcat [ text "Illegal polytype:" <+> ppr ty + , text "The type of a Typed Template Haskell expression must" <+> + text "not have any quantification." ] quotationCtxtDoc :: HsBracket Name -> SDoc quotationCtxtDoc br_body @@ -445,14 +453,15 @@ tcSpliceExpr splice _ = pprPanic "tcSpliceExpr" (ppr splice) tcNestedSplice :: ThStage -> PendingStuff -> Name - -> LHsExpr Name -> TcRhoType -> TcM (HsExpr Id) + -> LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id) -- See Note [How brackets and nested splices are handled] -- A splice inside brackets tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty - = do { meta_exp_ty <- tcTExpTy res_ty + = do { res_ty <- expTypeToType res_ty + ; meta_exp_ty <- tcTExpTy res_ty ; expr' <- setStage pop_stage $ setConstraintVar lie_var $ - tcMonoExpr expr meta_exp_ty + tcMonoExpr expr (mkCheckExpType meta_exp_ty) ; untypeq <- tcLookupId unTypeQName ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr' ; ps <- readMutVar ps_var @@ -464,13 +473,14 @@ tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty tcNestedSplice _ _ splice_name _ _ = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) -tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id) +tcTopSplice :: LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id) tcTopSplice expr res_ty = do { -- Typecheck the expression, -- making sure it has type Q (T res_ty) - meta_exp_ty <- tcTExpTy res_ty + res_ty <- expTypeToType res_ty + ; meta_exp_ty <- tcTExpTy res_ty ; zonked_q_expr <- tcTopSpliceExpr Typed $ - tcMonoExpr expr meta_exp_ty + tcMonoExpr expr (mkCheckExpType meta_exp_ty) -- Run the expression ; expr2 <- runMetaE zonked_q_expr @@ -484,7 +494,7 @@ tcTopSplice expr res_ty -- These steps should never fail; this is a *typed* splice ; addErrCtxt (spliceResultDoc expr) $ do { (exp3, _fvs) <- rnLExpr expr2 - ; exp4 <- tcMonoExpr exp3 res_ty + ; exp4 <- tcMonoExpr exp3 (mkCheckExpType res_ty) ; return (unLoc exp4) } } {- diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot index 743362024b..db4884e354 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ b/compiler/typecheck/TcSplice.hs-boot @@ -5,7 +5,7 @@ import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr ) import HsExpr ( PendingRnSplice ) import Name ( Name ) import TcRnTypes( TcM, TcId ) -import TcType ( TcRhoType ) +import TcType ( ExpRhoType ) import Annotations ( Annotation, CoreAnnTarget ) #ifdef GHCI @@ -16,15 +16,15 @@ import qualified Language.Haskell.TH as TH #endif tcSpliceExpr :: HsSplice Name - -> TcRhoType + -> ExpRhoType -> TcM (HsExpr TcId) tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] - -> TcRhoType + -> ExpRhoType -> TcM (HsExpr TcId) tcTypedBracket :: HsBracket Name - -> TcRhoType + -> ExpRhoType -> TcM (HsExpr TcId) runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 3534b46115..b46685eb36 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -24,6 +24,10 @@ module TcType ( TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, TcKind, TcCoVar, TcTyCoVar, TcTyBinder, + ExpType(..), ExpSigmaType, ExpRhoType, mkCheckExpType, + + SyntaxOpType(..), synKnownType, mkSynFunTys, + -- TcLevel TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, strictlyDeeperThan, sameDepthAs, fmvTcLevel, @@ -35,7 +39,7 @@ module TcType ( MetaDetails(Flexi, Indirect), MetaInfo(..), TauTvFlavour(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, isSigTyVar, isOverlappableTyVar, isTyConableTyVar, - isFskTyVar, isFmvTyVar, isFlattenTyVar, isReturnTyVar, + isFskTyVar, isFmvTyVar, isFlattenTyVar, isAmbiguousTyVar, metaTvRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, @@ -68,7 +72,7 @@ module TcType ( -- Again, newtypes are opaque eqType, eqTypes, cmpType, cmpTypes, eqTypeX, pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, - isSigmaTy, isRhoTy, isOverloadedTy, + isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, @@ -274,6 +278,59 @@ type TcTyCoVarSet = TyCoVarSet type TcDTyVarSet = DTyVarSet type TcDTyCoVarSet = DTyCoVarSet +-- | An expected type to check against during type-checking. +-- See Note [ExpType] in TcMType, where you'll also find manipulators. +data ExpType = Check TcType + | Infer Unique -- for debugging only + TcLevel -- See Note [TcLevel of ExpType] in TcMType + Kind + (IORef (Maybe TcType)) + +type ExpSigmaType = ExpType +type ExpRhoType = ExpType + +instance Outputable ExpType where + ppr (Check ty) = ppr ty + ppr (Infer u lvl ki _) + = parens (text "Infer" <> braces (ppr u <> comma <> ppr lvl) + <+> dcolon <+> ppr ki) + +-- | Make an 'ExpType' suitable for checking. +mkCheckExpType :: TcType -> ExpType +mkCheckExpType = Check + +-- | What to expect for an argument to a rebindable-syntax operator. +-- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp. +-- The callback called from tcSyntaxOp gets a list of types; the meaning +-- of these types is determined by a left-to-right depth-first traversal +-- of the 'SyntaxOpType' tree. So if you pass in +-- +-- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny +-- +-- you'll get three types back: one for the first 'SynAny', the /element/ +-- type of the list, and one for the last 'SynAny'. You don't get anything +-- for the 'SynType', because you've said positively that it should be an +-- Int, and so it shall be. +-- +-- This is defined here to avoid defining it in TcExpr.hs-boot. +data SyntaxOpType + = SynAny -- ^ Any type + | SynRho -- ^ A rho type, deeply skolemised or instantiated as appropriate + | SynList -- ^ A list type. You get back the element type of the list + | SynFun SyntaxOpType SyntaxOpType + -- ^ A function. + | SynType ExpType -- ^ A known type. +infixr 0 `SynFun` + +-- | Like 'SynType' but accepts a regular TcType +synKnownType :: TcType -> SyntaxOpType +synKnownType = SynType . mkCheckExpType + +-- | Like 'mkFunTys' but for 'SyntaxOpType' +mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType +mkSynFunTys arg_tys res_ty = foldr SynFun (SynType res_ty) arg_tys + + {- Note [TcRhoType] ~~~~~~~~~~~~~~~~ @@ -313,35 +370,6 @@ Similarly consider When doing kind inference on {S,T} we don't want *skolems* for k1,k2, because they end up unifying; we want those SigTvs again. -Note [ReturnTv] -~~~~~~~~~~~~~~~ -We sometimes want to convert a checking algorithm into an inference -algorithm. An easy way to do this is to "check" that a term has a -metavariable as a type. But, we must be careful to allow that metavariable -to unify with *anything*. (Well, anything that doesn't fail an occurs-check.) -This is what ReturnTv means. - -For example, if we have - - (undefined :: (forall a. TF1 a ~ TF2 a => a)) x - -we'll call (tcInfer . tcExpr) on the function expression. tcInfer will -create a ReturnTv to represent the expression's type. We really need this -ReturnTv to become set to (forall a. TF1 a ~ TF2 a => a) despite the fact -that this type mentions type families and is a polytype. - -However, we must also be careful to make sure that the ReturnTvs really -always do get unified with something -- we don't want these floating -around in the solver. So, we check after running the checker to make -sure the ReturnTv is filled. If it's not, we set it to a TauTv. - -We can't ASSERT that no ReturnTvs hit the solver, because they -can if there's, say, a kind error that stops checkTauTvUpdate from -working. This happens in test case typecheck/should_fail/T5570, for -example. - -See also the commentary on #9404. - Note [TyVars and TcTyVars] ~~~~~~~~~~~~~~~~~~~~~~~~~~ The Var type has constructors TyVar and TcTyVar. They are used @@ -396,10 +424,6 @@ data MetaInfo -- A TauTv is always filled in with a tau-type, which -- never contains any ForAlls. - | ReturnTv -- Can unify with *anything*. Used to convert a - -- type "checking" algorithm into a type inference algorithm. - -- See Note [ReturnTv] - | SigTv -- A variant of TauTv, except that it should not be -- unified with a type, only with a type variable -- SigTvs are only distinguished to improve error messages @@ -607,7 +631,6 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) = pp_info <> colon <> ppr tclvl where pp_info = case info of - ReturnTv -> text "ret" TauTv -> text "tau" SigTv -> text "sig" FlatMetaTv -> text "fuv" @@ -835,7 +858,7 @@ isImmutableTyVar tv isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, isMetaTyVar, isAmbiguousTyVar, - isFmvTyVar, isFskTyVar, isFlattenTyVar, isReturnTyVar :: TcTyVar -> Bool + isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool isTyConableTyVar tv -- True of a meta-type variable that can be filled in @@ -884,11 +907,6 @@ isMetaTyVar tv _ -> False | otherwise = False -isReturnTyVar tv - = case tcTyVarDetails tv of - MetaTv { mtv_info = ReturnTv } -> True - _ -> False - -- isAmbiguousTyVar is used only when reporting type errors -- It picks out variables that are unbound, namely meta -- type variables and the RuntimUnk variables created by @@ -1409,8 +1427,7 @@ occurCheckExpand :: DynFlags -> TcTyVar -> Type -> OccCheckResult Type -- See Note [Occurs check expansion] -- Check whether -- a) the given variable occurs in the given type. --- b) there is a forall in the type (unless we have -XImpredicativeTypes --- or it's a ReturnTv +-- b) there is a forall in the type (unless we have -XImpredicativeTypes) -- c) if it's a SigTv, ty should be a tyvar -- -- We may have needed to do some type synonym unfolding in order to @@ -1558,7 +1575,6 @@ occurCheckExpand dflags tv ty canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool canUnifyWithPolyType dflags details = case details of - MetaTv { mtv_info = ReturnTv } -> True -- See Note [ReturnTv] MetaTv { mtv_info = SigTv } -> False MetaTv { mtv_info = TauTv } -> xopt LangExt.ImpredicativeTypes dflags _other -> True @@ -1817,6 +1833,11 @@ isRhoTy (ForAllTy (Named {}) _) = False isRhoTy (ForAllTy (Anon a) r) = not (isPredTy a) && isRhoTy r isRhoTy _ = True +-- | Like 'isRhoTy', but also says 'True' for 'Infer' types +isRhoExpTy :: ExpType -> Bool +isRhoExpTy (Check ty) = isRhoTy ty +isRhoExpTy (Infer {}) = True + isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing -- Used only by bindLocalMethods diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index a548e8d86a..8d0f79708a 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -10,14 +10,14 @@ Type subsumption and unification module TcUnify ( -- Full-blown subsumption - tcWrapResult, tcWrapResultO, tcSkolemise, - tcSubTypeHR, tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_O, - tcSubTypeDS_NC, tcSubTypeDS_NC_O, + tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET, + tcSubTypeHR, tcSubType, tcSubTypeO, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_O, + tcSubTypeDS_NC, tcSubTypeDS_NC_O, tcSubTypeET, tcSubTypeET_NC, checkConstraints, buildImplication, buildImplicationFor, -- Various unifications unifyType_, unifyType, unifyTheta, unifyKind, noThing, - uType, + uType, unifyExpType, -------------------------------- -- Holes @@ -61,6 +61,7 @@ import Outputable import FastString import Control.Monad +import Control.Arrow ( second ) {- ************************************************************************ @@ -103,78 +104,117 @@ namely: A function definition An operator section +This function must be written CPS'd because it needs to fill in the +ExpTypes produced for arguments before it can fill in the ExpType +passed in. + -} -- Use this one when you have an "expected" type. matchExpectedFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] -> Arity - -> TcSigmaType -- deeply skolemised - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) --- If matchExpectedFunTys n ty = (wrap, [t1,..,tn], ty_r) --- then wrap : (t1 -> ... -> tn -> ty_r) "->" ty - --- This function is always called with a deeply skolemised expected result --- type. This means that matchActualFunTys will never actually instantiate, --- and the returned HsWrapper will be reversible (that is, just a coercion). --- So we just piggyback on matchActualFunTys. This is just a bit dodgy, but --- it's much better than duplicating all the logic in matchActualFunTys. --- To keep expected/actual working out properly, we tell matchActualFunTys --- to swap the arguments to unifyType. -matchExpectedFunTys herald arity ty - = ASSERT( is_deeply_skolemised ty ) - do { (wrap, arg_tys, res_ty) - <- match_fun_tys True herald - (Shouldn'tHappenOrigin "matchExpectedFunTys") - arity ty [] arity - ; return $ - case symWrapper_maybe wrap of - Just wrap' -> (wrap', arg_tys, res_ty) - Nothing -> pprPanic "matchExpectedFunTys" (ppr wrap $$ ppr ty) } + -> ExpRhoType -- deeply skolemised + -> ([ExpSigmaType] -> ExpRhoType -> TcM a) + -- must fill in these ExpTypes here + -> TcM (a, HsWrapper) +-- If matchExpectedFunTys n ty = (_, wrap) +-- then wrap : (t1 -> ... -> tn -> ty_r) "->" ty, +-- where [t1, ..., tn], ty_r are passed to the thing_inside +matchExpectedFunTys herald arity orig_ty thing_inside + = case orig_ty of + Check ty -> go [] arity ty + _ -> defer [] arity orig_ty where - is_deeply_skolemised (TyVarTy {}) = True - is_deeply_skolemised (AppTy {}) = True - is_deeply_skolemised (TyConApp {}) = True - is_deeply_skolemised (LitTy {}) = True - is_deeply_skolemised (CastTy ty _) = is_deeply_skolemised ty - is_deeply_skolemised (CoercionTy {}) = True + go acc_arg_tys 0 ty + = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty) + ; return (result, idHsWrapper) } + + go acc_arg_tys n ty + | Just ty' <- coreView ty = go acc_arg_tys n ty' + + go acc_arg_tys n (ForAllTy (Anon arg_ty) res_ty) + = ASSERT( not (isPredTy arg_ty) ) + do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys) + (n-1) res_ty + ; return ( result + , mkWpFun idHsWrapper wrap_res arg_ty res_ty ) } + + go acc_arg_tys n ty@(TyVarTy tv) + | ASSERT( isTcTyVar tv) isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> go acc_arg_tys n ty' + Flexi -> defer acc_arg_tys n (mkCheckExpType ty) } + + -- In all other cases we bale out into ordinary unification + -- However unlike the meta-tyvar case, we are sure that the + -- number of arguments doesn't match arity of the original + -- type, so we can add a bit more context to the error message + -- (cf Trac #7869). + -- + -- It is not always an error, because specialized type may have + -- different arity, for example: + -- + -- > f1 = f2 'a' + -- > f2 :: Monad m => m Bool + -- > f2 = undefined + -- + -- But in that case we add specialized type into error context + -- anyway, because it may be useful. See also Trac #9605. + go acc_arg_tys n ty = addErrCtxtM mk_ctxt $ + defer acc_arg_tys n (mkCheckExpType ty) + + ------------ + defer acc_arg_tys n fun_ty + = do { more_arg_tys <- replicateM n newOpenInferExpType + ; res_ty <- newOpenInferExpType + ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty + ; more_arg_tys <- mapM readExpType more_arg_tys + ; res_ty <- readExpType res_ty + ; let unif_fun_ty = mkFunTys more_arg_tys res_ty + ; wrap <- tcSubTypeDS GenSigCtxt noThing unif_fun_ty fun_ty + ; return (result, wrap) } - is_deeply_skolemised (ForAllTy (Anon _) res) = is_deeply_skolemised res - is_deeply_skolemised (ForAllTy (Named {}) _) = False + ------------ + mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_tc_ty + ; let (args, _) = tcSplitFunTys ty + n_actual = length args + (env'', orig_ty') = tidyOpenType env' orig_tc_ty + ; return ( env'' + , mk_fun_tys_msg orig_ty' ty n_actual arity herald) } + where + orig_tc_ty = checkingExpType "matchExpectedFunTys" orig_ty + -- this is safe b/c we're called from "go" -matchActualFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] +-- Like 'matchExpectedFunTys', but used when you have an "actual" type, +-- for example in function application +matchActualFunTys :: Outputable a + => SDoc -- See Note [Herald for matchExpectedFunTys] -> CtOrigin + -> Maybe a -- the thing with type TcSigmaType -> Arity -> TcSigmaType -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) -matchActualFunTys herald ct_orig arity ty - = matchActualFunTysPart herald ct_orig arity ty [] arity +-- If matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r) +-- then wrap : ty "->" (t1 -> ... -> tn -> ty_r) +matchActualFunTys herald ct_orig mb_thing arity ty + = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity -- | Variant of 'matchActualFunTys' that works when supplied only part -- (that is, to the right of some arrows) of the full function type -matchActualFunTysPart :: SDoc -- See Note [Herald for matchExpectedFunTys] +matchActualFunTysPart :: Outputable a + => SDoc -- See Note [Herald for matchExpectedFunTys] -> CtOrigin + -> Maybe a -- the thing with type TcSigmaType -> Arity -> TcSigmaType -> [TcSigmaType] -- reversed args. See (*) below. -> Arity -- overall arity of the function, for errs -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) -matchActualFunTysPart = match_fun_tys False - -match_fun_tys :: Bool -- True <=> swap the args when unifying, - -- for better expected/actual in error messages; - -- see comments with matchExpectedFunTys - -> SDoc - -> CtOrigin - -> Arity - -> TcSigmaType - -> [TcSigmaType] - -> Arity - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) -match_fun_tys swap_tys herald ct_orig arity orig_ty orig_old_args full_arity +matchActualFunTysPart herald ct_orig mb_thing arity orig_ty + orig_old_args full_arity = go arity orig_old_args orig_ty --- If matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r) --- then wrap : ty "->" (t1 -> ... -> tn -> ty_r) --- -- Does not allocate unnecessary meta variables: if the input already is -- a function, we just take it apart. Not only is this efficient, -- it's important for higher rank: the argument might be of form @@ -221,15 +261,15 @@ match_fun_tys swap_tys herald ct_orig arity orig_ty orig_old_args full_arity go n acc_args (ForAllTy (Anon arg_ty) res_ty) = ASSERT( not (isPredTy arg_ty) ) do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty - ; return ( mkWpFun idHsWrapper wrap_res arg_ty (mkFunTys tys ty_r) - , arg_ty:tys, ty_r ) } + ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r + , arg_ty : tys, ty_r ) } go n acc_args ty@(TyVarTy tv) | ASSERT( isTcTyVar tv) isMetaTyVar tv = do { cts <- readMetaTyVar tv ; case cts of Indirect ty' -> go n acc_args ty' - Flexi -> defer n ty (isReturnTyVar tv) } + Flexi -> defer n ty } -- In all other cases we bale out into ordinary unification -- However unlike the meta-tyvar case, we are sure that the @@ -247,25 +287,15 @@ match_fun_tys swap_tys herald ct_orig arity orig_ty orig_old_args full_arity -- But in that case we add specialized type into error context -- anyway, because it may be useful. See also Trac #9605. go n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $ - defer n ty False + defer n ty ------------ - -- If we decide that a ReturnTv (see Note [ReturnTv] in TcType) should - -- really be a function type, then we need to allow the - -- result types also to be a ReturnTv. - defer n fun_ty is_return - = do { arg_tys <- replicateM n new_flexi - ; res_ty <- new_flexi + defer n fun_ty + = do { arg_tys <- replicateM n newOpenFlexiTyVarTy + ; res_ty <- newOpenFlexiTyVarTy ; let unif_fun_ty = mkFunTys arg_tys res_ty - ; co <- if swap_tys - then mkTcSymCo <$> unifyType noThing unif_fun_ty fun_ty - else unifyType noThing fun_ty unif_fun_ty + ; co <- unifyType mb_thing fun_ty unif_fun_ty ; return (mkWpCastN co, arg_tys, res_ty) } - where - -- preserve ReturnTv-ness - new_flexi :: TcM TcType - new_flexi | is_return = (mkTyVarTy . fst) <$> newOpenReturnTyVar - | otherwise = newOpenFlexiTyVarTy ------------ mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc) @@ -276,17 +306,24 @@ match_fun_tys swap_tys herald ct_orig arity orig_ty orig_old_args full_arity ; let (zonked_args, _) = tcSplitFunTys zonked n_actual = length zonked_args (env2, unzonked) = tidyOpenType env1 ty - ; return (env2, mk_msg unzonked zonked n_actual) } - - mk_msg full_ty ty n_args - = herald <+> speakNOf full_arity (text "argument") <> comma $$ - if n_args == full_arity - then text "its type is" <+> quotes (pprType full_ty) <> - comma $$ - text "it is specialized to" <+> quotes (pprType ty) - else sep [text "but its type" <+> quotes (pprType ty), - if n_args == 0 then text "has none" - else text "has only" <+> speakN n_args] + ; return ( env2 + , mk_fun_tys_msg unzonked zonked n_actual full_arity herald) } + +mk_fun_tys_msg :: TcType -- the full type passed in (unzonked) + -> TcType -- the full type passed in (zonked) + -> Arity -- the # of args found + -> Arity -- the # of args wanted + -> SDoc -- overall herald + -> SDoc +mk_fun_tys_msg full_ty ty n_args full_arity herald + = herald <+> speakNOf full_arity (text "argument") <> comma $$ + if n_args == full_arity + then text "its type is" <+> quotes (pprType full_ty) <> + comma $$ + text "it is specialized to" <+> quotes (pprType ty) + else sep [text "but its type" <+> quotes (pprType ty), + if n_args == 0 then text "has none" + else text "has only" <+> speakN n_args] ---------------------- matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) @@ -486,28 +523,66 @@ skolemising the type. tcSubTypeHR :: Outputable a => CtOrigin -- ^ of the actual type -> Maybe a -- ^ If present, it has type ty_actual - -> TcSigmaType -> TcRhoType -> TcM HsWrapper + -> TcSigmaType -> ExpRhoType -> TcM HsWrapper tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt tcSubType :: Outputable a => UserTypeCtxt -> Maybe a -- ^ If present, it has type ty_actual - -> TcSigmaType -> TcSigmaType -> TcM HsWrapper + -> TcSigmaType -> ExpSigmaType -> TcM HsWrapper -- Checks that actual <= expected -- Returns HsWrapper :: actual ~ expected tcSubType ctxt maybe_thing ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubType" (vcat [ pprUserTypeCtxt ctxt - , ppr maybe_thing - , ppr ty_actual - , ppr ty_expected ]) - ; tc_sub_type origin origin ctxt ty_actual ty_expected } + = tcSubTypeO origin ctxt ty_actual ty_expected where origin = TypeEqOrigin { uo_actual = ty_actual , uo_expected = ty_expected , uo_thing = mkErrorThing <$> maybe_thing } + +-- | This is like 'tcSubType' but accepts an 'ExpType' as the /actual/ type. +-- You probably want this only when looking at patterns, never expressions. +tcSubTypeET :: CtOrigin -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +tcSubTypeET orig ty_actual ty_expected + = uExpTypeX orig ty_expected ty_actual + (return . mkWpCastN . mkTcSymCo) + (\ty_a -> tcSubTypeO orig GenSigCtxt ty_a + (mkCheckExpType ty_expected)) + +-- | This is like 'tcSubType' but accepts an 'ExpType' as the /actual/ type. +-- You probably want this only when looking at patterns, never expressions. +-- Does not add context. +tcSubTypeET_NC :: UserTypeCtxt -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +tcSubTypeET_NC _ ty_actual@(Infer {}) ty_expected + = mkWpCastN . mkTcSymCo <$> unifyExpType noThing ty_expected ty_actual +tcSubTypeET_NC ctxt (Check ty_actual) ty_expected + = tc_sub_type orig orig ctxt ty_actual ty_expected' + where + ty_expected' = mkCheckExpType ty_expected + orig = TypeEqOrigin { uo_actual = ty_actual + , uo_expected = ty_expected' + , uo_thing = Nothing } + +tcSubTypeO :: CtOrigin -- ^ of the actual type + -> UserTypeCtxt -- ^ of the expected type + -> TcSigmaType + -> ExpSigmaType + -> TcM HsWrapper +tcSubTypeO origin ctxt ty_actual ty_expected + = addSubTypeCtxt ty_actual ty_expected $ + do { traceTc "tcSubType" (vcat [ pprCtOrigin origin + , pprUserTypeCtxt ctxt + , ppr ty_actual + , ppr ty_expected ]) + ; tc_sub_type eq_orig origin ctxt ty_actual ty_expected } + where + eq_orig | TypeEqOrigin {} <- origin = origin + | otherwise + = TypeEqOrigin { uo_actual = ty_actual + , uo_expected = ty_expected + , uo_thing = Nothing } + tcSubTypeDS :: Outputable a => UserTypeCtxt -> Maybe a -- ^ has type ty_actual - -> TcSigmaType -> TcRhoType -> TcM HsWrapper + -> TcSigmaType -> ExpRhoType -> TcM HsWrapper -- Just like tcSubType, but with the additional precondition that -- ty_expected is deeply skolemised (hence "DS") tcSubTypeDS ctxt m_expr ty_actual ty_expected @@ -518,7 +593,7 @@ tcSubTypeDS ctxt m_expr ty_actual ty_expected -- the "actual" type tcSubTypeDS_O :: Outputable a => CtOrigin -> UserTypeCtxt - -> Maybe a -> TcSigmaType -> TcRhoType + -> Maybe a -> TcSigmaType -> ExpRhoType -> TcM HsWrapper tcSubTypeDS_O orig ctxt maybe_thing ty_actual ty_expected = addSubTypeCtxt ty_actual ty_expected $ @@ -528,16 +603,23 @@ tcSubTypeDS_O orig ctxt maybe_thing ty_actual ty_expected , ppr ty_expected ]) ; tcSubTypeDS_NC_O orig ctxt maybe_thing ty_actual ty_expected } -addSubTypeCtxt :: TcType -> TcType -> TcM a -> TcM a +addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a addSubTypeCtxt ty_actual ty_expected thing_inside - | isRhoTy ty_actual -- If there is no polymorphism involved, the - , isRhoTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) - = thing_inside -- gives enough context by itself + | isRhoTy ty_actual -- If there is no polymorphism involved, the + , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) + = thing_inside -- gives enough context by itself | otherwise = addErrCtxtM mk_msg thing_inside where mk_msg tidy_env = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual + -- might not be filled if we're debugging. ugh. + ; mb_ty_expected <- readExpType_maybe ty_expected + ; (tidy_env, ty_expected) <- case mb_ty_expected of + Just ty -> second mkCheckExpType <$> + zonkTidyTcType tidy_env ty + Nothing -> return (tidy_env, ty_expected) + ; ty_expected <- readExpType ty_expected ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected ; let msg = vcat [ hang (text "When checking that:") 4 (ppr ty_actual) @@ -549,7 +631,7 @@ addSubTypeCtxt ty_actual ty_expected thing_inside -- The "_NC" variants do not add a typechecker-error context; -- the caller is assumed to do that -tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> ExpSigmaType -> TcM HsWrapper tcSubType_NC ctxt ty_actual ty_expected = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) ; tc_sub_type origin origin ctxt ty_actual ty_expected } @@ -561,7 +643,7 @@ tcSubType_NC ctxt ty_actual ty_expected tcSubTypeDS_NC :: Outputable a => UserTypeCtxt -> Maybe a -- ^ If present, this has type ty_actual - -> TcSigmaType -> TcRhoType -> TcM HsWrapper + -> TcSigmaType -> ExpRhoType -> TcM HsWrapper tcSubTypeDS_NC ctxt maybe_thing ty_actual ty_expected = do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) ; tcSubTypeDS_NC_O origin ctxt maybe_thing ty_actual ty_expected } @@ -574,25 +656,35 @@ tcSubTypeDS_NC_O :: Outputable a => CtOrigin -- origin used for instantiation only -> UserTypeCtxt -> Maybe a - -> TcSigmaType -> TcRhoType -> TcM HsWrapper + -> TcSigmaType -> ExpRhoType -> TcM HsWrapper -- Just like tcSubType, but with the additional precondition that -- ty_expected is deeply skolemised -tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected - = tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected +tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual et + = uExpTypeX eq_orig ty_actual et + (return . mkWpCastN) + (tc_sub_type_ds eq_orig inst_orig ctxt ty_actual) where - eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty_expected - , uo_thing = mkErrorThing <$> m_thing} + eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = et + , uo_thing = mkErrorThing <$> m_thing } --------------- tc_sub_type :: CtOrigin -- origin used when calling uType -> CtOrigin -- origin used when instantiating - -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper -tc_sub_type eq_orig inst_orig ctxt ty_actual ty_expected + -> UserTypeCtxt -> TcSigmaType -> ExpSigmaType -> TcM HsWrapper +tc_sub_type eq_orig inst_orig ctxt ty_actual et + = uExpTypeX eq_orig ty_actual et + (return . mkWpCastN) + (tc_sub_tc_type eq_orig inst_orig ctxt ty_actual) + +tc_sub_tc_type :: CtOrigin -- used when calling uType + -> CtOrigin -- used when instantiating + -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected | Just tv_actual <- tcGetTyVar_maybe ty_actual -- See Note [Higher rank types] = do { lookup_res <- lookupTcTyVar tv_actual ; case lookup_res of - Filled ty_actual' -> tc_sub_type eq_orig inst_orig - ctxt ty_actual' ty_expected + Filled ty_actual' -> tc_sub_tc_type eq_orig inst_orig + ctxt ty_actual' ty_expected -- It's tempting to see if tv_actual can unify with a polytype -- and, if so, call uType; otherwise, skolemise first. But this @@ -641,7 +733,7 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected Filled ty_e' -> do { traceTc "tcSubTypeDS_NC_O following filled exp meta-tyvar:" (ppr tv_e <+> text "-->" <+> ppr ty_e') - ; tc_sub_type eq_orig inst_orig ctxt ty_a ty_e' } + ; tc_sub_tc_type eq_orig inst_orig ctxt ty_a ty_e' } Unfilled details | canUnifyWithPolyType dflags details && isTouchableMetaTyVar tclvl tv_e -- don't want skolems here @@ -660,8 +752,10 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected = -- See Note [Co/contra-variance of subsumption checking] do { res_wrap <- tc_sub_type_ds eq_orig inst_orig ctxt act_res exp_res ; arg_wrap - <- tc_sub_type eq_orig (GivenOrigin (SigSkol GenSigCtxt exp_arg)) - ctxt exp_arg act_arg + <- tc_sub_tc_type eq_orig (GivenOrigin + (SigSkol GenSigCtxt + (mkCheckExpType exp_arg))) + ctxt exp_arg act_arg ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res) } -- arg_wrap :: exp_arg ~ act_arg -- res_wrap :: act-res ~ exp_res @@ -670,7 +764,11 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected | let (tvs, theta, _) = tcSplitSigmaTy ty_a , not (null tvs && null theta) = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a - ; body_wrap <- tcSubTypeDS_NC_O inst_orig ctxt noThing in_rho ty_e + ; body_wrap <- tc_sub_type_ds + (eq_orig { uo_actual = in_rho + , uo_expected = + mkCheckExpType ty_expected }) + inst_orig ctxt in_rho ty_e ; return (body_wrap <.> in_wrap) } | otherwise -- Revert to unification @@ -706,13 +804,13 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected ----------------- -- needs both un-type-checked (for origins) and type-checked (for wrapping) -- expressions -tcWrapResult :: HsExpr Name -> HsExpr TcId -> TcSigmaType -> TcRhoType +tcWrapResult :: HsExpr Name -> HsExpr TcId -> TcSigmaType -> ExpRhoType -> TcM (HsExpr TcId) tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) -- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more -- convenient. -tcWrapResultO :: CtOrigin -> HsExpr TcId -> TcSigmaType -> TcRhoType +tcWrapResultO :: CtOrigin -> HsExpr TcId -> TcSigmaType -> ExpRhoType -> TcM (HsExpr TcId) tcWrapResultO orig expr actual_ty res_ty = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty @@ -736,21 +834,14 @@ wrapFunResCoercion arg_tys co_fn_res ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpEvVarApps arg_ids) } ----------------------------------- --- | Infer a type using a type "checking" function by passing in a ReturnTv, --- which can unify with *anything*. See also Note [ReturnTv] in TcType -tcInfer :: (TcType -> TcM a) -> TcM (a, TcType) +-- | Infer a type using a fresh ExpType +-- See also Note [ExpType] in TcMType +tcInfer :: (ExpRhoType -> TcM a) -> TcM (a, TcType) tcInfer tc_check - = do { (ret_tv, ret_kind) <- newOpenReturnTyVar - ; res <- tc_check (mkTyVarTy ret_tv) - ; details <- readMetaTyVar ret_tv - ; res_ty <- case details of - Indirect ty -> return ty - Flexi -> -- Checking was uninformative - do { traceTc "Defaulting un-filled ReturnTv to a TauTv" (ppr ret_tv) - ; tau_ty <- newFlexiTyVarTy ret_kind - ; writeMetaTyVar ret_tv tau_ty - ; return tau_ty } - ; return (res, res_ty) } + = do { res_ty <- newOpenInferExpType + ; result <- tc_check res_ty + ; res_ty <- readExpType res_ty + ; return (result, res_ty) } {- ************************************************************************ @@ -765,9 +856,7 @@ tcInfer tc_check -- The returned 'HsWrapper' has type @specific_ty -> expected_ty@. tcSkolemise :: UserTypeCtxt -> TcSigmaType -> ([TcTyVar] -> TcType -> TcM result) - -- ^ thing_inside is passed only the *type* variables, not - -- *coercion* variables. They are only ever used for scoped type - -- variables. + -- ^ These are only ever used for scoped type variables. -> TcM (HsWrapper, result) -- ^ The expression has type: spec_ty -> expected_ty @@ -801,7 +890,8 @@ tcSkolemise ctxt expected_ty thing_inside -- Use the *instantiated* type in the SkolemInfo -- so that the names of displayed type variables line up - ; let skol_info = SigSkol ctxt (mkFunTys (map varType given) rho') + ; let skol_info = SigSkol ctxt (mkCheckExpType $ + mkFunTys (map varType given) rho') ; (ev_binds, result) <- checkConstraints skol_info tvs' given $ thing_inside tvs' rho' @@ -810,6 +900,15 @@ tcSkolemise ctxt expected_ty thing_inside -- The ev_binds returned by checkConstraints is very -- often empty, in which case mkWpLet is a no-op +-- | Variant of 'tcSkolemise' that takes an ExpType +tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType + -> (ExpRhoType -> TcM result) + -> TcM (HsWrapper, result) +tcSkolemiseET _ et@(Infer {}) thing_inside + = (idHsWrapper, ) <$> thing_inside et +tcSkolemiseET ctxt (Check ty) thing_inside + = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType + checkConstraints :: SkolemInfo -> [TcTyVar] -- Skolems -> [EvVar] -- Given @@ -893,32 +992,42 @@ unifyType_ :: Outputable a => Maybe a -- ^ If present, has type 'ty1' unifyType_ thing ty1 ty2 = void $ unifyType thing ty1 ty2 unifyType :: Outputable a => Maybe a -- ^ If present, has type 'ty1' - -> TcTauType -> TcTauType -> TcM TcCoercion + -> TcTauType -> TcTauType -> TcM TcCoercionN -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 unifyType thing ty1 ty2 = uType origin TypeLevel ty1 ty2 where - origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 + origin = TypeEqOrigin { uo_actual = ty1, uo_expected = mkCheckExpType ty2 , uo_thing = mkErrorThing <$> thing } +-- | Variant of 'unifyType' that takes an 'ExpType' as its second type +unifyExpType :: Outputable a => Maybe a + -> TcTauType -> ExpType -> TcM TcCoercionN +unifyExpType mb_thing ty1 ty2 + = uExpType ty_orig ty1 ty2 + where + ty_orig = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = mkErrorThing <$> mb_thing } + -- | Use this instead of 'Nothing' when calling 'unifyType' without -- a good "thing" (where the "thing" has the "actual" type passed in) -- This has an 'Outputable' instance, avoiding amgiguity problems. noThing :: Maybe (HsExpr Name) noThing = Nothing -unifyKind :: Outputable a => Maybe a -> TcKind -> TcKind -> TcM Coercion +unifyKind :: Outputable a => Maybe a -> TcKind -> TcKind -> TcM CoercionN unifyKind thing ty1 ty2 = uType origin KindLevel ty1 ty2 - where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 + where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = mkCheckExpType ty2 , uo_thing = mkErrorThing <$> thing } --------------- -unifyPred :: PredType -> PredType -> TcM TcCoercion +unifyPred :: PredType -> PredType -> TcM TcCoercionN -- Actual and expected types unifyPred = unifyType noThing --------------- -unifyTheta :: TcThetaType -> TcThetaType -> TcM [TcCoercion] +unifyTheta :: TcThetaType -> TcThetaType -> TcM [TcCoercionN] -- Actual and expected types unifyTheta theta1 theta2 = do { checkTc (equalLength theta1 theta2) @@ -936,6 +1045,33 @@ unifyTheta theta1 theta2 uType is the heart of the unifier. -} +uExpType :: CtOrigin -> TcType -> ExpType -> TcM CoercionN +uExpType orig ty1 et + = uExpTypeX orig ty1 et return $ + uType orig TypeLevel ty1 + +-- | Tries to unify with an ExpType. If the ExpType is filled in, calls the first +-- continuation with the produced coercion. Otherwise, calls the second +-- continuation. This can happen either with a Check or with an untouchable +-- ExpType that reverts to a tau-type. See Note [TcLevel of ExpType] +uExpTypeX :: CtOrigin -> TcType -> ExpType + -> (TcCoercionN -> TcM a) -- Infer case, co :: TcType ~N ExpType + -> (TcType -> TcM a) -- Check / untouchable case + -> TcM a +uExpTypeX orig ty1 et@(Infer _ tc_lvl ki _) coercion_cont type_cont + = do { cur_lvl <- getTcLevel + ; if cur_lvl `sameDepthAs` tc_lvl + then do { ki_co <- uType kind_orig KindLevel (typeKind ty1) ki + ; writeExpType et (ty1 `mkCastTy` ki_co) + ; coercion_cont $ mkTcNomReflCo ty1 `mkTcCoherenceRightCo` ki_co } + else do { traceTc "Preventing writing to untouchable ExpType" empty + ; tau <- expTypeToType et -- See Note [TcLevel of ExpType] + ; type_cont tau }} + where + kind_orig = KindEqOrigin ty1 Nothing orig (Just TypeLevel) +uExpTypeX _ _ (Check ty2) _ type_cont + = type_cont ty2 + ------------ uType, uType_defer :: CtOrigin @@ -1076,7 +1212,8 @@ uType origin t_or_k orig_ty1 orig_ty2 go (CoercionTy co1) (CoercionTy co2) = do { let ty1 = coercionType co1 ty2 = coercionType co2 - ; kco <- uType (KindEqOrigin orig_ty1 orig_ty2 origin (Just t_or_k)) + ; kco <- uType (KindEqOrigin orig_ty1 (Just orig_ty2) origin + (Just t_or_k)) KindLevel ty1 ty2 ; return $ mkProofIrrelCo Nominal kco co1 co2 } @@ -1268,7 +1405,7 @@ uUnfilledVars origin t_or_k swapped tv1 details1 tv2 details2 k2 = tyVarKind tv2 ty1 = mkTyVarTy tv1 ty2 = mkTyVarTy tv2 - kind_origin = KindEqOrigin ty1 ty2 origin (Just t_or_k) + kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k) -- | apply sym iff swapped maybe_sym :: SwapFlag -> Coercion -> Coercion @@ -1282,10 +1419,6 @@ nicer_to_update_tv1 _ SigTv _ = False -- variables in preference to ones gotten (say) by -- instantiating a polymorphic function with a user-written -- type sig -nicer_to_update_tv1 _ ReturnTv _ = True -nicer_to_update_tv1 _ _ ReturnTv = False - -- ReturnTvs are really holes just begging to be filled in. - -- Let's oblige. nicer_to_update_tv1 tv1 _ _ = isSystemName (Var.varName tv1) ---------------- @@ -1297,9 +1430,9 @@ checkTauTvUpdate :: DynFlags -> TcM (Maybe ( TcType -- possibly-expanded ty , Coercion )) -- :: k2 ~N k1 -- (checkTauTvUpdate tv ty) --- We are about to update the TauTv/ReturnTv tv with ty. +-- We are about to update the TauTv tv with ty. -- Check (a) that tv doesn't occur in ty (occurs check) --- (b) that kind(ty) is a sub-kind of kind(tv) +-- (b) that kind(ty) matches kind(tv) -- -- We have two possible outcomes: -- (1) Return the type to update the type variable with, @@ -1323,12 +1456,7 @@ checkTauTvUpdate dflags origin t_or_k tv ty | otherwise = do { ty <- zonkTcType ty ; co_k <- uType kind_origin KindLevel (typeKind ty) (tyVarKind tv) - ; if | is_return_tv -> -- ReturnTv: a simple occurs-check is all that we need - -- See Note [ReturnTv] in TcType - if tv `elemVarSet` tyCoVarsOfType ty - then return Nothing - else return (Just (ty, co_k)) - | defer_me ty -> -- Quick test + ; if | defer_me ty -> -- Quick test -- Failed quick test so try harder case occurCheckExpand dflags tv ty of OC_OK ty2 | defer_me ty2 -> return Nothing @@ -1336,10 +1464,9 @@ checkTauTvUpdate dflags origin t_or_k tv ty _ -> return Nothing | otherwise -> return (Just (ty, co_k)) } where - kind_origin = KindEqOrigin (mkTyVarTy tv) ty origin (Just t_or_k) + kind_origin = KindEqOrigin (mkTyVarTy tv) (Just ty) origin (Just t_or_k) details = tcTyVarDetails tv info = mtv_info details - is_return_tv = isReturnTyVar tv impredicative = canUnifyWithPolyType dflags details defer_me :: TcType -> Bool @@ -1541,24 +1668,22 @@ matchExpectedFunKind num_args_remaining ty = go = do { maybe_kind <- readMetaTyVar kvar ; case maybe_kind of Indirect fun_kind -> go fun_kind - Flexi -> defer (isReturnTyVar kvar) k } + Flexi -> defer k } go k@(ForAllTy (Anon arg) res) = return (mkNomReflCo k, arg, res) - go other = defer False other + go other = defer other - defer is_return k - = do { arg_kind <- new_flexi - ; res_kind <- new_flexi + defer k + = do { arg_kind <- newMetaKindVar + ; res_kind <- newMetaKindVar ; let new_fun = mkFunTy arg_kind res_kind thing = mkTypeErrorThingArgs ty num_args_remaining origin = TypeEqOrigin { uo_actual = k - , uo_expected = new_fun + , uo_expected = mkCheckExpType new_fun , uo_thing = Just thing } ; co <- uType origin KindLevel k new_fun ; return (co, arg_kind, res_kind) } where - new_flexi | is_return = newReturnTyVarTy liftedTypeKind - | otherwise = newMetaKindVar diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 3aa8d78cf2..6efbebe6e8 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -199,7 +199,7 @@ checkAmbiguity ctxt ty ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ captureConstraints $ - tcSubType_NC ctxt ty ty + tcSubType_NC ctxt ty (mkCheckExpType ty) ; simplifyAmbiguityCheck ty wanted ; traceTc "Done ambiguity check for" (ppr ty) } diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index af4f0253db..812e4e8e77 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -22,7 +22,7 @@ module MonadUtils , anyM, allM, orM , foldlM, foldlM_, foldrM , maybeMapM - , whenM + , whenM, unlessM ) where ------------------------------------------------------------------------------- @@ -197,3 +197,8 @@ maybeMapM m (Just x) = liftM Just $ m x whenM :: Monad m => m Bool -> m () -> m () whenM mb thing = do { b <- mb ; when b thing } + +-- | Monadic version of @unless@, taking the condition in the monad +unlessM :: Monad m => m Bool -> m () -> m () +unlessM condM acc = do { cond <- condM + ; unless cond acc } diff --git a/libraries/process b/libraries/process -Subproject 296cbce6294316d6534b4449fc7ab0f0d3f5775 +Subproject 0edb97876c2f783b33f9a69089ca9d26a061e11 diff --git a/libraries/transformers b/libraries/transformers -Subproject a2f7dd057a0ee0c6cb206609594d7a07d26a186 +Subproject 1a2bc4ecada9561911e9c2e8a98a3c6bf59b7bb diff --git a/testsuite/tests/ado/ado004.stderr b/testsuite/tests/ado/ado004.stderr index 6472310ece..6e877617dc 100644 --- a/testsuite/tests/ado/ado004.stderr +++ b/testsuite/tests/ado/ado004.stderr @@ -2,27 +2,27 @@ TYPE SIGNATURES test1 :: forall (f :: * -> *). Applicative f => (Int -> f Int) -> f Int test2 :: - forall (f :: * -> *) b a. - (Applicative f, Num a, Num b) => - (a -> f b) -> f b + forall (f :: * -> *) b t. + (Applicative f, Num t, Num b) => + (t -> f b) -> f b test3 :: - forall (m :: * -> *) a a1 a2. - (Num a2, Monad m) => - (a2 -> m a1) -> (a1 -> a1 -> m a) -> m a + forall (m :: * -> *) a t t1. + (Num t, Monad m) => + (t -> m t1) -> (t1 -> t1 -> m a) -> m a test4 :: - forall (m :: * -> *) a a1 a2. - (Num a2, Monad m) => - (a2 -> m a1) -> (a1 -> a1 -> m a) -> m a + forall (m :: * -> *) a a1 t. + (Num t, Monad m) => + (t -> m a1) -> (a1 -> a1 -> m a) -> m a test5 :: - forall (m :: * -> *) a a1 a2. - (Num a2, Monad m) => - (a2 -> m a1) -> (a1 -> a1 -> m a) -> m a + forall (m :: * -> *) a a1 t. + (Num t, Monad m) => + (t -> m a1) -> (a1 -> a1 -> m a) -> m a test6 :: - forall r (m :: * -> *) a. + forall t (m :: * -> *) a. (Num (m a), Monad m) => - (m a -> m (m a)) -> r -> m a + (m a -> m (m a)) -> t -> m a TYPE CONSTRUCTORS COERCION AXIOMS Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, - integer-gmp-1.0.0.0] + integer-gmp-1.0.0.1] diff --git a/testsuite/tests/annotations/should_fail/annfail10.stderr b/testsuite/tests/annotations/should_fail/annfail10.stderr index 251f0c317c..3d55d4aed4 100644 --- a/testsuite/tests/annotations/should_fail/annfail10.stderr +++ b/testsuite/tests/annotations/should_fail/annfail10.stderr @@ -1,8 +1,8 @@ annfail10.hs:9:1: error: - • Ambiguous type variable ‘a0’ arising from an annotation - prevents the constraint ‘(Data.Data.Data a0)’ from being solved. - Probable fix: use a type annotation to specify what ‘a0’ should be. + • Ambiguous type variable ‘t0’ arising from an annotation + prevents the constraint ‘(Data.Data.Data t0)’ from being solved. + Probable fix: use a type annotation to specify what ‘t0’ should be. These potential instances exist: instance (Data.Data.Data a, Data.Data.Data b) => Data.Data.Data (Either a b) @@ -15,9 +15,9 @@ annfail10.hs:9:1: error: • In the annotation: {-# ANN f 1 #-} annfail10.hs:9:11: error: - • Ambiguous type variable ‘a0’ arising from the literal ‘1’ - prevents the constraint ‘(Num a0)’ from being solved. - Probable fix: use a type annotation to specify what ‘a0’ should be. + • Ambiguous type variable ‘t0’ arising from the literal ‘1’ + prevents the constraint ‘(Num t0)’ from being solved. + Probable fix: use a type annotation to specify what ‘t0’ should be. These potential instances exist: instance Num Integer -- Defined in ‘GHC.Num’ instance Num Double -- Defined in ‘GHC.Float’ diff --git a/testsuite/tests/deSugar/should_run/dsrun017.hs b/testsuite/tests/deSugar/should_run/dsrun017.hs index 7a8d16efe5..7f2ba5db64 100644 --- a/testsuite/tests/deSugar/should_run/dsrun017.hs +++ b/testsuite/tests/deSugar/should_run/dsrun017.hs @@ -8,6 +8,6 @@ import GHC.Exts(the,groupWith) main = putStrLn (show output) where - output = [ (the dept, sum salary, name) + output = [ (the dept, sum salary, name) | (dept, salary, name) <- [("A", 1, "Bob"), ("B", 2, "Fred"), ("A", 5, "Jim"), ("A", 9, "Jim")] - , then group by dept using groupWith ]
\ No newline at end of file + , then group by dept using groupWith ] diff --git a/testsuite/tests/determinism/typecheck/A.hs b/testsuite/tests/determinism/typecheck/A.hs index 50b3ab1db2..1d8c5267db 100644 --- a/testsuite/tests/determinism/typecheck/A.hs +++ b/testsuite/tests/determinism/typecheck/A.hs @@ -39,7 +39,7 @@ instance Data Node where toConstr = toConstr dataTypeOf = dataTypeOf - dataCast1 = undefined + dataCast1 _ = undefined dataCast2 = dataCast2 gmapT = gmapT diff --git a/testsuite/tests/gadt/gadt-escape1.stderr b/testsuite/tests/gadt/gadt-escape1.stderr index 215426ed15..9bcd99cffe 100644 --- a/testsuite/tests/gadt/gadt-escape1.stderr +++ b/testsuite/tests/gadt/gadt-escape1.stderr @@ -1,19 +1,19 @@ gadt-escape1.hs:19:58: error: - • Couldn't match type ‘r’ with ‘ExpGADT Int’ - ‘r’ is untouchable - inside the constraints: t ~ Int + • Couldn't match type ‘t’ with ‘ExpGADT Int’ + ‘t’ is untouchable + inside the constraints: t1 ~ Int bound by a pattern with constructor: ExpInt :: Int -> ExpGADT Int, in a case alternative at gadt-escape1.hs:19:43-50 - ‘r’ is a rigid type variable bound by - the inferred type of weird1 :: r at gadt-escape1.hs:19:1 + ‘t’ is a rigid type variable bound by + the inferred type of weird1 :: t at gadt-escape1.hs:19:1 Possible fix: add a type signature for ‘weird1’ - Expected type: r - Actual type: ExpGADT t + Expected type: t + Actual type: ExpGADT t1 • In the expression: a In a case alternative: Hidden (ExpInt _) a -> a In the expression: case (hval :: Hidden) of { Hidden (ExpInt _) a -> a } • Relevant bindings include - weird1 :: r (bound at gadt-escape1.hs:19:1) + weird1 :: t (bound at gadt-escape1.hs:19:1) diff --git a/testsuite/tests/gadt/gadt13.stderr b/testsuite/tests/gadt/gadt13.stderr index 57ee3fdc92..bc14bf1c51 100644 --- a/testsuite/tests/gadt/gadt13.stderr +++ b/testsuite/tests/gadt/gadt13.stderr @@ -1,17 +1,17 @@ gadt13.hs:15:13: error: - • Couldn't match expected type ‘r’ + • Couldn't match expected type ‘t1’ with actual type ‘String -> [Char]’ - ‘r’ is untouchable + ‘t1’ is untouchable inside the constraints: t ~ Int bound by a pattern with constructor: I :: Int -> Term Int, in an equation for ‘shw’ at gadt13.hs:15:6-8 - ‘r’ is a rigid type variable bound by - the inferred type of shw :: Term t -> r at gadt13.hs:15:1 + ‘t1’ is a rigid type variable bound by + the inferred type of shw :: Term t -> t1 at gadt13.hs:15:1 Possible fix: add a type signature for ‘shw’ • Possible cause: ‘(.)’ is applied to too many arguments In the expression: ("I " ++) . shows t In an equation for ‘shw’: shw (I t) = ("I " ++) . shows t • Relevant bindings include - shw :: Term t -> r (bound at gadt13.hs:15:1) + shw :: Term t -> t1 (bound at gadt13.hs:15:1) diff --git a/testsuite/tests/gadt/gadt7.stderr b/testsuite/tests/gadt/gadt7.stderr index 93b8c70c1f..8219bee032 100644 --- a/testsuite/tests/gadt/gadt7.stderr +++ b/testsuite/tests/gadt/gadt7.stderr @@ -1,20 +1,20 @@ gadt7.hs:16:38: error: - • Couldn't match expected type ‘r’ with actual type ‘r1’ - ‘r’ is untouchable - inside the constraints: t ~ Int + • Couldn't match expected type ‘t2’ with actual type ‘t’ + ‘t2’ is untouchable + inside the constraints: t1 ~ Int bound by a pattern with constructor: K :: T Int, in a case alternative at gadt7.hs:16:33 - ‘r’ is a rigid type variable bound by - the inferred type of i1b :: T t -> r1 -> r at gadt7.hs:16:1 - ‘r1’ is a rigid type variable bound by - the inferred type of i1b :: T t -> r1 -> r at gadt7.hs:16:1 + ‘t2’ is a rigid type variable bound by + the inferred type of i1b :: T t1 -> t -> t2 at gadt7.hs:16:1 + ‘t’ is a rigid type variable bound by + the inferred type of i1b :: T t1 -> t -> t2 at gadt7.hs:16:1 Possible fix: add a type signature for ‘i1b’ • In the expression: y1 In a case alternative: K -> y1 In the expression: case t1 of { K -> y1 } • Relevant bindings include - y1 :: r1 (bound at gadt7.hs:16:16) - y :: r1 (bound at gadt7.hs:16:7) - i1b :: T t -> r1 -> r (bound at gadt7.hs:16:1) + y1 :: t (bound at gadt7.hs:16:16) + y :: t (bound at gadt7.hs:16:7) + i1b :: T t1 -> t -> t2 (bound at gadt7.hs:16:1) diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.stdout b/testsuite/tests/ghc-api/annotations-literals/parsed.stdout index fdf2bfc739..ce7a004929 100644 --- a/testsuite/tests/ghc-api/annotations-literals/parsed.stdout +++ b/testsuite/tests/ghc-api/annotations-literals/parsed.stdout @@ -1,12 +1,12 @@ HsIntegral [0003] 3 -HsString [] "noSyntaxExpr" +HsString [] "noExpr" HsIntegral [0x04] 4 -HsString [] "noSyntaxExpr" +HsString [] "noExpr" HsString ["\x20"] " " HsChar ['\x20'] ' ' -HsString [] "noSyntaxExpr" +HsString [] "noExpr" HsCharPrim ['\x41'] 'A' HsIntPrim [0004#] 4 HsWordPrim [005##] 5 HsIntegral [1] 1 -HsString [] "noSyntaxExpr" +HsString [] "noExpr" diff --git a/testsuite/tests/ghci.debugger/scripts/break003.stderr b/testsuite/tests/ghci.debugger/scripts/break003.stderr index 66310e5355..d069493986 100644 --- a/testsuite/tests/ghci.debugger/scripts/break003.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break003.stderr @@ -1,5 +1,5 @@ <interactive>:4:1: error: - • No instance for (Show (t -> a2)) arising from a use of ‘print’ + • No instance for (Show (t1 -> t)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) • In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci.debugger/scripts/break003.stdout b/testsuite/tests/ghci.debugger/scripts/break003.stdout index e1f4d351d1..1d0844c6cc 100644 --- a/testsuite/tests/ghci.debugger/scripts/break003.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break003.stdout @@ -1,6 +1,6 @@ Breakpoint 0 activated at ../Test3.hs:2:18-31 Stopped in Main.mymap, ../Test3.hs:2:18-31 -_result :: [a2] = _ -f :: t -> a2 = _ -x :: t = _ -xs :: [t] = [_] +_result :: [t] = _ +f :: t1 -> t = _ +x :: t1 = _ +xs :: [t1] = [_] diff --git a/testsuite/tests/ghci.debugger/scripts/break005.stdout b/testsuite/tests/ghci.debugger/scripts/break005.stdout index d6b287eb58..81eae63726 100644 --- a/testsuite/tests/ghci.debugger/scripts/break005.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break005.stdout @@ -4,7 +4,7 @@ a :: Integer = 1 left :: [Integer] = _ right :: [Integer] = _ Stopped in QSort.qsort, ../QSort.hs:5:17-26 -_result :: [a2] = _ -left :: [a2] = _ +_result :: [t] = _ +left :: [t] = _ () left = [] diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr index 9098cc9c65..3b57eb3a64 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr @@ -1,9 +1,9 @@ <interactive>:4:1: error: - • No instance for (Show a2) arising from a use of ‘print’ - Cannot resolve unknown runtime type ‘a2’ + • No instance for (Show t) arising from a use of ‘print’ + Cannot resolve unknown runtime type ‘t’ Use :print or :force to determine these types - Relevant bindings include it :: a2 (bound at <interactive>:4:1) + Relevant bindings include it :: t (bound at <interactive>:4:1) These potential instances exist: instance (Show a, Show b) => Show (Either a b) -- Defined in ‘Data.Either’ @@ -15,10 +15,10 @@ • In a stmt of an interactive GHCi command: print it <interactive>:6:1: error: - • No instance for (Show a2) arising from a use of ‘print’ - Cannot resolve unknown runtime type ‘a2’ + • No instance for (Show t) arising from a use of ‘print’ + Cannot resolve unknown runtime type ‘t’ Use :print or :force to determine these types - Relevant bindings include it :: a2 (bound at <interactive>:6:1) + Relevant bindings include it :: t (bound at <interactive>:6:1) These potential instances exist: instance (Show a, Show b) => Show (Either a b) -- Defined in ‘Data.Either’ diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stdout b/testsuite/tests/ghci.debugger/scripts/break006.stdout index 93326416e0..d8f1b65864 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break006.stdout @@ -1,13 +1,13 @@ Stopped in Main.mymap, ../Test3.hs:2:18-31 -_result :: [a2] = _ -f :: Integer -> a2 = _ +_result :: [t] = _ +f :: Integer -> t = _ x :: Integer = 1 xs :: [Integer] = [2,3] xs :: [Integer] = [2,3] x :: Integer = 1 -f :: Integer -> a2 = _ -_result :: [a2] = _ -y = (_t1::a2) +f :: Integer -> t = _ +_result :: [t] = _ +y = (_t1::t) y = 2 xs :: [Integer] = [2,3] x :: Integer = 1 diff --git a/testsuite/tests/ghci.debugger/scripts/break012.stdout b/testsuite/tests/ghci.debugger/scripts/break012.stdout index 4eed1e61f0..539a894b16 100644 --- a/testsuite/tests/ghci.debugger/scripts/break012.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break012.stdout @@ -1,14 +1,14 @@ Stopped in Main.g, break012.hs:5:10-18 -_result :: (r, a3 -> a3, (), a2 -> a2 -> a2) = _ -a :: r = _ +_result :: (t, a3 -> a3, (), a2 -> a2 -> a2) = _ +a :: t = _ b :: a4 -> a4 = _ c :: () = _ d :: a2 -> a2 -> a2 = _ -a :: r +a :: t b :: a4 -> a4 c :: () d :: a2 -> a2 -> a2 -a = (_t1::r) +a = (_t1::t) b = (_t2::a4 -> a4) c = (_t3::()) d = (_t4::a2 -> a2 -> a2) diff --git a/testsuite/tests/ghci.debugger/scripts/hist001.stdout b/testsuite/tests/ghci.debugger/scripts/hist001.stdout index c5b2787db5..7ef5dc1e8e 100644 --- a/testsuite/tests/ghci.debugger/scripts/hist001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/hist001.stdout @@ -9,25 +9,25 @@ _result :: [a] = _ -6 : mymap (../Test3.hs:2:18-31) <end of history> Logged breakpoint at ../Test3.hs:2:22-31 -_result :: [a2] -f :: t -> a2 -xs :: [t] -xs :: [t] = [] -f :: t -> a2 = _ -_result :: [a2] = _ +_result :: [t] +f :: t1 -> t +xs :: [t1] +xs :: [t1] = [] +f :: t1 -> t = _ +_result :: [t] = _ Logged breakpoint at ../Test3.hs:2:18-20 -_result :: a2 -f :: Integer -> a2 +_result :: t +f :: Integer -> t x :: Integer -xs :: [t] = [] +xs :: [t1] = [] x :: Integer = 2 -f :: Integer -> a2 = _ -_result :: a2 = _ +f :: Integer -> t = _ +_result :: t = _ _result = 3 Logged breakpoint at ../Test3.hs:2:18-31 -_result :: [a2] -f :: Integer -> a2 +_result :: [t] +f :: Integer -> t x :: Integer xs :: [Integer] Logged breakpoint at ../Test3.hs:2:18-20 -_result :: a2 +_result :: t diff --git a/testsuite/tests/ghci.debugger/scripts/print022.stdout b/testsuite/tests/ghci.debugger/scripts/print022.stdout index 47c1483fc4..40d2b59544 100644 --- a/testsuite/tests/ghci.debugger/scripts/print022.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print022.stdout @@ -2,7 +2,7 @@ test = C 1 32 1.2 1.23 'x' 1 1.2 1.23 Breakpoint 0 activated at print022.hs:11:7 Stopped in Main.f, print022.hs:11:7 -_result :: r = _ -x :: r = _ +_result :: t = _ +x :: t = _ x = C2 1 (W# 32) (TwoFields 'a' 3) x :: T2 diff --git a/testsuite/tests/ghci/scripts/T2182ghci.stderr b/testsuite/tests/ghci/scripts/T2182ghci.stderr index dd65a7fc1f..8a8d3dd65b 100644 --- a/testsuite/tests/ghci/scripts/T2182ghci.stderr +++ b/testsuite/tests/ghci/scripts/T2182ghci.stderr @@ -1,25 +1,25 @@ <interactive>:2:1: error: - No instance for (Show (r0 -> r0)) arising from a use of ‘print’ - (maybe you haven't applied a function to enough arguments?) - In a stmt of an interactive GHCi command: print it + • No instance for (Show (t0 -> t0)) arising from a use of ‘print’ + (maybe you haven't applied a function to enough arguments?) + • In a stmt of an interactive GHCi command: print it <interactive>:10:1: error: - No instance for (Show (r0 -> r0)) arising from a use of ‘print’ - (maybe you haven't applied a function to enough arguments?) - In a stmt of an interactive GHCi command: print it + • No instance for (Show (t0 -> t0)) arising from a use of ‘print’ + (maybe you haven't applied a function to enough arguments?) + • In a stmt of an interactive GHCi command: print it <interactive>:19:1: error: - No instance for (Show (r0 -> r0)) arising from a use of ‘print’ - (maybe you haven't applied a function to enough arguments?) - In a stmt of an interactive GHCi command: print it + • No instance for (Show (t0 -> t0)) arising from a use of ‘print’ + (maybe you haven't applied a function to enough arguments?) + • In a stmt of an interactive GHCi command: print it <interactive>:28:1: error: - No instance for (Show (r0 -> r0)) arising from a use of ‘print’ - (maybe you haven't applied a function to enough arguments?) - In a stmt of an interactive GHCi command: print it + • No instance for (Show (t0 -> t0)) arising from a use of ‘print’ + (maybe you haven't applied a function to enough arguments?) + • In a stmt of an interactive GHCi command: print it <interactive>:49:1: error: - No instance for (Show (r0 -> r0)) arising from a use of ‘print’ - (maybe you haven't applied a function to enough arguments?) - In a stmt of an interactive GHCi command: print it + • No instance for (Show (t0 -> t0)) arising from a use of ‘print’ + (maybe you haven't applied a function to enough arguments?) + • In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci/scripts/T8959.script b/testsuite/tests/ghci/scripts/T8959.script index da60aeb44e..e8f7490111 100644 --- a/testsuite/tests/ghci/scripts/T8959.script +++ b/testsuite/tests/ghci/scripts/T8959.script @@ -1,20 +1,22 @@ :set -XPatternGuards -XArrows -XRankNTypes +let hr :: (forall a. a -> a) -> a; hr _ = undefined + :t lookup -:t undefined :: (forall a. a -> a) -> a +:t hr :: (forall a. a -> a) -> a :t () >- () -< () >>- () -<< () let fun foo | True <- () = () :set -fprint-unicode-syntax :t lookup -:t undefined :: (forall a. a -> a) -> a +:t hr :: (forall a. a -> a) -> a :t () >- () -< () >>- () -<< () let fun foo | True <- () = () :set -fno-print-unicode-syntax :t lookup -:t undefined :: (forall a. a -> a) -> a +:t hr :: (forall a. a -> a) -> a :t () >- () -< () >>- () -<< () let fun foo | True <- () = () diff --git a/testsuite/tests/ghci/scripts/T8959.stderr b/testsuite/tests/ghci/scripts/T8959.stderr index 2c1d5e5d25..2890a172c2 100644 --- a/testsuite/tests/ghci/scripts/T8959.stderr +++ b/testsuite/tests/ghci/scripts/T8959.stderr @@ -1,36 +1,36 @@ -<interactive>:1:1: +<interactive>:1:1: error: Arrow command found where an expression was expected: () >- () -< () >>- () -<< () -<interactive>:6:15: - Couldn't match expected type ‘()’ with actual type ‘Bool’ - In the pattern: True - In a stmt of a pattern guard for - an equation for ‘fun’: - True <- () - In an equation for ‘fun’: fun foo | True <- () = () +<interactive>:8:15: error: + • Couldn't match expected type ‘()’ with actual type ‘Bool’ + • In the pattern: True + In a stmt of a pattern guard for + an equation for ‘fun’: + True <- () + In an equation for ‘fun’: fun foo | True <- () = () -<interactive>:1:1: +<interactive>:1:1: error: Arrow command found where an expression was expected: () ⤚ () ⤙ () ⤜ () ⤛ () -<interactive>:13:15: - Couldn't match expected type ‘()’ with actual type ‘Bool’ - In the pattern: True - In a stmt of a pattern guard for - an equation for ‘fun’: - True ← () - In an equation for ‘fun’: fun foo | True ← () = () +<interactive>:15:15: error: + • Couldn't match expected type ‘()’ with actual type ‘Bool’ + • In the pattern: True + In a stmt of a pattern guard for + an equation for ‘fun’: + True ← () + In an equation for ‘fun’: fun foo | True ← () = () -<interactive>:1:1: +<interactive>:1:1: error: Arrow command found where an expression was expected: () >- () -< () >>- () -<< () -<interactive>:20:15: - Couldn't match expected type ‘()’ with actual type ‘Bool’ - In the pattern: True - In a stmt of a pattern guard for - an equation for ‘fun’: - True <- () - In an equation for ‘fun’: fun foo | True <- () = () +<interactive>:22:15: error: + • Couldn't match expected type ‘()’ with actual type ‘Bool’ + • In the pattern: True + In a stmt of a pattern guard for + an equation for ‘fun’: + True <- () + In an equation for ‘fun’: fun foo | True <- () = () diff --git a/testsuite/tests/ghci/scripts/T8959.stdout b/testsuite/tests/ghci/scripts/T8959.stdout index 02b5f828c2..6e40a5f316 100644 --- a/testsuite/tests/ghci/scripts/T8959.stdout +++ b/testsuite/tests/ghci/scripts/T8959.stdout @@ -1,11 +1,6 @@ lookup :: Eq a => a -> [(a, b)] -> Maybe b -undefined :: (forall a. a -> a) -> a - :: (?callStack::GHC.Stack.Types.CallStack) => - (forall a1. a1 -> a1) -> a +hr :: (forall a. a -> a) -> a :: (forall a1. a1 -> a1) -> a lookup ∷ Eq a ⇒ a → [(a, b)] → Maybe b -undefined :: (forall a. a -> a) -> a - ∷ (?callStack::GHC.Stack.Types.CallStack) ⇒ (∀ a1. a1 → a1) → a +hr :: (forall a. a -> a) -> a ∷ (∀ a1. a1 → a1) → a lookup :: Eq a => a -> [(a, b)] -> Maybe b -undefined :: (forall a. a -> a) -> a - :: (?callStack::GHC.Stack.Types.CallStack) => - (forall a1. a1 -> a1) -> a +hr :: (forall a. a -> a) -> a :: (forall a1. a1 -> a1) -> a diff --git a/testsuite/tests/indexed-types/should_compile/T3484.hs b/testsuite/tests/indexed-types/should_compile/T3484.hs index e558cbbe21..1d53b320d2 100644 --- a/testsuite/tests/indexed-types/should_compile/T3484.hs +++ b/testsuite/tests/indexed-types/should_compile/T3484.hs @@ -8,9 +8,9 @@ newtype S n = S n class Nat n where caseNat :: (n ~ Z => r) -> (forall p. (n ~ S p, Nat p) => p -> r) -> n -> r instance Nat Z where - caseNat = error "urk1" + caseNat _ _ = error "urk1" instance Nat n => Nat (S n) where - caseNat = error "urk2" + caseNat _ _ = error "urk2" -- empty type newtype Naught = Naught (forall a. a) @@ -40,4 +40,4 @@ natEqDec m n = caseNat undefined mIsS m where -- strange things: -- (1) commenting out the "Yes" case or changing it to "undefined" makes compilation succeed --- (2) replacing the "No" line with with the commented out "No" line makes compilation succeed
\ No newline at end of file +-- (2) replacing the "No" line with with the commented out "No" line makes compilation succeed diff --git a/testsuite/tests/indexed-types/should_compile/T4120.hs b/testsuite/tests/indexed-types/should_compile/T4120.hs index 3b1475916d..ffa729aa8a 100644 --- a/testsuite/tests/indexed-types/should_compile/T4120.hs +++ b/testsuite/tests/indexed-types/should_compile/T4120.hs @@ -17,10 +17,8 @@ create :: (forall s. MVector s a) -> Int create = create1 -- Here we get Couldn't match expected type `forall s. MVector s a' -- with actual type `forall s. Mutable Vector s a1' --- Reason: when unifying under a for-all we don't solve type +-- Reason: when unifying under a for-all we don't solve type -- equalities. Think more about this. create1 :: (forall s. Mutable Vector s a) -> Int -create1 = error "urk" - - +create1 _ = error "urk" diff --git a/testsuite/tests/indexed-types/should_compile/T4494.hs b/testsuite/tests/indexed-types/should_compile/T4494.hs index ec04943d6b..ef8887ac9c 100644 --- a/testsuite/tests/indexed-types/should_compile/T4494.hs +++ b/testsuite/tests/indexed-types/should_compile/T4494.hs @@ -6,7 +6,7 @@ type family H s type family F v bar :: (forall t. Maybe t -> a) -> H a -> Int -bar = error "urk" +bar _ = error "urk" call :: F Bool -> Int call x = bar (\_ -> x) (undefined :: H (F Bool)) @@ -29,4 +29,3 @@ fuv1 := fuv2 alpha := F Bool -} - diff --git a/testsuite/tests/indexed-types/should_compile/T9090.hs b/testsuite/tests/indexed-types/should_compile/T9090.hs index b3b639f126..7dc065d639 100644 --- a/testsuite/tests/indexed-types/should_compile/T9090.hs +++ b/testsuite/tests/indexed-types/should_compile/T9090.hs @@ -10,7 +10,7 @@ type instance F (Eq a) = Eq a -- checks f :: Eq b => (forall a. F (Eq a) => f a -> Bool) -> f b -> Bool -f = error "urk" -- g x = g x +f _ = error "urk" -- g x = g x -- checks f' :: Eq b => (forall a. Eq a => f a -> Bool) -> f b -> Bool diff --git a/testsuite/tests/indexed-types/should_compile/T9316.hs b/testsuite/tests/indexed-types/should_compile/T9316.hs index 31da8f4791..473c213965 100644 --- a/testsuite/tests/indexed-types/should_compile/T9316.hs +++ b/testsuite/tests/indexed-types/should_compile/T9316.hs @@ -54,7 +54,7 @@ withSomeSing :: SingKind ('KProxy :: KProxy k) => DemoteRep ('KProxy :: KProxy k) -> (forall (a :: k). Sing a -> r) -> r -withSomeSing = error "urk" +withSomeSing _ _ = error "urk" ----------------------------------- diff --git a/testsuite/tests/indexed-types/should_fail/T3330a.hs b/testsuite/tests/indexed-types/should_fail/T3330a.hs index 51d97d5e1d..55bf067238 100644 --- a/testsuite/tests/indexed-types/should_fail/T3330a.hs +++ b/testsuite/tests/indexed-types/should_fail/T3330a.hs @@ -44,5 +44,4 @@ collect = error "collect" hmapM :: (forall ix. phi ix -> r ix -> m (r' ix)) -> phi ix -> f r ix -> m (f r' ix) -hmapM = error "hmapM" - +hmapM _ = error "hmapM" diff --git a/testsuite/tests/indexed-types/should_fail/T5934.stderr b/testsuite/tests/indexed-types/should_fail/T5934.stderr index 8460105c2f..20b16b273b 100644 --- a/testsuite/tests/indexed-types/should_fail/T5934.stderr +++ b/testsuite/tests/indexed-types/should_fail/T5934.stderr @@ -1,7 +1,6 @@ -T5934.hs:12:7: - Couldn't match type ‘Integer’ with ‘(forall s. GenST s) -> Int’ - Expected type: Integer -> (forall s. GenST s) -> Int - Actual type: Integer -> Integer - In the expression: 0 - In an equation for ‘run’: run = 0 +T5934.hs:12:7: error: + • Couldn't match expected type ‘(forall s. GenST s) -> Int’ + with actual type ‘Integer’ + • In the expression: 0 + In an equation for ‘run’: run = 0 diff --git a/testsuite/tests/indexed-types/should_fail/T7788.stderr b/testsuite/tests/indexed-types/should_fail/T7788.stderr index fa4f3ed260..65c78aea3b 100644 --- a/testsuite/tests/indexed-types/should_fail/T7788.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7788.stderr @@ -1,11 +1,10 @@ -T7788.hs:19:20: error: +T7788.hs:9:7: error: • Reduction stack overflow; size = 201 When simplifying the following type: F (Id (Fix Id)) Use -freduction-depth=0 to disable this check (any upper bound you could choose might fail unpredictably with minor updates to GHC, so disabling the check is recommended if you're sure that type checking should terminate) - • In the first argument of ‘foo’, namely ‘Proxy’ - In the second argument of ‘($)’, namely ‘foo Proxy’ - In the expression: print $ foo Proxy + • In the expression: undefined + In an equation for ‘foo’: foo = undefined diff --git a/testsuite/tests/indexed-types/should_fail/T8518.stderr b/testsuite/tests/indexed-types/should_fail/T8518.stderr index 0df2b3cf83..037bb76bbe 100644 --- a/testsuite/tests/indexed-types/should_fail/T8518.stderr +++ b/testsuite/tests/indexed-types/should_fail/T8518.stderr @@ -1,7 +1,10 @@ T8518.hs:14:18: error: - • Couldn't match expected type ‘Maybe (F c)’ with actual type ‘F c’ - • In the expression: rpt (4 :: Int) c z b + • Couldn't match expected type ‘Z c -> B c -> Maybe (F c)’ + with actual type ‘F c’ + • The function ‘rpt’ is applied to four arguments, + but its type ‘Int -> c -> F c’ has only two + In the expression: rpt (4 :: Int) c z b In an equation for ‘callCont’: callCont c z b = rpt (4 :: Int) c z b @@ -14,19 +17,15 @@ T8518.hs:14:18: error: c :: c (bound at T8518.hs:14:10) callCont :: c -> Z c -> B c -> Maybe (F c) (bound at T8518.hs:14:1) -T8518.hs:17:78: error: - • Couldn't match expected type ‘F a’ - with actual type ‘Z a -> B a -> F a’ - • In the expression: rpt (i - 1) c'' - In the expression: - let c'' = fromJust (snd <$> (continue c' z' b')) in rpt (i - 1) c'' - In an equation for ‘rpt’: - rpt i c' z' b' - = let c'' = fromJust (snd <$> (continue c' z' b')) - in rpt (i - 1) c'' +T8518.hs:16:9: error: + • Couldn't match type ‘F t1’ with ‘Z t1 -> B t1 -> F t1’ + Expected type: t -> t1 -> F t1 + Actual type: t -> t1 -> Z t1 -> B t1 -> F t1 + • In an equation for ‘callCont’: + callCont c z b + = rpt (4 :: Int) c z b + where + rpt 0 c' z' b' = fromJust (fst <$> (continue c' z' b')) + rpt i c' z' b' = let ... in rpt (i - 1) c'' • Relevant bindings include - c'' :: a (bound at T8518.hs:17:30) - b' :: B a (bound at T8518.hs:17:21) - z' :: Z a (bound at T8518.hs:17:18) - c' :: a (bound at T8518.hs:17:15) - rpt :: a1 -> a -> Z a -> B a -> F a (bound at T8518.hs:16:9) + rpt :: t -> t1 -> F t1 (bound at T8518.hs:16:9) diff --git a/testsuite/tests/module/mod71.stderr b/testsuite/tests/module/mod71.stderr index 9c72697300..9480e92271 100644 --- a/testsuite/tests/module/mod71.stderr +++ b/testsuite/tests/module/mod71.stderr @@ -2,11 +2,11 @@ mod71.hs:4:9: error: • Found hole: _ :: t Where: ‘t’ is a rigid type variable bound by - the inferred type of f :: Num a => (t -> a -> r) -> r + the inferred type of f :: Num t1 => (t -> t1 -> t2) -> t2 at mod71.hs:4:1 • In the first argument of ‘x’, namely ‘_’ In the expression: x _ 1 In an equation for ‘f’: f x = x _ 1 • Relevant bindings include - x :: t -> a -> r (bound at mod71.hs:4:3) - f :: (t -> a -> r) -> r (bound at mod71.hs:4:1) + x :: t -> t1 -> t2 (bound at mod71.hs:4:3) + f :: (t -> t1 -> t2) -> t2 (bound at mod71.hs:4:1) diff --git a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail03.hs b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail03.hs index d1981846df..25d859d2a8 100644 --- a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail03.hs +++ b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail03.hs @@ -1,3 +1,3 @@ {-# LANGUAGE OverloadedLists #-} -main = print (length ['a',"b"]) +main = print (length (['a',"b"] :: [Char])) diff --git a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail03.stderr b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail03.stderr index 9c2e41640e..4d55087e18 100644 --- a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail03.stderr +++ b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail03.stderr @@ -1,6 +1,9 @@ -overloadedlistsfail03.hs:3:27: - Couldn't match expected type ‘Char’ with actual type ‘[Char]’ - In the expression: "b" - In the first argument of ‘length’, namely ‘['a', "b"]’ - In the first argument of ‘print’, namely ‘(length ['a', "b"])’ +overloadedlistsfail03.hs:3:28: error: + • Couldn't match type ‘[Char]’ with ‘Char’ + Expected type: GHC.Exts.Item [Char] + Actual type: [Char] + • In the expression: "b" + In the first argument of ‘length’, namely ‘(['a', "b"] :: [Char])’ + In the first argument of ‘print’, namely + ‘(length (['a', "b"] :: [Char]))’ diff --git a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail05.hs b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail05.hs index 3601c6e2f1..7059b4b5aa 100644 --- a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail05.hs +++ b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail05.hs @@ -1,3 +1,3 @@ {-# LANGUAGE OverloadedLists #-} -main = print (length ['a'..(10 :: Int)]) +main = print (length (['a'..(10 :: Int)] :: [Int])) diff --git a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail05.stderr b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail05.stderr index c576b5868c..edd0c7fcef 100644 --- a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail05.stderr +++ b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail05.stderr @@ -1,7 +1,10 @@ -overloadedlistsfail05.hs:3:29: - Couldn't match expected type ‘Char’ with actual type ‘Int’ - In the expression: (10 :: Int) - In the first argument of ‘length’, namely ‘['a' .. (10 :: Int)]’ - In the first argument of ‘print’, namely - ‘(length ['a' .. (10 :: Int)])’ +overloadedlistsfail05.hs:3:24: error: + • Couldn't match type ‘Char’ with ‘Int’ + Expected type: GHC.Exts.Item [Int] + Actual type: Char + • In the expression: 'a' + In the first argument of ‘length’, namely + ‘(['a' .. (10 :: Int)] :: [Int])’ + In the first argument of ‘print’, namely + ‘(length (['a' .. (10 :: Int)] :: [Int]))’ diff --git a/testsuite/tests/parser/should_compile/read014.stderr b/testsuite/tests/parser/should_compile/read014.stderr index ebc07af88e..030b2c52de 100644 --- a/testsuite/tests/parser/should_compile/read014.stderr +++ b/testsuite/tests/parser/should_compile/read014.stderr @@ -1,13 +1,13 @@ read014.hs:4:1: warning: Top-level binding with no type signature: - ng1 :: forall r a. Num a => r -> a -> a + ng1 :: forall t a. Num a => t -> a -> a read014.hs:4:5: warning: Defined but not used: ‘x’ read014.hs:6:10: warning: - No explicit implementation for - ‘+’, ‘*’, ‘abs’, ‘signum’, and ‘fromInteger’ - In the instance declaration for ‘Num (a, b)’ + • No explicit implementation for + ‘+’, ‘*’, ‘abs’, ‘signum’, and ‘fromInteger’ + • In the instance declaration for ‘Num (a, b)’ read014.hs:8:53: warning: Defined but not used: ‘x’ diff --git a/testsuite/tests/parser/should_fail/T7848.stderr b/testsuite/tests/parser/should_fail/T7848.stderr index b957433e9b..f7617ee606 100644 --- a/testsuite/tests/parser/should_fail/T7848.stderr +++ b/testsuite/tests/parser/should_fail/T7848.stderr @@ -1,33 +1,19 @@ -T7848.hs:6:57: error: +T7848.hs:6:1: error: • Occurs check: cannot construct the infinite type: - t2 ~ r0 -> t -> t1 -> A -> A -> A -> A -> t2 - • In the expression: y - In an equation for ‘x’: - x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h) - = y - where - infixl 3 `y` - y _ = (&) - {-# INLINE (&) #-} - {-# SPECIALIZE (&) :: a #-} - (&) = x - • Relevant bindings include - y :: forall r. r -> t -> t1 -> A -> A -> A -> A -> t2 - (bound at T7848.hs:8:9) - (&) :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:11:9) - z :: t1 (bound at T7848.hs:6:12) - (&) :: t1 (bound at T7848.hs:6:8) - (+) :: t (bound at T7848.hs:6:3) - x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1) + t ~ t0 -> t1 -> A -> A -> A -> A -> t2 -> t + • When checking that: + t0 -> t1 -> A -> A -> A -> A -> forall t2. t2 -> t + is more polymorphic than: t + • Relevant bindings include x :: t (bound at T7848.hs:6:1) T7848.hs:10:9: error: - • Couldn't match expected type ‘t -> t1 -> A -> A -> A -> A -> t2’ - with actual type ‘a’ - ‘a’ is a rigid type variable bound by + • Couldn't match expected type ‘t’ with actual type ‘a’ + because type variable ‘a’ would escape its scope + This (rigid, skolem) type variable is bound by the type signature for: - (&) :: forall a. a - at T7848.hs:10:9 + (&) :: a + at T7848.hs:10:9-35 • In the SPECIALISE pragma {-# SPECIALIZE (&) :: a #-} In an equation for ‘x’: x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h) @@ -38,8 +24,4 @@ T7848.hs:10:9: error: {-# INLINE (&) #-} {-# SPECIALIZE (&) :: a #-} (&) = x - • Relevant bindings include - z :: t1 (bound at T7848.hs:6:12) - (&) :: t1 (bound at T7848.hs:6:8) - (+) :: t (bound at T7848.hs:6:3) - x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1) + • Relevant bindings include x :: t (bound at T7848.hs:6:1) diff --git a/testsuite/tests/partial-sigs/should_compile/T10438.stderr b/testsuite/tests/partial-sigs/should_compile/T10438.stderr index f26bfe7a8d..d04fca208b 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10438.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10438.stderr @@ -1,8 +1,8 @@ T10438.hs:7:22: warning: - • Found type wildcard ‘_’ standing for ‘r2’ - Where: ‘r2’ is a rigid type variable bound by - the inferred type of g :: r2 -> r2 at T10438.hs:6:9 + • Found type wildcard ‘_’ standing for ‘t2’ + Where: ‘t2’ is a rigid type variable bound by + the inferred type of g :: t2 -> t2 at T10438.hs:6:9 • In the type signature: x :: _ In an equation for ‘g’: @@ -21,8 +21,8 @@ T10438.hs:7:22: warning: x :: _ x = r • Relevant bindings include - x :: r2 (bound at T10438.hs:8:17) - r :: r2 (bound at T10438.hs:6:11) - g :: r2 -> r2 (bound at T10438.hs:6:9) - f :: r (bound at T10438.hs:5:5) - foo :: r -> forall r1. r1 -> r1 (bound at T10438.hs:5:1) + x :: t2 (bound at T10438.hs:8:17) + r :: t2 (bound at T10438.hs:6:11) + g :: t2 -> t2 (bound at T10438.hs:6:9) + f :: t (bound at T10438.hs:5:5) + foo :: t -> forall t1. t1 -> t1 (bound at T10438.hs:5:1) diff --git a/testsuite/tests/partial-sigs/should_compile/T11192.stderr b/testsuite/tests/partial-sigs/should_compile/T11192.stderr index 77b70e3fe2..f2892b7fae 100644 --- a/testsuite/tests/partial-sigs/should_compile/T11192.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T11192.stderr @@ -21,11 +21,11 @@ T11192.hs:7:14: warning: fails :: a (bound at T11192.hs:6:1) T11192.hs:13:14: warning: - • Found type wildcard ‘_’ standing for ‘t -> t1 -> t1’ - Where: ‘t1’ is a rigid type variable bound by - the inferred type of go :: t -> t1 -> t1 at T11192.hs:14:8 - ‘t’ is a rigid type variable bound by - the inferred type of go :: t -> t1 -> t1 at T11192.hs:14:8 + • Found type wildcard ‘_’ standing for ‘t1 -> t -> t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of go :: t1 -> t -> t at T11192.hs:14:8 + ‘t1’ is a rigid type variable bound by + the inferred type of go :: t1 -> t -> t at T11192.hs:14:8 • In the type signature: go :: _ In the expression: @@ -40,5 +40,5 @@ T11192.hs:13:14: warning: go _ a = a in go (0 :: Int) undefined • Relevant bindings include - go :: t -> t1 -> t1 (bound at T11192.hs:14:8) + go :: t1 -> t -> t (bound at T11192.hs:14:8) succeeds :: a (bound at T11192.hs:12:1) diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 9c3daa71b1..13ac9b8286 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -603,12 +603,13 @@ test('T9020', [(wordsize(32), 343005716, 10), # Original: 381360728 # 2014-07-31: 343005716 (Windows) (general round of updates) - (wordsize(64), 786189008, 10)]) + (wordsize(64), 698401736, 10)]) # prev: 795469104 # 2014-07-17: 728263536 (general round of updates) # 2014-09-10: 785871680 post-AMP-cleanup # 2014-11-03: 680162056 Further Applicative and Monad adjustments # 2015-10-21: 786189008 Make stronglyConnCompFromEdgedVertices deterministic + # 2016-01-26: 698401736 improvement from using ExpTypes instead of ReturnTvs ], compile,['']) diff --git a/testsuite/tests/polykinds/T7438.stderr b/testsuite/tests/polykinds/T7438.stderr index 46b7181840..d3ed001879 100644 --- a/testsuite/tests/polykinds/T7438.stderr +++ b/testsuite/tests/polykinds/T7438.stderr @@ -1,19 +1,19 @@ T7438.hs:6:14: error: - • Couldn't match expected type ‘r1’ with actual type ‘r’ - ‘r1’ is untouchable + • Couldn't match expected type ‘t3’ with actual type ‘t2’ + ‘t3’ is untouchable inside the constraints: t1 ~ t bound by a pattern with constructor: Nil :: forall k (a :: k). Thrist a a, in an equation for ‘go’ at T7438.hs:6:4-6 - ‘r1’ is a rigid type variable bound by - the inferred type of go :: Thrist t t1 -> r -> r1 at T7438.hs:6:1 - ‘r’ is a rigid type variable bound by - the inferred type of go :: Thrist t t1 -> r -> r1 at T7438.hs:6:1 + ‘t3’ is a rigid type variable bound by + the inferred type of go :: Thrist t t1 -> t2 -> t3 at T7438.hs:6:1 + ‘t2’ is a rigid type variable bound by + the inferred type of go :: Thrist t t1 -> t2 -> t3 at T7438.hs:6:1 Possible fix: add a type signature for ‘go’ • In the expression: acc In an equation for ‘go’: go Nil acc = acc • Relevant bindings include - acc :: r (bound at T7438.hs:6:8) - go :: Thrist t t1 -> r -> r1 (bound at T7438.hs:6:1) + acc :: t2 (bound at T7438.hs:6:8) + go :: Thrist t t1 -> t2 -> t3 (bound at T7438.hs:6:1) diff --git a/testsuite/tests/rebindable/rebindable6.hs b/testsuite/tests/rebindable/rebindable6.hs index ec975e7f37..3ec03477d2 100644 --- a/testsuite/tests/rebindable/rebindable6.hs +++ b/testsuite/tests/rebindable/rebindable6.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} module Main where { @@ -88,7 +89,7 @@ module Main where negate :: a; }; - instance HasNegate (a -> a) where + instance (b ~ (a -> a)) => HasNegate b where { negate a = a; -- don't actually negate }; @@ -98,7 +99,7 @@ module Main where (-) :: a; }; - instance HasMinus (a -> a -> a) where + instance (b ~ (a -> a -> a)) => HasMinus b where { (-) x y = y; -- changed function }; diff --git a/testsuite/tests/rebindable/rebindable6.stderr b/testsuite/tests/rebindable/rebindable6.stderr index 0497c9fc61..8d2ea09928 100644 --- a/testsuite/tests/rebindable/rebindable6.stderr +++ b/testsuite/tests/rebindable/rebindable6.stderr @@ -1,18 +1,18 @@ -rebindable6.hs:109:17: error: +rebindable6.hs:110:17: error: • Ambiguous type variable ‘t0’ arising from a do statement prevents the constraint ‘(HasSeq (IO a -> t0 -> IO b))’ from being solved. (maybe you haven't applied a function to enough arguments?) Relevant bindings include - g :: IO (Maybe b) (bound at rebindable6.hs:107:19) - f :: IO a (bound at rebindable6.hs:107:17) + g :: IO (Maybe b) (bound at rebindable6.hs:108:19) + f :: IO a (bound at rebindable6.hs:108:17) test_do :: IO a -> IO (Maybe b) -> IO b - (bound at rebindable6.hs:107:9) + (bound at rebindable6.hs:108:9) Probable fix: use a type annotation to specify what ‘t0’ should be. These potential instance exist: instance HasSeq (IO a -> IO b -> IO b) - -- Defined at rebindable6.hs:55:18 + -- Defined at rebindable6.hs:56:18 • In a stmt of a 'do' block: f In the expression: do { f; @@ -24,7 +24,7 @@ rebindable6.hs:109:17: error: Just (b :: b) <- g; return b } -rebindable6.hs:110:17: error: +rebindable6.hs:111:17: error: • Ambiguous type variable ‘t1’ arising from a do statement with the failable pattern ‘Just (b :: b)’ prevents the constraint ‘(HasFail @@ -33,7 +33,7 @@ rebindable6.hs:110:17: error: Probable fix: use a type annotation to specify what ‘t1’ should be. These potential instance exist: instance HasFail (String -> IO a) - -- Defined at rebindable6.hs:60:18 + -- Defined at rebindable6.hs:61:18 • In a stmt of a 'do' block: Just (b :: b) <- g In the expression: do { f; @@ -45,18 +45,18 @@ rebindable6.hs:110:17: error: Just (b :: b) <- g; return b } -rebindable6.hs:111:17: error: +rebindable6.hs:112:17: error: • Ambiguous type variable ‘t1’ arising from a use of ‘return’ prevents the constraint ‘(HasReturn (b -> t1))’ from being solved. (maybe you haven't applied a function to enough arguments?) Relevant bindings include - b :: b (bound at rebindable6.hs:110:23) - g :: IO (Maybe b) (bound at rebindable6.hs:107:19) + b :: b (bound at rebindable6.hs:111:23) + g :: IO (Maybe b) (bound at rebindable6.hs:108:19) test_do :: IO a -> IO (Maybe b) -> IO b - (bound at rebindable6.hs:107:9) + (bound at rebindable6.hs:108:9) Probable fix: use a type annotation to specify what ‘t1’ should be. These potential instance exist: - instance HasReturn (a -> IO a) -- Defined at rebindable6.hs:45:18 + instance HasReturn (a -> IO a) -- Defined at rebindable6.hs:46:18 • In a stmt of a 'do' block: return b In the expression: do { f; diff --git a/testsuite/tests/rename/should_compile/T3103/GHC/Num.hs b/testsuite/tests/rename/should_compile/T3103/GHC/Num.hs new file mode 100644 index 0000000000..1d403249f2 --- /dev/null +++ b/testsuite/tests/rename/should_compile/T3103/GHC/Num.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Num (fromInteger) where + +import GHC.Base +import GHC.Integer + +fromInteger :: Num a => Integer -> a +fromInteger = fromInteger diff --git a/testsuite/tests/rename/should_compile/T3103/GHC/Word.hs b/testsuite/tests/rename/should_compile/T3103/GHC/Word.hs index 6866e92879..c0172640cd 100644 --- a/testsuite/tests/rename/should_compile/T3103/GHC/Word.hs +++ b/testsuite/tests/rename/should_compile/T3103/GHC/Word.hs @@ -6,10 +6,10 @@ module GHC.Word ( import GHC.Base import GHC.Types +import GHC.Num () import {-# SOURCE #-} GHC.Unicode () instance Num Word where signum 0 = 0 signum _ = 1 - diff --git a/testsuite/tests/th/T11452.hs b/testsuite/tests/th/T11452.hs new file mode 100644 index 0000000000..8d91ee47c9 --- /dev/null +++ b/testsuite/tests/th/T11452.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RankNTypes, TemplateHaskell #-} + +module T11452 where + +impred :: (forall a. a -> a) -> () +impred = $$( [|| \_ -> () ||] ) diff --git a/testsuite/tests/th/T11452.stderr b/testsuite/tests/th/T11452.stderr new file mode 100644 index 0000000000..f59fcbd7d2 --- /dev/null +++ b/testsuite/tests/th/T11452.stderr @@ -0,0 +1,15 @@ + +T11452.hs:6:14: error: + • Illegal polytype: (forall a. a -> a) -> () + The type of a Typed Template Haskell expression must not have any quantification. + • In the Template Haskell splice $$([|| \ _ -> () ||]) + In the expression: $$([|| \ _ -> () ||]) + In an equation for ‘impred’: impred = $$([|| \ _ -> () ||]) + +T11452.hs:6:14: error: + • Cannot instantiate unification variable ‘t0’ + with a type involving foralls: forall a. a -> a + GHC doesn't yet support impredicative polymorphism + • In the Template Haskell quotation [|| \ _ -> () ||] + In the expression: [|| \ _ -> () ||] + In the Template Haskell splice $$([|| \ _ -> () ||]) diff --git a/testsuite/tests/th/T2222.stderr b/testsuite/tests/th/T2222.stderr index b0a7e9f799..4ddf100bf6 100644 --- a/testsuite/tests/th/T2222.stderr +++ b/testsuite/tests/th/T2222.stderr @@ -1,4 +1,4 @@ -inside b: a_0 +inside b: t_0 inside d: GHC.Types.Bool type of c: GHC.Types.Bool inside f: GHC.Types.Bool diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 8b38e3f402..dd32ccab2e 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -398,3 +398,4 @@ test('T11345', normal, compile_and_run, ['-v0 -dsuppress-uniques']) test('TH_finalizer', normal, compile, ['-v0']) test('T10603', normal, compile, ['-ddump-splices -dsuppress-uniques']) +test('T11452', normal, compile_fail, ['-v0']) diff --git a/testsuite/tests/typecheck/should_compile/RebindHR.hs b/testsuite/tests/typecheck/should_compile/RebindHR.hs new file mode 100644 index 0000000000..01a1e042ec --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/RebindHR.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE RebindableSyntax, GADTs, RankNTypes, TypeOperators, ScopedTypeVariables #-} + +module RebindHR where + +import Prelude hiding ( (>>=) ) +import Data.Typeable + +data Exp = Int Int | Plus Exp Exp | Bool Bool +data TExp a where + TInt :: Int -> TExp Int + TPlus :: TExp Int -> TExp Int -> TExp Int + TBool :: Bool -> TExp Bool + +(>>=) :: ((forall t. Typeable t => TExp t -> Maybe r) -> Maybe r) + -> (forall t. Typeable t => TExp t -> Maybe r) + -> Maybe r +x >>= y = x y + +check :: Exp -> (forall t. Typeable t => TExp t -> Maybe r) -> Maybe r +check (Int n) k = k (TInt n) +check (Bool b) k = k (TBool b) +check (Plus e1 e2) k = do te1 :: TExp ty1 <- check e1 + te2 :: TExp ty2 <- check e2 + case (eqT :: Maybe (ty1 :~: Int), eqT :: Maybe (ty2 :~: Int)) of + (Just Refl, Just Refl) -> k (TPlus te1 te2) + _ -> Nothing diff --git a/testsuite/tests/typecheck/should_compile/RebindNegate.hs b/testsuite/tests/typecheck/should_compile/RebindNegate.hs new file mode 100644 index 0000000000..bb5fc49692 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/RebindNegate.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RebindableSyntax #-} + +module RebindNegate where + +import Prelude ( length ) + +negate = length + +y = - "foo" diff --git a/testsuite/tests/typecheck/should_compile/T11397.hs b/testsuite/tests/typecheck/should_compile/T11397.hs new file mode 100644 index 0000000000..6e8a939472 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T11397.hs @@ -0,0 +1,69 @@ +module T11397 where + + +f :: a -> [Maybe a] +f x = + let switch l = [l Nothing, l (Just x)] + in switch id + +u :: a +u = u + +f2 :: a +f2 = let switch l = l u in switch u + + +f3 :: a +f3 = let switch l = l undefined in switch undefined + + +newtype VectorLazy a = VectorLazy a +newtype Vector a = Vector a +newtype Pointer a = Pointer a + +empty :: VectorLazy a +empty = undefined + +cons :: Vector a -> Pointer a +cons = undefined + +unfoldrResult :: (a -> Either c (b, a)) -> a -> (VectorLazy b, c) +unfoldrResult = undefined + +switchL :: b -> (a -> Pointer a -> b) -> Pointer a -> b +switchL = undefined + +inverseFrequencyModulationChunk :: + (Num t, Ord t) => + (s -> Maybe (t,s)) -> (t,s) -> Vector v -> (VectorLazy v, Maybe (t,s)) +inverseFrequencyModulationChunk nextC (phase,cst0) chunk = + let {- + switch :: + (Maybe (t, s) -> r) -> + ((t, v) -> (s, Pointer v) -> r) -> + t -> + (s, Pointer v) -> r + -} + switch l r t (cp0,xp0) = + maybe + (l Nothing) + (\(c1,cp1) -> + switchL + (l (Just (t,cp0))) + (\x1 xp1 -> r (t+c1,x1) (cp1,xp1)) + xp0) + (nextC cp0) + + {- + go :: + (t,v) -> (s, Pointer v) -> + Either (Maybe (t,s)) (v, ((t,v), (s, Pointer v))) + -} + go (c,x) cxp = + if c<1 + then switch Left go c cxp + else Right (x, ((c-1,x),cxp)) + + in switch ((,) empty) + (curry $ unfoldrResult (uncurry go)) + phase (cst0, cons chunk) diff --git a/testsuite/tests/typecheck/should_compile/T11458.hs b/testsuite/tests/typecheck/should_compile/T11458.hs new file mode 100644 index 0000000000..b0f8cfa513 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T11458.hs @@ -0,0 +1,5 @@ +module T11458 where + +optIntArg f = (f Nothing, f (Just True)) + +optIntArg2 f = (f (Just True), f Nothing) diff --git a/testsuite/tests/typecheck/should_compile/T2683.hs b/testsuite/tests/typecheck/should_compile/T2683.hs index 9f3591af46..d38e590323 100644 --- a/testsuite/tests/typecheck/should_compile/T2683.hs +++ b/testsuite/tests/typecheck/should_compile/T2683.hs @@ -10,7 +10,7 @@ class Transformer t a | t -> a where data EL a = forall l. EL (l a) unEL :: EL a -> (forall l. l a -> b) -> b -unEL = error "unEL" +unEL _ _ = error "unEL" transform' :: (Transformer t a) => t -> EL a -> EL a transform' = error "transform'" diff --git a/testsuite/tests/typecheck/should_compile/T7888.hs b/testsuite/tests/typecheck/should_compile/T7888.hs index 63fe6ab7de..1930f0b92f 100644 --- a/testsuite/tests/typecheck/should_compile/T7888.hs +++ b/testsuite/tests/typecheck/should_compile/T7888.hs @@ -4,8 +4,12 @@ module T7888 where import GHC.Err( undefined )
import GHC.Prim
+{- The fix for #11431 makes this no longer work. But it shouldn't really,
+without impredicativity.
f :: (forall a. a) -> b
f = undefined
+-}
+-- this still had better work, though!
g :: Int -> Int#
g _ = undefined
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 5975ed0fe9..e6f0cfa30e 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -498,3 +498,7 @@ test('T11462', ('T11462.hs', '')], '-dynamic']) test('T11480', normal, compile, ['']) +test('RebindHR', normal, compile, ['']) +test('RebindNegate', normal, compile, ['']) +test('T11397', normal, compile, ['']) +test('T11458', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_compile/tc141.stderr b/testsuite/tests/typecheck/should_compile/tc141.stderr index e0de74c945..15bdad80c3 100644 --- a/testsuite/tests/typecheck/should_compile/tc141.stderr +++ b/testsuite/tests/typecheck/should_compile/tc141.stderr @@ -35,7 +35,7 @@ tc141.hs:13:13: error: in v tc141.hs:15:18: error: - • Couldn't match expected type ‘a1’ with actual type ‘r1’ + • Couldn't match expected type ‘a1’ with actual type ‘t1’ because type variable ‘a1’ would escape its scope This (rigid, skolem) type variable is bound by the type signature for: @@ -50,5 +50,5 @@ tc141.hs:15:18: error: in v • Relevant bindings include v :: a1 (bound at tc141.hs:15:14) - b :: r1 (bound at tc141.hs:13:5) - g :: r -> r1 -> forall a. a (bound at tc141.hs:13:1) + b :: t1 (bound at tc141.hs:13:5) + g :: t -> t1 -> forall a. a (bound at tc141.hs:13:1) diff --git a/testsuite/tests/typecheck/should_compile/tc158.hs b/testsuite/tests/typecheck/should_compile/tc158.hs index 1e8b661d10..25879b067d 100644 --- a/testsuite/tests/typecheck/should_compile/tc158.hs +++ b/testsuite/tests/typecheck/should_compile/tc158.hs @@ -9,4 +9,4 @@ type All u = forall x. x->u type All' u = u -> All u all1 :: All u -> (u -> All u) -> All u -all1 = undefined +all1 _ _ = undefined diff --git a/testsuite/tests/typecheck/should_compile/twins.hs b/testsuite/tests/typecheck/should_compile/twins.hs index f87b5a5ea3..3fdc5b80df 100644 --- a/testsuite/tests/typecheck/should_compile/twins.hs +++ b/testsuite/tests/typecheck/should_compile/twins.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes, LiberalTypeSynonyms #-} --- This test checks that deep skolemisation and deep +-- This test checks that deep skolemisation and deep -- instanatiation work right. A buggy prototype -- of GHC 7.0, where the type checker generated wrong -- code, sent applyTypeToArgs into a loop. @@ -22,7 +22,7 @@ gzip f x y else Nothing gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) -gzipWithM = error "urk" +gzipWithM _ = error "urk" orElse :: Maybe a -> Maybe a -> Maybe a -orElse = error "urk"
\ No newline at end of file +orElse = error "urk" diff --git a/testsuite/tests/typecheck/should_fail/FDsFromGivens2.hs b/testsuite/tests/typecheck/should_fail/FDsFromGivens2.hs index 83b6e32ccf..b3e3d2c574 100644 --- a/testsuite/tests/typecheck/should_fail/FDsFromGivens2.hs +++ b/testsuite/tests/typecheck/should_fail/FDsFromGivens2.hs @@ -11,4 +11,5 @@ data KCC where f :: C Char [a] => a -> a f = undefined +bar :: KCC -> a -> a bar (KCC _) = f diff --git a/testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr b/testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr index a084b303dd..00e55ea20a 100644 --- a/testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr +++ b/testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr @@ -1,14 +1,14 @@ -FDsFromGivens2.hs:14:15: error: - Couldn't match type ‘Char’ with ‘[a]’ - arising from a functional dependency between constraints: - ‘C Char [a]’ arising from a use of ‘f’ at FDsFromGivens2.hs:14:15 - ‘C Char Char’ - arising from a pattern with constructor: - KCC :: C Char Char => () -> KCC, - in an equation for ‘bar’ - at FDsFromGivens2.hs:14:6-10 - In the expression: f - In an equation for ‘bar’: bar (KCC _) = f - Relevant bindings include - bar :: KCC -> a -> a (bound at FDsFromGivens2.hs:14:1) +FDsFromGivens2.hs:15:15: error: + • Couldn't match type ‘Char’ with ‘[a]’ + arising from a functional dependency between constraints: + ‘C Char [a]’ arising from a use of ‘f’ at FDsFromGivens2.hs:15:15 + ‘C Char Char’ + arising from a pattern with constructor: + KCC :: C Char Char => () -> KCC, + in an equation for ‘bar’ + at FDsFromGivens2.hs:15:6-10 + • In the expression: f + In an equation for ‘bar’: bar (KCC _) = f + • Relevant bindings include + bar :: KCC -> a -> a (bound at FDsFromGivens2.hs:15:1) diff --git a/testsuite/tests/typecheck/should_fail/T10619.stderr b/testsuite/tests/typecheck/should_fail/T10619.stderr index 5ed7cfed68..e002759ba0 100644 --- a/testsuite/tests/typecheck/should_fail/T10619.stderr +++ b/testsuite/tests/typecheck/should_fail/T10619.stderr @@ -17,7 +17,7 @@ T10619.hs:9:15: error: else \ y -> y • Relevant bindings include - foo :: r -> (b -> b) -> b -> b (bound at T10619.hs:8:1) + foo :: t -> (b -> b) -> b -> b (bound at T10619.hs:8:1) T10619.hs:14:15: error: • Couldn't match type ‘b’ with ‘a’ @@ -42,7 +42,7 @@ T10619.hs:14:15: error: else ((\ x -> x) :: (forall a. a -> a) -> forall b. b -> b) • Relevant bindings include - bar :: r -> (b -> b) -> b -> b (bound at T10619.hs:12:1) + bar :: t -> (b -> b) -> b -> b (bound at T10619.hs:12:1) T10619.hs:16:13: error: • Couldn't match type ‘forall a. a -> a’ with ‘b -> b’ diff --git a/testsuite/tests/typecheck/should_fail/T3613.stderr b/testsuite/tests/typecheck/should_fail/T3613.stderr index b7ffd671c8..6d3c70346b 100644 --- a/testsuite/tests/typecheck/should_fail/T3613.stderr +++ b/testsuite/tests/typecheck/should_fail/T3613.stderr @@ -9,7 +9,9 @@ T3613.hs:14:20: error: let fooThen m = foo >> m in fooThen (bar >> undefined) T3613.hs:17:24: error: - • Couldn't match expected type ‘Maybe a0’ with actual type ‘IO ()’ + • Couldn't match type ‘IO’ with ‘Maybe’ + Expected type: Maybe () + Actual type: IO () • In a stmt of a 'do' block: bar In the first argument of ‘fooThen’, namely ‘(do { bar; diff --git a/testsuite/tests/typecheck/should_fail/T5570.stderr b/testsuite/tests/typecheck/should_fail/T5570.stderr index 8c4ace5173..710104012d 100644 --- a/testsuite/tests/typecheck/should_fail/T5570.stderr +++ b/testsuite/tests/typecheck/should_fail/T5570.stderr @@ -1,7 +1,6 @@ T5570.hs:7:16: error: - • Couldn't match a lifted type with an unlifted type - When matching the kind of ‘Double#’ + • Expecting a lifted type, but ‘Double#’ is unlifted • In the second argument of ‘($)’, namely ‘D# $ 3.0##’ In the expression: print $ D# $ 3.0## In an equation for ‘main’: main = print $ D# $ 3.0## diff --git a/testsuite/tests/typecheck/should_fail/T7453.stderr b/testsuite/tests/typecheck/should_fail/T7453.stderr index 47bfa78754..bcb2df84c8 100644 --- a/testsuite/tests/typecheck/should_fail/T7453.stderr +++ b/testsuite/tests/typecheck/should_fail/T7453.stderr @@ -1,13 +1,13 @@ T7453.hs:9:15: error: - • Couldn't match type ‘r’ with ‘t’ - because type variable ‘t’ would escape its scope + • Couldn't match type ‘t’ with ‘t1’ + because type variable ‘t1’ would escape its scope This (rigid, skolem) type variable is bound by the type signature for: - z :: Id t + z :: Id t1 at T7453.hs:8:11-19 - Expected type: Id t - Actual type: Id r + Expected type: Id t1 + Actual type: Id t • In the expression: aux In an equation for ‘z’: z = aux @@ -22,20 +22,20 @@ T7453.hs:9:15: error: where aux = Id v • Relevant bindings include - aux :: Id r (bound at T7453.hs:10:21) - z :: Id t (bound at T7453.hs:9:11) - v :: r (bound at T7453.hs:7:7) - cast1 :: r -> a (bound at T7453.hs:7:1) + aux :: Id t (bound at T7453.hs:10:21) + z :: Id t1 (bound at T7453.hs:9:11) + v :: t (bound at T7453.hs:7:7) + cast1 :: t -> a (bound at T7453.hs:7:1) T7453.hs:15:15: error: - • Couldn't match type ‘r’ with ‘t1’ - because type variable ‘t1’ would escape its scope + • Couldn't match type ‘t’ with ‘t2’ + because type variable ‘t2’ would escape its scope This (rigid, skolem) type variable is bound by the type signature for: - z :: () -> t1 + z :: () -> t2 at T7453.hs:14:11-22 - Expected type: () -> t1 - Actual type: () -> r + Expected type: () -> t2 + Actual type: () -> t • In the expression: aux In an equation for ‘z’: z = aux @@ -50,17 +50,17 @@ T7453.hs:15:15: error: where aux = const v • Relevant bindings include - aux :: forall b. b -> r (bound at T7453.hs:16:21) - z :: () -> t1 (bound at T7453.hs:15:11) - v :: r (bound at T7453.hs:13:7) - cast2 :: r -> t (bound at T7453.hs:13:1) + aux :: forall b. b -> t (bound at T7453.hs:16:21) + z :: () -> t2 (bound at T7453.hs:15:11) + v :: t (bound at T7453.hs:13:7) + cast2 :: t -> t1 (bound at T7453.hs:13:1) T7453.hs:21:15: error: - • Couldn't match expected type ‘t1’ with actual type ‘r’ - because type variable ‘t1’ would escape its scope + • Couldn't match expected type ‘t2’ with actual type ‘t’ + because type variable ‘t2’ would escape its scope This (rigid, skolem) type variable is bound by the type signature for: - z :: t1 + z :: t2 at T7453.hs:20:11-16 • In the expression: v In an equation for ‘z’: @@ -76,7 +76,7 @@ T7453.hs:21:15: error: where aux = const v • Relevant bindings include - aux :: forall b. b -> r (bound at T7453.hs:22:21) - z :: t1 (bound at T7453.hs:21:11) - v :: r (bound at T7453.hs:19:7) - cast3 :: r -> forall t. t (bound at T7453.hs:19:1) + aux :: forall b. b -> t (bound at T7453.hs:22:21) + z :: t2 (bound at T7453.hs:21:11) + v :: t (bound at T7453.hs:19:7) + cast3 :: t -> forall t1. t1 (bound at T7453.hs:19:1) diff --git a/testsuite/tests/typecheck/should_fail/T7734.stderr b/testsuite/tests/typecheck/should_fail/T7734.stderr index 53536d1a13..1b1716bfc5 100644 --- a/testsuite/tests/typecheck/should_fail/T7734.stderr +++ b/testsuite/tests/typecheck/should_fail/T7734.stderr @@ -1,18 +1,18 @@ T7734.hs:4:13: error: - • Occurs check: cannot construct the infinite type: r2 ~ r2 -> r1 + • Occurs check: cannot construct the infinite type: t1 ~ t1 -> t2 • In the first argument of ‘x’, namely ‘x’ In the expression: x x In an equation for ‘f’: x `f` y = x x • Relevant bindings include - x :: r2 -> r1 (bound at T7734.hs:4:1) - f :: (r2 -> r1) -> r -> r1 (bound at T7734.hs:4:1) + x :: t1 -> t2 (bound at T7734.hs:4:1) + f :: (t1 -> t2) -> t -> t2 (bound at T7734.hs:4:3) T7734.hs:5:13: error: - • Occurs check: cannot construct the infinite type: r2 ~ r2 -> r1 + • Occurs check: cannot construct the infinite type: t1 ~ t1 -> t2 • In the first argument of ‘x’, namely ‘x’ In the expression: x x In an equation for ‘&’: (&) x y = x x • Relevant bindings include - x :: r2 -> r1 (bound at T7734.hs:5:5) - (&) :: (r2 -> r1) -> r -> r1 (bound at T7734.hs:5:1) + x :: t1 -> t2 (bound at T7734.hs:5:5) + (&) :: (t1 -> t2) -> t -> t2 (bound at T7734.hs:5:1) diff --git a/testsuite/tests/typecheck/should_fail/T8603.stderr b/testsuite/tests/typecheck/should_fail/T8603.stderr index 53d4e422cb..baf3264734 100644 --- a/testsuite/tests/typecheck/should_fail/T8603.stderr +++ b/testsuite/tests/typecheck/should_fail/T8603.stderr @@ -5,11 +5,11 @@ T8603.hs:13:10: error: • In the instance declaration for ‘Monad RV’ T8603.hs:29:17: error: - • Couldn't match type ‘RV a0’ with ‘StateT s RV t0’ - Expected type: [Integer] -> StateT s RV t0 - Actual type: (->) ((->) [a0]) (RV a0) + • Couldn't match type ‘RV a1’ with ‘StateT s RV a0’ + Expected type: [Integer] -> StateT s RV a0 + Actual type: (->) ((->) [a1]) (RV a1) • The function ‘lift’ is applied to two arguments, - but its type ‘([a0] -> RV a0) -> (->) ((->) [a0]) (RV a0)’ + but its type ‘([a1] -> RV a1) -> (->) ((->) [a1]) (RV a1)’ has only one In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3] In the expression: diff --git a/testsuite/tests/typecheck/should_fail/T9109.stderr b/testsuite/tests/typecheck/should_fail/T9109.stderr index f13b0fc310..6a08318ac0 100644 --- a/testsuite/tests/typecheck/should_fail/T9109.stderr +++ b/testsuite/tests/typecheck/should_fail/T9109.stderr @@ -1,14 +1,15 @@ T9109.hs:8:13: error: - • Couldn't match expected type ‘r’ with actual type ‘Bool’ - ‘r’ is untouchable + • Couldn't match expected type ‘t1’ with actual type ‘Bool’ + ‘t1’ is untouchable inside the constraints: t ~ Bool bound by a pattern with constructor: GBool :: G Bool, in an equation for ‘foo’ at T9109.hs:8:5-9 - ‘r’ is a rigid type variable bound by - the inferred type of foo :: G t -> r at T9109.hs:8:1 + ‘t1’ is a rigid type variable bound by + the inferred type of foo :: G t -> t1 at T9109.hs:8:1 Possible fix: add a type signature for ‘foo’ • In the expression: True In an equation for ‘foo’: foo GBool = True - • Relevant bindings include foo :: G t -> r (bound at T9109.hs:8:1) + • Relevant bindings include + foo :: G t -> t1 (bound at T9109.hs:8:1) diff --git a/testsuite/tests/typecheck/should_fail/VtaFail.stderr b/testsuite/tests/typecheck/should_fail/VtaFail.stderr index ea435e4f19..6d11a4a46c 100644 --- a/testsuite/tests/typecheck/should_fail/VtaFail.stderr +++ b/testsuite/tests/typecheck/should_fail/VtaFail.stderr @@ -13,7 +13,7 @@ VtaFail.hs:12:26: error: answer_constraint_fail = addOne @Bool 5 VtaFail.hs:14:17: error: - • Cannot apply expression of type ‘r0 -> r0’ + • Cannot apply expression of type ‘t0 -> t0’ to a visible type argument ‘Int’ • In the expression: (\ x -> x) @Int 12 In an equation for ‘answer_lambda’: diff --git a/testsuite/tests/typecheck/should_fail/tcfail014.stderr b/testsuite/tests/typecheck/should_fail/tcfail014.stderr index 6b88e835ed..a186fb1310 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail014.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail014.stderr @@ -1,9 +1,9 @@ tcfail014.hs:5:33: error: - • Occurs check: cannot construct the infinite type: r8 ~ r8 -> r7 + • Occurs check: cannot construct the infinite type: t7 ~ t7 -> t8 • In the first argument of ‘z’, namely ‘z’ In the expression: z z In an equation for ‘h’: h z = z z • Relevant bindings include - z :: r8 -> r7 (bound at tcfail014.hs:5:27) - h :: (r8 -> r7) -> r7 (bound at tcfail014.hs:5:25) + z :: t7 -> t8 (bound at tcfail014.hs:5:27) + h :: (t7 -> t8) -> t8 (bound at tcfail014.hs:5:25) diff --git a/testsuite/tests/typecheck/should_fail/tcfail016.stderr b/testsuite/tests/typecheck/should_fail/tcfail016.stderr index cb1fa945e7..949cb65855 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail016.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail016.stderr @@ -1,24 +1,7 @@ -tcfail016.hs:9:20: error: +tcfail016.hs:8:1: error: • Couldn't match type ‘(t, Expr t)’ with ‘Expr t’ - Expected type: Expr t - Actual type: AnnExpr t - • In the first argument of ‘g’, namely ‘e1’ - In the first argument of ‘(++)’, namely ‘(g e1)’ - In the expression: (g e1) ++ (g e2) + Expected type: AnnExpr t -> [[Char]] + Actual type: Expr t -> [[Char]] • Relevant bindings include - e2 :: AnnExpr t (bound at tcfail016.hs:9:11) - e1 :: AnnExpr t (bound at tcfail016.hs:9:8) - g :: Expr t -> [[Char]] (bound at tcfail016.hs:8:1) - -tcfail016.hs:9:28: error: - • Couldn't match type ‘(t, Expr t)’ with ‘Expr t’ - Expected type: Expr t - Actual type: AnnExpr t - • In the first argument of ‘g’, namely ‘e2’ - In the second argument of ‘(++)’, namely ‘(g e2)’ - In the expression: (g e1) ++ (g e2) - • Relevant bindings include - e2 :: AnnExpr t (bound at tcfail016.hs:9:11) - e1 :: AnnExpr t (bound at tcfail016.hs:9:8) - g :: Expr t -> [[Char]] (bound at tcfail016.hs:8:1) + g :: AnnExpr t -> [[Char]] (bound at tcfail016.hs:8:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail032.stderr b/testsuite/tests/typecheck/should_fail/tcfail032.stderr index 79ec408274..ce3ce2d018 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail032.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail032.stderr @@ -1,6 +1,6 @@ tcfail032.hs:14:8: error: - • Couldn't match expected type ‘a1 -> Int’ with actual type ‘r’ + • Couldn't match expected type ‘a1 -> Int’ with actual type ‘t’ because type variable ‘a1’ would escape its scope This (rigid, skolem) type variable is bound by an expression type signature: @@ -9,5 +9,5 @@ tcfail032.hs:14:8: error: • In the expression: (x :: (Eq a) => a -> Int) In an equation for ‘f’: f x = (x :: (Eq a) => a -> Int) • Relevant bindings include - x :: r (bound at tcfail032.hs:14:3) - f :: r -> forall a. Eq a => a -> Int (bound at tcfail032.hs:14:1) + x :: t (bound at tcfail032.hs:14:3) + f :: t -> forall a. Eq a => a -> Int (bound at tcfail032.hs:14:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail099.stderr b/testsuite/tests/typecheck/should_fail/tcfail099.stderr index 3ba8165766..f3908f36e4 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail099.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail099.stderr @@ -1,6 +1,6 @@ tcfail099.hs:9:20: error: - • Couldn't match expected type ‘a’ with actual type ‘r’ + • Couldn't match expected type ‘a’ with actual type ‘t’ because type variable ‘a’ would escape its scope This (rigid, skolem) type variable is bound by a pattern with constructor: C :: forall a. (a -> Int) -> DS, @@ -10,6 +10,6 @@ tcfail099.hs:9:20: error: In the expression: f arg In an equation for ‘call’: call (C f) arg = f arg • Relevant bindings include - arg :: r (bound at tcfail099.hs:9:12) + arg :: t (bound at tcfail099.hs:9:12) f :: a -> Int (bound at tcfail099.hs:9:9) - call :: DS -> r -> Int (bound at tcfail099.hs:9:1) + call :: DS -> t -> Int (bound at tcfail099.hs:9:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail104.stderr b/testsuite/tests/typecheck/should_fail/tcfail104.stderr index b6c21e5e82..a0a6595231 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail104.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail104.stderr @@ -1,11 +1,13 @@ -tcfail104.hs:14:15: error: - • Couldn't match expected type ‘forall a. a -> a’ - with actual type ‘Char -> Char’ - • When checking that the pattern signature: forall a. a -> a - fits the type of its context: Char -> Char - In the pattern: x :: forall a. a -> a +tcfail104.hs:14:12: error: + • Couldn't match type ‘forall a. a -> a’ with ‘Char -> Char’ + Expected type: (Char -> Char) -> Char -> Char + Actual type: (forall a. a -> a) -> Char -> Char + • When checking that: (forall a. a -> a) -> forall a. a -> a + is more polymorphic than: (Char -> Char) -> Char -> Char In the expression: (\ (x :: forall a. a -> a) -> x) + In the expression: + if v then (\ (x :: forall a. a -> a) -> x) else (\ x -> x) tcfail104.hs:22:15: error: • Couldn't match expected type ‘forall a. a -> a’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail140.stderr b/testsuite/tests/typecheck/should_fail/tcfail140.stderr index b3bf602200..4c3fecec43 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail140.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail140.stderr @@ -9,14 +9,14 @@ tcfail140.hs:10:7: error: • Relevant bindings include bar :: t (bound at tcfail140.hs:10:1) tcfail140.hs:12:10: error: - • Couldn't match expected type ‘Integer -> t’ + • Couldn't match expected type ‘Integer -> t1’ with actual type ‘Int’ • The operator ‘f’ takes two arguments, but its type ‘Int -> Int’ has only one In the expression: 3 `f` 4 In an equation for ‘rot’: rot xs = 3 `f` 4 • Relevant bindings include - rot :: r -> t (bound at tcfail140.hs:12:1) + rot :: t -> t1 (bound at tcfail140.hs:12:1) tcfail140.hs:14:15: error: • Couldn't match expected type ‘t -> b’ with actual type ‘Int’ @@ -31,8 +31,9 @@ tcfail140.hs:14:15: error: tcfail140.hs:16:8: error: • The constructor ‘Just’ should have 1 argument, but has been given none • In the pattern: Just + The lambda expression ‘\ Just x -> x’ has two arguments, + but its type ‘Maybe a -> a’ has only one In the expression: (\ Just x -> x) :: Maybe a -> a - In the expression: ((\ Just x -> x) :: Maybe a -> a) (Just 1) tcfail140.hs:19:1: error: • Couldn't match expected type ‘Int’ with actual type ‘t0 -> Bool’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail159.stderr b/testsuite/tests/typecheck/should_fail/tcfail159.stderr index e28363a707..412ba47d3f 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail159.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail159.stderr @@ -1,7 +1,6 @@ tcfail159.hs:9:11: error: - Couldn't match a lifted type with an unlifted type - When matching the kind of ‘(# Int, Int #)’ - In the pattern: ~(# p, q #) - In a case alternative: ~(# p, q #) -> p - In the expression: case h x of { ~(# p, q #) -> p } + • Expecting a lifted type, but got an unlifted + • In the pattern: ~(# p, q #) + In a case alternative: ~(# p, q #) -> p + In the expression: case h x of { ~(# p, q #) -> p } diff --git a/testsuite/tests/typecheck/should_fail/tcfail181.stderr b/testsuite/tests/typecheck/should_fail/tcfail181.stderr index 6cf22a9f61..a231133fd4 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail181.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail181.stderr @@ -3,7 +3,7 @@ tcfail181.hs:17:9: error: • Could not deduce (Monad m0) arising from a use of ‘foo’ from the context: Monad m bound by the inferred type of - wog :: Monad m => r -> Something (m Bool) e + wog :: Monad m => t -> Something (m Bool) e at tcfail181.hs:17:1-30 The type variable ‘m0’ is ambiguous These potential instances exist: diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 1969216956..ccdd327217 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -299,8 +299,8 @@ boundThings modname lbinding = ConPatIn _ conargs -> conArgs conargs tl ConPatOut{ pat_args = conargs } -> conArgs conargs tl LitPat _ -> tl - NPat _ _ _ -> tl -- form of literal pattern? - NPlusKPat id _ _ _ -> thing id : tl + NPat {} -> tl -- form of literal pattern? + NPlusKPat id _ _ _ _ _ -> thing id : tl SigPatIn p _ -> patThings p tl SigPatOut p _ -> patThings p tl _ -> error "boundThings" |