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-27 09:33:26 -0500 |
| commit | 00cbbab3362578df44851442408a8b91a2a769fa (patch) | |
| tree | c8f79d003510e191adeab0d1b98f20ebde40d914 /compiler | |
| parent | 2899aa580d633103fc551e36c977720b94f5b41c (diff) | |
| download | haskell-00cbbab3362578df44851442408a8b91a2a769fa.tar.gz | |
Refactor the typechecker to use ExpTypes.
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
Diffstat (limited to 'compiler')
51 files changed, 2168 insertions, 1338 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 a5faef0201..9b7c87397f 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 a3b8f1a91d..dce8f2fa5b 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 1107710bcc..2d5372d187 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 caa327e3d9..285a4dbcda 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 440691ddb6..ce2d16a5d5 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 bbe3179b2b..707f706511 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 aabf72d877..b483b84b33 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 12576cd4ed..924837c2d4 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 796c0429f6..54be1d6e31 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 39d9afc6ef..31e53f0a73 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 } |