diff options
24 files changed, 588 insertions, 560 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 2a181e8d16..f77d23ec06 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -630,51 +630,45 @@ repAnnProv ModuleAnnProvenance repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) repC (L _ (ConDeclH98 { con_name = con - , con_qvars = Nothing, con_cxt = Nothing - , con_details = details })) - = repDataCon con details + , con_forall = False + , con_mb_cxt = Nothing + , con_args = args })) + = repDataCon con args repC (L _ (ConDeclH98 { con_name = con - , con_qvars = mcon_tvs, con_cxt = mcxt - , con_details = details })) - = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs - ctxt = unLoc $ fromMaybe (noLoc []) mcxt - ; addTyVarBinds con_tvs $ \ ex_bndrs -> - do { c' <- repDataCon con details - ; ctxt' <- repContext ctxt - ; if isEmptyLHsQTvs con_tvs && null ctxt + , con_forall = is_existential + , con_ex_tvs = con_tvs + , con_mb_cxt = mcxt + , con_args = args })) + = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> + do { c' <- repDataCon con args + ; ctxt' <- repMbContext mcxt + ; if not is_existential && isNothing mcxt then return c' else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } } repC (L _ (ConDeclGADT { con_names = cons - , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })})) - | (details, res_ty', L _ [] , []) <- gadtDetails - , [] <- imp_tvs - -- no implicit or explicit variables, no context = no need for a forall - = do { let doc = text "In the constructor for " <+> ppr (head cons) - ; (hs_details, gadt_res_ty) <- - updateGadtResult failWithDs doc details res_ty' - ; repGadtDataCons cons hs_details gadt_res_ty } - - | (details,res_ty',ctxt, exp_tvs) <- gadtDetails - = do { let doc = text "In the constructor for " <+> ppr (head cons) - con_tvs = HsQTvs { hsq_implicit = imp_tvs - , hsq_explicit = exp_tvs - , hsq_dependent = emptyNameSet } - -- NB: Don't put imp_tvs into the hsq_explicit field above + , con_qvars = qtvs, con_mb_cxt = mcxt + , con_args = args, con_res_ty = res_ty })) + | isEmptyLHsQTvs qtvs -- No implicit or explicit variables + , Nothing <- mcxt -- No context + -- ==> no need for a forall + = repGadtDataCons cons args res_ty + + | otherwise + = addTyVarBinds qtvs $ \ ex_bndrs -> -- See Note [Don't quantify implicit type variables in quotes] - ; addTyVarBinds con_tvs $ \ ex_bndrs -> do - { (hs_details, gadt_res_ty) <- - updateGadtResult failWithDs doc details res_ty' - ; c' <- repGadtDataCons cons hs_details gadt_res_ty - ; ctxt' <- repContext (unLoc ctxt) - ; if null exp_tvs && null (unLoc ctxt) + do { c' <- repGadtDataCons cons args res_ty + ; ctxt' <- repMbContext mcxt + ; if null (hsQTvExplicit qtvs) && isNothing mcxt then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } } - where - gadtDetails = gadtDeclDetails res_ty + else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } + +repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ) +repMbContext Nothing = repContext [] +repMbContext (Just (L _ cxt)) = repContext cxt repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] @@ -867,24 +861,30 @@ addSimpleTyVarBinds names thing_inside ; term <- addBinds fresh_names thing_inside ; wrapGenSyms fresh_names term } +addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added + -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env + -> DsM (Core (TH.Q a)) +addHsTyVarBinds exp_tvs thing_inside + = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs) + ; term <- addBinds fresh_exp_names $ + do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr + (exp_tvs `zip` fresh_exp_names) + ; thing_inside kbs } + ; wrapGenSyms fresh_exp_names term } + where + mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) + addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument - -addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m - = do { fresh_imp_names <- mkGenSyms imp_tvs - ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs) - ; let fresh_names = fresh_imp_names ++ fresh_exp_names - ; term <- addBinds fresh_names $ - do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr - (exp_tvs `zip` fresh_exp_names) - ; m kbs } - ; wrapGenSyms fresh_names term } - where - mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) +addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) + thing_inside + = addSimpleTyVarBinds imp_tvs $ + addHsTyVarBinds exp_tvs $ + thing_inside addTyClTyVarBinds :: LHsQTyVars GhcRn -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) @@ -943,12 +943,9 @@ repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) repHsSigType (HsIB { hsib_vars = implicit_tvs , hsib_body = body }) | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body - = addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs - , hsq_explicit = explicit_tvs - , hsq_dependent = emptyNameSet }) - -- NB: Don't pass implicit_tvs to the hsq_explicit field above - -- See Note [Don't quantify implicit type variables in quotes] - $ \ th_explicit_tvs -> + = addSimpleTyVarBinds implicit_tvs $ + -- See Note [Don't quantify implicit type variables in quotes] + addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs -> do { th_ctxt <- repLContext ctxt ; th_ty <- repLTy ty ; if null explicit_tvs && null (unLoc ctxt) @@ -958,20 +955,15 @@ repHsSigType (HsIB { hsib_vars = implicit_tvs repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs , hsib_body = body }) - = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs -> - addTyVarBinds (newTvs [] exis) $ \th_exis -> + = addSimpleTyVarBinds implicit_tvs $ + -- See Note [Don't quantify implicit type variables in quotes] + addHsTyVarBinds univs $ \th_univs -> + addHsTyVarBinds exis $ \th_exis -> do { th_reqs <- repLContext reqs ; th_provs <- repLContext provs ; th_ty <- repLTy ty ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) } where - newTvs impl_tvs expl_tvs = HsQTvs - { hsq_implicit = impl_tvs - , hsq_explicit = expl_tvs - , hsq_dependent = emptyNameSet } - -- NB: Don't pass impl_tvs to the hsq_explicit field above - -- See Note [Don't quantify implicit type variables in quotes] - (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) @@ -990,8 +982,7 @@ repForall :: HsType GhcRn -> DsM (Core TH.TypeQ) -- Arg of repForall is always HsForAllTy or HsQualTy repForall ty | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) - = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs - , hsq_dependent = emptyNameSet }) $ \bndrs -> + = addHsTyVarBinds tvs $ \bndrs -> do { ctxt1 <- repLContext ctxt ; ty1 <- repLTy tau ; repTForall bndrs ctxt1 ty1 } diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 4336243e91..47c2182a7a 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -42,7 +42,7 @@ import MonadUtils ( foldrM ) import qualified Data.ByteString as BS import Control.Monad( unless, liftM, ap, (<=<) ) -import Data.Maybe( catMaybes, fromMaybe, isNothing ) +import Data.Maybe( catMaybes, isNothing ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH @@ -490,59 +490,57 @@ cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) cvtConstr (NormalC c strtys) = do { c' <- cNameL c - ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys - ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') } + ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c - ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ mkConDeclH98 c' Nothing cxt' + ; returnL $ mkConDeclH98 c' Nothing Nothing (RecCon (noLoc args')) } cvtConstr (InfixC st1 c st2) = do { c' <- cNameL c - ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') } + ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') } cvtConstr (ForallC tvs ctxt con) - = do { tvs' <- cvtTvs tvs - ; L loc ctxt' <- cvtContext ctxt - ; L _ con' <- cvtConstr con - ; returnL $ case con' of - ConDeclGADT { con_type = conT } -> - let hs_ty = mkHsForAllTy tvs noSrcSpan tvs' rho_ty - rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt') - (hsib_body conT) - in con' { con_type = mkHsImplicitBndrs hs_ty } - ConDeclH98 {} -> - let qvars = case (tvs, con_qvars con') of - ([], Nothing) -> Nothing - (_ , m_qvs ) -> Just $ - mkHsQTvs (hsQTvExplicit tvs' ++ - maybe [] hsQTvExplicit m_qvs) - in con' { con_qvars = qvars - , con_cxt = Just $ - L loc (ctxt' ++ - unLoc (fromMaybe (noLoc []) - (con_cxt con'))) } } + = do { tvs' <- cvtTvs tvs + ; ctxt' <- cvtContext ctxt + ; L _ con' <- cvtConstr con + ; returnL $ add_forall tvs' ctxt' con' } + where + add_cxt lcxt Nothing = Just lcxt + add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2)) + + add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) + = con { con_forall = not (null all_tvs) + , con_qvars = mkHsQTvs all_tvs + , con_mb_cxt = add_cxt cxt' cxt } + where + all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars + + add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt }) + = con { con_forall = not (null all_tvs) + , con_ex_tvs = all_tvs + , con_mb_cxt = add_cxt cxt' cxt } + where + all_tvs = hsQTvExplicit tvs' ++ ex_tvs cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys ; L _ ty' <- cvtType ty ; c_ty <- mk_arr_apps args ty' - ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)} + ; returnL $ mkGadtDecl c' c_ty} cvtConstr (RecGadtC c varstrtys ty) = do { c' <- mapM cNameL c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty') - ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) } + ; returnL $ mkGadtDecl c' rec_ty } cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 55d43fd058..8078582fe3 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -63,10 +63,8 @@ module HsDecls ( CImportSpec(..), -- ** Data-constructor declarations ConDecl(..), LConDecl, - HsConDeclDetails, hsConDeclArgTys, - getConNames, - getConDetails, - gadtDeclDetails, + HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta, + getConNames, getConArgs, -- ** Document comments DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations @@ -909,7 +907,7 @@ data FamilyDecl pass = FamilyDecl { fdInfo :: FamilyInfo pass -- type/data, closed/open , fdLName :: Located (IdP pass) -- type constructor , fdTyVars :: LHsQTyVars pass -- type variables - , fdFixity :: LexicalFixity -- Fixity used in the declaration + , fdFixity :: LexicalFixity -- Fixity used in the declaration , fdResultSig :: LFamilyResultSig pass -- result signature , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann } @@ -1151,8 +1149,19 @@ type LConDecl pass = Located (ConDecl pass) data ConDecl pass = ConDeclGADT { con_names :: [Located (IdP pass)] - , con_type :: LHsSigType pass - -- ^ The type after the ‘::’ + + -- The next four fields describe the type after the '::' + -- See Note [GADT abstract syntax] + , con_forall :: Bool -- ^ True <=> explicit forall + -- False => hsq_explicit is empty + , con_qvars :: LHsQTyVars pass + -- Whether or not there is an /explicit/ forall, we still + -- need to capture the implicitly-bound type/kind variables + + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon + , con_res_ty :: LHsType pass -- ^ Result type + , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } @@ -1160,24 +1169,56 @@ data ConDecl pass | ConDeclH98 { con_name :: Located (IdP pass) - , con_qvars :: Maybe (LHsQTyVars pass) - -- User-written forall (if any), and its implicit - -- kind variables - -- Non-Nothing means an explicit user-written forall - -- e.g. data T a = forall b. MkT b (b->a) - -- con_qvars = {b} - - , con_cxt :: Maybe (LHsContext pass) - -- ^ User-written context (if any) - - , con_details :: HsConDeclDetails pass - -- ^ Arguments + , con_forall :: Bool -- ^ True <=> explicit user-written forall + -- e.g. data T a = forall b. MkT b (b->a) + -- con_ex_tvs = {b} + -- False => con_ex_tvs is empty + , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } deriving instance (DataId pass) => Data (ConDecl pass) +{- Note [GADT abstract syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a wrinkle in ConDeclGADT + +* For record syntax, it's all uniform. Given: + data T a where + K :: forall a. Ord a => { x :: [a], ... } -> T a + we make the a ConDeclGADT for K with + con_qvars = {a} + con_mb_cxt = Just [Ord a] + con_args = RecCon <the record fields> + con_res_ty = T a + + We need the RecCon before the reanmer, so we can find the record field + binders in HsUtils.hsConDeclsBinders. + +* However for a GADT constr declaration which is not a record, it can + be hard parse until we know operator fixities. Consider for example + C :: a :*: b -> a :*: b -> a :+: b + Initially this type will parse as + a :*: (b -> (a :*: (b -> (a :+: b)))) + so it's hard to split up the arguments until we've done the precedence + resolution (in the renamer). + + So: - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr + type into the res_ty for a ConDeclGADT for now, and use + PrefixCon [] + con_args = PrefixCon [] + con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b)))) + + - In the renamer (RnSource.rnConDecl), we unravel it afer + operator fixities are sorted. So we generate. So we end + up with + con_args = PrefixCon [ a :*: b, a :*: b ] + con_res_ty = a :+: b +-} + -- | Haskell data Constructor Declaration Details type HsConDeclDetails pass = HsConDetails (LBangType pass) (Located [LConDeclField pass]) @@ -1186,36 +1227,21 @@ getConNames :: ConDecl pass -> [Located (IdP pass)] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names --- don't call with RdrNames, because it can't deal with HsAppsTy -getConDetails :: ConDecl pass -> HsConDeclDetails pass -getConDetails ConDeclH98 {con_details = details} = details -getConDetails ConDeclGADT {con_type = ty } = details - where - (details,_,_,_) = gadtDeclDetails ty - --- don't call with RdrNames, because it can't deal with HsAppsTy -gadtDeclDetails :: LHsSigType pass - -> ( HsConDeclDetails pass - , LHsType pass - , LHsContext pass - , [LHsTyVarBndr pass] ) -gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs) - where - (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty - (details, res_ty) -- See Note [Sorting out the result type] - = case tau of - L _ (HsFunTy (L l (HsRecTy flds)) res_ty') - -> (RecCon (L l flds), res_ty') - _other -> (PrefixCon [], tau) +getConArgs :: ConDecl pass -> HsConDeclDetails pass +getConArgs d = con_args d hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass] hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) -pp_data_defn :: (SourceTextX pass, OutputableBndrId pass) - => (HsContext pass -> SDoc) -- Printing the header - -> HsDataDefn pass +hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass] +hsConDeclTheta Nothing = [] +hsConDeclTheta (Just (L _ theta)) = theta + +pp_data_defn :: (SourceTextX p, OutputableBndrId p) + => (HsContext p -> SDoc) -- Printing the header + -> HsDataDefn p -> SDoc pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context , dd_cType = mb_ct @@ -1258,26 +1284,34 @@ instance (SourceTextX pass, OutputableBndrId pass) pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con - , con_qvars = mtvs - , con_cxt = mcxt - , con_details = details + , con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt + , con_args = args , con_doc = doc }) - = sep [ppr_mbDoc doc, pprHsForAll tvs cxt, ppr_details details] + = sep [ppr_mbDoc doc, pprHsForAll ex_tvs cxt, ppr_details args] where ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con : map (pprHsType . unLoc) tys) ppr_details (RecCon fields) = pprPrefixOcc con <+> pprConDeclFields (unLoc fields) - tvs = case mtvs of - Nothing -> [] - Just (HsQTvs { hsq_explicit = tvs }) -> tvs + cxt = fromMaybe (noLoc []) mcxt + +pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars + , con_mb_cxt = mcxt, con_args = args + , con_res_ty = res_ty, con_doc = doc }) + = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon + <+> (sep [pprHsForAll (hsq_explicit qvars) cxt, + ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) + where + get_args (PrefixCon args) = map ppr args + get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] + get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons) cxt = fromMaybe (noLoc []) mcxt -pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc }) - = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon - <+> ppr res_ty] + ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) + ppr_arrow_chain [] = empty ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index f5b4149f99..10e2d00c0e 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -35,7 +35,7 @@ module HsTypes ( SrcStrictness(..), SrcUnpackedness(..), getBangType, getBangStrictness, - ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult, + ConDeclField(..), LConDeclField, pprConDeclFields, HsConDetails(..), @@ -50,7 +50,7 @@ module HsTypes ( mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs, - isHsKindedTyVar, hsTvbAllKinded, + isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy, hsScopedTvs, hsWcScopedTvs, dropWildCards, hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames, @@ -59,7 +59,7 @@ module HsTypes ( splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy, splitHsFunType, splitHsAppsTy, splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe, - mkHsOpTy, mkHsAppTy, mkHsAppTys, + mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppsTy, ignoreParens, hsSigType, hsSigWcType, hsLTyVarBndrToType, hsLTyVarBndrsToTypes, @@ -93,7 +93,6 @@ import Maybes( isJust ) import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Maybe ( fromMaybe ) -import Control.Monad ( unless ) {- ************************************************************************ @@ -785,30 +784,6 @@ instance (Outputable arg, Outputable rec) ppr (RecCon rec) = text "RecCon:" <+> ppr rec ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] --- Takes details and result type of a GADT data constructor as created by the --- parser and rejigs them using information about fixities from the renamer. --- See Note [Sorting out the result type] in RdrHsSyn -updateGadtResult - :: (Monad m) - => (SDoc -> m ()) - -> SDoc - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) - -- ^ Original details - -> LHsType GhcRn -- ^ Original result type - -> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), - LHsType GhcRn) -updateGadtResult failWith doc details ty - = do { let (arg_tys, res_ty) = splitHsFunType ty - badConSig = text "Malformed constructor signature" - ; case details of - InfixCon {} -> pprPanic "updateGadtResult" (ppr ty) - - RecCon {} -> do { unless (null arg_tys) - (failWith (doc <+> badConSig)) - ; return (details, res_ty) } - - PrefixCon {} -> return (PrefixCon arg_tys, res_ty)} - {- Note [ConDeclField passs] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -917,9 +892,12 @@ sameWildCard :: Located (HsWildCardInfo pass) sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2 ignoreParens :: LHsType pass -> LHsType pass -ignoreParens (L _ (HsParTy ty)) = ignoreParens ty -ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty -ignoreParens ty = ty +ignoreParens (L _ (HsParTy ty)) = ignoreParens ty +ignoreParens ty = ty + +isLHsForAllTy :: LHsType p -> Bool +isLHsForAllTy (L _ (HsForAllTy {})) = True +isLHsForAllTy _ = False {- ************************************************************************ @@ -941,6 +919,11 @@ mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass mkHsAppTys = foldl mkHsAppTy +mkHsAppsTy :: [LHsAppType GhcPs] -> HsType GhcPs +-- In the common case of a singleton non-operator, +-- avoid the clutter of wrapping in a HsAppsTy +mkHsAppsTy [L _ (HsAppPrefix (L _ ty))] = ty +mkHsAppsTy app_tys = HsAppsTy app_tys {- ************************************************************************ diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 8e17994993..67c0c3bc23 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -84,7 +84,6 @@ module HsUtils( hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors, getPatSynBinds, hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, - hsDataDefnBinders, -- Collecting implicit binders lStmtsImplicits, hsValBindsImplicits, lPatImplicits @@ -1106,55 +1105,48 @@ hsDataDefnBinders (HsDataDefn { dd_cons = cons }) -- See Note [Binders in family instances] ------------------- +type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass] + -- Filters out ones that have already been seen + hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) - -- See hsLTyClDeclBinders for what this does - -- The function is boringly complicated because of the records - -- And since we only have equality, we have to be a little careful -hsConDeclsBinders cons = go id cons - where go :: ([LFieldOcc pass] -> [LFieldOcc pass]) - -> [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) - go _ [] = ([], []) - go remSeen (r:rs) = - -- don't re-mangle the location of field names, because we don't - -- have a record of the full location of the field declaration anyway - case r of - -- remove only the first occurrence of any seen field in order to - -- avoid circumventing detection of duplicate fields (#9156) - L loc (ConDeclGADT { con_names = names - , con_type = HsIB { hsib_body = res_ty}}) -> - case tau of - L _ (HsFunTy - (L _ (HsAppsTy - [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty) - -> record_gadt flds - L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty) - -> record_gadt flds - - _other -> (map (L loc . unLoc) names ++ ns, fs) - where (ns, fs) = go remSeen rs - where - (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty - record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs) - where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) - remSeen' = foldr (.) remSeen - [deleteBy ((==) `on` - unLoc . rdrNameFieldOcc . unLoc) v - | v <- r'] - (ns, fs) = go remSeen' rs - - L loc (ConDeclH98 { con_name = name - , con_details = RecCon flds }) -> - ([L loc (unLoc name)] ++ ns, r' ++ fs) - where r' = remSeen (concatMap (cd_fld_names . unLoc) - (unLoc flds)) - remSeen' - = foldr (.) remSeen - [deleteBy ((==) `on` - unLoc . rdrNameFieldOcc . unLoc) v | v <- r'] - (ns, fs) = go remSeen' rs - L loc (ConDeclH98 { con_name = name }) -> - ([L loc (unLoc name)] ++ ns, fs) - where (ns, fs) = go remSeen rs + -- See hsLTyClDeclBinders for what this does + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +hsConDeclsBinders cons + = go id cons + where + go :: Seen pass -> [LConDecl pass] + -> ([Located (IdP pass)], [LFieldOcc pass]) + go _ [] = ([], []) + go remSeen (r:rs) + -- Don't re-mangle the location of field names, because we don't + -- have a record of the full location of the field declaration anyway + = case r of + -- remove only the first occurrence of any seen field in order to + -- avoid circumventing detection of duplicate fields (#9156) + L loc (ConDeclGADT { con_names = names, con_args = args }) + -> (map (L loc . unLoc) names ++ ns, flds ++ fs) + where + (remSeen', flds) = get_flds remSeen args + (ns, fs) = go remSeen' rs + + L loc (ConDeclH98 { con_name = name, con_args = args }) + -> ([L loc (unLoc name)] ++ ns, flds ++ fs) + where + (remSeen', flds) = get_flds remSeen args + (ns, fs) = go remSeen' rs + + get_flds :: Seen pass -> HsConDeclDetails pass + -> (Seen pass, [LFieldOcc pass]) + get_flds remSeen (RecCon flds) + = (remSeen', fld_names) + where + fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) + remSeen' = foldr (.) remSeen + [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v + | v <- fld_names] + get_flds remSeen _ + = (remSeen, []) {- diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index c60f51722f..7ae653fe98 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1839,7 +1839,7 @@ typedoc :: { LHsType GhcPs } -- See Note [Parsing ~] btype :: { LHsType GhcPs } : tyapps {% splitTildeApps (reverse (unLoc $1)) >>= - \ts -> return $ sL1 $1 $ HsAppsTy ts } + \ts -> return $ sL1 $1 $ mkHsAppsTy ts } -- Used for parsing Haskell98-style data constructors, -- in order to forbid the blasphemous @@ -2064,7 +2064,7 @@ gadt_constr :: { LConDecl GhcPs } -- see Note [Difference in parsing GADT and data constructors] -- Returns a list because of: C,D :: ty : con_list '::' sigtype - {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3))) + {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) $3)) [mu AnnDcolon $2] } {- Note [Difference in parsing GADT and data constructors] @@ -2093,13 +2093,17 @@ constr :: { LConDecl GhcPs } : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev {% ams (let (con,details) = unLoc $5 in addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con - (snd $ unLoc $2) $3 details)) + (snd $ unLoc $2) + (Just $3) + details)) ($1 `mplus` $6)) (mu AnnDarrow $4:(fst $ unLoc $2)) } | maybe_docnext forall constr_stuff maybe_docprev {% ams ( let (con,details) = unLoc $3 in addConDoc (L (comb2 $2 $3) (mkConDeclH98 con - (snd $ unLoc $2) (noLoc []) details)) + (snd $ unLoc $2) + Nothing -- No context + details)) ($1 `mplus` $4)) (fst $ unLoc $2) } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 126e92e7ad..0c2b204d46 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -7,6 +7,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MagicHash #-} module RdrHsSyn ( mkHsOpApp, @@ -68,7 +69,6 @@ module RdrHsSyn ( ) where import GhcPrelude - import HsSyn -- Lots of it import Class ( FunDep ) import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) @@ -552,24 +552,44 @@ recordPatSynErr loc pat = ppr pat mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs] - -> LHsContext GhcPs -> HsConDeclDetails GhcPs + -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs -> ConDecl GhcPs -mkConDeclH98 name mb_forall cxt details - = ConDeclH98 { con_name = name - , con_qvars = fmap mkHsQTvs mb_forall - , con_cxt = Just cxt - -- AZ:TODO: when can cxt be Nothing? - -- remembering that () is a valid context. - , con_details = details - , con_doc = Nothing } +mkConDeclH98 name mb_forall mb_cxt args + = ConDeclH98 { con_name = name + , con_forall = isJust mb_forall + , con_ex_tvs = mb_forall `orElse` [] + , con_mb_cxt = mb_cxt + , con_args = args + , con_doc = Nothing } mkGadtDecl :: [Located RdrName] - -> LHsSigType GhcPs -- Always a HsForAllTy + -> LHsType GhcPs -- Always a HsForAllTy -> ConDecl GhcPs -mkGadtDecl names ty = ConDeclGADT { con_names = names - , con_type = ty - , con_doc = Nothing } +mkGadtDecl names ty + = ConDeclGADT { con_names = names + , con_forall = isLHsForAllTy ty + , con_qvars = mkHsQTvs tvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty + , con_doc = Nothing } + where + (tvs, rho) = splitLHsForAllTy ty + (mcxt, tau) = split_rho rho + + split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) + = (Just cxt, tau) + split_rho (L _ (HsParTy ty)) = split_rho ty + split_rho tau = (Nothing, tau) + + (args, res_ty) = split_tau tau + + -- See Note [GADT abstract syntax] in HsDecls + split_tau (L _ (HsFunTy (L loc (HsRecTy rf)) res_ty)) + = (RecCon (L loc rf), res_ty) + split_tau (L _ (HsParTy ty)) = split_tau ty + split_tau tau = (PrefixCon [], tau) setRdrNameSpace :: RdrName -> NameSpace -> RdrName -- ^ This rather gruesome function is used mainly by the parser. @@ -656,23 +676,6 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It really doesn't matter! -} --- | Note [Sorting out the result type] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In a GADT declaration which is not a record, we put the whole constr type --- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once --- it has sorted out operator fixities. Consider for example --- C :: a :*: b -> a :*: b -> a :+: b --- Initially this type will parse as --- a :*: (b -> (a :*: (b -> (a :+: b)))) --- --- so it's hard to split up the arguments until we've done the precedence --- resolution (in the renamer). On the other hand, for a record --- { x,y :: Int } -> a :*: b --- there is no doubt. AND we need to sort records out so that --- we can bring x,y into scope. So: --- * For PrefixCon we keep all the args in the res_ty --- * For RecCon we do not - checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs] -> P (LHsQTyVars GhcPs) -- Same as checkTyVars, but in the P monad @@ -694,13 +697,10 @@ checkTyVars pp_what equals_or_where tc tparms = do { tvs <- mapM chk tparms ; return (mkHsQTvs tvs) } where - chk (L _ (HsParTy ty)) = chk ty - chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty -- Check that the name space is correct! - chk (L l (HsKindSig - (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k)) + chk (L l (HsKindSig (L lv (HsTyVar _ (L _ tv))) k)) | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k)) chk (L l (HsTyVar _ (L ltv tv))) | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv))) diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index b1dc8877b5..60c8b1b7dd 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -639,24 +639,16 @@ getLocalNonValBinders fixity_env -> [(Name, [FieldLabel])] mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) where - find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr - , con_details = RecCon cdflds })) + find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr + , con_args = RecCon cdflds })) = [( find_con_name rdr , concatMap find_con_decl_flds (unLoc cdflds) )] - find_con_flds (L _ (ConDeclGADT - { con_names = rdrs - , con_type = (HsIB { hsib_body = res_ty})})) - = map (\ (L _ rdr) -> ( find_con_name rdr - , concatMap find_con_decl_flds cdflds)) - rdrs - where - (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty - cdflds = case tau of - L _ (HsFunTy - (L _ (HsAppsTy - [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds - L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds - _ -> [] + find_con_flds (L _ (ConDeclGADT { con_names = rdrs + , con_args = RecCon flds })) + = [ ( find_con_name rdr + , concatMap find_con_decl_flds (unLoc flds)) + | L _ rdr <- rdrs ] + find_con_flds _ = [] find_con_name rdr @@ -664,6 +656,7 @@ getLocalNonValBinders fixity_env find (\ n -> nameOccName n == rdrNameOcc rdr) names find_con_decl_flds (L _ x) = map find_con_decl_fld (cd_fld_names x) + find_con_decl_fld (L _ (FieldOcc (L _ rdr) _)) = expectJust "getLocalNonValBinders/find_con_decl_fld" $ find (\ fl -> flLabel fl == lbl) flds diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index c0347c4d6b..897e660515 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -52,7 +52,6 @@ import Avail import Outputable import Bag import BasicTypes ( DerivStrategy, RuleName, pprRuleName ) -import Maybes ( orElse ) import FastString import SrcLoc import DynFlags @@ -1536,6 +1535,7 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, ; typeintype <- xoptM LangExt.TypeInType ; let cusk = hsTvbAllKinded tyvars' && (not typeintype || no_rhs_kvs) + ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars' , tcdFixity = fixity , tcdDataDefn = defn', tcdDataCusk = cusk @@ -1872,52 +1872,90 @@ rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) rnConDecls = mapFvRn (wrapLocFstM rnConDecl) rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) -rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs - , con_cxt = mcxt, con_details = details +rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt, con_args = args , con_doc = mb_doc }) - = do { _ <- addLocM checkConName name - ; new_name <- lookupLocatedTopBndrRn name - ; mb_doc' <- rnMbLHsDoc mb_doc - - ; let doc = ConDeclCtx [new_name] - qtvs' = qtvs `orElse` mkHsQTvs [] - body_kvs = [] -- Consider data T a = forall (b::k). MkT (...) - -- The 'k' will already be in scope from the - -- bindHsQTyVars for the entire DataDecl - -- So there can be no new body_kvs here - ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing body_kvs qtvs' $ - \new_tyvars _ -> do - { (new_context, fvs1) <- case mcxt of - Nothing -> return (Nothing,emptyFVs) - Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt - ; return (Just lctx',fvs) } - ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details - ; let (new_details',fvs3) = (new_details,emptyFVs) + = do { _ <- addLocM checkConName name + ; new_name <- lookupLocatedTopBndrRn name + ; mb_doc' <- rnMbLHsDoc mb_doc + + -- We bind no implicit binders here; this is just like + -- a nested HsForAllTy. E.g. consider + -- data T a = forall (b::k). MkT (...) + -- The 'k' will already be in scope from the bindHsQTyVars + -- for the data decl itself. So we'll get + -- data T {k} a = ... + -- And indeed we may later discover (a::k). But that's the + -- scoping we get. So no implicit binders at the existential forall + + ; let ctxt = ConDeclCtx [new_name] + ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt)) + Nothing ex_tvs $ \ new_ex_tvs -> + do { (new_context, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args + ; let all_fvs = fvs1 `plusFV` fvs2 ; traceRn "rnConDecl" (ppr name <+> vcat - [ text "qtvs:" <+> ppr qtvs - , text "qtvs':" <+> ppr qtvs' ]) - ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 - new_tyvars' = case qtvs of - Nothing -> Nothing - Just _ -> Just new_tyvars - ; return (decl { con_name = new_name, con_qvars = new_tyvars' - , con_cxt = new_context, con_details = new_details' + [ text "ex_tvs:" <+> ppr ex_tvs + , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) + + ; return (decl { con_name = new_name, con_ex_tvs = new_ex_tvs + , con_mb_cxt = new_context, con_args = new_args , con_doc = mb_doc' }, all_fvs) }} -rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty +rnConDecl decl@(ConDeclGADT { con_names = names + , con_forall = explicit_forall + , con_qvars = qtvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty , con_doc = mb_doc }) = do { mapM_ (addLocM checkConName) names - ; new_names <- mapM lookupLocatedTopBndrRn names - ; let doc = ConDeclCtx new_names - ; mb_doc' <- rnMbLHsDoc mb_doc - - ; (ty', fvs) <- rnHsSigType doc ty - ; traceRn "rnConDecl" (ppr names <+> vcat - [ text "fvs:" <+> ppr fvs ]) - ; return (decl { con_names = new_names, con_type = ty' + ; new_names <- mapM lookupLocatedTopBndrRn names + ; mb_doc' <- rnMbLHsDoc mb_doc + + ; let explicit_tkvs = hsQTvExplicit qtvs + theta = hsConDeclTheta mcxt + arg_tys = hsConDeclArgTys args + ; free_tkvs <- extractHsTysRdrTyVarsDups (res_ty : theta ++ arg_tys) + ; free_tkvs <- extractHsTvBndrs explicit_tkvs free_tkvs + + ; let ctxt = ConDeclCtx new_names + mb_ctxt = Just (inHsDocContext ctxt) + + ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall ) + ; rnImplicitBndrs (not explicit_forall) ctxt free_tkvs $ \ implicit_tkvs -> + bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs -> + do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args + ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + (args', res_ty') + = case args of + InfixCon {} -> pprPanic "rnConDecl" (ppr names) + RecCon {} -> (new_args, new_res_ty) + PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty + -> ASSERT( null as ) + -- See Note [GADT abstract syntax] in HsDecls + (PrefixCon arg_tys, final_res_ty) + + new_qtvs = HsQTvs { hsq_implicit = implicit_tkvs + , hsq_explicit = explicit_tkvs + , hsq_dependent = emptyNameSet } + + ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) + ; return (decl { con_names = new_names + , con_qvars = new_qtvs, con_mb_cxt = new_cxt + , con_args = args', con_res_ty = res_ty' , con_doc = mb_doc' }, - fvs) } + all_fvs) } } + +rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) + -> RnM (Maybe (LHsContext GhcRn), FreeVars) +rnMbContext _ Nothing = return (Nothing, emptyFVs) +rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt + ; return (Just ctx',fvs) } rnConDeclDetails :: Name diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index dd66cd3aec..727744d54d 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -23,13 +23,14 @@ module RnTypes ( checkPrecMatch, checkSectionPrec, -- Binding related stuff - bindLHsTyVarBndr, + bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames, extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups, extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars, extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars, extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars, + extractHsTvBndrs, freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars, elemRdr ) where @@ -59,6 +60,7 @@ import NameSet import FieldLabel import Util +import ListSetOps ( deleteBys ) import BasicTypes ( compareFixity, funTyFixity, negateFixity, Fixity(..), FixityDirection(..), LexicalFixity(..) ) import Outputable @@ -66,7 +68,7 @@ import FastString import Maybes import qualified GHC.LanguageExtensions as LangExt -import Data.List ( nubBy, partition ) +import Data.List ( nubBy, partition, (\\) ) import Control.Monad ( unless, when ) #include "HsVersions.h" @@ -85,7 +87,7 @@ to break several loop. rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars) rnHsSigWcType doc sig_ty - = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' -> + = rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' -> return (sig_ty', emptyFVs) rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs @@ -99,26 +101,31 @@ rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs rnHsSigWcTypeScoped ctx sig_ty thing_inside = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty) - ; rn_hs_sig_wc_type False ctx sig_ty thing_inside + ; rn_hs_sig_wc_type True ctx sig_ty thing_inside } - -- False: for pattern type sigs and rules we /do/ want - -- to bring those type variables into scope + -- True: for pattern type sigs and rules we /do/ want + -- to bring those type variables into scope, even + -- if there's a forall at the top which usually + -- stops that happening -- e.g \ (x :: forall a. a-> b) -> e -- Here we do bring 'b' into scope -rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs +rn_hs_sig_wc_type :: Bool -- True <=> always bind any free tyvars of the + -- type, regardless of whether it has + -- a forall at the top -> HsDocContext -> LHsSigWcType GhcPs -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- rn_hs_sig_wc_type is used for source-language type signatures -rn_hs_sig_wc_type no_implicit_if_forall ctxt +rn_hs_sig_wc_type always_bind_free_tvs ctxt (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) thing_inside = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars ; let nwc_rdrs = nubL nwc_rdrs' - ; rnImplicitBndrs no_implicit_if_forall ctxt hs_ty tv_rdrs $ \ vars -> + bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty) + ; rnImplicitBndrs bind_free_tvs ctxt tv_rdrs $ \ vars -> do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' } ib_ty' = mk_implicit_bndrs vars hs_ty' fvs1 @@ -265,32 +272,31 @@ rnHsSigType :: HsDocContext -> LHsSigType GhcPs rnHsSigType ctx (HsIB { hsib_body = hs_ty }) = do { traceRn "rnHsSigType" (ppr hs_ty) ; vars <- extractFilteredRdrTyVarsDups hs_ty - ; rnImplicitBndrs True ctx hs_ty vars $ \ vars -> + ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) ctx vars $ \ vars -> do { (body', fvs) <- rnLHsType ctx hs_ty ; return ( mk_implicit_bndrs vars body' fvs, fvs ) } } -rnImplicitBndrs :: Bool -- True <=> no implicit quantification - -- if type is headed by a forall +rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables -- E.g. f :: forall a. a->b - -- Do not quantify over 'b' too. + -- we do not want to bring 'b' into scope, hence False + -- But f :: a -> b + -- we want to bring both 'a' and 'b' into scope -> HsDocContext - -> LHsType GhcPs -- hs_ty: the type over which the - -- implicit binders will scope -> FreeKiTyVarsWithDups -- Free vars of hs_ty (excluding wildcards) -- May have duplicates, which is -- checked here -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -rnImplicitBndrs no_implicit_if_forall doc (L loc hs_ty) +rnImplicitBndrs bind_free_tvs doc fvs_with_dups@(FKTV { fktv_kis = kvs_with_dups , fktv_tys = tvs_with_dups }) thing_inside = do { let FKTV kvs tvs = rmDupsInRdrTyVars fvs_with_dups - real_tvs | no_implicit_if_forall - , HsForAllTy {} <- hs_ty = [] - | otherwise = tvs - -- Quantify over type variables only if there is no + real_tvs | bind_free_tvs = tvs + | otherwise = [] + -- We always bind over free /kind/ variables. + -- Bind free /type/ variables only if there is no -- explicit forall. E.g. -- f :: Proxy (a :: k) -> b -- Quantify over {k} and {a,b} @@ -300,8 +306,9 @@ rnImplicitBndrs no_implicit_if_forall doc (L loc hs_ty) -- but, rather arbitrarily, we switch off the type-quantification -- if there is an explicit forall - ; traceRn "rnImplicitBndrs" (vcat [ ppr hs_ty, ppr kvs, ppr tvs, ppr real_tvs ]) + ; traceRn "rnImplicitBndrs" (vcat [ ppr kvs, ppr tvs, ppr real_tvs ]) + ; loc <- getSrcSpanM ; vars <- mapM (newLocalBndrRn . L loc . unLoc) (kvs ++ real_tvs) ; checkBadKindBndrs doc kvs @@ -898,23 +905,24 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside ; let -- See Note [bindHsQTyVars examples] for what -- all these various things are doing - bndrs, kv_occs, implicit_bndr_kvs, - implicit_body_kvs, implicit_kvs :: [Located RdrName] - bndrs = map hsLTyVarLocName hs_tv_bndrs - kv_occs = body_kv_occs ++ bndr_kv_occs - implicit_bndr_kvs = filter_occs rdr_env bndrs bndr_kv_occs - implicit_body_kvs = filter_occs rdr_env (implicit_bndr_kvs ++ bndrs) body_kv_occs + bndrs, kv_occs, implicit_kvs :: [Located RdrName] + bndrs = map hsLTyVarLocName hs_tv_bndrs + kv_occs = nubL (body_kv_occs ++ bndr_kv_occs) + implicit_kvs = filter_occs rdr_env bndrs kv_occs -- Deleting bndrs: See Note [Kind-variable ordering] - implicit_kvs = implicit_bndr_kvs ++ implicit_body_kvs - -- dep_bndrs is the subset of bndrs that are dependent -- i.e. appear in bndr/body_kv_occs -- Can't use implicit_kvs because we've deleted bndrs from that! dep_bndrs = filter (`elemRdr` kv_occs) bndrs + del = deleteBys eqLocated + all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs) ; traceRn "checkMixedVars3" $ vcat [ text "kv_occs" <+> ppr kv_occs - , text "bndrs" <+> ppr bndrs ] + , text "bndrs" <+> ppr hs_tv_bndrs + , text "bndr_kv_occs" <+> ppr bndr_kv_occs + , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs) + ] ; checkBadKindBndrs doc implicit_kvs ; checkMixedVars kv_occs bndrs @@ -927,7 +935,7 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside ; thing_inside (HsQTvs { hsq_implicit = implicit_kv_nms , hsq_explicit = rn_bndrs , hsq_dependent = mkNameSet dep_bndr_nms }) - (null implicit_body_kvs) } } + all_bound_on_lhs } } where filter_occs :: LocalRdrEnv -- In scope @@ -957,15 +965,10 @@ Then: body_kv_occs = [k2,k1], kind variables free in the result kind signature - implicit_bndr_kvs = [k1], kind variables free in kind signatures - of hs_tv_bndrs, and not bound by bndrs - - implicit_body_kvs = [k2], kind variables free in the result kind - signature, and not bound either by - bndrs or by implicit_bndr_kvs + implicit_kvs = [k1,k2], kind variables free in kind signatures + of hs_tv_bndrs, and not bound by bndrs -* We want to quantify add implicit bindings for - implicit_bndr_kvs and implicit_body_kvs +* We want to quantify add implicit bindings for implicit_kvs * The "dependent" bndrs (hsq_dependent) are the subset of bndrs that are free in bndr_kv_occs or body_kv_occs @@ -1739,11 +1742,11 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig foldrM (extract_con . unLoc) emptyFKTV cons) where extract_con (ConDeclGADT { }) acc = return acc - extract_con (ConDeclH98 { con_qvars = qvs - , con_cxt = ctxt, con_details = details }) acc - = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<< + extract_con (ConDeclH98 { con_ex_tvs = ex_tvs + , con_mb_cxt = ctxt, con_args = args }) acc + = extract_hs_tv_bndrs ex_tvs acc =<< extract_mlctxt ctxt =<< - extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV + extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV extract_mlctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> RnM FreeKiTyVars extract_mlctxt Nothing acc = return acc @@ -1815,6 +1818,12 @@ extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc +extractHsTvBndrs :: [LHsTyVarBndr GhcPs] + -> FreeKiTyVars -- Free in body + -> RnM FreeKiTyVars -- Free in result +extractHsTvBndrs tv_bndrs body_fvs + = extract_hs_tv_bndrs tv_bndrs emptyFKTV body_fvs + extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars -> FreeKiTyVars -> RnM FreeKiTyVars -- In (forall (a :: Maybe e). a -> b) we have diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 10794e2d2b..cc826b9401 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -32,7 +32,7 @@ module TcHsType ( tcHsLiftedType, tcHsOpenType, tcHsLiftedTypeNC, tcHsOpenTypeNC, tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType, - tcHsContext, tcLHsPredType, tcInferApps, + tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps, solveEqualities, -- useful re-export typeLevelMode, kindLevelMode, @@ -983,6 +983,10 @@ instantiateTyUntilN mb_kind_env n ty ki instantiateTyN mb_kind_env num_to_inst ty bndrs inner_ki --------------------------- +tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] +tcHsMbContext Nothing = return [] +tcHsMbContext (Just cxt) = tcHsContext cxt + tcHsContext :: LHsContext GhcRn -> TcM [PredType] tcHsContext = tc_hs_context typeLevelMode diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index f77a70b69b..e3b8b4d7bd 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -619,34 +619,34 @@ kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name ------------------- kcConDecl :: ConDecl GhcRn -> TcM () -kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs - , con_cxt = ex_ctxt, con_details = details }) +kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = ex_ctxt, con_args = args }) = addErrCtxt (dataConCtxtName [name]) $ - -- the 'False' says that the existentials don't have a CUSK, as the - -- concept doesn't really apply here. We just need to bring the variables - -- into scope. (Similarly, the choice of PromotedDataConFlavour isn't - -- particularly important.) - do { _ <- kcHsTyVarBndrs (unLoc name) PromotedDataConFlavour - False False - ((fromMaybe emptyLHsQTvs ex_tvs)) $ - do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt) - ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details) - ; return (panic "kcConDecl", ()) } - -- We don't need to check the telescope here, because that's - -- done in tcConDecl + do { _ <- tcExplicitTKBndrs ex_tvs $ \ _ -> + do { _ <- tcHsMbContext ex_ctxt + ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) + ; return (panic "kcConDecl", emptyVarSet) } ; return () } kcConDecl (ConDeclGADT { con_names = names - , con_type = ty }) - = addErrCtxt (dataConCtxtName names) $ - do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty - -- Even though the data constructor's type is closed, we - -- must still call tcGadtSigType, because that influences - -- the inferred kind of the /type/ constructor. Example: - -- data T f a where - -- MkT :: f a -> T f a - -- If we don't look at MkT we won't get the correct kind - -- for the type constructor T + , con_qvars = qtvs, con_mb_cxt = cxt + , con_args = args, con_res_ty = res_ty }) + | HsQTvs { hsq_implicit = implicit_tkv_nms + , hsq_explicit = explicit_tkv_nms } <- qtvs + = -- Even though the data constructor's type is closed, we + -- must still kind-check the type, because that may influence + -- the inferred kind of the /type/ constructor. Example: + -- data T f a where + -- MkT :: f a -> T f a + -- If we don't look at MkT we won't get the correct kind + -- for the type constructor T + addErrCtxt (dataConCtxtName names) $ + do { _ <- tcImplicitTKBndrs implicit_tkv_nms $ + tcExplicitTKBndrs explicit_tkv_nms $ \ _ -> + do { _ <- tcHsMbContext cxt + ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) + ; _ <- tcHsOpenType res_ty + ; return (panic "kcConDecl", emptyVarSet) } ; return () } {- @@ -1637,43 +1637,35 @@ tcConDecl :: TyCon -- Representation tycon. Knot-tied! tcConDecl rep_tycon tmpl_bndrs res_tmpl (ConDeclH98 { con_name = name - , con_qvars = hs_qvars, con_cxt = hs_ctxt - , con_details = hs_details }) + , con_ex_tvs = explicit_tkv_nms + , con_mb_cxt = hs_ctxt + , con_args = hs_args }) = addErrCtxt (dataConCtxtName [name]) $ do { -- Get hold of the existential type variables -- e.g. data T a = forall (b::k) f. MkT a (f b) -- Here tmpl_bndrs = {a} - -- hs_kvs = {k} - -- hs_tvs = {f,b} - ; let (hs_kvs, hs_tvs) = case hs_qvars of - Nothing -> ([], []) - Just (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) - -> (kvs, tvs) + -- hs_qvars = HsQTvs { hsq_implicit = {k} + -- , hsq_explicit = {f,b} } - ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr hs_kvs, ppr hs_tvs ]) + ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) - ; (imp_tvs, (exp_tvs, ctxt, arg_tys, field_lbls, stricts)) + ; ((exp_tvs, ctxt, arg_tys, field_lbls, stricts), _bound_vars) <- solveEqualities $ - tcImplicitTKBndrs hs_kvs $ - tcExplicitTKBndrs hs_tvs $ \ exp_tvs -> - do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs) - ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt) - ; btys <- tcConArgs hs_details + tcExplicitTKBndrs explicit_tkv_nms $ \ exp_tvs -> + do { ctxt <- tcHsMbContext hs_ctxt + ; btys <- tcConArgs hs_args ; field_lbls <- lookupConstructorFields (unLoc name) ; let (arg_tys, stricts) = unzip btys - bound_vars = allBoundVariabless ctxt `unionVarSet` - allBoundVariabless arg_tys + bound_vars = emptyVarSet -- Not used ; return ((exp_tvs, ctxt, arg_tys, field_lbls, stricts), bound_vars) } -- exp_tvs have explicit, user-written binding sites - -- imp_tvs are user-written kind variables, without an explicit binding site -- the kvs below are those kind variables entirely unmentioned by the user -- and discovered only by generalization -- Kind generalisation - ; let all_user_tvs = imp_tvs ++ exp_tvs - ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys all_user_tvs $ + ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys exp_tvs $ mkFunTys ctxt $ mkFunTys arg_tys $ unitTy) @@ -1688,7 +1680,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl -- Zonk to Types ; (ze, qkvs) <- zonkTyBndrsX emptyZonkEnv kvs - ; (ze, user_qtvs) <- zonkTyBndrsX ze all_user_tvs + ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs ; arg_tys <- zonkTcTypeToTypes ze arg_tys ; ctxt <- zonkTcTypeToTypes ze ctxt @@ -1707,7 +1699,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl -- See Note [DataCon user type variable binders] in DataCon. user_tvbs = univ_tvbs ++ ex_tvbs buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixH98 name hs_details + { is_infix <- tcConIsInfixH98 name hs_args ; rep_nm <- newTyConRepName name ; buildDataCon fam_envs name is_infix rep_nm @@ -1724,11 +1716,31 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl } tcConDecl rep_tycon tmpl_bndrs res_tmpl - (ConDeclGADT { con_names = names, con_type = ty }) + (ConDeclGADT { con_names = names + , con_qvars = qtvs + , con_mb_cxt = cxt, con_args = hs_args + , con_res_ty = res_ty }) + | HsQTvs { hsq_implicit = implicit_tkv_nms + , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1" (ppr names) - ; (user_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details) - <- tcGadtSigType (ppr names) (unLoc $ head names) ty + ; let (L _ name : _) = names + + ; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts)) + <- solveEqualities $ + tcImplicitTKBndrs implicit_tkv_nms $ + tcExplicitTKBndrs explicit_tkv_nms $ \ exp_tvs -> + do { ctxt <- tcHsMbContext cxt + ; btys <- tcConArgs hs_args + ; res_ty' <- tcHsLiftedType res_ty + ; field_lbls <- lookupConstructorFields name + ; let (arg_tys, stricts) = unzip btys + bound_vars = allBoundVariabless ctxt `unionVarSet` + allBoundVariabless arg_tys + + ; return ((exp_tvs, ctxt, arg_tys, res_ty', field_lbls, stricts), bound_vars) + } + ; let user_tvs = imp_tvs ++ exp_tvs ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys user_tvs $ mkFunTys ctxt $ @@ -1767,7 +1779,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; let buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixGADT name hs_details + { is_infix <- tcConIsInfixGADT name hs_args ; rep_nm <- newTyConRepName name ; buildDataCon fam_envs name is_infix @@ -1783,31 +1795,6 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl ; mapM buildOneDataCon names } - -tcGadtSigType :: SDoc -> Name -> LHsSigType GhcRn - -> TcM ( [TcTyVar], [PredType],[HsSrcBang], [FieldLabel], [Type], Type - , HsConDetails (LHsType GhcRn) - (Located [LConDeclField GhcRn]) ) -tcGadtSigType doc name ty@(HsIB { hsib_vars = vars }) - = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty - ; (hs_details, res_ty) <- updateGadtResult failWithTc doc hs_details' res_ty' - ; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts)) - <- solveEqualities $ - tcImplicitTKBndrs vars $ - tcExplicitTKBndrs gtvs $ \ exp_tvs -> - do { ctxt <- tcHsContext cxt - ; btys <- tcConArgs hs_details - ; ty' <- tcHsLiftedType res_ty - ; field_lbls <- lookupConstructorFields name - ; let (arg_tys, stricts) = unzip btys - bound_vars = allBoundVariabless ctxt `unionVarSet` - allBoundVariabless arg_tys - - ; return ((exp_tvs, ctxt, arg_tys, ty', field_lbls, stricts), bound_vars) - } - ; return (imp_tvs ++ exp_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty, hs_details) - } - tcConIsInfixH98 :: Name -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) -> TcM Bool diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs index c311ac9c85..a0fd9879bc 100644 --- a/compiler/utils/ListSetOps.hs +++ b/compiler/utils/ListSetOps.hs @@ -8,7 +8,7 @@ {-# LANGUAGE CPP #-} module ListSetOps ( - unionLists, minusList, + unionLists, minusList, deleteBys, -- Association lists Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, @@ -37,6 +37,11 @@ getNth :: Outputable a => [a] -> Int -> a getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) xs !! n +deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a] +-- (deleteBys eq xs ys) returns xs-ys, using the given equality function +-- Just like 'Data.List.delete' but with an equality function +deleteBys eq xs ys = foldl (flip (deleteBy eq)) xs ys + {- ************************************************************************ * * diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index adc0d14370..a0c0b24d73 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -28,13 +28,15 @@ test('T10357', [extra_files(['Test10357.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10357']) test('T10358', [extra_files(['Test10358.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10358']) -test('T10278', [extra_files(['Test10278.hs']), +test('T10278', [expect_broken(14529), + extra_files(['Test10278.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10278']) test('T10354', [extra_files(['Test10354.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10354']) test('T10396', [extra_files(['Test10396.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10396']) -test('T10399', [extra_files(['Test10399.hs']), +test('T10399', [expect_broken(14529), + extra_files(['Test10399.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10399']) test('T10313', [extra_files(['Test10313.hs', 'stringSource.hs']), ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10313']) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 46ab21412e..127f28ac4e 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -30,10 +30,9 @@ ({ DumpParsedAst.hs:5:14-17 } (Unqual {OccName: Zero})) + (False) + [] (Nothing) - (Just - ({ <no location info> } - [])) (PrefixCon []) (Nothing))) @@ -42,10 +41,9 @@ ({ DumpParsedAst.hs:5:21-24 } (Unqual {OccName: Succ})) + (False) + [] (Nothing) - (Just - ({ <no location info> } - [])) (PrefixCon [({ DumpParsedAst.hs:5:26-30 } (HsTyVar @@ -144,15 +142,11 @@ []))] (Prefix) ({ DumpParsedAst.hs:9:21-24 } - (HsAppsTy - [({ DumpParsedAst.hs:9:21-24 } - (HsAppPrefix - ({ DumpParsedAst.hs:9:21-24 } - (HsTyVar - (NotPromoted) - ({ DumpParsedAst.hs:9:21-24 } - (Unqual - {OccName: Zero}))))))]))) + (HsTyVar + (NotPromoted) + ({ DumpParsedAst.hs:9:21-24 } + (Unqual + {OccName: Zero}))))) (PlaceHolder)))])) ({ DumpParsedAst.hs:7:13-18 } (Unqual @@ -165,35 +159,23 @@ (Unqual {OccName: as})) ({ DumpParsedAst.hs:7:27-29 } - (HsAppsTy - [({ DumpParsedAst.hs:7:27-29 } - (HsAppPrefix - ({ DumpParsedAst.hs:7:27-29 } - (HsListTy - ({ DumpParsedAst.hs:7:28 } - (HsAppsTy - [({ DumpParsedAst.hs:7:28 } - (HsAppPrefix - ({ DumpParsedAst.hs:7:28 } - (HsTyVar - (NotPromoted) - ({ DumpParsedAst.hs:7:28 } - (Unqual - {OccName: k}))))))]))))))]))))] + (HsListTy + ({ DumpParsedAst.hs:7:28 } + (HsTyVar + (NotPromoted) + ({ DumpParsedAst.hs:7:28 } + (Unqual + {OccName: k}))))))))] (PlaceHolder)) (Prefix) ({ DumpParsedAst.hs:7:32-39 } (KindSig ({ DumpParsedAst.hs:7:35-39 } - (HsAppsTy - [({ DumpParsedAst.hs:7:35-39 } - (HsAppPrefix - ({ DumpParsedAst.hs:7:35-39 } - (HsTyVar - (NotPromoted) - ({ DumpParsedAst.hs:7:35-39 } - (Unqual - {OccName: Peano}))))))])))) + (HsTyVar + (NotPromoted) + ({ DumpParsedAst.hs:7:35-39 } + (Unqual + {OccName: Peano})))))) (Nothing))))) ,({ DumpParsedAst.hs:11:1-23 } (ValD diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index c7daf90ff0..3ddb5ed462 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -70,10 +70,9 @@ (ConDeclH98 ({ DumpRenamedAst.hs:6:14-17 } {Name: DumpRenamedAst.Zero}) + (False) + [] (Nothing) - (Just - ({ <no location info> } - [])) (PrefixCon []) (Nothing))) @@ -81,10 +80,9 @@ (ConDeclH98 ({ DumpRenamedAst.hs:6:21-24 } {Name: DumpRenamedAst.Succ}) + (False) + [] (Nothing) - (Just - ({ <no location info> } - [])) (PrefixCon [({ DumpRenamedAst.hs:6:26-30 } (HsTyVar @@ -293,65 +291,68 @@ (ConDeclGADT [({ DumpRenamedAst.hs:16:3-5 } {Name: DumpRenamedAst.Nat})] - (HsIB + (False) + (HsQTvs [{Name: f} ,{Name: g}] - ({ DumpRenamedAst.hs:16:10-45 } - (HsFunTy - ({ DumpRenamedAst.hs:16:10-34 } - (HsParTy - ({ DumpRenamedAst.hs:16:11-33 } - (HsForAllTy - [({ DumpRenamedAst.hs:16:18-19 } - (UserTyVar - ({ DumpRenamedAst.hs:16:18-19 } - {Name: xx})))] - ({ DumpRenamedAst.hs:16:22-33 } - (HsFunTy - ({ DumpRenamedAst.hs:16:22-25 } - (HsAppTy - ({ DumpRenamedAst.hs:16:22 } - (HsTyVar - (NotPromoted) - ({ DumpRenamedAst.hs:16:22 } - {Name: f}))) - ({ DumpRenamedAst.hs:16:24-25 } - (HsTyVar - (NotPromoted) - ({ DumpRenamedAst.hs:16:24-25 } - {Name: xx}))))) - ({ DumpRenamedAst.hs:16:30-33 } - (HsAppTy - ({ DumpRenamedAst.hs:16:30 } - (HsTyVar - (NotPromoted) - ({ DumpRenamedAst.hs:16:30 } - {Name: g}))) - ({ DumpRenamedAst.hs:16:32-33 } - (HsTyVar - (NotPromoted) - ({ DumpRenamedAst.hs:16:32-33 } - {Name: xx}))))))))))) - ({ DumpRenamedAst.hs:16:39-45 } - (HsAppTy - ({ DumpRenamedAst.hs:16:39-43 } - (HsAppTy - ({ DumpRenamedAst.hs:16:39-41 } - (HsTyVar - (NotPromoted) - ({ DumpRenamedAst.hs:16:39-41 } - {Name: DumpRenamedAst.Nat}))) - ({ DumpRenamedAst.hs:16:43 } - (HsTyVar - (NotPromoted) - ({ DumpRenamedAst.hs:16:43 } - {Name: f}))))) - ({ DumpRenamedAst.hs:16:45 } - (HsTyVar - (NotPromoted) - ({ DumpRenamedAst.hs:16:45 } - {Name: g}))))))) - (True)) + [] + {NameSet: + []}) + (Nothing) + (PrefixCon + [({ DumpRenamedAst.hs:16:10-34 } + (HsParTy + ({ DumpRenamedAst.hs:16:11-33 } + (HsForAllTy + [({ DumpRenamedAst.hs:16:18-19 } + (UserTyVar + ({ DumpRenamedAst.hs:16:18-19 } + {Name: xx})))] + ({ DumpRenamedAst.hs:16:22-33 } + (HsFunTy + ({ DumpRenamedAst.hs:16:22-25 } + (HsAppTy + ({ DumpRenamedAst.hs:16:22 } + (HsTyVar + (NotPromoted) + ({ DumpRenamedAst.hs:16:22 } + {Name: f}))) + ({ DumpRenamedAst.hs:16:24-25 } + (HsTyVar + (NotPromoted) + ({ DumpRenamedAst.hs:16:24-25 } + {Name: xx}))))) + ({ DumpRenamedAst.hs:16:30-33 } + (HsAppTy + ({ DumpRenamedAst.hs:16:30 } + (HsTyVar + (NotPromoted) + ({ DumpRenamedAst.hs:16:30 } + {Name: g}))) + ({ DumpRenamedAst.hs:16:32-33 } + (HsTyVar + (NotPromoted) + ({ DumpRenamedAst.hs:16:32-33 } + {Name: xx})))))))))))]) + ({ DumpRenamedAst.hs:16:39-45 } + (HsAppTy + ({ DumpRenamedAst.hs:16:39-43 } + (HsAppTy + ({ DumpRenamedAst.hs:16:39-41 } + (HsTyVar + (NotPromoted) + ({ DumpRenamedAst.hs:16:39-41 } + {Name: DumpRenamedAst.Nat}))) + ({ DumpRenamedAst.hs:16:43 } + (HsTyVar + (NotPromoted) + ({ DumpRenamedAst.hs:16:43 } + {Name: f}))))) + ({ DumpRenamedAst.hs:16:45 } + (HsTyVar + (NotPromoted) + ({ DumpRenamedAst.hs:16:45 } + {Name: g}))))) (Nothing)))] ({ <no location info> } []))) diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index 53e4a6f941..439c5ff135 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -29,10 +29,9 @@ (ConDeclH98 ({ T14189.hs:6:15-16 } {Name: T14189.MT}) + (False) + [] (Nothing) - (Just - ({ <no location info> } - [])) (PrefixCon [({ T14189.hs:6:18-20 } (HsTyVar @@ -44,10 +43,9 @@ (ConDeclH98 ({ T14189.hs:6:24-25 } {Name: T14189.NT}) + (False) + [] (Nothing) - (Just - ({ <no location info> } - [])) (PrefixCon []) (Nothing))) @@ -55,10 +53,9 @@ (ConDeclH98 ({ T14189.hs:6:29 } {Name: T14189.F}) + (False) + [] (Nothing) - (Just - ({ <no location info> } - [])) (RecCon ({ T14189.hs:6:31-42 } [({ T14189.hs:6:33-40 } diff --git a/testsuite/tests/patsyn/should_fail/T11039.stderr b/testsuite/tests/patsyn/should_fail/T11039.stderr index 4783bc9fe6..14d67a2bb2 100644 --- a/testsuite/tests/patsyn/should_fail/T11039.stderr +++ b/testsuite/tests/patsyn/should_fail/T11039.stderr @@ -2,7 +2,8 @@ T11039.hs:8:15: error: • Couldn't match type ‘f’ with ‘A’ ‘f’ is a rigid type variable bound by - the signature for pattern synonym ‘Q’ at T11039.hs:7:14-38 + the signature for pattern synonym ‘Q’ + at T11039.hs:7:1-38 Expected type: f a Actual type: A a • In the pattern: A a diff --git a/testsuite/tests/patsyn/should_fail/T11667.stderr b/testsuite/tests/patsyn/should_fail/T11667.stderr index fdd447704d..c9c00c9165 100644 --- a/testsuite/tests/patsyn/should_fail/T11667.stderr +++ b/testsuite/tests/patsyn/should_fail/T11667.stderr @@ -16,7 +16,8 @@ T11667.hs:18:28: error: arising from the "provided" constraints claimed by the signature of ‘Pat2’ ‘b’ is a rigid type variable bound by - the signature for pattern synonym ‘Pat2’ at T11667.hs:17:17-50 + the signature for pattern synonym ‘Pat2’ + at T11667.hs:17:1-50 • In the declaration for pattern synonym ‘Pat2’ • Relevant bindings include y :: b (bound at T11667.hs:18:21) diff --git a/testsuite/tests/rename/should_compile/T5331.stderr b/testsuite/tests/rename/should_compile/T5331.stderr index 9bc0b102b7..fb27e64af1 100644 --- a/testsuite/tests/rename/should_compile/T5331.stderr +++ b/testsuite/tests/rename/should_compile/T5331.stderr @@ -5,7 +5,7 @@ T5331.hs:8:17: warning: [-Wunused-foralls (in -Wextra)] T5331.hs:11:16: warning: [-Wunused-foralls (in -Wextra)] Unused quantified type variable ‘a’ - In the type ‘forall a. W’ + In the definition of data constructor ‘W1’ T5331.hs:13:13: warning: [-Wunused-foralls (in -Wextra)] Unused quantified type variable ‘a’ diff --git a/testsuite/tests/th/T13123.hs b/testsuite/tests/th/T13123.hs index d7e1006b9e..dbc071c184 100644 --- a/testsuite/tests/th/T13123.hs +++ b/testsuite/tests/th/T13123.hs @@ -8,6 +8,7 @@ module T13123 where import GHC.Exts (Constraint) +{- $([d| idProxy :: forall proxy (a :: k). proxy a -> proxy a idProxy x = x |]) @@ -31,6 +32,7 @@ $([d| class Foo b where $([d| data GADT where MkGADT :: forall proxy (a :: k). proxy a -> GADT |]) +-} $([d| data Dec13 :: (* -> Constraint) -> * where MkDec13 :: c a => a -> Dec13 c diff --git a/testsuite/tests/typecheck/should_compile/T2494.stderr b/testsuite/tests/typecheck/should_compile/T2494.stderr index 48b2221220..5cf4fde746 100644 --- a/testsuite/tests/typecheck/should_compile/T2494.stderr +++ b/testsuite/tests/typecheck/should_compile/T2494.stderr @@ -2,9 +2,11 @@ T2494.hs:15:14: error: • Couldn't match type ‘b’ with ‘a’ ‘b’ is a rigid type variable bound by - the RULE "foo/foo" at T2494.hs:14:16-62 + the RULE "foo/foo" + at T2494.hs:(12,1)-(15,33) ‘a’ is a rigid type variable bound by - the RULE "foo/foo" at T2494.hs:13:16-62 + the RULE "foo/foo" + at T2494.hs:(12,1)-(15,33) Expected type: Maybe (m a) -> Maybe (m a) Actual type: Maybe (m b) -> Maybe (m b) • In the first argument of ‘foo’, namely ‘g’ @@ -20,9 +22,11 @@ T2494.hs:15:14: error: T2494.hs:15:30: error: • Couldn't match type ‘b’ with ‘a’ ‘b’ is a rigid type variable bound by - the RULE "foo/foo" at T2494.hs:14:16-62 + the RULE "foo/foo" + at T2494.hs:(12,1)-(15,33) ‘a’ is a rigid type variable bound by - the RULE "foo/foo" at T2494.hs:13:16-62 + the RULE "foo/foo" + at T2494.hs:(12,1)-(15,33) Expected type: Maybe (m b) -> Maybe (m a) Actual type: Maybe (m b) -> Maybe (m b) • In the second argument of ‘(.)’, namely ‘g’ diff --git a/utils/haddock b/utils/haddock -Subproject aaf07338cbfec7df69532a4d1e8a0f21c9a1cfd +Subproject 24841386cff6fdccc11accf9daa815c2c7444d6 diff --git a/utils/hsc2hs b/utils/hsc2hs -Subproject 738f3666c878ee9e79c3d5e819ef8b3460288ed +Subproject 9483ad10064fbbb97ab525280623826b1ef6395 |