diff options
| author | Jan Stolarek <jan.stolarek@p.lodz.pl> | 2014-07-11 13:54:45 +0200 |
|---|---|---|
| committer | Jan Stolarek <jan.stolarek@p.lodz.pl> | 2015-09-03 05:55:15 +0200 |
| commit | 374457809de343f409fbeea0a885877947a133a2 (patch) | |
| tree | a354d0f4ddb6c32e6c85b853071d2107f6b8398c | |
| parent | bd16e0bc6af13f1347235782935f7dcd40b260e2 (diff) | |
| download | haskell-374457809de343f409fbeea0a885877947a133a2.tar.gz | |
Injective type families
For details see #6018, Phab:D202 and the wiki page:
https://ghc.haskell.org/trac/ghc/wiki/InjectiveTypeFamilies
This patch also wires-in Maybe data type and updates haddock submodule.
Test Plan: ./validate
Reviewers: simonpj, goldfire, austin, bgamari
Subscribers: mpickering, bgamari, alanz, thomie, goldfire, simonmar,
carter
Differential Revision: https://phabricator.haskell.org/D202
GHC Trac Issues: #6018
127 files changed, 3962 insertions, 842 deletions
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index ad584a325e..36d0794836 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -12,7 +12,7 @@ have a standard form, namely: - primitive operations -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, DataKinds #-} module MkId ( mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, @@ -911,7 +911,8 @@ wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr wrapTypeFamInstBody axiom ind args body = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args)) -wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr +wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr + -> CoreExpr wrapTypeUnbranchedFamInstBody axiom = wrapTypeFamInstBody axiom 0 @@ -926,7 +927,8 @@ unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr unwrapTypeFamInstScrut axiom ind args scrut = mkCast scrut (mkAxInstCo Representational axiom ind args) -unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr +unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr + -> CoreExpr unwrapTypeUnbranchedFamInstScrut axiom = unwrapTypeFamInstScrut axiom 0 diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs index 7adc89832a..f5ea6edf19 100644 --- a/compiler/basicTypes/VarSet.hs +++ b/compiler/basicTypes/VarSet.hs @@ -27,6 +27,7 @@ module VarSet ( import Var ( Var, TyVar, CoVar, Id ) import Unique import UniqSet +import UniqFM( disjointUFM ) {- ************************************************************************ @@ -98,7 +99,7 @@ lookupVarSet = lookupUniqSet mapVarSet = mapUniqSet sizeVarSet = sizeUniqSet filterVarSet = filterUniqSet -extendVarSet_C = addOneToUniqSet_C +extendVarSet_C = addOneToUniqSet_C delVarSetByKey = delOneFromUniqSet_Directly elemVarSetByKey = elemUniqSet_Directly partitionVarSet = partitionUniqSet @@ -107,7 +108,7 @@ mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs -- See comments with type signatures intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) -disjointVarSet s1 s2 = isEmptyVarSet (s1 `intersectVarSet` s2) +disjointVarSet s1 s2 = disjointUFM s1 s2 subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index 3c115f419c..69410cd6cd 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -43,6 +43,9 @@ module MkCore ( mkNilExpr, mkConsExpr, mkListExpr, mkFoldrExpr, mkBuildExpr, + -- * Constructing Maybe expressions + mkNothingExpr, mkJustExpr, + -- * Error Ids mkRuntimeErrorApp, mkImpossibleExpr, errorIds, rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, @@ -605,6 +608,24 @@ mkBuildExpr elt_ty mk_build_inside = do {- ************************************************************************ * * + Manipulating Maybe data type +* * +************************************************************************ +-} + + +-- | Makes a Nothing for the specified type +mkNothingExpr :: Type -> CoreExpr +mkNothingExpr ty = mkConApp nothingDataCon [Type ty] + +-- | Makes a Just from a value of the specified type +mkJustExpr :: Type -> CoreExpr -> CoreExpr +mkJustExpr ty val = mkConApp justDataCon [Type ty, val] + + +{- +************************************************************************ +* * Error expressions * * ************************************************************************ diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index c222b33ed9..867f900a78 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -310,34 +310,69 @@ repSynDecl tc bndrs ty ; repTySyn tc bndrs ty1 } repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, - fdLName = tc, - fdTyVars = tvs, - fdKindSig = opt_kind })) +repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, + fdLName = tc, + fdTyVars = tvs, + fdResultSig = L _ resultSig, + fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; let mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs } + resTyVar = case resultSig of + TyVarSig bndr -> mkHsQTvs [bndr] + _ -> mkHsQTvs [] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - case (opt_kind, info) of - (_ , ClosedTypeFamily Nothing) -> - notHandled "abstract closed type family" (ppr decl) - (Nothing, ClosedTypeFamily (Just eqns)) -> - do { eqns1 <- mapM repTyFamEqn eqns - ; eqns2 <- coreList tySynEqnQTyConName eqns1 - ; repClosedFamilyNoKind tc1 bndrs eqns2 } - (Just ki, ClosedTypeFamily (Just eqns)) -> - do { eqns1 <- mapM repTyFamEqn eqns - ; eqns2 <- coreList tySynEqnQTyConName eqns1 - ; ki1 <- repLKind ki - ; repClosedFamilyKind tc1 bndrs ki1 eqns2 } - (Nothing, _) -> - do { info' <- repFamilyInfo info - ; repFamilyNoKind info' tc1 bndrs } - (Just ki, _) -> - do { info' <- repFamilyInfo info - ; ki1 <- repLKind ki - ; repFamilyKind info' tc1 bndrs ki1 } + addTyClTyVarBinds resTyVar $ \_ -> + case info of + ClosedTypeFamily Nothing -> + notHandled "abstract closed type family" (ppr decl) + ClosedTypeFamily (Just eqns) -> + do { eqns1 <- mapM repTyFamEqn eqns + ; eqns2 <- coreList tySynEqnQTyConName eqns1 + ; result <- repFamilyResultSig resultSig + ; inj <- repInjectivityAnn injectivity + ; repClosedFamilyD tc1 bndrs result inj eqns2 } + OpenTypeFamily -> + do { result <- repFamilyResultSig resultSig + ; inj <- repInjectivityAnn injectivity + ; repOpenFamilyD tc1 bndrs result inj } + DataFamily -> + do { kind <- repFamilyResultSigToMaybeKind resultSig + ; repDataFamilyD tc1 bndrs kind } ; return (loc, dec) } +-- | Represent result signature of a type family +repFamilyResultSig :: FamilyResultSig Name -> DsM (Core TH.FamilyResultSig) +repFamilyResultSig NoSig = repNoSig +repFamilyResultSig (KindSig ki) = do { ki' <- repLKind ki + ; repKindSig ki' } +repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr + ; repTyVarSig bndr' } + +-- | Represent result signature using a Maybe Kind. Used with data families, +-- where the result signature can be either missing or a kind but never a named +-- result variable. +repFamilyResultSigToMaybeKind :: FamilyResultSig Name + -> DsM (Core (Maybe TH.Kind)) +repFamilyResultSigToMaybeKind NoSig = + do { coreNothing kindTyConName } +repFamilyResultSigToMaybeKind (KindSig ki) = + do { ki' <- repLKind ki + ; coreJust kindTyConName ki' } +repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind" + +-- | Represent injectivity annotation of a type family +repInjectivityAnn :: Maybe (LInjectivityAnn Name) + -> DsM (Core (Maybe TH.InjectivityAnn)) +repInjectivityAnn Nothing = + do { coreNothing injAnnTyConName } +repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = + do { lhs' <- lookupBinder (unLoc lhs) + ; rhs1 <- mapM (lookupBinder . unLoc) rhs + ; rhs2 <- coreList nameTyConName rhs1 + ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2] + ; coreJust injAnnTyConName injAnn } + repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ] repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) @@ -381,13 +416,6 @@ repLFunDep (L _ (xs, ys)) ys' <- repList nameTyConName (lookupBinder . unLoc) ys repFunDep xs' ys' --- represent family declaration flavours --- -repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour) -repFamilyInfo OpenTypeFamily = rep2 typeFamName [] -repFamilyInfo DataFamily = rep2 dataFamName [] -repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo" - -- Represent instance declarations -- repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) @@ -831,6 +859,14 @@ repTyVarBndrWithKind (L _ (UserTyVar _)) nm repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm = repLKind ki >>= repKindedTV nm +-- | Represent a type variable binder +repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr) +repTyVarBndr (L _ (UserTyVar nm)) = do { nm' <- lookupBinder nm + ; repPlainTV nm' } +repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm + ; ki' <- repLKind ki + ; repKindedTV nm' ki' } + -- represent a type context -- repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) @@ -1827,35 +1863,31 @@ repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases) repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ) repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] -repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] - -> DsM (Core TH.DecQ) -repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs) - = rep2 familyNoKindDName [flav, nm, tvs] - -repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] - -> Core TH.Kind - -> DsM (Core TH.DecQ) -repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki) - = rep2 familyKindDName [flav, nm, tvs, ki] - repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ) repTySynInst (MkC nm) (MkC eqn) = rep2 tySynInstDName [nm, eqn] -repClosedFamilyNoKind :: Core TH.Name - -> Core [TH.TyVarBndr] - -> Core [TH.TySynEqnQ] - -> DsM (Core TH.DecQ) -repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns) - = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns] - -repClosedFamilyKind :: Core TH.Name - -> Core [TH.TyVarBndr] - -> Core TH.Kind - -> Core [TH.TySynEqnQ] - -> DsM (Core TH.DecQ) -repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns) - = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns] +repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr] + -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ) +repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) + = rep2 dataFamilyDName [nm, tvs, kind] + +repOpenFamilyD :: Core TH.Name + -> Core [TH.TyVarBndr] + -> Core TH.FamilyResultSig + -> Core (Maybe TH.InjectivityAnn) + -> DsM (Core TH.DecQ) +repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) + = rep2 openTypeFamilyDName [nm, tvs, result, inj] + +repClosedFamilyD :: Core TH.Name + -> Core [TH.TyVarBndr] + -> Core TH.FamilyResultSig + -> Core (Maybe TH.InjectivityAnn) + -> Core [TH.TySynEqnQ] + -> DsM (Core TH.DecQ) +repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) + = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) repTySynEqn (MkC lhs) (MkC rhs) @@ -2007,6 +2039,18 @@ repKConstraint :: DsM (Core TH.Kind) repKConstraint = rep2 constraintKName [] ---------------------------------------------------------- +-- Type family result signature + +repNoSig :: DsM (Core TH.FamilyResultSig) +repNoSig = rep2 noSigName [] + +repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig) +repKindSig (MkC ki) = rep2 kindSigName [ki] + +repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig) +repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] + +---------------------------------------------------------- -- Literals repLiteral :: HsLit -> DsM (Core TH.Lit) @@ -2082,7 +2126,7 @@ repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a])) repSequenceQ ty_a (MkC list) = rep2 sequenceQName [Type ty_a, list] ------------- Lists and Tuples ------------------- +------------ Lists ------------------- -- turn a list of patterns into a single pattern matching a list repList :: Name -> (a -> DsM (Core b)) @@ -2109,6 +2153,30 @@ nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) coreStringLit :: String -> DsM (Core String) coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } +------------------- Maybe ------------------ + +-- | Construct Core expression for Nothing of a given type name +coreNothing :: Name -- ^ Name of the TyCon of the element type + -> DsM (Core (Maybe a)) +coreNothing tc_name = + do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) } + +-- | Construct Core expression for Nothing of a given type +coreNothing' :: Type -- ^ The element type + -> Core (Maybe a) +coreNothing' elt_ty = MkC (mkNothingExpr elt_ty) + +-- | Store given Core expression in a Just of a given type name +coreJust :: Name -- ^ Name of the TyCon of the element type + -> Core a -> DsM (Core (Maybe a)) +coreJust tc_name es + = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) } + +-- | Store given Core expression in a Just of a given type +coreJust' :: Type -- ^ The element type + -> Core a -> Core (Maybe a) +coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es)) + ------------ Literals & Variables ------------------- coreIntLit :: Int -> DsM (Core Int) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index db4ae97946..9466ab0577 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -253,14 +253,11 @@ cvtDec (ForeignD ford) = do { ford' <- cvtForD ford ; returnJustL $ ForD ford' } -cvtDec (FamilyD flav tc tvs kind) +cvtDec (DataFamilyD tc tvs kind) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs - ; kind' <- cvtMaybeKind kind + ; result <- cvtMaybeKindToFamilyResultSig kind ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl (cvtFamFlavour flav) tc' tvs' kind' } - where - cvtFamFlavour TypeFam = OpenTypeFamily - cvtFamFlavour DataFam = DataFamily + FamilyDecl DataFamily tc' tvs' result Nothing } cvtDec (DataInstD ctxt tc tys constrs derivs) = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys @@ -296,12 +293,21 @@ cvtDec (TySynInstD tc eqn) { tfid_inst = TyFamInstDecl { tfid_eqn = eqn' , tfid_fvs = placeHolderNames } } } -cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns) +cvtDec (OpenTypeFamilyD tc tvs result injectivity) + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs + ; result' <- cvtFamilyResultSig result + ; injectivity' <- traverse cvtInjectivityAnnotation injectivity + ; returnJustL $ TyClD $ FamDecl $ + FamilyDecl OpenTypeFamily tc' tvs' result' injectivity' } + +cvtDec (ClosedTypeFamilyD tc tyvars result injectivity eqns) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars - ; mkind' <- cvtMaybeKind mkind + ; result' <- cvtFamilyResultSig result ; eqns' <- mapM (cvtTySynEqn tc') eqns + ; injectivity' <- traverse cvtInjectivityAnnotation injectivity ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tvs' mkind' } + FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tvs' result' + injectivity' } cvtDec (TH.RoleAnnotD tc roles) = do { tc' <- tconNameL tc @@ -1132,10 +1138,31 @@ cvtOpAppT x op y cvtKind :: TH.Kind -> CvtM (LHsKind RdrName) cvtKind = cvtTypeKind "kind" -cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName)) -cvtMaybeKind Nothing = return Nothing -cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki - ; return (Just ki') } +-- | Convert Maybe Kind to a type family result signature. Used with data +-- families where naming of the result is not possible (thus only kind or no +-- signature is possible). +cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind + -> CvtM (LFamilyResultSig RdrName) +cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig +cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki + ; returnL (Hs.KindSig ki') } + +-- | Convert type family result signature. Used with both open and closed type +-- families. +cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig RdrName) +cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig +cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki + ; returnL (Hs.KindSig ki') } +cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr + ; returnL (Hs.TyVarSig tv) } + +-- | Convert injectivity annotation of a type family. +cvtInjectivityAnnotation :: TH.InjectivityAnn + -> CvtM (Hs.LInjectivityAnn RdrName) +cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) + = do { annLHS' <- tNameL annLHS + ; annRHS' <- mapM tNameL annRHS + ; returnL (Hs.InjectivityAnn annLHS' annRHS') } ----------------------------------------------------------- cvtFixity :: TH.Fixity -> Hs.Fixity @@ -1165,7 +1192,7 @@ cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = -------------------------------------------------------------------- -- variable names -vNameL, cNameL, vcNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) +vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName -- Variable names @@ -1181,6 +1208,7 @@ vcNameL n = wrapL (vcName n) vcName n = if isVarName n then vName n else cName n -- Type variable names +tNameL n = wrapL (tName n) tName n = cvtName OccName.tvName n -- Type Constructor names diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 7b263ab4fc..aefbfa658f 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -72,6 +72,9 @@ module HsDecls ( AnnProvenance(..), annProvenanceName_maybe, -- ** Role annotations RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName, + -- ** Injective type families + FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, + resultVariableName, -- * Grouping HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups @@ -108,7 +111,6 @@ import Data.Data hiding (TyCon,Fixity) import Data.Foldable ( Foldable ) import Data.Traversable ( Traversable ) #endif -import Data.Maybe {- ************************************************************************ @@ -465,9 +467,10 @@ data TyClDecl name -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnData', -- 'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnWhere', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnClose' + -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP', + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP', + -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow', + -- 'ApiAnnotation.AnnVbar' -- For details on above see note [Api annotations] in ApiAnnotation FamDecl { tcdFam :: FamilyDecl name } @@ -545,28 +548,9 @@ tyClGroupConcat = concatMap group_tyclds mkTyClGroup :: [LTyClDecl name] -> TyClGroup name mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] } -type LFamilyDecl name = Located (FamilyDecl name) -data FamilyDecl name = FamilyDecl - { fdInfo :: FamilyInfo name -- type or data, closed or open - , fdLName :: Located name -- type constructor - , fdTyVars :: LHsTyVarBndrs name -- type variables - , fdKindSig :: Maybe (LHsKind name) } -- result kind - deriving( Typeable ) -deriving instance (DataId id) => Data (FamilyDecl id) - -data FamilyInfo name - = DataFamily - | OpenTypeFamily - -- | 'Nothing' if we're in an hs-boot file and the user - -- said "type family Foo x where .." - | ClosedTypeFamily (Maybe [LTyFamInstEqn name]) - deriving( Typeable ) -deriving instance (DataId name) => Data (FamilyInfo name) -{- ------------------------------- -Simple classifiers --} +-- Simple classifiers for TyClDecl +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- | @True@ <=> argument is a @data@\/@newtype@ -- declaration. @@ -662,38 +646,8 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) hsDeclHasCusk (DataDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars --- | Does this family declaration have a complete, user-supplied kind signature? -famDeclHasCusk :: FamilyDecl name -> Bool -famDeclHasCusk (FamilyDecl { fdInfo = ClosedTypeFamily _ - , fdTyVars = tyvars - , fdKindSig = m_sig }) - = hsTvbAllKinded tyvars && isJust m_sig -famDeclHasCusk _ = True -- all open families have CUSKs! - -{- -Note [Complete user-supplied kind signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We kind-check declarations differently if they have a complete, user-supplied -kind signature (CUSK). This is because we can safely generalise a CUSKed -declaration before checking all of the others, supporting polymorphic recursion. -See https://ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy -and #9200 for lots of discussion of how we got here. - -A declaration has a CUSK if we can know its complete kind without doing any inference, -at all. Here are the rules: - - - A class or datatype is said to have a CUSK if and only if all of its type -variables are annotated. Its result kind is, by construction, Constraint or * -respectively. - - - A type synonym has a CUSK if and only if all of its type variables and its -RHS are annotated with kinds. - - - A closed type family is said to have a CUSK if and only if all of its type -variables and its return type are annotated. - - - An open type family always has a CUSK -- unannotated type variables (and return type) default to *. --} +-- Pretty-printing TyClDecl +-- ~~~~~~~~~~~~~~~~~~~~~~~~ instance OutputableBndr name => Outputable (TyClDecl name) where @@ -729,15 +683,223 @@ instance OutputableBndr name => Outputable (TyClGroup name) where = ppr tyclds $$ ppr roles +pp_vanilla_decl_head :: OutputableBndr name + => Located name + -> LHsTyVarBndrs name + -> HsContext name + -> SDoc +pp_vanilla_decl_head thing tyvars context + = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars] + +pprTyClDeclFlavour :: TyClDecl a -> SDoc +pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") +pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") +pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) + = pprFlavour info +pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) + = ppr nd + + +{- ********************************************************************* +* * + Data and type family declarations +* * +********************************************************************* -} + +-- Note [FamilyResultSig] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- +-- This data type represents the return signature of a type family. Possible +-- values are: +-- +-- * NoSig - the user supplied no return signature: +-- type family Id a where ... +-- +-- * KindSig - the user supplied the return kind: +-- type family Id a :: * where ... +-- +-- * TyVarSig - user named the result with a type variable and possibly +-- provided a kind signature for that variable: +-- type family Id a = r where ... +-- type family Id a = (r :: *) where ... +-- +-- Naming result of a type family is required if we want to provide +-- injectivity annotation for a type family: +-- type family Id a = r | r -> a where ... +-- +-- See also: Note [Injectivity annotation] + +-- Note [Injectivity annotation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- A user can declare a type family to be injective: +-- +-- type family Id a = r | r -> a where ... +-- +-- * The part after the "|" is called "injectivity annotation". +-- * "r -> a" part is called "injectivity condition"; at the moment terms +-- "injectivity annotation" and "injectivity condition" are synonymous +-- because we only allow a single injectivity condition. +-- * "r" is the "LHS of injectivity condition". LHS can only contain the +-- variable naming the result of a type family. + +-- * "a" is the "RHS of injectivity condition". RHS contains space-separated +-- type and kind variables representing the arguments of a type +-- family. Variables can be omitted if a type family is not injective in +-- these arguments. Example: +-- type family Foo a b c = d | d -> a c where ... +-- +-- Note that: +-- a) naming of type family result is required to provide injectivity +-- annotation +-- b) for associated types if the result was named then injectivity annotation +-- is mandatory. Otherwise result type variable is indistinguishable from +-- associated type default. +-- +-- It is possible that in the future this syntax will be extended to support +-- more complicated injectivity annotations. For example we could declare that +-- if we know the result of Plus and one of its arguments we can determine the +-- other argument: +-- +-- type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ... +-- +-- Here injectivity annotation would consist of two comma-separated injectivity +-- conditions. +-- +-- See also Note [Injective type families] in TyCon + +type LFamilyResultSig name = Located (FamilyResultSig name) +data FamilyResultSig name = -- see Note [FamilyResultSig] + NoSig + -- ^ - 'ApiAnnotation.AnnKeywordId' : + + -- For details on above see note [Api annotations] in ApiAnnotation + + | KindSig (LHsKind name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnCloseP' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | TyVarSig (LHsTyVarBndr name) + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' + + -- For details on above see note [Api annotations] in ApiAnnotation + + deriving ( Typeable ) +deriving instance (DataId name) => Data (FamilyResultSig name) + +type LFamilyDecl name = Located (FamilyDecl name) +data FamilyDecl name = FamilyDecl + { fdInfo :: FamilyInfo name -- type/data, closed/open + , fdLName :: Located name -- type constructor + , fdTyVars :: LHsTyVarBndrs name -- type variables + , fdResultSig :: LFamilyResultSig name -- result signature + , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann + } + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily', + -- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP', + -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP', + -- 'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow', + -- 'ApiAnnotation.AnnVbar' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving ( Typeable ) + +deriving instance (DataId id) => Data (FamilyDecl id) + +type LInjectivityAnn name = Located (InjectivityAnn name) + +-- | If the user supplied an injectivity annotation it is represented using +-- InjectivityAnn. At the moment this is a single injectivity condition - see +-- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity +-- condition. `[Located name]` stores the RHS of injectivity condition. Example: +-- +-- type family Foo a b c = r | r -> a c where ... +-- +-- This will be represented as "InjectivityAnn `r` [`a`, `c`]" +data InjectivityAnn name + = InjectivityAnn (Located name) [Located name] + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar' + + -- For details on above see note [Api annotations] in ApiAnnotation + deriving ( Data, Typeable ) + +data FamilyInfo name + = DataFamily + | OpenTypeFamily + -- | 'Nothing' if we're in an hs-boot file and the user + -- said "type family Foo x where .." + | ClosedTypeFamily (Maybe [LTyFamInstEqn name]) + deriving( Typeable ) +deriving instance (DataId name) => Data (FamilyInfo name) + +-- | Does this family declaration have a complete, user-supplied kind signature? +famDeclHasCusk :: FamilyDecl name -> Bool +famDeclHasCusk (FamilyDecl { fdInfo = ClosedTypeFamily _ + , fdTyVars = tyvars + , fdResultSig = L _ resultSig }) + = hsTvbAllKinded tyvars && hasReturnKindSignature resultSig +famDeclHasCusk _ = True -- all open families have CUSKs! + +-- | Does this family declaration have user-supplied return kind signature? +hasReturnKindSignature :: FamilyResultSig a -> Bool +hasReturnKindSignature NoSig = False +hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False +hasReturnKindSignature _ = True + +-- | Maybe return name of the result type variable +resultVariableName :: FamilyResultSig a -> Maybe a +resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig +resultVariableName _ = Nothing + +{- +Note [Complete user-supplied kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We kind-check declarations differently if they have a complete, user-supplied +kind signature (CUSK). This is because we can safely generalise a CUSKed +declaration before checking all of the others, supporting polymorphic recursion. +See ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy +and #9200 for lots of discussion of how we got here. + +A declaration has a CUSK if we can know its complete kind without doing any +inference, at all. Here are the rules: + + - A class or datatype is said to have a CUSK if and only if all of its type +variables are annotated. Its result kind is, by construction, Constraint or * +respectively. + + - A type synonym has a CUSK if and only if all of its type variables and its +RHS are annotated with kinds. + + - A closed type family is said to have a CUSK if and only if all of its type +variables and its return type are annotated. + + - An open type family always has a CUSK -- unannotated type variables (and +return type) default to *. +-} + instance (OutputableBndr name) => Outputable (FamilyDecl name) where - ppr (FamilyDecl { fdInfo = info, fdLName = ltycon, - fdTyVars = tyvars, fdKindSig = mb_kind}) - = vcat [ pprFlavour info <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind <+> pp_where + ppr (FamilyDecl { fdInfo = info, fdLName = ltycon + , fdTyVars = tyvars, fdResultSig = L _ result + , fdInjectivityAnn = mb_inj }) + = vcat [ pprFlavour info <+> pp_vanilla_decl_head ltycon tyvars [] <+> + pp_kind <+> pp_inj <+> pp_where , nest 2 $ pp_eqns ] where - pp_kind = case mb_kind of - Nothing -> empty - Just kind -> dcolon <+> ppr kind + pp_kind = case result of + NoSig -> empty + KindSig kind -> dcolon <+> ppr kind + TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr + pp_inj = case mb_inj of + Just (L _ (InjectivityAnn lhs rhs)) -> + hsep [ text "|", ppr lhs, text "->", hsep (map ppr rhs) ] + Nothing -> empty (pp_where, pp_eqns) = case info of ClosedTypeFamily mb_eqns -> ( ptext (sLit "where") @@ -754,38 +916,13 @@ pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type family") instance Outputable (FamilyInfo name) where ppr = pprFlavour -pp_vanilla_decl_head :: OutputableBndr name - => Located name - -> LHsTyVarBndrs name - -> HsContext name - -> SDoc -pp_vanilla_decl_head thing tyvars context - = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars] -pp_fam_inst_lhs :: OutputableBndr name - => Located name - -> HsTyPats name - -> HsContext name - -> SDoc -pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns - = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing) - , hsep (map (pprParendHsType.unLoc) typats)] -pprTyClDeclFlavour :: TyClDecl a -> SDoc -pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") -pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") -pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) - = pprFlavour info -pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) - = ppr nd - -{- -************************************************************************ +{- ********************************************************************* * * -\subsection[ConDecl]{A data-constructor declaration} + Data types and data constructors * * -************************************************************************ --} +********************************************************************* -} data HsDataDefn name -- The payload of a data type defn -- Used *both* for vanilla data declarations, @@ -1030,12 +1167,13 @@ It is parameterised over its tfe_pats field: (or something similar for a closed family) It is represented by a TyFamInstEqn, with *type* in the tfe_pats field. - * On the other hand, the *default instance* of an associated type looksl like + * On the other hand, the *default instance* of an associated type looks like this in source Haskell class C a where type T a b type T a b = a -> b -- The default instance - It is represented by a TyFamDefltEqn, with *type variables8 in the tfe_pats field. + It is represented by a TyFamDefltEqn, with *type variables* in the tfe_pats + field. -} ----------------- Type synonym family instances ------------- @@ -1204,6 +1342,15 @@ pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) }) = ppr nd +pp_fam_inst_lhs :: OutputableBndr name + => Located name + -> HsTyPats name + -> HsContext name + -> SDoc +pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns + = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing) + , hsep (map (pprParendHsType.unLoc) typats)] + instance (OutputableBndr name) => Outputable (ClsInstDecl name) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats @@ -1233,8 +1380,6 @@ ppOverlapPragma mb = Just (L _ (Incoherent _)) -> ptext (sLit "{-# INCOHERENT #-}") - - instance (OutputableBndr name) => Outputable (InstDecl name) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 2a09ebf0c3..0393ccac2d 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -201,7 +201,7 @@ mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = PlaceHolder -------------------------------------------------- -- | These names are used early on to store the names of implicit -- parameters. They completely disappear after type-checking. -newtype HsIPName = HsIPName FastString-- ?x +newtype HsIPName = HsIPName FastString deriving( Eq, Data, Typeable ) hsIPNameFS :: HsIPName -> FastString diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 00a2cdf5d6..91d37eaab3 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -71,7 +71,7 @@ Historically these have been filled in with place holder values of the form panic "error message" -This has meant the AST is difficult to traverse using standed generic +This has meant the AST is difficult to traverse using standard generic programming techniques. The problem is addressed by introducing pass-specific data types, implemented as a pair of open type families, one for PostTc and one for PostRn. These are then explicitly populated diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 640ad9b799..8efd342b22 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -46,19 +46,23 @@ import Outputable buildSynonymTyCon :: Name -> [TyVar] -> [Role] -> Type -> Kind -- ^ Kind of the RHS - -> TcRnIf m n TyCon + -> TyCon buildSynonymTyCon tc_name tvs roles rhs rhs_kind - = return (mkSynonymTyCon tc_name kind tvs roles rhs) + = mkSynonymTyCon tc_name kind tvs roles rhs where kind = mkPiKinds tvs rhs_kind -buildFamilyTyCon :: Name -> [TyVar] - -> FamTyConFlav - -> Kind -- ^ Kind of the RHS - -> TyConParent - -> TcRnIf m n TyCon -buildFamilyTyCon tc_name tvs rhs rhs_kind parent - = return (mkFamilyTyCon tc_name kind tvs rhs parent) +buildFamilyTyCon :: Name -- ^ Type family name + -> [TyVar] -- ^ Type variables + -> Maybe Name -- ^ Result variable name + -> FamTyConFlav -- ^ Open, closed or in a boot file? + -> Kind -- ^ Kind of the RHS + -> TyConParent -- ^ Parent, if exists + -> Injectivity -- ^ Injectivity annotation + -- See [Injectivity annotation] in HsDecls + -> TyCon +buildFamilyTyCon tc_name tvs res_tv rhs rhs_kind parent injectivity + = mkFamilyTyCon tc_name kind tvs res_tv rhs parent injectivity where kind = mkPiKinds tvs rhs_kind diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index fc5053b58c..6371c43b0e 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -55,9 +55,9 @@ import Fingerprint import Binary import BooleanFormula ( BooleanFormula ) import HsBinds -import TyCon (Role (..)) +import TyCon ( Role (..), Injectivity(..) ) import StaticFlags (opt_PprStyle_Debug) -import Util( filterOut ) +import Util( filterOut, filterByList ) import InstEnv import DataCon (SrcStrictness(..), SrcUnpackedness(..)) @@ -113,9 +113,13 @@ data IfaceDecl | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables + ifResVar :: Maybe IfLclName, -- Result variable name, used + -- only for pretty-printing + -- with --show-iface ifFamKind :: IfaceKind, -- Kind of the *rhs* (not of -- the tycon) - ifFamFlav :: IfaceFamTyConFlav } + ifFamFlav :: IfaceFamTyConFlav, + ifFamInj :: Injectivity } -- injectivity information | IfaceClass { ifCtxt :: IfaceContext, -- Superclasses ifName :: IfaceTopBndr, -- Name of the class TyCon @@ -689,11 +693,22 @@ pprIfaceDecl ss (IfaceSynonym { ifName = tc (tvs, theta, tau) = splitIfaceSigmaTy mono_ty pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars - , ifFamFlav = rhs, ifFamKind = kind }) - = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars <+> dcolon) - 2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs)) + , ifFamFlav = rhs, ifFamKind = kind + , ifResVar = res_var, ifFamInj = inj }) + = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars) + 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) , ppShowRhs ss (nest 2 (pp_branches rhs)) ] where + pp_inj Nothing _ = dcolon <+> ppr kind + pp_inj (Just res) inj + | Injective injectivity <- inj = hsep [ equals, ppr res, dcolon, ppr kind + , pp_inj_cond res injectivity] + | otherwise = hsep [ equals, ppr res, dcolon, ppr kind ] + + pp_inj_cond res inj = case filterByList inj tyvars of + [] -> empty + tvs -> hsep [text "|", ppr res, text "->", interppSP (map fst tvs)] + pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (ptext (sLit "open")) pp_rhs IfaceAbstractClosedSynFamilyTyCon @@ -1348,12 +1363,14 @@ instance Binary IfaceDecl where put_ bh a4 put_ bh a5 - put_ bh (IfaceFamily a1 a2 a3 a4) = do + put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do putByte bh 4 put_ bh (occNameFS a1) put_ bh a2 put_ bh a3 put_ bh a4 + put_ bh a5 + put_ bh a6 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do putByte bh 5 @@ -1420,8 +1437,10 @@ instance Binary IfaceDecl where a2 <- get bh a3 <- get bh a4 <- get bh + a5 <- get bh + a6 <- get bh occ <- return $! mkTcOccFS a1 - return (IfaceFamily occ a2 a3 a4) + return (IfaceFamily occ a2 a3 a4 a5 a6) 5 -> do a1 <- get bh a2 <- get bh a3 <- get bh diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index f594181af4..e8b37cea5e 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -1623,15 +1623,17 @@ tyConToIfaceDecl env tycon ifTyVars = if_tc_tyvars, ifRoles = tyConRoles tycon, ifSynRhs = if_syn_type syn_rhs, - ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) + ifSynKind = tidyToIfaceType tc_env1 (tyConResKind tycon) }) | Just fam_flav <- famTyConFlav_maybe tycon = ( tc_env1 , IfaceFamily { ifName = getOccName tycon, ifTyVars = if_tc_tyvars, + ifResVar = if_res_var, ifFamFlav = to_if_fam_flav fam_flav, - ifFamKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) + ifFamKind = tidyToIfaceType tc_env1 (tyConResKind tycon), + ifFamInj = familyTyConInjectivityInfo tycon }) | isAlgTyCon tycon @@ -1662,8 +1664,9 @@ tyConToIfaceDecl env tycon ifParent = IfNoParent }) where (tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon) - if_tc_tyvars = toIfaceTvBndrs tc_tyvars + if_tc_tyvars = toIfaceTvBndrs tc_tyvars if_syn_type ty = tidyToIfaceType tc_env1 ty + if_res_var = getFS `fmap` tyConFamilyResVar_maybe tycon funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 2cd256b030..b601dc656a 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -6,7 +6,7 @@ Type checking of type signatures in interface files -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, DataKinds #-} module TcIface ( tcLookupImported_maybe, @@ -351,20 +351,23 @@ tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs, ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tcIfaceType rhs_ty - ; tycon <- buildSynonymTyCon tc_name tyvars roles rhs rhs_kind + ; let tycon = buildSynonymTyCon tc_name tyvars roles rhs rhs_kind ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type synonym") <+> ppr n tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, ifFamFlav = fam_flav, - ifFamKind = kind }) + ifFamKind = kind, + ifResVar = res, ifFamInj = inj }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tc_fam_flav fam_flav - ; tycon <- buildFamilyTyCon tc_name tyvars rhs rhs_kind parent + ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res + ; let tycon = buildFamilyTyCon tc_name tyvars res_name rhs rhs_kind + parent inj ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type synonym") <+> ppr n diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 4b72098210..f6c1cecf92 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -184,7 +184,7 @@ module GHC ( isPrimTyCon, isFunTyCon, isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, tyConClass_maybe, - synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind, + synTyConRhs_maybe, synTyConDefn_maybe, tyConResKind, -- ** Type variables TyVar, @@ -304,7 +304,7 @@ import RdrName import qualified HsSyn -- hack as we want to reexport the whole module import HsSyn import Type hiding( typeKind ) -import Kind ( synTyConResKind ) +import Kind ( tyConResKind ) import TcType hiding( typeKind ) import Id import TysPrim ( alphaTyVars ) diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs index 5ae1d0447b..7376e305ea 100644 --- a/compiler/parser/ApiAnnotation.hs +++ b/compiler/parser/ApiAnnotation.hs @@ -22,7 +22,7 @@ Note [Api annotations] ~~~~~~~~~~~~~~~~~~~~~~ In order to do source to source conversions using the GHC API, the locations of all elements of the original source needs to be tracked. -The includes keywords such as 'let' / 'in' / 'do' etc as well as +This includes keywords such as 'let' / 'in' / 'do' etc as well as punctuation such as commas and braces, and also comments. These are captured in a structure separate from the parse tree, and diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 1b4df16d28..7e7f5792d9 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -836,12 +836,14 @@ ty_decl :: { LTyClDecl RdrName } [mj AnnType $1,mj AnnEqual $3] } -- type family declarations - | 'type' 'family' type opt_kind_sig where_type_family + | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info + where_type_family -- Note the use of type for the head; this allows -- infix type constructors to be declared - {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $5) $3 - (snd $ unLoc $4)) - (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)++(fst $ unLoc $5)) } + {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3 + (snd $ unLoc $4) (snd $ unLoc $5)) + (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4) + ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) } -- ordinary data type or newtype declaration | data_or_newtype capi_ctype tycl_hdr constrs deriving @@ -863,8 +865,9 @@ ty_decl :: { LTyClDecl RdrName } ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } -- data/newtype family - | 'data' 'family' type opt_kind_sig - {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (snd $ unLoc $4)) + | 'data' 'family' type opt_datafam_kind_sig + {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 + (snd $ unLoc $4) Nothing) (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) } inst_decl :: { LInstDecl RdrName } @@ -911,6 +914,22 @@ overlap_pragma :: { Maybe (Located OverlapMode) } | {- empty -} { Nothing } +-- Injective type families + +opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn RdrName)) } + : {- empty -} { noLoc ([], Nothing) } + | '|' injectivity_cond { sLL $1 $> ( mj AnnVbar $1 : fst (unLoc $2) + , Just (snd (unLoc $2))) } + +injectivity_cond :: { Located ([AddAnn], LInjectivityAnn RdrName) } + : tyvarid '->' inj_varids + { sLL $1 $> ( [mj AnnRarrow $2] + , (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3))))) } + +inj_varids :: { Located [Located RdrName] } + : inj_varids tyvarid { sLL $1 $> ($2 : unLoc $1) } + | tyvarid { sLL $1 $> [$1] } + -- Closed type families where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) } @@ -958,20 +977,24 @@ ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn RdrName) } -- at_decl_cls :: { LHsDecl RdrName } : -- data family declarations, with optional 'family' keyword - 'data' opt_family type opt_kind_sig + 'data' opt_family type opt_datafam_kind_sig {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3 - (snd $ unLoc $4))) + (snd $ unLoc $4) Nothing)) (mj AnnData $1:$2++(fst $ unLoc $4)) } -- type family declarations, with optional 'family' keyword -- (can't use opt_instance because you get shift/reduce errors - | 'type' type opt_kind_sig - {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $2 $3) - OpenTypeFamily $2 (snd $ unLoc $3))) + | 'type' type opt_at_kind_inj_sig + {% amms (liftM mkTyClD + (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2 + (fst . snd $ unLoc $3) + (snd . snd $ unLoc $3))) (mj AnnType $1:(fst $ unLoc $3)) } - | 'type' 'family' type opt_kind_sig - {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) - OpenTypeFamily $3 (snd $ unLoc $4))) + | 'type' 'family' type opt_at_kind_inj_sig + {% amms (liftM mkTyClD + (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3 + (fst . snd $ unLoc $4) + (snd . snd $ unLoc $4))) (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) } -- default type instances, with optional 'instance' keyword @@ -1014,13 +1037,33 @@ at_decl_inst :: { LInstDecl RdrName } $3 (snd $ unLoc $4) (snd $ unLoc $5) (unLoc $6)) ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } -data_or_newtype :: { Located (AddAnn,NewOrData) } +data_or_newtype :: { Located (AddAnn, NewOrData) } : 'data' { sL1 $1 (mj AnnData $1,DataType) } | 'newtype' { sL1 $1 (mj AnnNewtype $1,NewType) } -opt_kind_sig :: { Located ([AddAnn],Maybe (LHsKind RdrName)) } - : { noLoc ([],Nothing) } - | '::' kind { sLL $1 $> ([mj AnnDcolon $1],Just ($2)) } +-- Family result/return kind signatures + +opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind RdrName)) } + : { noLoc ([] , Nothing) } + | '::' kind { sLL $1 $> ([mj AnnDcolon $1], Just $2) } + +opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) } + : { noLoc ([] , noLoc NoSig )} + | '::' kind { sLL $1 $> ([mj AnnDcolon $1], sLL $1 $> (KindSig $2))} + +opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig RdrName) } + : { noLoc ([] , noLoc NoSig )} + | '::' kind { sLL $1 $> ([mj AnnDcolon $1], sLL $1 $> (KindSig $2))} + | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig $2))} + +opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig RdrName + , Maybe (LInjectivityAnn RdrName)))} + : { noLoc ([], (noLoc NoSig, Nothing)) } + | '::' kind { sLL $1 $> ( [mj AnnDcolon $1] + , (sLL $2 $> (KindSig $2), Nothing)) } + | '=' tv_bndr '|' injectivity_cond + { sLL $1 $> ( mj AnnEqual $1 : mj AnnVbar $3 : fst (unLoc $4) + , (sLL $1 $2 (TyVarSig $2), Just (snd (unLoc $4))))} -- tycl_hdr parses the header of a class or data type decl, -- which takes the form diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 18890b594f..edc8a63bad 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -213,13 +213,13 @@ mkTyFamInstEqn lhs rhs ann) } mkDataFamInst :: SrcSpan - -> NewOrData - -> Maybe (Located CType) - -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (LHsKind RdrName) - -> [LConDecl RdrName] - -> Maybe (Located [LHsType RdrName]) - -> P (LInstDecl RdrName) + -> NewOrData + -> Maybe (Located CType) + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) + -> Maybe (LHsKind RdrName) + -> [LConDecl RdrName] + -> Maybe (Located [LHsType RdrName]) + -> P (LInstDecl RdrName) mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan @@ -237,15 +237,18 @@ mkTyFamInst loc eqn mkFamDecl :: SrcSpan -> FamilyInfo RdrName - -> LHsType RdrName -- LHS - -> Maybe (LHsKind RdrName) -- Optional kind signature + -> LHsType RdrName -- LHS + -> Located (FamilyResultSig RdrName) -- Optional result signature + -> Maybe (LInjectivityAnn RdrName) -- Injectivity annotation -> P (LTyClDecl RdrName) -mkFamDecl loc info lhs ksig - = do { (tc, tparams,ann) <- checkTyClHdr False lhs +mkFamDecl loc info lhs ksig injAnn + = do { (tc, tparams, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams - ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc - , fdTyVars = tyvars, fdKindSig = ksig }))) } + ; return (L loc (FamDecl (FamilyDecl{ fdInfo = info, fdLName = tc + , fdTyVars = tyvars + , fdResultSig = ksig + , fdInjectivityAnn = injAnn }))) } where equals_or_where = case info of DataFamily -> empty diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index e56307fa94..1684a2f3e0 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -1313,17 +1313,16 @@ ghciIoClassKey = mkPreludeClassUnique 44 ************************************************************************ -} -addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, - charPrimTyConKey, charTyConKey, doublePrimTyConKey, doubleTyConKey, - floatPrimTyConKey, floatTyConKey, funTyConKey, intPrimTyConKey, - intTyConKey, int8TyConKey, int16TyConKey, int32PrimTyConKey, - int32TyConKey, int64PrimTyConKey, int64TyConKey, - integerTyConKey, - listTyConKey, foreignObjPrimTyConKey, weakPrimTyConKey, - mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, mutableByteArrayPrimTyConKey, - orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, - realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, - anyTyConKey, eqTyConKey, smallArrayPrimTyConKey, +addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, + byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, + doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, + intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, + int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, + integerTyConKey, listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, + weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, + mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, + ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, + stablePtrTyConKey, anyTyConKey, eqTyConKey, smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey :: Unique addrPrimTyConKey = mkPreludeTyConUnique 1 arrayPrimTyConKey = mkPreludeTyConUnique 3 @@ -1348,6 +1347,7 @@ integerTyConKey = mkPreludeTyConUnique 22 listTyConKey = mkPreludeTyConUnique 24 foreignObjPrimTyConKey = mkPreludeTyConUnique 25 +maybeTyConKey = mkPreludeTyConUnique 26 weakPrimTyConKey = mkPreludeTyConUnique 27 mutableArrayPrimTyConKey = mkPreludeTyConUnique 28 mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 29 @@ -1560,7 +1560,7 @@ charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, word8DataConKey, ioDataConKey, integerDataConKey, eqBoxDataConKey, - coercibleDataConKey :: Unique + coercibleDataConKey, nothingDataConKey, justDataConKey :: Unique charDataConKey = mkPreludeDataConUnique 1 consDataConKey = mkPreludeDataConUnique 2 doubleDataConKey = mkPreludeDataConUnique 3 @@ -1568,6 +1568,8 @@ falseDataConKey = mkPreludeDataConUnique 4 floatDataConKey = mkPreludeDataConUnique 5 intDataConKey = mkPreludeDataConUnique 6 integerSDataConKey = mkPreludeDataConUnique 7 +nothingDataConKey = mkPreludeDataConUnique 8 +justDataConKey = mkPreludeDataConUnique 9 nilDataConKey = mkPreludeDataConUnique 11 ratioDataConKey = mkPreludeDataConUnique 12 word8DataConKey = mkPreludeDataConUnique 13 diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index cd65385bb4..9367d4b85a 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -17,7 +17,7 @@ import FastString -- -- 1) Allocate a key -- 2) Make a "Name" --- 3) Add the name to knownKeyNames +-- 3) Add the name to templateHaskellNames templateHaskellNames :: [Name] -- The names that are implicitly mentioned by ``bracket'' @@ -65,8 +65,8 @@ templateHaskellNames = [ classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, defaultSigDName, - familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, - tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, + dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, + dataInstDName, newtypeInstDName, tySynInstDName, infixLDName, infixRDName, infixNDName, roleAnnotDName, -- Cxt @@ -93,6 +93,10 @@ templateHaskellNames = [ -- Kind varKName, conKName, tupleKName, arrowKName, listKName, appKName, starKName, constraintKName, + -- FamilyResultSig + noSigName, kindSigName, tyVarSigName, + -- InjectivityAnn + injectivityAnnName, -- Callconv cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName, -- Safety @@ -126,7 +130,7 @@ templateHaskellNames = [ typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName, - roleTyConName, tExpTyConName, + roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName, -- Quasiquoting quoteDecName, quoteTypeName, quoteExpName, quotePatName] @@ -151,21 +155,24 @@ qqFun = mk_known_key_name OccName.varName qqLib qTyConName, nameTyConName, fieldExpTyConName, patTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, - predTyConName, tExpTyConName :: Name -qTyConName = thTc (fsLit "Q") qTyConKey -nameTyConName = thTc (fsLit "Name") nameTyConKey -fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey -patTyConName = thTc (fsLit "Pat") patTyConKey -fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey -expTyConName = thTc (fsLit "Exp") expTyConKey -decTyConName = thTc (fsLit "Dec") decTyConKey -typeTyConName = thTc (fsLit "Type") typeTyConKey -tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey -matchTyConName = thTc (fsLit "Match") matchTyConKey -clauseTyConName = thTc (fsLit "Clause") clauseTyConKey -funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey -predTyConName = thTc (fsLit "Pred") predTyConKey -tExpTyConName = thTc (fsLit "TExp") tExpTyConKey + predTyConName, tExpTyConName, injAnnTyConName, kindTyConName :: Name +qTyConName = thTc (fsLit "Q") qTyConKey +nameTyConName = thTc (fsLit "Name") nameTyConKey +fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey +patTyConName = thTc (fsLit "Pat") patTyConKey +fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey +expTyConName = thTc (fsLit "Exp") expTyConKey +decTyConName = thTc (fsLit "Dec") decTyConKey +typeTyConName = thTc (fsLit "Type") typeTyConKey +tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey +matchTyConName = thTc (fsLit "Match") matchTyConKey +clauseTyConName = thTc (fsLit "Clause") clauseTyConKey +funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey +predTyConName = thTc (fsLit "Pred") predTyConKey +tExpTyConName = thTc (fsLit "TExp") tExpTyConKey +injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey +kindTyConName = thTc (fsLit "Kind") kindTyConKey + returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, @@ -295,41 +302,37 @@ parSName = libFun (fsLit "parS") parSIdKey funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, - familyNoKindDName, standaloneDerivDName, defaultSigDName, - familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, - closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, + standaloneDerivDName, defaultSigDName, + dataInstDName, newtypeInstDName, tySynInstDName, + dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name -funDName = libFun (fsLit "funD") funDIdKey -valDName = libFun (fsLit "valD") valDIdKey -dataDName = libFun (fsLit "dataD") dataDIdKey -newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey -tySynDName = libFun (fsLit "tySynD") tySynDIdKey -classDName = libFun (fsLit "classD") classDIdKey -instanceDName = libFun (fsLit "instanceD") instanceDIdKey -standaloneDerivDName - = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey -sigDName = libFun (fsLit "sigD") sigDIdKey -defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey -forImpDName = libFun (fsLit "forImpD") forImpDIdKey -pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey -pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey -pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey -pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey -pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey -pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey -familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey -familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey -dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey -newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey -tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey -closedTypeFamilyKindDName - = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey -closedTypeFamilyNoKindDName - = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey -infixLDName = libFun (fsLit "infixLD") infixLDIdKey -infixRDName = libFun (fsLit "infixRD") infixRDIdKey -infixNDName = libFun (fsLit "infixND") infixNDIdKey -roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey +funDName = libFun (fsLit "funD") funDIdKey +valDName = libFun (fsLit "valD") valDIdKey +dataDName = libFun (fsLit "dataD") dataDIdKey +newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey +tySynDName = libFun (fsLit "tySynD") tySynDIdKey +classDName = libFun (fsLit "classD") classDIdKey +instanceDName = libFun (fsLit "instanceD") instanceDIdKey +standaloneDerivDName = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey +sigDName = libFun (fsLit "sigD") sigDIdKey +defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey +forImpDName = libFun (fsLit "forImpD") forImpDIdKey +pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey +pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey +pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey +pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey +pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey +pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey +dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey +newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey +tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey +closedTypeFamilyDName= libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey +dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey +infixLDName = libFun (fsLit "infixLD") infixLDIdKey +infixRDName = libFun (fsLit "infixRD") infixRDIdKey +infixNDName = libFun (fsLit "infixND") infixNDIdKey +roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey -- type Ctxt = ... cxtName :: Name @@ -410,6 +413,16 @@ appKName = libFun (fsLit "appK") appKIdKey starKName = libFun (fsLit "starK") starKIdKey constraintKName = libFun (fsLit "constraintK") constraintKIdKey +-- data FamilyResultSig = ... +noSigName, kindSigName, tyVarSigName :: Name +noSigName = libFun (fsLit "noSig") noSigIdKey +kindSigName = libFun (fsLit "kindSig") kindSigIdKey +tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey + +-- data InjectivityAnn = ... +injectivityAnnName :: Name +injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey + -- data Callconv = ... cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name cCallName = libFun (fsLit "cCall") cCallIdKey @@ -509,7 +522,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey, - roleTyConKey, tExpTyConKey :: Unique + roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 200 matchTyConKey = mkPreludeTyConUnique 201 clauseTyConKey = mkPreludeTyConUnique 202 @@ -541,6 +554,8 @@ ruleBndrQTyConKey = mkPreludeTyConUnique 227 tySynEqnQTyConKey = mkPreludeTyConUnique 228 roleTyConKey = mkPreludeTyConUnique 229 tExpTyConKey = mkPreludeTyConUnique 230 +injAnnTyConKey = mkPreludeTyConUnique 231 +kindTyConKey = mkPreludeTyConUnique 232 -- IdUniques available: 200-499 -- If you want to change this, make sure you check in PrelNames @@ -672,38 +687,37 @@ parSIdKey = mkPreludeMiscIdUnique 323 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey, - pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, defaultSigDIdKey, - dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey, - closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey, - infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique -funDIdKey = mkPreludeMiscIdUnique 330 -valDIdKey = mkPreludeMiscIdUnique 331 -dataDIdKey = mkPreludeMiscIdUnique 332 -newtypeDIdKey = mkPreludeMiscIdUnique 333 -tySynDIdKey = mkPreludeMiscIdUnique 334 -classDIdKey = mkPreludeMiscIdUnique 335 -instanceDIdKey = mkPreludeMiscIdUnique 336 -sigDIdKey = mkPreludeMiscIdUnique 337 -forImpDIdKey = mkPreludeMiscIdUnique 338 -pragInlDIdKey = mkPreludeMiscIdUnique 339 -pragSpecDIdKey = mkPreludeMiscIdUnique 340 -pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 -pragSpecInstDIdKey = mkPreludeMiscIdUnique 342 -pragRuleDIdKey = mkPreludeMiscIdUnique 343 -pragAnnDIdKey = mkPreludeMiscIdUnique 344 -familyNoKindDIdKey = mkPreludeMiscIdUnique 345 -familyKindDIdKey = mkPreludeMiscIdUnique 346 -dataInstDIdKey = mkPreludeMiscIdUnique 347 -newtypeInstDIdKey = mkPreludeMiscIdUnique 348 -tySynInstDIdKey = mkPreludeMiscIdUnique 349 -closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 350 -closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 351 -infixLDIdKey = mkPreludeMiscIdUnique 352 -infixRDIdKey = mkPreludeMiscIdUnique 353 -infixNDIdKey = mkPreludeMiscIdUnique 354 -roleAnnotDIdKey = mkPreludeMiscIdUnique 355 -standaloneDerivDIdKey = mkPreludeMiscIdUnique 356 -defaultSigDIdKey = mkPreludeMiscIdUnique 357 + pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, openTypeFamilyDIdKey, + closedTypeFamilyDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, + standaloneDerivDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey, + roleAnnotDIdKey :: Unique +funDIdKey = mkPreludeMiscIdUnique 330 +valDIdKey = mkPreludeMiscIdUnique 331 +dataDIdKey = mkPreludeMiscIdUnique 332 +newtypeDIdKey = mkPreludeMiscIdUnique 333 +tySynDIdKey = mkPreludeMiscIdUnique 334 +classDIdKey = mkPreludeMiscIdUnique 335 +instanceDIdKey = mkPreludeMiscIdUnique 336 +sigDIdKey = mkPreludeMiscIdUnique 337 +forImpDIdKey = mkPreludeMiscIdUnique 338 +pragInlDIdKey = mkPreludeMiscIdUnique 339 +pragSpecDIdKey = mkPreludeMiscIdUnique 340 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 +pragSpecInstDIdKey = mkPreludeMiscIdUnique 342 +pragRuleDIdKey = mkPreludeMiscIdUnique 343 +pragAnnDIdKey = mkPreludeMiscIdUnique 344 +dataFamilyDIdKey = mkPreludeMiscIdUnique 345 +openTypeFamilyDIdKey = mkPreludeMiscIdUnique 346 +dataInstDIdKey = mkPreludeMiscIdUnique 347 +newtypeInstDIdKey = mkPreludeMiscIdUnique 348 +tySynInstDIdKey = mkPreludeMiscIdUnique 349 +closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 350 +infixLDIdKey = mkPreludeMiscIdUnique 352 +infixRDIdKey = mkPreludeMiscIdUnique 353 +infixNDIdKey = mkPreludeMiscIdUnique 354 +roleAnnotDIdKey = mkPreludeMiscIdUnique 355 +standaloneDerivDIdKey = mkPreludeMiscIdUnique 356 +defaultSigDIdKey = mkPreludeMiscIdUnique 357 -- type Cxt = ... cxtIdKey :: Unique @@ -783,6 +797,16 @@ appKIdKey = mkPreludeMiscIdUnique 413 starKIdKey = mkPreludeMiscIdUnique 414 constraintKIdKey = mkPreludeMiscIdUnique 415 +-- data FamilyResultSig = ... +noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique +noSigIdKey = mkPreludeMiscIdUnique 416 +kindSigIdKey = mkPreludeMiscIdUnique 417 +tyVarSigIdKey = mkPreludeMiscIdUnique 418 + +-- data InjectivityAnn = ... +injectivityAnnIdKey :: Unique +injectivityAnnIdKey = mkPreludeMiscIdUnique 419 + -- data Callconv = ... cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey, javaScriptCallIdKey :: Unique diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 5ce89ad7ef..d66b48e3b7 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -774,9 +774,10 @@ anyTy :: Type anyTy = mkTyConTy anyTyCon anyTyCon :: TyCon -anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] +anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] Nothing (ClosedSynFamilyTyCon Nothing) NoParentTyCon + NotInjective where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 449377d03c..97c84cd9f9 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -52,6 +52,10 @@ module TysWiredIn ( mkListTy, mkPromotedListTy, + -- * Maybe + maybeTyCon, maybeTyConName, + nothingDataCon, nothingDataConName, justDataCon, justDataConName, + -- * Tuples mkTupleTy, mkBoxedTupleTy, tupleTyCon, tupleDataCon, tupleTyConName, @@ -162,6 +166,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , wordTyCon , word8TyCon , listTyCon + , maybeTyCon , parrTyCon , eqTyCon , coercibleTyCon @@ -210,6 +215,19 @@ boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boo falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon +listTyConName, nilDataConName, consDataConName :: Name +listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon +nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon +consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + +maybeTyConName, nothingDataConName, justDataConName :: Name +maybeTyConName = mkWiredInTyConName UserSyntax gHC_BASE (fsLit "Maybe") + maybeTyConKey maybeTyCon +nothingDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Nothing") + nothingDataConKey nothingDataCon +justDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Just") + justDataConKey justDataCon + wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon @@ -713,11 +731,6 @@ gtDataConId = dataConWorkId gtDataCon mkListTy :: Type -> Type mkListTy ty = mkTyConApp listTyCon [ty] -listTyConName, nilDataConName, consDataConName :: Name -listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon -nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon -consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon - listTyCon :: TyCon listTyCon = pcTyCon False Recursive True listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon] @@ -739,7 +752,20 @@ consDataCon = pcDataConWithFixity True {- Declared infix -} -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy -- gets the over-specific type (Type -> Type) -{- ********************************************************************* +-- Wired-in type Maybe + +maybeTyCon :: TyCon +maybeTyCon = pcTyCon True NonRecursive True maybeTyConName Nothing alpha_tyvar + [nothingDataCon, justDataCon] + +nothingDataCon :: DataCon +nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon + +justDataCon :: DataCon +justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon + +{- +** ********************************************************************* * * The tuple types * * diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 1a6fa170be..820f0b045a 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -45,8 +45,9 @@ import ListSetOps ( findDupsEq, removeDups ) import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Control.Monad -import Data.List( sortBy ) +import Data.List ( sortBy ) import Maybes( orElse, mapMaybe ) +import qualified Data.Set as Set ( difference, fromList, toList, null ) #if __GLASGOW_HASKELL__ < 709 import Data.Traversable (traverse) #endif @@ -1015,7 +1016,8 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn ; let kvs = extractDataDefnKindVars defn doc = TyDataCtx tycon ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs) - ; ((tyvars', defn'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' -> + ; ((tyvars', defn'), fvs) <- + bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' -> do { (defn', fvs) <- rnDataDefn doc defn ; return ((tyvars', defn'), fvs) } ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars' @@ -1184,27 +1186,31 @@ badGadtStupidTheta _ = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"), ptext (sLit "(You can put a context on each contructor, though.)")] -rnFamDecl :: Maybe Name - -- Just cls => this FamilyDecl is nested - -- inside an *class decl* for cls - -- used for associated types +rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested + -- inside an *class decl* for cls + -- used for associated types -> FamilyDecl RdrName -> RnM (FamilyDecl Name, FreeVars) rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars - , fdInfo = info, fdKindSig = kind }) - = do { ((tycon', tyvars', kind'), fv1) <- - bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' -> - do { tycon' <- lookupLocatedTopBndrRn tycon - ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind - ; return ((tycon', tyvars', kind'), fv_kind) } + , fdInfo = info, fdResultSig = res_sig + , fdInjectivityAnn = injectivity }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; ((tyvars', res_sig', injectivity'), fv1) <- + bindHsTyVars doc mb_cls kvs tyvars $ \ tyvars' -> + do { (res_sig', fv_kind) <- wrapLocFstM (rnFamResultSig doc) res_sig + ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') + injectivity + ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } ; (info', fv2) <- rn_info info ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars' - , fdInfo = info', fdKindSig = kind' } + , fdInfo = info', fdResultSig = res_sig' + , fdInjectivityAnn = injectivity' } , fv1 `plusFV` fv2) } where - fmly_doc = TyFamilyCtx tycon - kvs = extractRdrKindSigVars kind + doc = TyFamilyCtx tycon + kvs = extractRdrKindSigVars res_sig + ---------------------- rn_info (ClosedTypeFamily (Just eqns)) = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns -- no class context, @@ -1214,6 +1220,134 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) rn_info DataFamily = return (DataFamily, emptyFVs) +rnFamResultSig :: HsDocContext -> FamilyResultSig RdrName + -> RnM (FamilyResultSig Name, FreeVars) +rnFamResultSig _ NoSig + = return (NoSig, emptyFVs) +rnFamResultSig doc (KindSig kind) + = do { (rndKind, ftvs) <- rnLHsKind doc kind + ; return (KindSig rndKind, ftvs) } +rnFamResultSig doc (TyVarSig tvbndr) + = do { -- `TyVarSig` tells us that user named the result of a type family by + -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to + -- be sure that the supplied result name is not identical to an + -- already in-scope type variables: + -- + -- (a) one of already declared type family arguments. Example of + -- disallowed declaration: + -- type family F a = a + -- + -- (b) already in-scope type variable. This second case might happen + -- for associated types, where type class head bounds some type + -- variables. Example of disallowed declaration: + -- class C a b where + -- type F b = a | a -> b + -- Both are caught by the "in-scope" check that comes next + rdr_env <- getLocalRdrEnv + ; let resName = hsLTyVarName tvbndr + ; when (resName `elemLocalRdrEnv` rdr_env) $ + addErrAt (getLoc tvbndr) $ + (hsep [ text "Type variable", quotes (ppr resName) <> comma + , text "naming a type family result," + ] $$ + text "shadows an already bound type variable") + + ; (tvbndr', fvs) <- rnLHsTyVarBndr doc Nothing rdr_env tvbndr + ; return (TyVarSig tvbndr', fvs) } + +-- Note [Renaming injectivity annotation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- During renaming of injectivity annotation we have to make several checks to +-- make sure that it is well-formed. At the moment injectivity annotation +-- consists of a single injectivity condition, so the terms "injectivity +-- annotation" and "injectivity condition" might be used interchangeably. See +-- Note [Injectivity annotation] for a detailed discussion of currently allowed +-- injectivity annotations. +-- +-- Checking LHS is simple because the only type variable allowed on the LHS of +-- injectivity condition is the variable naming the result in type family head. +-- Example of disallowed annotation: +-- +-- type family Foo a b = r | b -> a +-- +-- Verifying RHS of injectivity consists of checking that: +-- +-- 1. only variables defined in type family head appear on the RHS (kind +-- variables are also allowed). Example of disallowed annotation: +-- +-- type family Foo a = r | r -> b +-- +-- 2. for associated types the result variable does not shadow any of type +-- class variables. Example of disallowed annotation: +-- +-- class Foo a b where +-- type F a = b | b -> a +-- +-- Breaking any of these assumptions results in an error. + +-- | Rename injectivity annotation. Note that injectivity annotation is just the +-- part after the "|". Everything that appears before it is renamed in +-- rnFamDecl. +rnInjectivityAnn :: LHsTyVarBndrs Name -- ^ Type variables declared in + -- type family head + -> LFamilyResultSig Name -- ^ Result signature + -> LInjectivityAnn RdrName -- ^ Injectivity annotation + -> RnM (LInjectivityAnn Name) +rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv)) + (L srcSpan (InjectivityAnn injFrom injTo)) + = do + { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) + <- askNoErrs $ + bindLocalNames [hsLTyVarName resTv] $ + -- The return type variable scopes over the injectivity annotation + -- e.g. type family F a = (r::*) | r -> a + do { injFrom' <- rnLTyVar True injFrom + ; injTo' <- mapM (rnLTyVar True) injTo + ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } + + ; let tvNames = Set.fromList $ hsLKiTyVarNames tvBndrs + resName = hsLTyVarName resTv + -- See Note [Renaming injectivity annotation] + lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) + rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames + + -- if renaming of type variables ended with errors (eg. there were + -- not-in-scope variables) don't check the validity of injectivity + -- annotation. This gives better error messages. + ; when (noRnErrors && not lhsValid) $ + addErrAt (getLoc injFrom) + ( vcat [ text $ "Incorrect type variable on the LHS of " + ++ "injectivity condition" + , nest 5 + ( vcat [ text "Expected :" <+> ppr resName + , text "Actual :" <+> ppr injFrom ])]) + + ; when (noRnErrors && not (Set.null rhsValid)) $ + do { let errorVars = Set.toList rhsValid + ; addErrAt srcSpan $ ( hsep + [ text "Unknown type variable" <> plural errorVars + , text "on the RHS of injectivity condition:" + , interpp'SP errorVars ] ) } + + ; return injDecl' } + +-- We can only hit this case when the user writes injectivity annotation without +-- naming the result: +-- +-- type family F a | result -> a +-- type family F a :: * | result -> a +-- +-- So we rename injectivity annotation like we normally would except that +-- this time we expect "result" to be reported not in scope by rnLTyVar. +rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = + setSrcSpan srcSpan $ do + (injDecl', _) <- askNoErrs $ do + injFrom' <- rnLTyVar True injFrom + injTo' <- mapM (rnLTyVar True) injTo + return $ L srcSpan (InjectivityAnn injFrom' injTo') + return $ injDecl' + {- Note [Stupid theta] ~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 5dfd3fa7ad..090ed64fb8 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -13,7 +13,7 @@ module RnTypes ( rnHsKind, rnLHsKind, rnLHsMaybeKind, rnHsSigType, rnLHsInstType, rnConDeclFields, newTyVarNameRn, rnLHsTypeWithWildCards, - rnHsSigTypeWithWildCards, collectWildCards, + rnHsSigTypeWithWildCards, rnLTyVar, collectWildCards, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, @@ -21,8 +21,8 @@ module RnTypes ( -- Binding related stuff warnContextQuantification, warnUnusedForAlls, - bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, - extractHsTyRdrTyVars, extractHsTysRdrTyVars, + bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, rnLHsTyVarBndr, + extractHsTyRdrTyVars, extractHsTysRdrTyVars, extractTyVarBndrNames, extractRdrKindSigVars, extractDataDefnKindVars, filterInScope ) where @@ -48,6 +48,7 @@ import Outputable import FastString import Maybes import Data.List ( nub, nubBy, deleteFirstsBy ) +import qualified Data.Set as Set import Control.Monad ( unless, when ) #if __GLASGOW_HASKELL__ < 709 @@ -365,6 +366,10 @@ rnTyVar is_type rdr_name | is_type = lookupTypeOccRn rdr_name | otherwise = lookupKindOccRn rdr_name +rnLTyVar :: Bool -> Located RdrName -> RnM (Located Name) +rnLTyVar is_type (L loc rdr_name) = do + tyvar' <- rnTyVar is_type rdr_name + return (L loc tyvar') -------------- rnLHsTypes :: HsDocContext -> [LHsType RdrName] @@ -447,22 +452,11 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside ; bindLocalNamesFV kv_names $ do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs - rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) - rn_tv_bndr (L loc (UserTyVar rdr)) - = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; return (L loc (UserTyVar nm), emptyFVs) } - rn_tv_bndr (L loc (KindedTyVar (L lv rdr) kind)) - = do { sig_ok <- xoptM Opt_KindSignatures - ; unless sig_ok (badSigErr False doc kind) - ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; (kind', fvs) <- rnLHsKind doc kind - ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) } - -- Check for duplicate or shadowed tyvar bindrs ; checkDupRdrNames tv_names_w_loc ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) - ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs + ; (tv_bndrs', fvs1) <- mapFvRn (rnLHsTyVarBndr doc mb_assoc rdr_env) tvs ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $ do { inner_rdr_env <- getLocalRdrEnv ; traceRn (text "bhtv" <+> vcat @@ -473,6 +467,18 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) } ; return (res, fvs1 `plusFV` fvs2) } } +rnLHsTyVarBndr :: HsDocContext -> Maybe a -> LocalRdrEnv + -> LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) +rnLHsTyVarBndr _ mb_assoc rdr_env (L loc (UserTyVar rdr)) + = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr + ; return (L loc (UserTyVar nm), emptyFVs) } +rnLHsTyVarBndr doc mb_assoc rdr_env (L loc (KindedTyVar (L lv rdr) kind)) + = do { sig_ok <- xoptM Opt_KindSignatures + ; unless sig_ok (badSigErr False doc kind) + ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr + ; (kind', fvs) <- rnLHsKind doc kind + ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) } + newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name newTyVarNameRn mb_assoc rdr_env loc rdr | Just _ <- mb_assoc -- Use the same Name as the parent class decl @@ -1117,9 +1123,25 @@ extractHsTysRdrTyVars ty = case extract_ltys ty ([],[]) of (kvs, tvs) -> (nub kvs, nub tvs) -extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName] -extractRdrKindSigVars Nothing = [] -extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[]))) +-- Extracts variable names used in a type variable binder. Note that HsType +-- represents data and type constructors as type variables and so this function +-- will also return data and type constructors. +extractTyVarBndrNames :: LHsTyVarBndr RdrName -> Set.Set RdrName +extractTyVarBndrNames (L _ (UserTyVar name)) + = Set.singleton name +extractTyVarBndrNames (L _ (KindedTyVar (L _ name) k)) + = Set.singleton name `Set.union` (Set.fromList tvs) + `Set.union` (Set.fromList kvs) + where (kvs, tvs) = extractHsTyRdrTyVars k + +extractRdrKindSigVars :: LFamilyResultSig RdrName -> [RdrName] +extractRdrKindSigVars (L _ resultSig) + | KindSig k <- resultSig = kindRdrNameFromSig k + | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k + | TyVarSig (L _ (UserTyVar _)) <- resultSig = [] + | otherwise = [] -- this can only be NoSig but pattern exhasutiveness + -- checker complains about "NoSig <- resultSig" + where kindRdrNameFromSig k = nub (fst (extract_lkind k ([],[]))) extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName] -- Get the scoped kind variables mentioned free in the constructor decls diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 3af2358bcd..49fc5fe8b0 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -1,6 +1,6 @@ -- The @FamInst@ type: family instance heads -{-# LANGUAGE CPP, GADTs #-} +{-# LANGUAGE CPP, GADTs, DataKinds #-} module FamInst ( FamInstEnvs, tcGetFamInstEnvs, @@ -8,7 +8,12 @@ module FamInst ( tcLookupFamInst, tcLookupDataFamInst, tcLookupDataFamInst_maybe, tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, - newFamInst + newFamInst, + + -- * Injectivity + makeInjectivityErrors, + + tfHeadedErr, bareVariableInRHSErr ) where import HscTypes @@ -18,6 +23,7 @@ import Coercion hiding ( substTy ) import TcEvidence import LoadIface import TcRnMonad +import SrcLoc import TyCon import CoAxiom import DynFlags @@ -33,6 +39,7 @@ import TcMType import TcType import Name import Panic +import VarSet import Control.Monad import Data.Map (Map) import qualified Data.Map as Map @@ -130,7 +137,6 @@ checkFamInstConsistency :: [Module] -> [Module] -> TcM () checkFamInstConsistency famInstMods directlyImpMods = do { dflags <- getDynFlags ; (eps, hpt) <- getEpsAndHpt - ; let { -- Fetch the iface of a given module. Must succeed as -- all directly imported modules must already have been loaded. modIface mod = @@ -164,7 +170,11 @@ checkFamInstConsistency famInstMods directlyImpMods = do { env1 <- getFamInsts hpt_fam_insts m1 ; env2 <- getFamInsts hpt_fam_insts m2 ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) - (famInstEnvElts env1) } + (famInstEnvElts env1) + ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) + (famInstEnvElts env1) + } + getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv getFamInsts hpt_fam_insts mod @@ -315,8 +325,8 @@ tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv ; (inst_env', fam_insts') <- foldlM addLocalFamInst - (tcg_fam_inst_env env, tcg_fam_insts env) - fam_insts + (tcg_fam_inst_env env, tcg_fam_insts env) + fam_insts ; let env' = env { tcg_fam_insts = fam_insts' , tcg_fam_inst_env = inst_env' } ; setGblEnv env' thing_inside @@ -326,7 +336,9 @@ tcExtendLocalFamInstEnv fam_insts thing_inside -- and then add it to the home inst env -- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] -- in FamInstEnv.hs -addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst]) +addLocalFamInst :: (FamInstEnv,[FamInst]) + -> FamInst + -> TcM (FamInstEnv, [FamInst]) addLocalFamInst (home_fie, my_fis) fam_inst -- home_fie includes home package and this module -- my_fies is just the ones from this module @@ -349,9 +361,11 @@ addLocalFamInst (home_fie, my_fis) fam_inst ; let inst_envs = (eps_fam_inst_env eps, home_fie') home_fie'' = extendFamInstEnv home_fie fam_inst - -- Check for conflicting instance decls - ; no_conflict <- checkForConflicts inst_envs fam_inst - ; if no_conflict then + -- Check for conflicting instance decls and injectivity violations + ; no_conflict <- checkForConflicts inst_envs fam_inst + ; injectivity_ok <- checkForInjectivityConflicts inst_envs fam_inst + + ; if no_conflict && injectivity_ok then return (home_fie'', fam_inst : my_fis) else return (home_fie, my_fis) } @@ -379,26 +393,155 @@ checkForConflicts inst_envs fam_inst ; unless no_conflicts $ conflictInstErr fam_inst conflicts ; return no_conflicts } +-- | Check whether a new open type family equation can be added without +-- violating injectivity annotation supplied by the user. Returns True when +-- this is possible and False if adding this equation would violate injectivity +-- annotation. +checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM Bool +checkForInjectivityConflicts instEnvs famInst + | isTypeFamilyTyCon tycon + -- type family is injective in at least one argument + , Injective inj <- familyTyConInjectivityInfo tycon = do + { let axiom = brFromUnbranchedSingleton (co_ax_branches (fi_axiom famInst)) + conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst + -- see Note [Verifying injectivity annotation] in FamInstEnv + errs = makeInjectivityErrors tycon axiom inj conflicts + ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs + ; return (null errs) + } + + -- if there was no injectivity annotation or tycon does not represent a + -- type family we report no conflicts + | otherwise = return True + where tycon = famInstTyCon famInst + +-- | Build a list of injectivity errors together with their source locations. +makeInjectivityErrors + :: TyCon -- ^ Type family tycon for which we generate errors + -> CoAxBranch -- ^ Currently checked equation (represented by axiom) + -> [Bool] -- ^ Injectivity annotation + -> [CoAxBranch] -- ^ List of injectivity conflicts + -> [(SDoc, SrcSpan)] +makeInjectivityErrors tycon axiom inj conflicts + = let lhs = coAxBranchLHS axiom + rhs = coAxBranchRHS axiom + + are_conflicts = not $ null conflicts + unused_inj_tvs = unusedInjTvsInRHS inj lhs rhs + inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs + tf_headed = isTFHeaded rhs + bare_variables = bareTvInRHSViolated lhs rhs + wrong_bare_rhs = not $ null bare_variables + + err_builder herald eqns + = ( herald $$ vcat (map (pprCoAxBranch tycon) eqns) + , coAxBranchSpan (head eqns) ) + errorIf p f = if p then [f err_builder axiom] else [] + in errorIf are_conflicts (conflictInjInstErr conflicts ) + ++ errorIf inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs) + ++ errorIf tf_headed tfHeadedErr + ++ errorIf wrong_bare_rhs (bareVariableInRHSErr bare_variables) + + conflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () conflictInstErr fam_inst conflictingMatch | (FamInstMatch { fim_instance = confInst }) : _ <- conflictingMatch - = addFamInstsErr (ptext (sLit "Conflicting family instance declarations:")) - [fam_inst, confInst] + = let (err, span) = makeFamInstsErr + (text "Conflicting family instance declarations:") + [fam_inst, confInst] + in setSrcSpan span $ addErr err | otherwise = panic "conflictInstErr" -addFamInstsErr :: SDoc -> [FamInst] -> TcRn () -addFamInstsErr herald insts +-- | Type of functions that use error message and a list of axioms to build full +-- error message (with a source location) for injective type families. +type InjErrorBuilder = SDoc -> [CoAxBranch] -> (SDoc, SrcSpan) + +-- | Build injecivity error herald common to all injectivity errors. +injectivityErrorHerald :: Bool -> SDoc +injectivityErrorHerald isSingular = + text "Type family equation" <> s isSingular <+> text "violate" <> + s (not isSingular) <+> text "injectivity annotation" <> + if isSingular then dot else colon + -- Above is an ugly hack. We want this: "sentence. herald:" (note the dot and + -- colon). But if herald is empty we want "sentence:" (note the colon). We + -- can't test herald for emptiness so we rely on the fact that herald is empty + -- only when isSingular is False. If herald is non empty it must end with a + -- colon. + where + s False = text "s" + s True = empty + +-- | Build error message for a pair of equations violating an injectivity +-- annotation. +conflictInjInstErr :: [CoAxBranch] -> InjErrorBuilder -> CoAxBranch + -> (SDoc, SrcSpan) +conflictInjInstErr conflictingEqns errorBuilder tyfamEqn + | confEqn : _ <- conflictingEqns + = errorBuilder (injectivityErrorHerald False) [confEqn, tyfamEqn] + | otherwise + = panic "conflictInjInstErr" + +-- | Build error message for equation with injective type variables unused in +-- the RHS. +unusedInjectiveVarsErr :: TyVarSet -> InjErrorBuilder -> CoAxBranch + -> (SDoc, SrcSpan) +unusedInjectiveVarsErr unused_tyvars errorBuilder tyfamEqn + = errorBuilder (injectivityErrorHerald True $$ + mkUnusedInjectiveVarsErr unused_tyvars) [tyfamEqn] + where + mkUnusedInjectiveVarsErr :: TyVarSet -> SDoc + mkUnusedInjectiveVarsErr unused_tyvars = + let tyVars = varSetElems $ filterVarSet isTypeVar unused_tyvars + kiVars = varSetElems $ filterVarSet isKindVar unused_tyvars + tyVarsSDoc + = if not (null tyVars) + then text "Injective type variable" <> plural tyVars <+> + pprQuotedList tyVars <+> doOrDoes tyVars <+> + text "not appear on injective position." + else empty + kiVarsSDoc + = if not (null kiVars) + then text "Injective kind variable" <> plural kiVars <+> + pprQuotedList kiVars <+> isOrAre kiVars <+> + text "not inferable from the RHS type variables." + else empty + in tyVarsSDoc $$ kiVarsSDoc $$ + text "In the RHS of type family equation:" + +-- | Build error message for equation that has a type family call at the top +-- level of RHS +tfHeadedErr :: InjErrorBuilder -> CoAxBranch + -> (SDoc, SrcSpan) +tfHeadedErr errorBuilder famInst + = errorBuilder (injectivityErrorHerald True $$ + text "RHS of injective type family equation cannot" <+> + text "be a type family:") [famInst] + +-- | Build error message for equation that has a bare type variable in the RHS +-- but LHS pattern is not a bare type variable. +bareVariableInRHSErr :: [Type] -> InjErrorBuilder -> CoAxBranch + -> (SDoc, SrcSpan) +bareVariableInRHSErr tys errorBuilder famInst + = errorBuilder (injectivityErrorHerald True $$ + text "RHS of injective type family equation is a bare" <+> + text "type variable" $$ + text "but these LHS type and kind patterns are not bare" <+> + text "variables:" <+> pprQuotedList tys) [famInst] + + +makeFamInstsErr :: SDoc -> [FamInst] -> (SDoc, SrcSpan) +makeFamInstsErr herald insts = ASSERT( not (null insts) ) - setSrcSpan srcSpan $ addErr $ - hang herald - 2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) 0 - | fi <- sorted ]) + ( hang herald + 2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) 0 + | fi <- sorted ]) + , srcSpan ) where - getSpan = getSrcLoc . famInstAxiom - sorted = sortWith getSpan insts - fi1 = head sorted - srcSpan = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) + getSpan = getSrcLoc . famInstAxiom + sorted = sortWith getSpan insts + fi1 = head sorted + srcSpan = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) -- The sortWith just arranges that instances are dislayed in order -- of source location, which reduced wobbling in error messages, -- and is better for users diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index ed3955d0f3..3f0a198a88 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -282,7 +282,7 @@ in TcSMonad, which has this example: Suppose we are trying to solve [G] d1 : Ord a [W] d2 : C [a] -If we (bogusly) added the superclass of d2 as Gievn we'd have +If we (bogusly) added the superclass of d2 as Given we'd have [G] d1 : Ord a [W] d2 : C [a] [G] d3 : Ord [a] -- Superclass of d2, bogus @@ -292,7 +292,7 @@ Then we'll use the instance decl to give [G] d3 : Ord [a] -- Superclass of d2, bogus [W] d4: Ord [a] -ANd now we could bogusly solve d4 from d3. +And now we could bogusly solve d4 from d3. ---------- End of historical note ----------- Note [Add superclasses only during canonicalisation] @@ -938,7 +938,7 @@ If we see (T s1 t1 ~ T s2 t2), then we can just decompose to (s1 ~ s2, t1 ~ t2) and push those back into the work list. But if s1 = K k1 s2 = K k2 -then we will jus decomopose s1~s2, and it might be better to +then we will just decomopose s1~s2, and it might be better to do so on the spot. An important special case is where s1=s2, and we get just Refl. diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index e39fbf9882..fa67d491b2 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -1,6 +1,7 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE CPP, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an + -- orphan module TcEnv( TyThing(..), TcTyThing(..), TcId, diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index e08d0d5b30..83bbcca1b7 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -144,8 +144,8 @@ data TcCoercion | TcAppCo TcCoercion TcCoercion | TcForAllCo TyVar TcCoercion | TcCoVarCo EqVar - | TcAxiomInstCo (CoAxiom Branched) Int [TcCoercion] -- Int specifies branch number - -- See [CoAxiom Index] in Coercion.hs + | TcAxiomInstCo (CoAxiom Branched) Int -- Int specifies branch number + [TcCoercion] -- See [CoAxiom Index] in Coercion.hs -- This is number of types and coercions are expected to match to CoAxiomRule -- (i.e., the CoAxiomRules are always fully saturated) | TcAxiomRuleCo CoAxiomRule [TcType] [TcCoercion] diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 39ab4e621b..2f427916b4 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -950,7 +950,7 @@ kcScopedKindVars :: [Name] -> TcM a -> TcM a -- bind each scoped kind variable (k in this case) to a fresh -- kind skolem variable kcScopedKindVars kv_ns thing_inside - = do { kvs <- mapM (\n -> newSigTyVar n superKind) kv_ns + = do { kvs <- mapM newSigKindVar kv_ns -- NB: use mutable signature variables ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) thing_inside } @@ -965,8 +965,8 @@ kcHsTyVarBndrs :: Bool -- ^ True <=> the decl being checked has a CUSK -- with the other info kcHsTyVarBndrs cusk (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside = do { kvs <- if cusk - then mapM mkKindSigVar kv_ns - else mapM (\n -> newSigTyVar n superKind) kv_ns + then mapM mkKindSigVar kv_ns + else mapM newSigKindVar kv_ns ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) $ do { nks <- mapM (kc_hs_tv . unLoc) hs_tvs ; (res_kind, stuff) <- tcExtendKindEnv nks thing_inside @@ -1155,7 +1155,8 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside -- There may be fewer of these than the kvs of -- the type constructor, of course do { thing <- tcLookup tycon - ; let { kind = case thing of + ; let { kind = case thing of -- The kind of the tycon has been worked out + -- by the previous pass, and is fully zonked AThing kind -> kind _ -> panic "tcTyClTyVars" -- We only call tcTyClTyVars during typechecking in @@ -1171,11 +1172,12 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside -- e.g. class C a_29 where -- type T b_30 a_29 :: * -- Here the a_29 is shared - tc_hs_tv (L _ (UserTyVar n)) kind = return (mkTyVar n kind) + tc_hs_tv (L _ (UserTyVar n)) kind + = return (mkTyVar n kind) tc_hs_tv (L _ (KindedTyVar (L _ n) hs_k)) kind - = do { tc_kind <- tcLHsKind hs_k - ; checkKind kind tc_kind - ; return (mkTyVar n kind) } + = do { tc_kind <- tcLHsKind hs_k + ; checkKind kind tc_kind + ; return (mkTyVar n kind) } ----------------------------------- tcDataKindSig :: Kind -> TcM [TyVar] diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 461eb5a2e8..328a8cfa96 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -78,7 +78,7 @@ two passes over the instance decls. Note [How instance declarations are translated] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is how we translation instance declarations into Core +Here is how we translate instance declarations into Core Running example: class C a where @@ -530,7 +530,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) `unionNameSet` mkNameSet (map (unLoc . dfid_tycon . unLoc) adts) - ; tyfam_insts1 <- mapM (tcATDefault mini_subst defined_ats) + ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats) (classATItems clas) -- Finally, construct the Core representation of the instance. @@ -551,11 +551,11 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) } -tcATDefault :: TvSubst -> NameSet -> ClassATItem -> TcM [FamInst] +tcATDefault :: SrcSpan -> TvSubst -> NameSet -> ClassATItem -> TcM [FamInst] -- ^ Construct default instances for any associated types that -- aren't given a user definition -- Returns [] or singleton -tcATDefault inst_subst defined_ats (ATI fam_tc defs) +tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) -- User supplied instances ==> everything is OK | tyConName fam_tc `elemNameSet` defined_ats = return [] @@ -570,7 +570,7 @@ tcATDefault inst_subst defined_ats (ATI fam_tc defs) rhs' = substTy subst' rhs_ty tv_set' = tyVarsOfTypes pat_tys' tvs' = varSetElemsKvsFirst tv_set' - ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' + ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' fam_tc pat_tys' rhs' ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty , pprCoAxiom axiom ]) @@ -634,15 +634,15 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname -- (0) Check it's an open type family - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) - ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) -- (1) do the work of verifying the synonym group ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) eqn -- (2) check for validity - ; checkValidTyFamInst mb_clsinfo fam_tc co_ax_branch + ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch -- (3) construct coercion axiom ; rep_tc_name <- newFamInstAxiomName loc (unLoc fam_lname) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 6feb3f0c33..261d9afa51 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -24,12 +24,15 @@ import PrelNames ( knownNatClassName, knownSymbolClassName, callStackTyConKey, typeableClassName ) import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind ) import Id( idType ) +import CoAxiom ( Eqn, CoAxiom(..), CoAxBranch(..), fromBranchList ) import Class import TyCon import DataCon( dataConWrapId ) import FunDeps import FamInst +import FamInstEnv import Inst( tyVarsOfCt ) +import Unify ( tcUnifyTyWithTFs ) import TcEvidence import Outputable @@ -37,6 +40,7 @@ import Outputable import TcRnTypes import TcSMonad import Bag +import MonadUtils ( concatMapM ) import Data.List( partition, foldl', deleteFirstsBy ) import SrcLoc @@ -85,7 +89,7 @@ We unflatten after solving the wc_simples of an implication, and before attempti to float. This means that * The fsk/fmv flatten-skolems only survive during solveSimples. We don't - need to worry about then across successive passes over the constraint tree. + need to worry about them across successive passes over the constraint tree. (E.g. we don't need the old ic_fsk field of an implication. * When floating an equality outwards, we don't need to worry about floating its @@ -115,7 +119,7 @@ Note [Running plugins on unflattened wanteds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There is an annoying mismatch between solveSimpleGivens and solveSimpleWanteds, because the latter needs to fiddle with the inert -set, unflatten and and zonk the wanteds. It passes the zonked wanteds +set, unflatten and zonk the wanteds. It passes the zonked wanteds to runTcPluginsWanteds, which produces a replacement set of wanteds, some additional insolubles and a flag indicating whether to go round the loop again. If so, prepareInertsForImplications is used to remove @@ -215,7 +219,7 @@ See Note [Unflattening can force the solver to iterate] --------------------------------------------------------------- solveSimples :: Cts -> TcS () -- Returns the final InertSet in TcS --- Has no effect on work-list or residual-iplications +-- Has no effect on work-list or residual-implications -- The constraints are initially examined in left-to-right order solveSimples cts @@ -847,34 +851,73 @@ interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc ; reactFunEq ev fsk ev_i fsk_i ; stopWith ev "Work item rewrites inert" } - | Just ops <- isBuiltInSynFamTyCon_maybe tc - = do { let matching_funeqs = findFunEqsByTyCon funeqs tc - ; let interact = sfInteractInert ops args (lookupFlattenTyVar eqs fsk) - do_one (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = iev }) - = mapM_ (unifyDerived (ctEvLoc iev) Nominal) - (interact iargs (lookupFlattenTyVar eqs ifsk)) - do_one ct = pprPanic "interactFunEq" (ppr ct) - ; mapM_ do_one matching_funeqs - ; traceTcS "builtInCandidates 1: " $ vcat [ ptext (sLit "Candidates:") <+> ppr matching_funeqs - , ptext (sLit "TvEqs:") <+> ppr eqs ] - ; return (ContinueWith workItem) } + | otherwise -- Try improvement + = do { improveLocalFunEqs loc inerts tc args fsk + ; continueWith workItem } + where + loc = ctEvLoc ev + funeqs = inert_funeqs inerts + matching_inerts = findFunEqs funeqs tc args +interactFunEq _ workItem = pprPanic "interactFunEq" (ppr workItem) + +improveLocalFunEqs :: CtLoc -> InertCans -> TyCon -> [TcType] -> TcTyVar + -> TcS () +-- Generate derived improvement equalities, by comparing +-- the current work item with inert CFunEqs +-- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y' +improveLocalFunEqs loc inerts fam_tc args fsk + | not (null improvement_eqns) + = do { traceTcS "interactFunEq improvements: " $ + vcat [ ptext (sLit "Eqns:") <+> ppr improvement_eqns + , ptext (sLit "Candidates:") <+> ppr funeqs_for_tc + , ptext (sLit "TvEqs:") <+> ppr tv_eqs ] + ; mapM_ (unifyDerived loc Nominal) improvement_eqns } | otherwise - = return (ContinueWith workItem) + = return () where - eqs = inert_eqs inerts - funeqs = inert_funeqs inerts - matching_inerts = findFunEqs funeqs tc args + tv_eqs = inert_model inerts + funeqs = inert_funeqs inerts + funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc + rhs = lookupFlattenTyVar tv_eqs fsk + + -------------------- + improvement_eqns + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = -- Try built-in families, notably for arithmethic + concatMap (do_one_built_in ops) funeqs_for_tc -interactFunEq _ wi = pprPanic "interactFunEq" (ppr wi) + | Injective injective_args <- familyTyConInjectivityInfo fam_tc + = -- Try improvement from type families with injectivity annotations + concatMap (do_one_injective injective_args) funeqs_for_tc -lookupFlattenTyVar :: TyVarEnv EqualCtList -> TcTyVar -> TcType + | otherwise + = [] + + -------------------- + do_one_built_in ops (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk }) + = sfInteractInert ops args rhs iargs (lookupFlattenTyVar tv_eqs ifsk) + do_one_built_in _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) + + -------------------- + -- See Note [Type inference for type families with injectivity] + do_one_injective injective_args + (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk }) + | rhs `tcEqType` lookupFlattenTyVar tv_eqs ifsk + = [Pair arg iarg | (arg, iarg, True) + <- zip3 args iargs injective_args ] + | otherwise + = [] + do_one_injective _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) + +------------- +lookupFlattenTyVar :: InertModel -> TcTyVar -> TcType -- ^ Look up a flatten-tyvar in the inert nominal TyVarEqs; -- this is used only when dealing with a CFunEqCan -lookupFlattenTyVar inert_eqs ftv - = case lookupVarEnv inert_eqs ftv of - Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _) -> rhs - _ -> mkTyVarTy ftv +lookupFlattenTyVar model ftv + = case lookupVarEnv model ftv of + Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq }) -> rhs + _ -> mkTyVarTy ftv reactFunEq :: CtEvidence -> TcTyVar -- From this :: F tys ~ fsk1 -> CtEvidence -> TcTyVar -- Solve this :: F tys ~ fsk2 @@ -893,6 +936,44 @@ reactFunEq from_this fuv1 ev fuv2 ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fuv1 $$ ppr ev $$ ppr fuv2) } {- +Note [Type inference for type families with injectivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a type family with an injectivity annotation: + type family F a b = r | r -> b + +Then if we have two CFunEqCan constraints for F with the same RHS + F s1 t1 ~ rhs + F s2 t2 ~ rhs +then we can use the injectivity to get a new Derived constraint on +the injective argument + [D] t1 ~ t2 + +That in turn can help GHC solve constraints that would otherwise require +guessing. For example, consider the ambiguity check for + f :: F Int b -> Int +We get the constraint + [W] F Int b ~ F Int beta +where beta is a unification variable. Injectivity lets us pick beta ~ b. + +Injectivity information is also used at the call sites. For example: + g = f True +gives rise to + [W] F Int b ~ Bool +from which we can derive b. This requires looking at the defining equations of +a type family, ie. finding equation with a matching RHS (Bool in this example) +and infering values of type variables (b in this example) from the LHS patterns +of the matching equation. For closed type families we have to perform +additional apartness check for the selected equation to check that the selected +is guaranteed to fire for given LHS arguments. + +These new constraints are simply *Derived* constraints; they have no evidence. +We could go further and offer evidence from decomposing injective type-function +applications, but that would require new evidence forms, and an extension to +FC, so we don't do that right now (Dec 14). + +See also Note [Injective type families] in TyCon + + Note [Cache-caused loops] ~~~~~~~~~~~~~~~~~~~~~~~~~ It is very dangerous to cache a rewritten wanted family equation as 'solved' in our @@ -1163,7 +1244,7 @@ topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) topReactionsStage wi = do { tir <- doTopReact wi ; case tir of - ContinueWith wi -> return (ContinueWith wi) + ContinueWith wi -> continueWith wi Stop ev s -> return (Stop ev (ptext (sLit "Top react:") <+> s)) } doTopReact :: WorkItem -> TcS (StopOrContinue Ct) @@ -1181,7 +1262,7 @@ doTopReact work_item ; doTopReactDict inerts work_item } CFunEqCan {} -> doTopReactFunEq work_item _ -> -- Any other work item does not react with any top-level equations - return (ContinueWith work_item) } + continueWith work_item } -------------------- doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct) @@ -1270,71 +1351,136 @@ doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) -------------------- doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) --- Note [Short cut for top-level reaction] -doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc - , cc_tyargs = args , cc_fsk = fsk }) - = ASSERT(isTypeFamilyTyCon fam_tc) -- No associated data families - -- have reached this far - -- Look up in top-level instances, or built-in axiom - do { match_res <- matchFam fam_tc args -- See Note [MATCHING-SYNONYMS] - ; case match_res of { - Nothing -> do { try_improve - ; continueWith work_item } ; - Just (ax_co, rhs_ty) - - -- Found a top-level instance - - | Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty - , isTypeFamilyTyCon tc - , tc_args `lengthIs` tyConArity tc -- Short-cut - -> shortCutReduction old_ev fsk ax_co tc tc_args - -- Try shortcut; see Note [Short cut for top-level reaction] - - | isGiven old_ev -- Not shortcut - -> do { let final_co = mkTcSymCo (ctEvCoercion old_ev) `mkTcTransCo` ax_co - -- final_co :: fsk ~ rhs_ty - ; new_ev <- newGivenEvVar deeper_loc (mkTcEqPred (mkTyVarTy fsk) rhs_ty, - EvCoercion final_co) - ; emitWorkNC [new_ev] -- Non-canonical; that will mean we flatten rhs_ty - ; stopWith old_ev "Fun/Top (given)" } - - | not (fsk `elemVarSet` tyVarsOfType rhs_ty) - -> do { dischargeFmv old_ev fsk ax_co rhs_ty - ; traceTcS "doTopReactFunEq" $ - vcat [ text "old_ev:" <+> ppr old_ev - , nest 2 (text ":=") <+> ppr ax_co ] - ; stopWith old_ev "Fun/Top (wanted)" } - - | otherwise -- We must not assign ufsk := ...ufsk...! - -> do { alpha_ty <- newFlexiTcSTy (tyVarKind fsk) - ; new_ev <- newWantedEvVarNC loc (mkTcEqPred alpha_ty rhs_ty) - ; emitWorkNC [new_ev] - -- By emitting this as non-canonical, we deal with all - -- flattening, occurs-check, and ufsk := ufsk issues - ; let final_co = ax_co `mkTcTransCo` mkTcSymCo (ctEvCoercion new_ev) - -- ax_co :: fam_tc args ~ rhs_ty - -- new_ev :: alpha ~ rhs_ty - -- ufsk := alpha - -- final_co :: fam_tc args ~ alpha - ; dischargeFmv old_ev fsk final_co alpha_ty - ; traceTcS "doTopReactFunEq (occurs)" $ - vcat [ text "old_ev:" <+> ppr old_ev - , nest 2 (text ":=") <+> ppr final_co - , text "new_ev:" <+> ppr new_ev ] - ; stopWith old_ev "Fun/Top (wanted)" } } } +doTopReactFunEq work_item = do { fam_envs <- getFamInstEnvs + ; do_top_fun_eq fam_envs work_item } + +do_top_fun_eq :: FamInstEnvs -> Ct -> TcS (StopOrContinue Ct) +do_top_fun_eq fam_envs work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc + , cc_tyargs = args , cc_fsk = fsk }) + | Just (ax_co, rhs_ty) <- reduceTyFamApp_maybe fam_envs Nominal fam_tc args + -- Look up in top-level instances, or built-in axiom + -- See Note [MATCHING-SYNONYMS] + = reduce_top_fun_eq old_ev fsk (TcCoercion ax_co) rhs_ty + + | otherwise + = do { improveTopFunEqs (ctEvLoc old_ev) fam_envs fam_tc args fsk + ; continueWith work_item } + +do_top_fun_eq _ w = pprPanic "doTopReactFunEq" (ppr w) + +reduce_top_fun_eq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType + -> TcS (StopOrContinue Ct) +-- Found an applicable top-level axiom: use it to reduce +reduce_top_fun_eq old_ev fsk ax_co rhs_ty + | Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty + , isTypeFamilyTyCon tc + , tc_args `lengthIs` tyConArity tc -- Short-cut + = shortCutReduction old_ev fsk ax_co tc tc_args + -- Try shortcut; see Note [Short cut for top-level reaction] + + | ASSERT( not (isDerived old_ev) ) -- CFunEqCan is never Derived + isGiven old_ev -- Not shortcut + = do { let final_co = mkTcSymCo (ctEvCoercion old_ev) `mkTcTransCo` ax_co + -- final_co :: fsk ~ rhs_ty + ; new_ev <- newGivenEvVar deeper_loc (mkTcEqPred (mkTyVarTy fsk) rhs_ty, + EvCoercion final_co) + ; emitWorkNC [new_ev] -- Non-cannonical; that will mean we flatten rhs_ty + ; stopWith old_ev "Fun/Top (given)" } + + | not (fsk `elemVarSet` tyVarsOfType rhs_ty) + = do { dischargeFmv old_ev fsk ax_co rhs_ty + ; traceTcS "doTopReactFunEq" $ + vcat [ text "old_ev:" <+> ppr old_ev + , nest 2 (text ":=") <+> ppr ax_co ] + ; stopWith old_ev "Fun/Top (wanted)" } + + | otherwise -- We must not assign ufsk := ...ufsk...! + = do { alpha_ty <- newFlexiTcSTy (tyVarKind fsk) + ; new_ev <- newWantedEvVarNC loc (mkTcEqPred alpha_ty rhs_ty) + ; emitWorkNC [new_ev] + -- By emitting this as non-canonical, we deal with all + -- flattening, occurs-check, and ufsk := ufsk issues + ; let final_co = ax_co `mkTcTransCo` mkTcSymCo (ctEvCoercion new_ev) + -- ax_co :: fam_tc args ~ rhs_ty + -- ev :: alpha ~ rhs_ty + -- ufsk := alpha + -- final_co :: fam_tc args ~ alpha + ; dischargeFmv old_ev fsk final_co alpha_ty + ; traceTcS "doTopReactFunEq (occurs)" $ + vcat [ text "old_ev:" <+> ppr old_ev + , nest 2 (text ":=") <+> ppr final_co + , text "new_ev:" <+> ppr new_ev ] + ; stopWith old_ev "Fun/Top (wanted)" } where loc = ctEvLoc old_ev deeper_loc = bumpCtLocDepth loc - try_improve - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = do { inert_eqs <- getInertEqs - ; let eqns = sfInteractTop ops args (lookupFlattenTyVar inert_eqs fsk) - ; mapM_ (unifyDerived loc Nominal) eqns } - | otherwise - = return () +improveTopFunEqs :: CtLoc -> FamInstEnvs + -> TyCon -> [TcType] -> TcTyVar -> TcS () +improveTopFunEqs loc fam_envs fam_tc args fsk + = do { model <- getInertModel + ; eqns <- improve_top_fun_eqs fam_envs fam_tc args + (lookupFlattenTyVar model fsk) + ; mapM_ (unifyDerived loc Nominal) eqns } + +improve_top_fun_eqs :: FamInstEnvs + -> TyCon -> [TcType] -> TcType + -> TcS [Eqn] +improve_top_fun_eqs fam_envs fam_tc args rhs_ty + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = return (sfInteractTop ops args rhs_ty) + + -- see Note [Type inference for type families with injectivity] + | isOpenTypeFamilyTyCon fam_tc + , Injective injective_args <- familyTyConInjectivityInfo fam_tc + = -- it is possible to have several compatible equations in an open type + -- family but we only want to derive equalities from one such equation. + concatMapM (injImproveEqns injective_args) (take 1 $ + buildImprovementData (lookupFamInstEnvByTyCon fam_envs fam_tc) + fi_tys fi_rhs (const Nothing)) + + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc + , Injective injective_args <- familyTyConInjectivityInfo fam_tc + = concatMapM (injImproveEqns injective_args) $ + buildImprovementData (fromBranchList (co_ax_branches ax)) + cab_lhs cab_rhs Just + + | otherwise + = return [] + where + buildImprovementData + :: [a] -- axioms for a TF (FamInst or CoAxBranch) + -> (a -> [Type]) -- get LHS of an axiom + -> (a -> Type) -- get RHS of an axiom + -> (a -> Maybe CoAxBranch) -- Just => apartness check required + -> [( [Type], TvSubst, TyVarSet, Maybe CoAxBranch )] + -- Result: + -- ( [arguments of a matching axiom] + -- , RHS-unifying substitution + -- , axiom variables without substitution + -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] ) + buildImprovementData axioms axiomLHS axiomRHS wrap = + [ (ax_args, subst, unsubstTvs, wrap axiom) + | axiom <- axioms + , let ax_args = axiomLHS axiom + , let ax_rhs = axiomRHS axiom + , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty] + , let tvs = tyVarsOfTypes ax_args + notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst) + unsubstTvs = filterVarSet notInSubst tvs ] + + injImproveEqns :: [Bool] + -> ([Type], TvSubst, TyVarSet, Maybe CoAxBranch) + -> TcS [Eqn] + injImproveEqns inj_args (ax_args, theta, unsubstTvs, cabr) = do + (theta', _) <- instFlexiTcS (varSetElems unsubstTvs) + let subst = theta `unionTvSubst` theta' + return [ Pair arg (substTy subst ax_arg) + | case cabr of + Just cabr' -> apartnessCheck (substTys subst ax_args) cabr' + _ -> True + , (arg, ax_arg, True) <- zip3 args ax_args inj_args ] -doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion -> TyCon -> [TcType] -> TcS (StopOrContinue Ct) diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index 455c9566c9..a9c608d21b 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -33,7 +33,7 @@ module TcMType ( -------------------------------- -- Instantiation - tcInstTyVars, tcInstTyVarX, newSigTyVar, + tcInstTyVars, tcInstTyVarX, newSigTyVar, newSigKindVar, tcInstType, tcInstSkolTyVars, tcInstSuperSkolTyVarsX, tcInstSigTyVarsLoc, tcInstSigTyVars, @@ -290,14 +290,17 @@ newMetaTyVar meta_info kind ; details <- newMetaDetails meta_info ; return (mkTcTyVar name kind details) } +newSigKindVar :: Name -> TcM TcTyVar +newSigKindVar name = newSigTyVar name superKind + newSigTyVar :: Name -> Kind -> TcM TcTyVar newSigTyVar name kind - = do { uniq <- newUnique - ; let name' = setNameUnique name uniq - -- Use the same OccName so that the tidy-er - -- doesn't gratuitously rename 'a' to 'a0' etc - ; details <- newMetaDetails SigTv - ; return (mkTcTyVar name' kind details) } + = do { details <- newMetaDetails SigTv + ; uniq <- newUnique + ; let fresh_name = setNameUnique name uniq + -- Use the same OccName so that the tidy-er + -- doesn't gratuitously rename 'a' to 'a0' etc + ; return (mkTcTyVar fresh_name kind details) } newMetaDetails :: MetaInfo -> TcM TcTyVarDetails newMetaDetails info @@ -563,12 +566,12 @@ skolemiseUnboundMetaTyVar tv details = ASSERT2( isMetaTyVar tv, ppr tv ) do { span <- getSrcSpanM -- Get the location from "here" -- ie where we are generalising - ; uniq <- newUnique -- Remove it from TcMetaTyVar unique land ; kind <- zonkTcKind (tyVarKind tv) - ; let tv_name = getOccName tv - final_name = mkInternalName uniq tv_name span - final_kind = defaultKind kind - final_tv = mkTcTyVar final_name final_kind details + ; let uniq = getUnique tv + tv_name = getOccName tv + final_name = mkInternalName uniq tv_name span + final_kind = defaultKind kind + final_tv = mkTcTyVar final_name final_kind details ; traceTc "Skolemising" (ppr tv <+> ptext (sLit ":=") <+> ppr final_tv) ; writeMetaTyVar tv (mkTyVarTy final_tv) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 6e3fd81098..1595eef5b6 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -975,9 +975,13 @@ checkBootTyCon tc1 tc2 = eqClosedFamilyAx ax1 ax2 eqFamFlav (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2 eqFamFlav _ _ = False + injInfo1 = familyTyConInjectivityInfo tc1 + injInfo2 = familyTyConInjectivityInfo tc2 in + -- check equality of roles, family flavours and injectivity annotations check (roles1 == roles2) roles_msg `andThenCheck` - check (eqFamFlav fam_flav1 fam_flav2) empty -- nothing interesting to say + check (eqFamFlav fam_flav1 fam_flav2) empty `andThenCheck` + check (injInfo1 == injInfo2) empty | isAlgTyCon tc1 && isAlgTyCon tc2 , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index c1392f483a..2492c5544e 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -835,6 +835,19 @@ tryTc m -- in exception; see IOEnv.failM } +-- (askNoErrs m) runs m +-- If m fails, (askNoErrs m) fails +-- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b), +-- where b is True iff m generated no error +-- Regardless of success or failure, any errors generated by m are propagated +askNoErrs :: TcRn a -> TcRn (a, Bool) +askNoErrs m + = do { errs_var <- newTcRef emptyMessages + ; res <- setErrsVar errs_var m + ; (warns, errs) <- readTcRef errs_var + ; addMessages (warns, errs) + ; return (res, isEmptyBag errs) } + ----------------------- tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a) -- Run the thing, returning diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 3721975d3e..80437ff0f5 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -1043,8 +1043,8 @@ Note [Adding an inert canonical constraint the InertCans] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Adding any constraint c *other* than a CTyEqCan (TcSMonad.addInertCan): - * If c can be rewritten by model, emit [D] c, as NonCanonical. - See Note [Can be rewritten by model] + * If c can be rewritten by model, emit the shadow constraint [D] c + as NonCanonical. See Note [Emitting shadow constraints] * Reason for non-canonical: a CFunEqCan has a unique fmv on the RHS, so we must not duplicate it. @@ -1062,30 +1062,33 @@ Note [Adding an inert canonical constraint the InertCans] - A Derived equality can kick out [D] constraints in inert_dicts, inert_irreds etc. Nothing in inert_eqs because there are no - Derived constraints in inert_eqs. + Derived constraints in inert_eqs (they are in the model) Then, when adding: - * [Given/Wanted] a ~N ty - 1. (GWShadow) If the model can rewrite (a~ty), then emit [D] a~ty - (GWModel) Otherwise just add a~ty to the model - (Reason: [D] a~ty is inert wrt model, and (K2b) holds) - - 2. Add it to inert_eqs - - * [Given/Wanted] a ~R ty: just add it to inert_eqs - * [Derived] a ~N ty - 1. (DShadow) Emit shadow-copies (emitDerivedShadows): + 1. Add (a~ty) to the model + NB: 'a' cannot be in fv(ty), because the constraint is canonical. + + 2. (DShadow) Emit shadow-copies (emitDerivedShadows): For every inert G/W constraint c, st - (a) (a~ty) can rewrite c (see Note [Can be rewritten]), and - (b) the model cannot rewrite c + (a) (a~ty) can rewrite c (see Note [Emitting shadow constraints]), + and + (b) the model cannot rewrite c kick out a Derived *copy*, leaving the original unchanged. Reason for (b) if the model can rewrite c, then we have already generated a shadow copy - 2. Add (a~ty) to the model - NB: 'a' cannot be in fv(ty), because the constraint is canonical. + * [Given/Wanted] a ~N ty + 1. Add it to inert_eqs + 2. If the model can rewrite (a~ty) + then (GWShadow) emit [D] a~ty + else (GWModel) Use emitDerivedShadows just like (DShadow) + and add a~ty to the model + (Reason:[D] a~ty is inert wrt model, and (K2b) holds) + + * [Given/Wanted] a ~R ty: just add it to inert_eqs + * Unifying a:=ty, is like adding [G] a~ty, but we can't make a [D] a~ty, as in step (1) of the [G/W] case above. So instead, do kickOutAfterUnification: @@ -1093,17 +1096,46 @@ Note [Adding an inert canonical constraint the InertCans] (i.e. a=b or a in ty2). Example: [G] a ~ [b], model [D] b ~ [a] -Note [Can be rewritten] -~~~~~~~~~~~~~~~~~~~~~~~ -What does it mean to say "Constraint c can be rewritten by the model". -See modelCanRewrite, rewritableTyVars. +Note [Emitting shadow constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * Given a new model element [D] a ~ ty, we want to emit shadow + [D] constraints for any inert constraints 'c' that can be + rewritten [D] a-> ty + + * And similarly given a new Given/Wanted 'c', we want to emit a + shadow 'c' if the model can rewrite [D] c + +See modelCanRewrite. -Basically it means fvs(c) intersects dom(model). But can the model - [fmv -> ty] rewrite CFunEqCan F Int ~ fmv ? -No: we just look at the LHS of a CFunEqCan. +NB the use of rewritableTyVars. ou might wonder whether, given the new +constraint [D] fmv ~ ty and the inert [W] F alpha ~ fmv, do we want to +emit a shadow constraint [D] F alpha ~ fmv? No, we don't, because +it'll literally be a duplicate (since we do not rewrite the RHS of a +CFunEqCan) and hence immediately eliminated again. Insetad we simply +want to *kick-out* the [W] F alpha ~ fmv, so that it is reconsidered +from a fudep point of view. See Note [Kicking out CFunEqCan for +fundeps] + +Note [Kicking out CFunEqCan for fundeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + New: [D] fmv1 ~ fmv2 + Inert: [W] F alpha ~ fmv1 + [W] F beta ~ fmv2 + +The new (derived) equality certainly can't rewrite the inerts. But we +*must* kick out the first one, to get: + + New: [W] F alpha ~ fmv1 + Inert: [W] F beta ~ fmv2 + Model: [D] fmv1 ~ fmv2 + +and now improvement will discover [D] alpha ~ beta. This is important; +eg in Trac #9587. -} addInertEq :: Ct -> TcS () +-- This is a key function, because of the kick-out stuff -- Precondition: item /is/ canonical addInertEq ct@(CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel, cc_tyvar = tv }) = do { traceTcS "addInertEq {" $ @@ -1137,7 +1169,8 @@ add_inert_eq ics@(IC { inert_count = n | ReprEq <- eq_rel = return new_ics - -- Nominal equality, Given/Wanted + -- Nominal equality (tv ~N ty), Given/Wanted + -- See Note [Emitting shadow constraints] | modelCanRewrite old_model rw_tvs -- Shadow of new constraint is = do { emitNewDerivedEq loc pred -- not inert, so emit it ; return new_ics } @@ -1184,17 +1217,25 @@ emitDerivedShadows IC { inert_eqs = tv_eqs | otherwise = cts want_shadow ct - = not (isDerivedCt ct) -- No need for a shadow of a Derived! - && (new_tv `elemVarSet` rw_tvs) -- New tv can rewrite ct - && not (modelCanRewrite model rw_tvs) -- We have not alrady created a shadow + = not (isDerivedCt ct) -- No need for a shadow of a Derived! + && (new_tv `elemVarSet` rw_tvs) -- New tv can rewrite ct, yielding a + -- different ct + && not (modelCanRewrite model rw_tvs)-- We have not alrady created a + -- shadow where rw_tvs = rewritableTyVars ct modelCanRewrite :: InertModel -> TcTyVarSet -> Bool --- True if there is any intersection between dom(model) and pred -modelCanRewrite model tvs = foldVarSet ((||) . (`elemVarEnv` model)) False tvs +-- See Note [Emitting shadow constraints] +-- True if there is any intersection between dom(model) and tvs +modelCanRewrite model tvs = not (disjointUFM model tvs) + -- The low-level use of disjointUFM might e surprising. + -- InertModel = TyVarEnv Ct, and we want to see if its domain + -- is disjoint from that of a TcTyVarSet. So we drop down + -- to the underlying UniqFM. A bit yukky, but efficient. rewritableTyVars :: Ct -> TcTyVarSet +-- The tyvars of a Ct that can be rewritten rewritableTyVars (CFunEqCan { cc_tyargs = tys }) = tyVarsOfTypes tys rewritableTyVars ct = tyVarsOfType (ctPred ct) @@ -1205,18 +1246,18 @@ addInertCan ct text "Trying to insert new inert item:" <+> ppr ct ; ics <- getInertCans - ; let ics' = add_item ics ct - ; setInertCans ics' + ; setInertCans (add_item ics ct) -- Emit shadow derived if necessary + -- See Note [Emitting shadow constraints] + ; let ev = ctEvidence ct + pred = ctEvPred ev + rw_tvs = rewritableTyVars ct + ; when (not (isDerived ev) && modelCanRewrite (inert_model ics) rw_tvs) (emitNewDerived (ctEvLoc ev) pred) ; traceTcS "addInertCan }" $ empty } - where - rw_tvs = rewritableTyVars ct - ev = ctEvidence ct - pred = ctEvPred ev add_item :: InertCans -> Ct -> InertCans add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) @@ -1256,21 +1297,34 @@ kickOutRewritable :: CtFlavourRole -- Flavour and role of the equality that is -- inert_solved_dicts, and inert_solved_funeqs -- optimistically. But when we lookup we have to -- take the substitution into account -kickOutRewritable new_fr new_tv - ics@(IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_safehask = safehask - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insols = insols - , inert_count = n - , inert_model = model }) +kickOutRewritable new_fr new_tv ics@(IC { inert_funeqs = funeqmap }) | not (new_fr `eqCanRewriteFR` new_fr) - = (emptyWorkList, ics) -- If new_flavour can't rewrite itself, it can't rewrite - -- anything else, so no need to kick out anything - -- This is a common case: wanteds can't rewrite wanteds - - | otherwise + = if isFlattenTyVar new_tv + then (emptyWorkList { wl_funeqs = feqs_out }, ics { inert_funeqs = feqs_in }) + else (emptyWorkList, ics) + -- If new_fr can't rewrite itself, it can't rewrite + -- anything else, so no need to kick out anything. + -- (This is a common case: wanteds can't rewrite wanteds) + -- + -- ExCEPT (tiresomely) that we should kick out any CFunEqCans + -- that we should re-examine for their fundeps, even though + -- they can't be *rewrittten*. + -- See Note [Kicking out CFunEqCan for fundeps] + where + (feqs_out, feqs_in) = partitionFunEqs kick_out_fe funeqmap + + kick_out_fe :: Ct -> Bool + kick_out_fe (CFunEqCan { cc_fsk = fsk }) = fsk == new_tv + kick_out_fe _ = False -- Can't happen + +kickOutRewritable new_fr new_tv (IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_safehask = safehask + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_insols = insols + , inert_count = n + , inert_model = model }) = (kicked_out, inert_cans_in) where inert_cans_in = IC { inert_eqs = tv_eqs_in @@ -1291,7 +1345,7 @@ kickOutRewritable new_fr new_tv , wl_implics = emptyBag } (tv_eqs_out, tv_eqs_in) = foldVarEnv kick_out_eqs ([], emptyVarEnv) tv_eqs - (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap + (feqs_out, feqs_in) = partitionFunEqs kick_out_fe funeqmap (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap (irs_out, irs_in) = partitionBag kick_out_irred irreds (insols_out, insols_in) = partitionBag kick_out_ct insols @@ -1303,6 +1357,11 @@ kickOutRewritable new_fr new_tv kick_out_ct :: Ct -> Bool kick_out_ct ct = kick_out_ctev (ctEvidence ct) + kick_out_fe :: Ct -> Bool + kick_out_fe (CFunEqCan { cc_ev = ev, cc_fsk = fsk }) + = kick_out_ctev ev || fsk == new_tv + kick_out_fe _ = False -- Can't happen + kick_out_ctev :: CtEvidence -> Bool kick_out_ctev ev = can_rewrite ev && new_tv `elemVarSet` tyVarsOfType (ctEvPred ev) @@ -1386,9 +1445,8 @@ kickOutModel new_tv ics@(IC { inert_model = model, inert_eqs = eqs }) | not (isInInertEqs eqs tv rhs) = extendWorkListDerived (ctEvLoc ev) ev wl add _ wl = wl -{- -Note [Kicking out inert constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Kicking out inert constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given a new (a -> ty) inert, we want to kick out an existing inert constraint if a) the new constraint can rewrite the inert one diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index a018e4a525..52b52dbedf 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1088,7 +1088,51 @@ reifyTyCon tc | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) - | isFamilyTyCon tc + | isTypeFamilyTyCon tc + = do { let tvs = tyConTyVars tc + kind = tyConKind tc + resVar = famTcResVar tc + + -- we need the *result kind* (see #8884) + (kvs, mono_kind) = splitForAllTys kind + -- tyConArity includes *kind* params + (_, res_kind) = splitKindFunTysN (tyConArity tc - length kvs) + mono_kind + ; kind' <- reifyKind res_kind + ; let (resultSig, injectivity) = + case resVar of + Nothing -> (TH.KindSig kind', Nothing) + Just name -> + let thName = reifyName name + injAnnot = familyTyConInjectivityInfo tc + sig = TH.TyVarSig (TH.KindedTV thName kind') + inj = case injAnnot of + NotInjective -> Nothing + Injective ms -> + Just (TH.InjectivityAnn thName injRHS) + where + injRHS = map (reifyName . tyVarName) + (filterByList ms tvs) + in (sig, inj) + ; tvs' <- reifyTyVars tvs + ; if isOpenTypeFamilyTyCon tc + then do { fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc + (familyInstances fam_envs tc) + ; return (TH.FamilyI + (TH.OpenTypeFamilyD (reifyName tc) tvs' + resultSig injectivity) + instances) } + else do { eqns <- + case isClosedSynFamilyTyConWithAxiom_maybe tc of + Just ax -> brListMapM reifyAxBranch $ coAxiomBranches ax + Nothing -> return [] + ; return (TH.FamilyI + (TH.ClosedTypeFamilyD (reifyName tc) tvs' resultSig + injectivity eqns) + []) } } + + | isDataFamilyTyCon tc = do { let tvs = tyConTyVars tc kind = tyConKind tc @@ -1100,19 +1144,10 @@ reifyTyCon tc ; kind' <- fmap Just (reifyKind res_kind) ; tvs' <- reifyTyVars tvs - ; flav' <- reifyFamFlavour tc - ; case flav' of - { Left flav -> -- open type/data family - do { fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc - (familyInstances fam_envs tc) - ; return (TH.FamilyI - (TH.FamilyD flav (reifyName tc) tvs' kind') - instances) } - ; Right eqns -> -- closed type family - return (TH.FamilyI - (TH.ClosedTypeFamilyD (reifyName tc) tvs' kind' eqns) - []) } } + ; fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) + ; return (TH.FamilyI + (TH.DataFamilyD (reifyName tc) tvs' kind') instances) } | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym = do { rhs' <- reifyType rhs @@ -1336,21 +1371,6 @@ reifyCxt = mapM reifyPred reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) -reifyFamFlavour :: TyCon -> TcM (Either TH.FamFlavour [TH.TySynEqn]) -reifyFamFlavour tc - | isOpenTypeFamilyTyCon tc = return $ Left TH.TypeFam - | isDataFamilyTyCon tc = return $ Left TH.DataFam - | Just flav <- famTyConFlav_maybe tc = case flav of - OpenSynFamilyTyCon -> return $ Left TH.TypeFam - AbstractClosedSynFamilyTyCon -> return $ Right [] - BuiltInSynFamTyCon _ -> return $ Right [] - ClosedSynFamilyTyCon Nothing -> return $ Right [] - ClosedSynFamilyTyCon (Just ax) - -> do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax - ; return $ Right eqns } - | otherwise - = panic "TcSplice.reifyFamFlavour: not a type family" - reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr] reifyTyVars tvs = mapM reify_tv $ filter isTypeVar tvs diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 2eb2dafa48..19af9f0b18 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -36,8 +36,8 @@ import TcMType import TcType import TysWiredIn( unitTy ) import FamInst -import FamInstEnv( isDominatedBy, mkCoAxBranch, mkBranchedCoAxiom ) -import Coercion( pprCoAxBranch, ltRole ) +import FamInstEnv +import Coercion( ltRole ) import Type import TypeRep -- for checkValidRoles import Kind @@ -136,7 +136,7 @@ tcTyClGroup tyclds -- the final TyCons and Classes ; let role_annots = extractRoleAnnots tyclds decls = group_tyclds tyclds - ; tyclss <- fixM $ \ rec_tyclss -> do + ; tyclss <- fixM $ \ ~rec_tyclss -> do { is_boot <- tcIsHsBootOrSig ; self_boot <- tcSelfBootInfo ; let rec_flags = calcRecFlags self_boot is_boot @@ -144,7 +144,7 @@ tcTyClGroup tyclds -- Populate environment with knot-tied ATyCon for TyCons -- NB: if the decls mention any ill-staged data cons - -- (see Note [Recusion and promoting data constructors] + -- (see Note [Recusion and promoting data constructors]) -- we will have failed already in kcTyClGroup, so no worries here ; tcExtendRecEnv (zipRecTyClss names_w_poly_kinds rec_tyclss) $ @@ -406,16 +406,19 @@ getFamDeclInitialKinds decls getFamDeclInitialKind :: FamilyDecl Name -> TcM [(Name, TcTyThing)] -getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name - , fdTyVars = ktvs - , fdKindSig = ksig }) +getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name + , fdTyVars = ktvs + , fdResultSig = L _ resultSig }) = do { (fam_kind, _) <- kcHsTyVarBndrs (famDeclHasCusk decl) ktvs $ - do { res_k <- case ksig of - Just k -> tcLHsKind k - Nothing - | famDeclHasCusk decl -> return liftedTypeKind - | otherwise -> newMetaKindVar + do { res_k <- case resultSig of + KindSig ki -> tcLHsKind ki + TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKind ki + _ -- open type families have * return kind by default + | famDeclHasCusk decl -> return liftedTypeKind + -- closed type families have their return kind inferred + -- by default + | otherwise -> newMetaKindVar ; return (res_k, ()) } ; return [ (name, AThing fam_kind) ] } @@ -631,6 +634,7 @@ tcTyClDecl1 _parent rec_info -- This little knot is just so we can get -- hold of the name of the class TyCon, which we -- need to look up its recursiveness + ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr tvs' $$ ppr kind) ; let tycon_name = tyConName (classTyCon clas) tc_isrec = rti_is_rec rec_info tycon_name roles = rti_roles rec_info tycon_name @@ -662,45 +666,57 @@ tcTyClDecl1 _parent rec_info -- NB: Order is important due to the call to `mkGlobalThings' when -- tying the the type and class declaration type checking knot. where - tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tc_fd_tyvar . unLoc) tvs1 ; - ; tvs2' <- mapM (tc_fd_tyvar . unLoc) tvs2 ; + tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcFdTyVar tvs1 + ; tvs2' <- mapM tcFdTyVar tvs2 ; return (tvs1', tvs2') } - tc_fd_tyvar name -- Scoped kind variables are bound to unification variables - -- which are now fixed, so we can zonk - = do { tv <- tcLookupTyVar name - ; ty <- zonkTyVarOcc emptyZonkEnv tv - -- Squeeze out any kind unification variables - ; case getTyVar_maybe ty of - Just tv' -> return tv' - Nothing -> pprPanic "tc_fd_tyvar" (ppr name $$ ppr tv $$ ppr ty) } + +tcFdTyVar :: Located Name -> TcM TcTyVar +-- Look up a type/kind variable in a functional dependency +-- or injectivity annotation. In the case of kind variables, +-- the environment contains a binding of the kind var to a +-- a SigTv unification variables, which has now fixed. +-- So we must zonk to get the real thing. Ugh! +tcFdTyVar (L _ name) + = do { tv <- tcLookupTyVar name + ; ty <- zonkTyVarOcc emptyZonkEnv tv + ; case getTyVar_maybe ty of + Just tv' -> return tv' + Nothing -> pprPanic "tcFdTyVar" (ppr name $$ ppr tv $$ ppr ty) } tcFamDecl1 :: TyConParent -> FamilyDecl Name -> TcM [TyThing] -tcFamDecl1 parent - (FamilyDecl {fdInfo = OpenTypeFamily, fdLName = L _ tc_name, fdTyVars = tvs}) +tcFamDecl1 parent (FamilyDecl { fdInfo = OpenTypeFamily, fdLName = L _ tc_name + , fdTyVars = tvs, fdResultSig = L _ sig + , fdInjectivityAnn = inj }) = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "open type family:" (ppr tc_name) ; checkFamFlag tc_name - ; tycon <- buildFamilyTyCon tc_name tvs' OpenSynFamilyTyCon kind parent + ; inj' <- tcInjectivity tvs' inj + ; let tycon = buildFamilyTyCon tc_name tvs' (resultVariableName sig) + OpenSynFamilyTyCon kind parent inj' ; return [ATyCon tycon] } tcFamDecl1 parent (FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns - , fdLName = lname@(L _ tc_name), fdTyVars = tvs }) + , fdLName = L _ tc_name, fdTyVars = tvs + , fdResultSig = L _ sig, fdInjectivityAnn = inj }) -- Closed type families are a little tricky, because they contain the definition -- of both the type family and the equations for a CoAxiom. - = do { traceTc "closed type family:" (ppr tc_name) - -- the variables in the header have no scope: - ; (tvs', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind -> - return (tvs', kind) + = do { traceTc "Closed type family:" (ppr tc_name) + -- the variables in the header scope only over the injectivity + -- declaration but this is not involved here + ; (tvs', inj', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind -> + do { inj' <- tcInjectivity tvs' inj + ; return (tvs', inj', kind) } ; checkFamFlag tc_name -- make sure we have -XTypeFamilies -- If Nothing, this is an abstract family in a hs-boot file; -- but eqns might be empty in the Just case as well ; case mb_eqns of - Nothing -> do { tycon <- buildFamilyTyCon tc_name tvs' - AbstractClosedSynFamilyTyCon kind parent - ; return [ATyCon tycon] } + Nothing -> + return [ATyCon $ buildFamilyTyCon tc_name tvs' Nothing + AbstractClosedSynFamilyTyCon kind parent + NotInjective ] Just eqns -> do { -- Process the equations, creating CoAxBranches @@ -708,12 +724,13 @@ tcFamDecl1 parent ; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind) ; branches <- mapM (tcTyFamInstEqn fam_tc_shape) eqns + -- Do not attempt to drop equations dominated by earlier + -- ones here; in the case of mutual recursion with a data + -- type, we get a knot-tying failure. Instead we check + -- for this afterwards, in TcValidity.checkValidCoAxiom + -- Example: tc265 - -- we need the tycon that we will be creating, but it's in scope. - -- just look it up. - ; fam_tc <- tcLookupLocatedTyCon lname - - -- create a CoAxiom, with the correct src location. It is Vitally + -- Create a CoAxiom, with the correct src location. It is Vitally -- Important that we do not pass the branches into -- newFamInstAxiomName. They have types that have been zonked inside -- the knot and we will die if we look at them. This is OK here @@ -723,17 +740,17 @@ tcFamDecl1 parent ; loc <- getSrcSpanM ; co_ax_name <- newFamInstAxiomName loc tc_name [] - -- mkBranchedCoAxiom will fail on an empty list of branches ; let mb_co_ax - | null eqns = Nothing - | otherwise = Just $ mkBranchedCoAxiom co_ax_name fam_tc branches + | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list + | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) + + fam_tc = buildFamilyTyCon tc_name tvs' (resultVariableName sig) + (ClosedSynFamilyTyCon mb_co_ax) kind parent inj' + + ; return $ ATyCon fam_tc : maybeToList (fmap ACoAxiom mb_co_ax) } } - -- now, finally, build the TyCon - ; tycon <- buildFamilyTyCon tc_name tvs' - (ClosedSynFamilyTyCon mb_co_ax) kind parent - ; return $ ATyCon tycon : maybeToList (fmap ACoAxiom mb_co_ax) } } -- We check for instance validity later, when doing validity checking for --- the tycon +-- the tycon. Exception: checking equations overlap done by dropDominatedAxioms tcFamDecl1 parent (FamilyDecl {fdInfo = DataFamily, fdLName = L _ tc_name, fdTyVars = tvs}) @@ -750,6 +767,43 @@ tcFamDecl1 parent parent ; return [ATyCon tycon] } +-- | Maybe return a list of Bools that say whether a type family was declared +-- injective in the corresponding type arguments. Length of the list is equal to +-- the number of arguments (including implicit kind arguments). True on position +-- N means that a function is injective in its Nth argument. False means it is +-- not. +tcInjectivity :: [TyVar] -> Maybe (LInjectivityAnn Name) + -> TcM Injectivity +tcInjectivity _ Nothing + = return NotInjective + + -- User provided an injectivity annotation, so for each tyvar argument we + -- check whether a type family was declared injective in that argument. We + -- return a list of Bools, where True means that corresponding type variable + -- was mentioned in lInjNames (type family is injective in that argument) and + -- False means that it was not mentioned in lInjNames (type family is not + -- injective in that type variable). We also extend injectivity information to + -- kind variables, so if a user declares: + -- + -- type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a + -- + -- then we mark both `a` and `k1` as injective. + -- NB: the return kind is considered to be *input* argument to a type family. + -- Since injectivity allows to infer input arguments from the result in theory + -- we should always mark the result kind variable (`k3` in this example) as + -- injective. The reason is that result type has always an assigned kind and + -- therefore we can always infer the result kind if we know the result type. + -- But this does not seem to be useful in any way so we don't do it. (Another + -- reason is that the implementation would not be straightforward.) +tcInjectivity tvs (Just (L loc (InjectivityAnn _ lInjNames))) + = setSrcSpan loc $ + do { inj_tvs <- mapM tcFdTyVar lInjNames + ; let inj_ktvs = closeOverKinds (mkVarSet inj_tvs) + ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs + ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs + , ppr inj_ktvs, ppr inj_bools ]) + ; return $ Injective inj_bools } + tcTySynRhs :: RecTyInfo -> Name -> [TyVar] -> Kind @@ -760,7 +814,7 @@ tcTySynRhs rec_info tc_name tvs kind hs_ty ; rhs_ty <- tcCheckLHsType hs_ty kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty ; let roles = rti_roles rec_info tc_name - ; tycon <- buildSynonymTyCon tc_name tvs roles rhs_ty kind + tycon = buildSynonymTyCon tc_name tvs roles rhs_ty kind ; return [ATyCon tycon] } tcDataDefn :: RecTyInfo -> Name @@ -823,13 +877,10 @@ The following is an example of associated type defaults: data D a type F a b :: * - type F a Z = [a] -- Default - type F a (S n) = F a n -- Default + type F a b = [a] -- Default -Note that: - - We can have more than one default definition for a single associated type, - as long as they do not overlap (same rules as for instances) - - We can get default definitions only for type families, not data families +Note that we can get default definitions only for type families, not data +families. -} tcClassATs :: Name -- The class name (not knot-tied) @@ -1493,7 +1544,8 @@ checkValidTyCon tc | Just fam_flav <- famTyConFlav_maybe tc = case fam_flav of - { ClosedSynFamilyTyCon (Just ax) -> checkValidClosedCoAxiom ax + { ClosedSynFamilyTyCon (Just ax) -> tcAddClosedTypeFamilyDeclCtxt tc $ + checkValidCoAxiom ax ; ClosedSynFamilyTyCon Nothing -> return () ; AbstractClosedSynFamilyTyCon -> do { hsBoot <- tcIsHsBootOrSig @@ -1564,23 +1616,6 @@ checkValidTyCon tc fty2 = dataConFieldType con2 label check_fields [] = panic "checkValidTyCon/check_fields []" -checkValidClosedCoAxiom :: CoAxiom Branched -> TcM () -checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc }) - = tcAddClosedTypeFamilyDeclCtxt tc $ - do { brListFoldlM_ check_accessibility [] branches - ; void $ brListMapM (checkValidTyFamInst Nothing tc) branches } - where - check_accessibility :: [CoAxBranch] -- prev branches (in reverse order) - -> CoAxBranch -- cur branch - -> TcM [CoAxBranch] -- cur : prev - -- Check whether the branch is dominated by earlier - -- ones and hence is inaccessible - check_accessibility prev_branches cur_branch - = do { when (cur_branch `isDominatedBy` prev_branches) $ - addWarnAt (coAxBranchSpan cur_branch) $ - inaccessibleCoAxBranch tc cur_branch - ; return (cur_branch : prev_branches) } - checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet -> Type -> Type -> Type -> Type -> TcM () checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 @@ -2308,11 +2343,6 @@ wrongTyFamName fam_tc_name eqn_tc_name 2 (vcat [ ptext (sLit "Expected:") <+> ppr fam_tc_name , ptext (sLit " Actual:") <+> ppr eqn_tc_name ]) -inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc -inaccessibleCoAxBranch tc fi - = ptext (sLit "Overlapped type family instance equation:") $$ - (pprCoAxBranch tc fi) - badRoleAnnot :: Name -> Role -> Role -> SDoc badRoleAnnot var annot inferred = hang (ptext (sLit "Role mismatch on variable") <+> ppr var <> colon) diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index 18d3b32fdd..1f31d5666a 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -15,7 +15,8 @@ module TcTypeNats import Type import Pair import TcType ( TcType, tcEqType ) -import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon, TyConParent(..) ) +import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon + , Injectivity(..), TyConParent(..) ) import Coercion ( Role(..) ) import TcRnTypes ( Xi ) import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..) ) @@ -107,8 +108,10 @@ typeNatLeqTyCon = mkFamilyTyCon name (mkArrowKinds [ typeNatKind, typeNatKind ] boolKind) (mkTemplateTyVars [ typeNatKind, typeNatKind ]) + Nothing (BuiltInSynFamTyCon ops) NoParentTyCon + NotInjective where name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "<=?") @@ -124,8 +127,10 @@ typeNatCmpTyCon = mkFamilyTyCon name (mkArrowKinds [ typeNatKind, typeNatKind ] orderingKind) (mkTemplateTyVars [ typeNatKind, typeNatKind ]) + Nothing (BuiltInSynFamTyCon ops) NoParentTyCon + NotInjective where name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpNat") @@ -141,8 +146,10 @@ typeSymbolCmpTyCon = mkFamilyTyCon name (mkArrowKinds [ typeSymbolKind, typeSymbolKind ] orderingKind) (mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ]) + Nothing (BuiltInSynFamTyCon ops) NoParentTyCon + NotInjective where name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol") @@ -163,9 +170,10 @@ mkTypeNatFunTyCon2 op tcb = mkFamilyTyCon op (mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind) (mkTemplateTyVars [ typeNatKind, typeNatKind ]) + Nothing (BuiltInSynFamTyCon tcb) NoParentTyCon - + NotInjective diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 122b286243..c1b8a095e8 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -10,7 +10,9 @@ module TcValidity ( expectedKindInCtxt, checkValidTheta, checkValidFamPats, checkValidInstance, validDerivPred, - checkInstTermination, checkValidTyFamInst, checkTyFamFreeness, + checkInstTermination, + checkValidCoAxiom, checkValidCoAxBranch, + checkTyFamFreeness, checkConsistentFamInst, arityErr, badATErr ) where @@ -36,6 +38,9 @@ import TyCon import HsSyn -- HsType import TcRnMonad -- TcType, amongst others import FunDeps +import FamInstEnv ( isDominatedBy, injectiveBranches, + InjectivityCheckResult(..) ) +import FamInst ( makeInjectivityErrors ) import Name import VarEnv import VarSet @@ -999,7 +1004,7 @@ checkValidInstance ctxt hs_type ty Note [Paterson conditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Termination test: the so-called "Paterson conditions" (see Section 5 of -"Understanding functionsl dependencies via Constraint Handling Rules, +"Understanding functional dependencies via Constraint Handling Rules, JFP Jan 2007). We check that each assertion in the context satisfies: @@ -1210,12 +1215,63 @@ wrongATArgErr ty instTy = ************************************************************************ -} +checkValidCoAxiom :: CoAxiom Branched -> TcM () +checkValidCoAxiom (CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) + = do { _ <- brListMapM (checkValidCoAxBranch Nothing fam_tc) branches + ; brListFoldlM_ check_branch_compat [] branches } + where + injectivity = familyTyConInjectivityInfo fam_tc + + check_branch_compat :: [CoAxBranch] -- previous branches in reverse order + -> CoAxBranch -- current branch + -> TcM [CoAxBranch]-- current branch : previous branches + -- Check for + -- (a) this banch is dominated by previous ones + -- (b) failure of injectivity + check_branch_compat prev_branches cur_branch + | cur_branch `isDominatedBy` prev_branches + = do { addWarnAt (coAxBranchSpan cur_branch) $ + inaccessibleCoAxBranch fam_tc cur_branch + ; return prev_branches } + | otherwise + = do { check_injectivity prev_branches cur_branch + ; return (cur_branch : prev_branches) } + + -- Injectivity check: check whether a new (CoAxBranch) can extend + -- already checked equations without violating injectivity + -- annotation supplied by the user. + -- See Note [Verifying injectivity annotation] in FamInstEnv + check_injectivity prev_branches cur_branch + | Injective inj <- injectivity + = do { let conflicts = + fst $ foldl (gather_conflicts inj prev_branches cur_branch) + ([], 0) prev_branches + ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) + (makeInjectivityErrors fam_tc cur_branch inj conflicts) } + | otherwise + = return () + + gather_conflicts inj prev_branches cur_branch (acc, n) branch + -- n is 0-based index of branch in prev_branches + = case injectiveBranches inj cur_branch branch of + InjectivityUnified ax1 ax2 + | ax1 `isDominatedBy` (replace_br prev_branches n ax2) + -> (acc, n + 1) + | otherwise + -> (branch : acc, n + 1) + InjectivityAccepted -> (acc, n + 1) + + -- Replace n-th element in the list. Assumes 0-based indexing. + replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch] + replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs + + -- Check that a "type instance" is well-formed (which includes decidability -- unless -XUndecidableInstances is given). -- -checkValidTyFamInst :: Maybe ( Class, VarEnv Type ) +checkValidCoAxBranch :: Maybe ( Class, VarEnv Type ) -> TyCon -> CoAxBranch -> TcM () -checkValidTyFamInst mb_clsinfo fam_tc +checkValidCoAxBranch mb_clsinfo fam_tc (CoAxBranch { cab_tvs = tvs, cab_lhs = typats , cab_rhs = rhs, cab_loc = loc }) = setSrcSpan loc $ @@ -1295,6 +1351,14 @@ isTyFamFree = null . tcTyFamInsts -- Error messages +inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc +inaccessibleCoAxBranch fam_tc (CoAxBranch { cab_tvs = tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + = ptext (sLit "Type family instance equation is overlapped:") $$ + hang (pprUserForAll tvs) + 2 (hang (pprTypeApp fam_tc lhs) 2 (equals <+> (ppr rhs))) + tyFamInstIllegalErr :: Type -> SDoc tyFamInstIllegalErr ty = hang (ptext (sLit "Illegal type synonym family application in instance") <> diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs index 9a85185cc6..66cec4c6ac 100644 --- a/compiler/types/CoAxiom.hs +++ b/compiler/types/CoAxiom.hs @@ -1,6 +1,7 @@ -- (c) The University of Glasgow 2012 -{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures, ScopedTypeVariables, StandaloneDeriving #-} +{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures, + ScopedTypeVariables, StandaloneDeriving #-} -- | Module for coercion axioms, used to represent type family instances -- and newtypes @@ -9,6 +10,7 @@ module CoAxiom ( BranchFlag, Branched, Unbranched, BranchIndex, BranchList(..), toBranchList, fromBranchList, toBranchedList, toUnbranchedList, + brFromUnbranchedSingleton, brListLength, brListNth, brListMap, brListFoldr, brListMapM, brListFoldlM_, brListZipWith, @@ -55,7 +57,7 @@ from the axiom. For example, consider the axiom derived from the following declaration: -type instance where +type family F a where F [Int] = Bool F [a] = Double F (a b) = Char @@ -81,7 +83,7 @@ can unify with the supplied arguments. After all, it is possible that some of the type arguments are lambda-bound type variables whose instantiation may cause an earlier match among the branches. We wish to prohibit this behavior, so the type checker rules out the choice of a branch where a previous branch -can unify. See also [Branched instance checking] in FamInstEnv.hs. +can unify. See also [Apartness] in FamInstEnv.hs. For example, the following is malformed, where 'a' is a lambda-bound type variable: @@ -93,7 +95,7 @@ apply, not branch 2. This is a vital consistency check; without it, we could derive Int ~ Bool, and that is a Bad Thing. Note [Branched axioms] -~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~ Although a CoAxiom has the capacity to store many branches, in certain cases, we want only one. These cases are in data/newtype family instances, newtype coercions, and type family instances declared with "type instance ...", not @@ -132,6 +134,8 @@ data BranchList a (br :: BranchFlag) where FirstBranch :: a -> BranchList a br NextBranch :: a -> BranchList a br -> BranchList a Branched +deriving instance Typeable BranchList + -- convert to/from lists toBranchList :: [a] -> BranchList a Branched toBranchList [] = pprPanic "toBranchList" empty @@ -152,6 +156,10 @@ toUnbranchedList :: BranchList a br -> BranchList a Unbranched toUnbranchedList (FirstBranch b) = FirstBranch b toUnbranchedList _ = pprPanic "toUnbranchedList" empty +-- Extract a singleton axiom from Unbranched BranchList +brFromUnbranchedSingleton :: BranchList a Unbranched -> a +brFromUnbranchedSingleton (FirstBranch b) = b + -- length brListLength :: BranchList a br -> Int brListLength (FirstBranch _) = 1 @@ -257,7 +265,7 @@ data CoAxBranch , cab_incomps :: [CoAxBranch] -- The previous incompatible branches -- See Note [Storing compatibility] } - deriving Typeable + deriving ( Data.Data, Data.Typeable ) toBranchedAxiom :: CoAxiom br -> CoAxiom Branched toBranchedAxiom (CoAxiom unique name role tc branches implicit) diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index 80fdcc6430..5d4329d5ff 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -188,7 +188,8 @@ data Coercion -- These are destructors - | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + -- and (F t0 ... tn), assuming F is injective. -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles]) -- See Note [NthCo and newtypes] diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index 11e93df9cf..98222362cb 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -19,8 +19,14 @@ module FamInstEnv ( computeAxiomIncomps, FamInstMatch(..), - lookupFamInstEnv, lookupFamInstEnvConflicts, - isDominatedBy, + lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, + + isDominatedBy, apartnessCheck, + + -- Injectivity + InjectivityCheckResult(..), + lookupFamInstEnvInjectivityConflicts, unusedInjTvsInRHS, isTFHeaded, + bareTvInRHSViolated, injectiveBranches, -- Normalisation topNormaliseType, topNormaliseType_maybe, @@ -80,8 +86,9 @@ Note [FamInsts and CoAxioms] -} data FamInst -- See Note [FamInsts and CoAxioms] - = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom introduced - -- by this family instance + = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom + -- introduced by this family + -- instance , fi_flavor :: FamFlavor -- Everything below here is a redundant, @@ -94,14 +101,14 @@ data FamInst -- See Note [FamInsts and CoAxioms] , fi_tcs :: [Maybe Name] -- Top of type args -- INVARIANT: fi_tcs = roughMatchTcs fi_tys - -- Used for "proper matching"; ditto + -- Used for "proper matching"; ditto , fi_tvs :: [TyVar] -- Template tyvars for full match -- Like ClsInsts, these variables are always -- fresh. See Note [Template tyvars are fresh] -- in InstEnv + -- INVARIANT: fi_tvs = coAxiomTyVars fi_axiom , fi_tys :: [Type] -- and its arg types - -- INVARIANT: fi_tvs = coAxiomTyVars fi_axiom , fi_rhs :: Type -- the RHS, with its freshened vars } @@ -441,8 +448,7 @@ potentially-overlapping group is closed. As another example, consider this: -type family G x -type instance where +type family G x where G Int = Bool G a = Double @@ -480,6 +486,44 @@ compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) -> True _ -> False +-- | Result of testing two type family equations for injectiviy. +data InjectivityCheckResult + = InjectivityAccepted + -- ^ Either RHSs are distinct or unification of RHSs leads to unification of + -- LHSs + | InjectivityUnified CoAxBranch CoAxBranch + -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for + -- closed type families where equation after unification might be + -- overlpapped (in which case it is OK if they don't unify). Constructor + -- stores axioms after unification. + +-- | Check whether two type family axioms don't violate injectivity annotation. +injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch + -> InjectivityCheckResult +injectiveBranches injectivity + ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + -- See Note [Verifying injectivity annotation]. This function implements first + -- check described there. + = let getInjArgs = filterByList injectivity + in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification + Nothing -> InjectivityAccepted -- RHS are different, so equations are + -- injective. + Just subst -> -- RHS unify under a substitution + let lhs1Subst = Type.substTys subst (getInjArgs lhs1) + lhs2Subst = Type.substTys subst (getInjArgs lhs2) + -- If LHSs are equal under the substitution used for RHSs then this pair + -- of equations does not violate injectivity annotation. If LHSs are not + -- equal under that substitution then this pair of equations violates + -- injectivity annotation, but for closed type families it still might + -- be the case that one LHS after substitution is unreachable. + in if eqTypes lhs1Subst lhs2Subst + then InjectivityAccepted + else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 + , cab_rhs = Type.substTy subst rhs1 }) + ( ax2 { cab_lhs = Type.substTys subst lhs2 + , cab_rhs = Type.substTy subst rhs2 }) + -- takes a CoAxiom with unknown branch incompatibilities and computes -- the compatibilities -- See Note [Storing compatibility] in CoAxiom @@ -604,6 +648,14 @@ instance Outputable FamInstMatch where , fim_tys = tys }) = ptext (sLit "match with") <+> parens (ppr inst) <+> ppr tys +lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] +lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc + = get pkg_ie ++ get home_ie + where + get ie = case lookupUFM ie fam_tc of + Nothing -> [] + Just (FamIE fis) -> fis + lookupFamInstEnv :: FamInstEnvs -> TyCon -> [Type] -- What we are looking for @@ -646,6 +698,202 @@ lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) noSubst = panic "lookupFamInstEnvConflicts noSubst" new_branch = coAxiomSingleBranch new_axiom +-------------------------------------------------------------------------------- +-- Type family injectivity checking bits -- +-------------------------------------------------------------------------------- + +{- Note [Verifying injectivity annotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Injectivity means that the RHS of a type family uniquely determines the LHS (see +Note [Type inference for type families with injectivity]). User informs about +injectivity using an injectivity annotation and it is GHC's task to verify that +that annotation is correct wrt. to type family equations. Whenever we see a new +equation of a type family we need to make sure that adding this equation to +already known equations of a type family does not violate injectivity annotation +supplied by the user (see Note [Injectivity annotation]). Of course if the type +family has no injectivity annotation then no check is required. But if a type +family has injectivity annotation we need to make sure that the following +conditions hold: + +1. For each pair of *different* equations of a type family, one of the following + conditions holds: + + A: RHSs are different. + + B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution + then it must be possible to unify the LHSs under the same substitution. + Example: + + type family FunnyId a = r | r -> a + type instance FunnyId Int = Int + type instance FunnyId a = a + + RHSs of these two equations unify under [ a |-> Int ] substitution. + Under this substitution LHSs are equal therefore these equations don't + violate injectivity annotation. + + B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some + substitution then either the LHSs unify under the same substitution or + the LHS of the latter equation is overlapped by earlier equations. + Example 1: + + type family SwapIntChar a = r | r -> a where + SwapIntChar Int = Char + SwapIntChar Char = Int + SwapIntChar a = a + + Say we are checking the last two equations. RHSs unify under [ a |-> + Int ] substitution but LHSs don't. So we apply the substitution to LHS + of last equation and check whether it is overlapped by any of previous + equations. Since it is overlapped by the first equation we conclude + that pair of last two equations does not violate injectivity + annotation. + + A special case of B is when RHSs unify with an empty substitution ie. they + are identical. + + If any of the above two conditions holds we conclude that the pair of + equations does not violate injectivity annotation. But if we find a pair + of equations where neither of the above holds we report that this pair + violates injectivity annotation because for a given RHS we don't have a + unique LHS. (Note that (B) actually implies (A).) + + Note that we only take into account these LHS patterns that were declared + as injective. + +2. If a RHS of a type family equation is a bare type variable then + all LHS variables (including implicit kind variables) also have to be bare. + In other words, this has to be a sole equation of that type family and it has + to cover all possible patterns. So for example this definition will be + rejected: + + type family W1 a = r | r -> a + type instance W1 [a] = a + + If it were accepted we could call `W1 [W1 Int]`, which would reduce to + `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`, + which is bogus. + +3. If a RHS of a type family equation is a type family application then the type + family is rejected as not injective. + +4. If a LHS type variable that is declared as injective is not mentioned on + injective position in the RHS then the type family is rejected as not + injective. "Injective position" means either an argument to a type + constructor or argument to a type family on injective position. + +See also Note [Injective type families] in TyCon +-} + + +-- | Check whether an open type family equation can be added to already existing +-- instance environment without causing conflicts with supplied injectivity +-- annotations. Returns list of conflicting axioms (type instance +-- declarations). +lookupFamInstEnvInjectivityConflicts + :: [Bool] -- injectivity annotation for this type family instance + -- INVARIANT: list contains at least one True value + -> FamInstEnvs -- all type instances seens so far + -> FamInst -- new type instance that we're checking + -> [CoAxBranch] -- conflicting instance delcarations +lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) + fam_inst@(FamInst { fi_axiom = new_axiom }) + -- See Note [Verifying injectivity annotation]. This function implements + -- check (1.B1) for open type families described there. + = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie + where + fam = famInstTyCon fam_inst + new_branch = coAxiomSingleBranch new_axiom + + -- filtering function used by `lookup_inj_fam_conflicts` to check whether + -- a pair of equations conflicts with the injectivity annotation. + isInjConflict (FamInst { fi_axiom = old_axiom }) + | InjectivityAccepted <- + injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch + = False -- no conflict + | otherwise = True + + lookup_inj_fam_conflicts ie + | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUFM ie fam + = map (brFromUnbranchedSingleton . co_ax_branches . fi_axiom) $ + filter isInjConflict insts + | otherwise = [] + + +-- | Return a list of type variables that the function is injective in and that +-- do not appear on injective positions in the RHS of a family instance +-- declaration. +unusedInjTvsInRHS :: [Bool] -> [Type] -> Type -> TyVarSet +-- INVARIANT: [Bool] list contains at least one True value +-- See Note [Verifying injectivity annotation]. This function implements fourth +-- check described there. +-- In theory, instead of implementing this whole check in this way, we could +-- attempt to unify equation with itself. We would reject exactly the same +-- equations but this method gives us more precise error messages by returning +-- precise names of variables that are not mentioned in the RHS. +unusedInjTvsInRHS injList lhs rhs = + injLHSVars `minusVarSet` injRhsVars + where + -- set of type and kind variables in which type family is injective + injLHSVars = tyVarsOfTypes (filterByList injList lhs) + + -- set of type variables appearing in the RHS on an injective position. + -- For all returned variables we assume their associated kind variables + -- also appear in the RHS. + injRhsVars = closeOverKinds $ collectInjVars rhs + + -- Collect all type variables that are either arguments to a type + -- constructor or to injective type families. + collectInjVars :: Type -> VarSet + collectInjVars ty | Just (ty1, ty2) <- splitAppTy_maybe ty + = collectInjVars ty1 `unionVarSet` collectInjVars ty2 + collectInjVars (TyVarTy v) + = unitVarSet v + collectInjVars (TyConApp tc tys) + | isTypeFamilyTyCon tc = collectInjTFVars tys + (familyTyConInjectivityInfo tc) + | otherwise = mapUnionVarSet collectInjVars tys + collectInjVars (LitTy {}) + = emptyVarSet + collectInjVars (FunTy arg res) + = collectInjVars arg `unionVarSet` collectInjVars res + collectInjVars (AppTy fun arg) + = collectInjVars fun `unionVarSet` collectInjVars arg + -- no forall types in the RHS of a type family + collectInjVars (ForAllTy _ _) = + panic "unusedInjTvsInRHS.collectInjVars" + + collectInjTFVars :: [Type] -> Injectivity -> VarSet + collectInjTFVars _ NotInjective + = emptyVarSet + collectInjTFVars tys (Injective injList) + = mapUnionVarSet collectInjVars (filterByList injList tys) + +-- | Is type headed by a type family application? +isTFHeaded :: Type -> Bool +-- See Note [Verifying injectivity annotation]. This function implements third +-- check described there. +isTFHeaded ty | Just ty' <- tcView ty + = isTFHeaded ty' +isTFHeaded ty | (TyConApp tc args) <- ty + , isTypeFamilyTyCon tc + = tyConArity tc == length args +isTFHeaded _ = False + +-- | If a RHS is a bare type variable return a set of LHS patterns that are not +-- bare type variables. +bareTvInRHSViolated :: [Type] -> Type -> [Type] +-- See Note [Verifying injectivity annotation]. This function implements second +-- check described there. +bareTvInRHSViolated pats rhs | isTyVarTy rhs + = filter (not . isTyVarTy) pats +bareTvInRHSViolated _ _ = [] + +-------------------------------------------------------------------------------- +-- Type family overlap checking bits -- +-------------------------------------------------------------------------------- + {- Note [Family instance overlap conflicts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -721,8 +969,8 @@ lookup_fam_inst_env' match_fun ie fam match_tys lookup_fam_inst_env -- The worker, local to this module :: MatchFun -> FamInstEnvs - -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -- Successful matches + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches -- Precondition: the tycon is saturated (or over-saturated) @@ -814,7 +1062,6 @@ reduceTyFamApp_maybe envs role tc tys , FamInstMatch { fim_instance = fam_inst , fim_tys = inst_tys } : _ <- lookupFamInstEnv envs tc tys -- NB: Allow multiple matches because of compatible overlap - = let ax = famInstAxiom fam_inst co = mkUnbranchedAxInstCo role ax inst_tys ty = pSnd (coercionKind co) @@ -840,37 +1087,53 @@ chooseBranch axiom tys = do { let num_pats = coAxiomNumPats axiom (target_tys, extra_tys) = splitAt num_pats tys branches = coAxiomBranches axiom - ; (ind, inst_tys) <- findBranch (fromBranchList branches) 0 target_tys + ; (ind, inst_tys) <- findBranch (fromBranchList branches) target_tys ; return (ind, inst_tys ++ extra_tys) } -- The axiom must *not* be oversaturated findBranch :: [CoAxBranch] -- branches to check - -> BranchIndex -- index of current branch -> [Type] -- target types -> Maybe (BranchIndex, [Type]) -findBranch (CoAxBranch { cab_tvs = tpl_tvs, cab_lhs = tpl_lhs, cab_incomps = incomps } - : rest) ind target_tys - = case tcMatchTys (mkVarSet tpl_tvs) tpl_lhs target_tys of - Just subst -- matching worked. now, check for apartness. - | all (isSurelyApart - . tcUnifyTysFG instanceBindFun flattened_target - . coAxBranchLHS) incomps - -> -- matching worked & we're apart from all incompatible branches. success - Just (ind, substTyVars subst tpl_tvs) - - -- failure. keep looking - _ -> findBranch rest (ind+1) target_tys - - where isSurelyApart SurelyApart = True - isSurelyApart _ = False - - -- See Note [Flattening] below - flattened_target = flattenTys in_scope target_tys - in_scope = mkInScopeSet (unionVarSets $ - map (tyVarsOfTypes . coAxBranchLHS) incomps) - --- fail if no branches left -findBranch [] _ _ = Nothing +findBranch branches target_tys + = go 0 branches + where + go ind (branch@(CoAxBranch { cab_tvs = tpl_tvs, cab_lhs = tpl_lhs + , cab_incomps = incomps }) : rest) + = let in_scope = mkInScopeSet (unionVarSets $ + map (tyVarsOfTypes . coAxBranchLHS) incomps) + -- See Note [Flattening] below + flattened_target = flattenTys in_scope target_tys + in case tcMatchTys (mkVarSet tpl_tvs) tpl_lhs target_tys of + Just subst -- matching worked. now, check for apartness. + | apartnessCheck flattened_target branch + -> -- matching worked & we're apart from all incompatible branches. + -- success + Just (ind, substTyVars subst tpl_tvs) + + -- failure. keep looking + _ -> go (ind+1) rest + + -- fail if no branches left + go _ [] = Nothing + +-- | Do an apartness check, as described in the "Closed Type Families" paper +-- (POPL '14). This should be used when determining if an equation +-- ('CoAxBranch') of a closed type family can be used to reduce a certain target +-- type family application. +apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure + -- they're flattened! See Note [Flattening]. + -- (NB: This "flat" is a different + -- "flat" than is used in TcFlatten.) + -> CoAxBranch -- ^ the candidate equation we wish to use + -- Precondition: this matches the target + -> Bool -- ^ True <=> equation can fire +apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) + = all (isSurelyApart + . tcUnifyTysFG instanceBindFun flattened_target + . coAxBranchLHS) incomps + where + isSurelyApart SurelyApart = True + isSurelyApart _ = False {- ************************************************************************ diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs index e65c834efc..342cab503c 100644 --- a/compiler/types/Kind.hs +++ b/compiler/types/Kind.hs @@ -19,7 +19,7 @@ module Kind ( pprKind, pprParendKind, -- ** Deconstructing Kinds - kindAppResult, synTyConResKind, + kindAppResult, tyConResKind, splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe, -- ** Predicates on Kinds @@ -119,13 +119,14 @@ splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of (as, k) -> (a:as, k) splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) --- | Find the result 'Kind' of a type synonym, +-- | Find the result 'Kind' of a type synonym or a type family, -- after applying it to its 'arity' number of type variables -- Actually this function works fine on data types too, -- but they'd always return '*', so we never need to ask -synTyConResKind :: TyCon -> Kind -synTyConResKind tycon = kindAppResult (ptext (sLit "synTyConResKind") <+> ppr tycon) - (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon)) +tyConResKind :: TyCon -> Kind +tyConResKind tycon = + kindAppResult (ptext (sLit "tyConResKind") <+> ppr tycon) + (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon)) -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's isOpenTypeKind, isUnliftedTypeKind, diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs index 35d178122f..e112a20bf2 100644 --- a/compiler/types/OptCoercion.hs +++ b/compiler/types/OptCoercion.hs @@ -534,8 +534,8 @@ the surface, it seems that (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~ False) and that all is OK. But, all is not OK: we want to use the first branch of the axiom in this case, not the second. The problem is that the parameters of the first branch can unify with the supplied coercions, thus meaning that -the first branch should be taken. See also Note [Branched instance checking] -in types/FamInstEnv.hs. +the first branch should be taken. See also Note [Apartness] in +types/FamInstEnv.hs. Note [Why call checkAxInstCo during optimisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 683c939a8a..c10c7bab49 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -14,7 +14,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, - FamTyConFlav(..), Role(..), + FamTyConFlav(..), Role(..), Injectivity(..), -- ** Constructing TyCons mkAlgTyCon, @@ -47,6 +47,7 @@ module TyCon( isFamilyTyCon, isOpenFamilyTyCon, isTypeFamilyTyCon, isDataFamilyTyCon, isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, + familyTyConInjectivityInfo, isBuiltInSynFamTyCon_maybe, isUnLiftedTyCon, isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, @@ -71,7 +72,9 @@ module TyCon( tyConFlavour, tyConTuple_maybe, tyConClass_maybe, tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, - synTyConDefn_maybe, synTyConRhs_maybe, famTyConFlav_maybe, + tyConFamilyResVar_maybe, + synTyConDefn_maybe, synTyConRhs_maybe, + famTyConFlav_maybe, famTcResVar, algTyConRhs, newTyConRhs, newTyConEtadArity, newTyConEtadRhs, unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, @@ -98,6 +101,7 @@ module TyCon( import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars ) +import Binary import Var import Class import BasicTypes @@ -152,9 +156,7 @@ Note [Type synonym families] a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the appropriate CoAxiom representing the equations -* In the future we might want to support - * injective type families (allow decomposition) - but we don't at the moment [2013] +We also support injective type families -- see Note [Injective type families] Note [Data type families] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -301,6 +303,28 @@ it's worth noting that (~#)'s parameters are at role N. Promoted data constructors' type arguments are at role R. All kind arguments are at role N. +Note [Injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We allow injectivity annotations for type families (both open and closed): + + type family F (a :: k) (b :: k) = r | r -> a + type family G a b = res | res -> a b where ... + +Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. +`famTcInj` maybe stores a list of Bools, where each entry corresponds to a +single element of `tyConTyVars` (both lists should have identical length). If no +injectivity annotation was provided `famTcInj` is Nothing. From this follows an +invariant that if `famTcInj` is a Just then at least one element in the list +must be True. + +See also: + * [Injectivity annotation] in HsDecls + * [Renaming injectivity annotation] in RnSource + * [Verifying injectivity annotation] in FamInstEnv + * [Type inference for type families with injectivity] in TcInteract + + ************************************************************************ * * \subsection{The data type} @@ -457,19 +481,27 @@ data TyCon -- Precisely, this list scopes over: -- -- 1. The 'algTcStupidTheta' - -- 2. The cached types in 'algTyConRhs.NewTyCon' + -- 2. The cached types in algTyConRhs.NewTyCon -- 3. The family instance types if present -- -- Note that it does /not/ scope over the data -- constructors. + famTcResVar :: Maybe Name, -- ^ Name of result type variable, used + -- for pretty-printing with --show-iface + -- and for reifying TyCon in Template + -- Haskell + famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, -- abstract, built-in. See comments for -- FamTyConFlav - famTcParent :: TyConParent -- ^ TyCon of enclosing class for + famTcParent :: TyConParent, -- ^ TyCon of enclosing class for -- associated type families + famTcInj :: Injectivity -- ^ is this a type family injective in + -- its type variables? Nothing if no + -- injectivity annotation was given } -- | Primitive types; cannot be defined in Haskell. This includes @@ -696,6 +728,11 @@ isNoParent _ = False -------------------- +data Injectivity + = NotInjective + | Injective [Bool] -- Length is 1-1 with tyConTyVars (incl kind vars) + deriving( Eq ) + -- | Information pertaining to the expansion of a type synonym (@type@) data FamTyConFlav = -- | An open type synonym family e.g. @type family F x y :: * -> *@ @@ -1111,17 +1148,19 @@ mkSynonymTyCon name kind tyvars roles rhs } -- | Create a type family 'TyCon' -mkFamilyTyCon:: Name -> Kind -> [TyVar] -> FamTyConFlav -> TyConParent - -> TyCon -mkFamilyTyCon name kind tyvars flav parent +mkFamilyTyCon:: Name -> Kind -> [TyVar] -> Maybe Name -> FamTyConFlav + -> TyConParent -> Injectivity -> TyCon +mkFamilyTyCon name kind tyvars resVar flav parent inj = FamilyTyCon { tyConUnique = nameUnique name , tyConName = name , tyConKind = kind , tyConArity = length tyvars , tyConTyVars = tyvars + , famTcResVar = resVar , famTcFlav = flav , famTcParent = parent + , famTcInj = inj } @@ -1381,6 +1420,7 @@ isTypeFamilyTyCon :: TyCon -> Bool isTypeFamilyTyCon (FamilyTyCon {}) = True isTypeFamilyTyCon _ = False +-- | Is this an open type family TyCon? isOpenTypeFamilyTyCon :: TyCon -> Bool isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True isOpenTypeFamilyTyCon _ = False @@ -1392,6 +1432,12 @@ isClosedSynFamilyTyConWithAxiom_maybe (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing +-- | Try to read the injectivity information from a FamilyTyCon. Only +-- FamilyTyCons can be injective so for every other TyCon this function panics. +familyTyConInjectivityInfo :: TyCon -> Injectivity +familyTyConInjectivityInfo (FamilyTyCon { famTcInj = inj }) = inj +familyTyConInjectivityInfo _ = panic "familyTyConInjectivityInfo" + isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily isBuiltInSynFamTyCon_maybe (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops @@ -1607,6 +1653,11 @@ algTyConRhs :: TyCon -> AlgTyConRhs algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs algTyConRhs other = pprPanic "algTyConRhs" (ppr other) +-- | Extract type variable naming the result of injective type family +tyConFamilyResVar_maybe :: TyCon -> Maybe Name +tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res +tyConFamilyResVar_maybe _ = Nothing + -- | Get the list of roles for the type parameters of a TyCon tyConRoles :: TyCon -> [Role] -- See also Note [TyCon Role signatures] @@ -1803,6 +1854,16 @@ instance Data.Data TyCon where gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "TyCon" +instance Binary Injectivity where + put_ bh NotInjective = putByte bh 0 + put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs + + get bh = do { h <- getByte bh + ; case h of + 0 -> return NotInjective + _ -> do { xs <- get bh + ; return (Injective xs) } } + {- ************************************************************************ * * diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs index 291e14ccc1..b732247b3d 100644 --- a/compiler/types/TypeRep.hs +++ b/compiler/types/TypeRep.hs @@ -15,7 +15,8 @@ Note [The Type-related module hierarchy] Coercion imports Type -} -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable, DataKinds #-} {-# OPTIONS_HADDOCK hide #-} -- We expose the relevant stuff from this module via the Type module @@ -82,7 +83,7 @@ import StaticFlags( opt_PprStyle_Debug ) -- libraries import Data.List( mapAccumL, partition ) -import qualified Data.Data as Data hiding ( TyCon ) +import qualified Data.Data as Data hiding ( TyCon ) {- ************************************************************************ @@ -305,9 +306,7 @@ isKindVar v = isTKVar v && isSuperKind (varType v) tyVarsOfType :: Type -> VarSet -- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym --- tyVarsOfType returns only the free variables of a type --- For example, tyVarsOfType (a::k) returns {a}, not including the --- kind variable {k} +-- tyVarsOfType returns free variables of a type, including kind variables. tyVarsOfType (TyVarTy v) = unitVarSet v tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys tyVarsOfType (LitTy {}) = emptyVarSet @@ -407,7 +406,7 @@ instance NamedThing TyThing where -- Can't put this with the type -- the in-scope set is not relevant -- -- 3. The substitution is only applied ONCE! This is because --- in general such application will not reached a fixed point. +-- in general such application will not reach a fixed point. data TvSubst = TvSubst InScopeSet -- The in-scope type and kind variables TvSubstEnv -- Substitutes both type and kind variables diff --git a/compiler/types/TypeRep.hs-boot b/compiler/types/TypeRep.hs-boot index e4117de3da..42b8a7086a 100644 --- a/compiler/types/TypeRep.hs-boot +++ b/compiler/types/TypeRep.hs-boot @@ -1,6 +1,7 @@ module TypeRep where import Outputable (Outputable) +import Data.Data (Data,Typeable) data Type data TyThing @@ -11,3 +12,5 @@ type SuperKind = Type type ThetaType = [PredType] instance Outputable Type +instance Typeable Type +instance Data Type diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index fa80584df0..b816558a02 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -6,7 +6,7 @@ module Unify ( -- Matching of types: -- the "tc" prefix indicates that matching always -- respects newtypes (rather than looking through them) - tcMatchTy, tcMatchTys, tcMatchTyX, tcMatchTysX, + tcMatchTy, tcUnifyTyWithTFs, tcMatchTys, tcMatchTyX, tcMatchTysX, ruleMatchTyX, tcMatchPreds, MatchEnv(..), matchList, @@ -29,8 +29,9 @@ import Kind import Type import TyCon import TypeRep +import Util ( filterByList ) -import Control.Monad (liftM, ap) +import Control.Monad (liftM, foldM, ap) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative(..)) #endif @@ -390,6 +391,62 @@ tcUnifyTy ty1 ty2 Unifiable subst -> Just subst _other -> Nothing +-- | Unify two types, treating type family applications as possibly unifying +-- with anything and looking through injective type family applications. +tcUnifyTyWithTFs :: Bool -> Type -> Type -> Maybe TvSubst +-- This algorithm is a direct implementation of the "Algorithm U" presented in +-- the paper "Injective type families for Haskell", Figures 2 and 3. Equation +-- numbers in the comments refer to equations from the paper. +tcUnifyTyWithTFs twoWay t1 t2 = niFixTvSubst `fmap` go t1 t2 emptyTvSubstEnv + where + go :: Type -> Type -> TvSubstEnv -> Maybe TvSubstEnv + -- look through type synonyms + go t1 t2 theta | Just t1' <- tcView t1 = go t1' t2 theta + go t1 t2 theta | Just t2' <- tcView t2 = go t1 t2' theta + -- proper unification + go (TyVarTy tv) t2 theta + -- Equation (1) + | Just t1' <- lookupVarEnv theta tv + = go t1' t2 theta + | otherwise = let t2' = Type.substTy (niFixTvSubst theta) t2 + in if tv `elemVarEnv` tyVarsOfType t2' + -- Equation (2) + then Just theta + -- Equation (3) + else Just $ extendVarEnv theta tv t2' + -- Equation (4) + go t1 t2@(TyVarTy _) theta | twoWay = go t2 t1 theta + -- Equation (5) + go (AppTy s1 s2) ty theta | Just(t1, t2) <- splitAppTy_maybe ty = + go s1 t1 theta >>= go s2 t2 + go ty (AppTy s1 s2) theta | Just(t1, t2) <- splitAppTy_maybe ty = + go s1 t1 theta >>= go s2 t2 + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) theta + -- Equation (6) + | isAlgTyCon tc1 && isAlgTyCon tc2 && tc1 == tc2 + = let tys = zip tys1 tys2 + in foldM (\theta' (t1,t2) -> go t1 t2 theta') theta tys + + -- Equation (7) + | isTypeFamilyTyCon tc1 && isTypeFamilyTyCon tc2 && tc1 == tc2 + , Injective inj <- familyTyConInjectivityInfo tc1 + = let tys1' = filterByList inj tys1 + tys2' = filterByList inj tys2 + injTys = zip tys1' tys2' + in foldM (\theta' (t1,t2) -> go t1 t2 theta') theta injTys + + -- Equations (8) + | isTypeFamilyTyCon tc1 + = Just theta + + -- Equations (9) + | isTypeFamilyTyCon tc2, twoWay + = Just theta + + -- Equation (10) + go _ _ _ = Nothing + ----------------- tcUnifyTys :: (TyVar -> BindFlag) -> [Type] -> [Type] diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 93645d38fe..cb42d75327 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -32,7 +32,8 @@ module Outputable ( sep, cat, fsep, fcat, hang, punctuate, ppWhen, ppUnless, - speakNth, speakNTimes, speakN, speakNOf, plural, isOrAre, + speakNth, speakNTimes, speakN, speakNOf, plural, + thirdPerson, isOrAre, doOrDoes, coloured, PprColour, colType, colCoerc, colDataCon, colBinder, bold, keyword, @@ -994,6 +995,16 @@ plural :: [a] -> SDoc plural [_] = empty -- a bit frightening, but there you are plural _ = char 's' +-- | Determines the suffix to use in 3rd person singular depending on the length +-- of a list: +-- +-- > thirdPerson [] = empty +-- > thirdPerson ["Hello"] = char 's' +-- > thirdPerson ["Hello", "World"] = empty +thirdPerson :: [a] -> SDoc +thirdPerson [_] = char 's' +thirdPerson _ = empty + -- | Determines the form of to be appropriate for the length of a list: -- -- > isOrAre [] = ptext (sLit "are") @@ -1003,6 +1014,15 @@ isOrAre :: [a] -> SDoc isOrAre [_] = ptext (sLit "is") isOrAre _ = ptext (sLit "are") +-- | Determines the form of to do appropriate for the length of a list: +-- +-- > doOrDoes [] = ptext (sLit "do") +-- > doOrDoes ["Hello"] = ptext (sLit "does") +-- > doOrDoes ["Hello", "World"] = ptext (sLit "do") +doOrDoes :: [a] -> SDoc +doOrDoes [_] = ptext (sLit "does") +doOrDoes _ = ptext (sLit "do") + {- ************************************************************************ * * diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs index e24c7173b4..db578c37d0 100644 --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs @@ -54,6 +54,7 @@ module UniqFM ( minusUFM, intersectUFM, intersectUFM_C, + disjointUFM, foldUFM, foldUFM_Directly, mapUFM, mapUFM_Directly, elemUFM, elemUFM_Directly, @@ -164,6 +165,7 @@ minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt intersectUFM_C :: (elt1 -> elt2 -> elt3) -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3 +disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a @@ -262,6 +264,7 @@ plusUFM_CD f (UFM xm) dx (UFM ym) dy minusUFM (UFM x) (UFM y) = UFM (M.difference x y) intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) +disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y) foldUFM k z (UFM m) = M.fold k z m foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m diff --git a/docs/users_guide/7.12.1-notes.xml b/docs/users_guide/7.12.1-notes.xml index fa3ea0197d..5a6670df75 100644 --- a/docs/users_guide/7.12.1-notes.xml +++ b/docs/users_guide/7.12.1-notes.xml @@ -34,6 +34,7 @@ TODO FIXME. </para> </listitem> + <listitem> <para> The parser now supports Haddock comments on GADT data constructors. For example, @@ -70,6 +71,7 @@ <literal>CallStack</literal> type. </para> </listitem> + <listitem> <para> To conform to the common case, the default role assigned to parameters @@ -90,6 +92,14 @@ linkend="data-instance-declarations"/> for more details. </para> </listitem> + + <listitem> + <para> + GHC now allows to declare type families as injective. + Injectivity information can then be used by the typechecker. + See <xref linkend="injective-ty-fams"/> for details. + </para> + </listitem> </itemizedlist> </sect3> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 1a4fbdbb81..931706b955 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -6892,6 +6892,111 @@ instance Show v => Show (GMap () v) where ... </sect2> + <sect2 id="injective-ty-fams"> + <title>Injective type families</title> + <para>Starting with GHC 7.12 type families can be annotated with injectivity + information. This information is then used by GHC during type checking to + resolve type ambiguities in situations where a type variable appears only + under type family applications. + </para> + + <para>For full details on injective type families refer to Haskell Symposium + 2015 paper <ulink + url="http://ics.p.lodz.pl/~stolarek/_media/pl:research:stolarek_peyton-jones_eisenberg_injectivity_extended.pdf">Injective + type families for Haskell</ulink>.</para> + + <sect3 id="injective-ty-fams-syntax"> + <title>Syntax of injectivity annotation</title> + <para>Injectivity annotation is added after type family head and consists of + two parts: + <itemizedlist> + <listitem><para>type variable that names the result of a type family. + Syntax: <literal>= tyvar</literal> or <literal>= (tyvar :: + kind)</literal>. Type variable must be fresh. + </para> + </listitem> + <listitem><para>injectivity annotation of the form <literal>| A -> + B</literal>, where <literal>A</literal> is the result type variable (see + previous bullet) and <literal>B</literal> is a list of argument type and + kind variables in which type family is injective. It is possible to omit + some variables if type family is not injective in them.</para></listitem> + </itemizedlist> + Examples: + <programlisting> +type family Id a = result | result -> a where +type family F a b c = d | d -> a c b +type family G (a :: k) b c = foo | foo -> k b where + </programlisting> + </para> + <para>For open and closed type families it is OK to name the result but + skip the injectivity annotation. This is not the case for associated type + synonyms, where the named result without injectivity annotation will be + interpreted as associated type synonym default.</para> + </sect3> + + <sect3 id="injective-ty-fams-typecheck"> + <title>Verifying injectivity annotation against type family equations + </title> + <para>Once the user declares type family to be injective GHC must verify + that this declaration is correct, ie. type family equations don't violate + the injectivity annotation. A general idea is that if at least one + equation (bullets (1), (2) and (3) below) or a pair of equations (bullets + (4) and (5) below) violates the injectivity annotation then a type family + is not injective in a way user claims and an error is reported. In the + bullets below <emphasis>RHS</emphasis> refers to the right-hand side of the + type family equation being checked for injectivity. + <emphasis>LHS</emphasis> refers to the arguments of that type family + equation. Below are the rules followed when checking injectivity of a type + family: + <orderedlist> + <listitem><para>If a RHS of a type family equation is a type family + application GHC reports that the type family is not injective.</para> + </listitem> + <listitem>If a RHS of a type family equation is a bare type variable we + require that all LHS variables (including implicit kind variables) are + also bare. In other words, this has to be a sole equation of that type + family and it has to cover all possible patterns. If the patterns are + not covering GHC reports that the type family is not injective. + </listitem> + <listitem>If a LHS type variable that is declared as injective is not + mentioned on <emphasis>injective position</emphasis> in the RHS GHC + reports that the type family is not injective. Injective position means + either argument to a type constructor or injective argument to a type + family.</listitem> + <listitem><para><emphasis>Open type families</emphasis>Open type families + are typechecked incrementally. This means that when a module is imported + type family instances contained in that module are checked against + instances present in already imported modules.</para> + <para>A pair of an open type family equations is checked by attempting to + unify their RHSs. If the RHSs don't unify this pair does not violate + injectivity annotation. If unification succeeds with a substitution then + LHSs of unified equations must be identical under that substitution. If + they are not identical then GHC reports that the type family is not + injective.</para> + </listitem> + <listitem><para>In a <emphasis>closed type family</emphasis> all + equations are ordered and in one place. Equations are also checked + pair-wise but this time an equation has to be paired with all the + preceeding equations. Of course a single-equation closed type family is + trivially injective (unless (1), (2) or (3) above holds). + </para> + <para>When checking a pair of closed type family equations GHC tried to + unify their RHSs. If they don't unify this pair of equations does not + violate injectivity annotation. If the RHSs can be unified under some + substitution (possibly empty) then either the LHSs unify under the same + substitution or the LHS of the latter equation is subsumed by earlier + equations. If neither condition is met GHC reports that a type family is + not injective. + </para> + </listitem> + </orderedlist> + </para> + <para>Note that for the purpose of injectivity check in bullets (4) and (5) + GHC uses a special variant of unification algorithm that treats type family + applications as possibly unifying with anything.</para> + </sect3> + </sect2> + </sect1> diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 6472104c00..4db92b7582 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -71,6 +71,7 @@ module Language.Haskell.TH( Pat(..), FieldExp, FieldPat, -- ** Types Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..), + FamilyResultSig(..), Syntax.InjectivityAnn(..), -- * Library functions -- ** Abbreviations @@ -92,7 +93,7 @@ module Language.Haskell.TH( normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, -- *** Expressions - dyn, global, varE, conE, litE, appE, uInfixE, parensE, staticE, + dyn, varE, conE, litE, appE, uInfixE, parensE, staticE, infixE, infixApp, sectionL, sectionR, lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, @@ -113,7 +114,7 @@ module Language.Haskell.TH( -- **** Type literals numTyLit, strTyLit, -- **** Strictness - isStrict, notStrict, strictType, varStrictType, + isStrict, notStrict, strictType, varStrictType, -- **** Class Contexts cxt, classP, equalP, normalC, recC, infixC, forallC, @@ -125,16 +126,16 @@ module Language.Haskell.TH( -- *** Top Level Declarations -- **** Data - valD, funD, tySynD, dataD, newtypeD, + valD, funD, tySynD, dataD, newtypeD, -- **** Class classD, instanceD, sigD, standaloneDerivD, defaultSigD, -- **** Role annotations roleAnnotD, -- **** Type Family / Data Family - familyNoKindD, familyKindD, dataInstD, - closedTypeFamilyNoKindD, closedTypeFamilyKindD, + dataFamilyD, openTypeFamilyD, closedTypeFamilyD, dataInstD, + familyNoKindD, familyKindD, closedTypeFamilyNoKindD, closedTypeFamilyKindD, newtypeInstD, tySynInstD, - typeFam, dataFam, tySynEqn, + typeFam, dataFam, tySynEqn, injectivityAnn, noSig, kindSig, tyVarSig, -- **** Foreign Function Interface (FFI) cCall, stdCall, cApi, prim, javaScript, unsafe, safe, forImpD, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 5d2b08c671..fd5dd70802 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -2,12 +2,14 @@ -- TH.Lib contains lots of useful helper functions for -- generating and manipulating Template Haskell terms +{-# LANGUAGE CPP #-} + module Language.Haskell.TH.Lib where -- All of the exports from this module should -- be "public" functions. The main module TH -- re-exports them all. -import Language.Haskell.TH.Syntax hiding (Role) +import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) import qualified Language.Haskell.TH.Syntax as TH import Control.Monad( liftM, liftM2 ) import Data.Word( Word8 ) @@ -40,6 +42,7 @@ type FieldExpQ = Q FieldExp type RuleBndrQ = Q RuleBndr type TySynEqnQ = Q TySynEqn type Role = TH.Role -- must be defined here for DsMeta to find it +type InjectivityAnn = TH.InjectivityAnn ---------------------------------------------------------- -- * Lowercase pattern syntax functions @@ -201,11 +204,6 @@ clause ps r ds = do { ps' <- sequence ps; dyn :: String -> ExpQ dyn s = return (VarE (mkName s)) -global :: Name -> ExpQ -{-# DEPRECATED global "Use varE instead" #-} --- Trac #8656; I have no idea why this function is duplicated -global s = return (VarE s) - varE :: Name -> ExpQ varE s = return (VarE s) @@ -422,12 +420,6 @@ pragAnnD target expr pragLineD :: Int -> String -> DecQ pragLineD line file = return $ PragmaD $ LineP line file -familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ -familyNoKindD flav tc tvs = return $ FamilyD flav tc tvs Nothing - -familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ -familyKindD flav tc tvs k = return $ FamilyD flav tc tvs (Just k) - dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> [Name] -> DecQ dataInstD ctxt tc tys cons derivs = do @@ -450,17 +442,57 @@ tySynInstD tc eqn = eqn1 <- eqn return (TySynInstD tc eqn1) +dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ +dataFamilyD tc tvs kind + = return $ DataFamilyD tc tvs kind + +openTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig + -> Maybe InjectivityAnn -> DecQ +openTypeFamilyD tc tvs res inj + = return $ OpenTypeFamilyD tc tvs res inj + +closedTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig + -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ +closedTypeFamilyD tc tvs result injectivity eqns = + do eqns1 <- sequence eqns + return (ClosedTypeFamilyD tc tvs result injectivity eqns1) + +-- These were deprecated in GHC 7.12 with a plan to remove them in 7.14. If you +-- remove this check please also: +-- 1. remove deprecated functions +-- 2. remove CPP language extension from top of this module +-- 3. remove the FamFlavour data type from Syntax module +-- 4. make sure that all references to FamFlavour are gone from DsMeta, +-- Convert, TcSplice (follows from 3) +#if __GLASGOW_HASKELL__ > 712 +#error Remove deprecated familyNoKindD, familyKindD, closedTypeFamilyNoKindD and closedTypeFamilyKindD +#endif + +{-# DEPRECATED familyNoKindD, familyKindD + "This function will be removed in the next stable release. Use openTypeFamilyD/dataFamilyD instead." #-} +familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ +familyNoKindD flav tc tvs = + case flav of + TypeFam -> return $ OpenTypeFamilyD tc tvs NoSig Nothing + DataFam -> return $ DataFamilyD tc tvs Nothing + +familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ +familyKindD flav tc tvs k = + case flav of + TypeFam -> return $ OpenTypeFamilyD tc tvs (KindSig k) Nothing + DataFam -> return $ DataFamilyD tc tvs (Just k) + +{-# DEPRECATED closedTypeFamilyNoKindD, closedTypeFamilyKindD + "This function will be removed in the next stable release. Use closedTypeFamilyD instead." #-} closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ closedTypeFamilyNoKindD tc tvs eqns = - do - eqns1 <- sequence eqns - return (ClosedTypeFamilyD tc tvs Nothing eqns1) + do eqns1 <- sequence eqns + return (ClosedTypeFamilyD tc tvs NoSig Nothing eqns1) closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ closedTypeFamilyKindD tc tvs kind eqns = - do - eqns1 <- sequence eqns - return (ClosedTypeFamilyD tc tvs (Just kind) eqns1) + do eqns1 <- sequence eqns + return (ClosedTypeFamilyD tc tvs (KindSig kind) Nothing eqns1) roleAnnotD :: Name -> [Role] -> DecQ roleAnnotD name roles = return $ RoleAnnotD name roles @@ -653,6 +685,24 @@ constraintK :: Kind constraintK = ConstraintT ------------------------------------------------------------------------------- +-- * Type family result + +noSig :: FamilyResultSig +noSig = NoSig + +kindSig :: Kind -> FamilyResultSig +kindSig = KindSig + +tyVarSig :: TyVarBndr -> FamilyResultSig +tyVarSig = TyVarSig + +------------------------------------------------------------------------------- +-- * Injectivity annotation + +injectivityAnn :: Name -> [Name] -> InjectivityAnn +injectivityAnn = TH.InjectivityAnn + +------------------------------------------------------------------------------- -- * Role nominalR, representationalR, phantomR, inferR :: Role diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 5fb7197bc7..589382aac3 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -66,7 +66,7 @@ instance Ppr Info where case mb_d of { Nothing -> empty; Just d -> ppr d }] ppr_sig :: Name -> Type -> Doc -ppr_sig v ty = ppr v <+> text "::" <+> ppr ty +ppr_sig v ty = ppr v <+> dcolon <+> ppr ty pprFixity :: Name -> Fixity -> Doc pprFixity _ f | f == defaultFixity = empty @@ -167,7 +167,7 @@ pprExp _ (CompE ss) = text "[" <> ppr s ss' = init ss pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es -pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t +pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) pprExp i (StaticE e) = parensIf (i >= appPrec) $ @@ -267,7 +267,7 @@ pprPat _ (RecP nm fs) <+> braces (sep $ punctuate comma $ map (\(s,p) -> ppr s <+> equals <+> ppr p) fs) pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps -pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t +pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p ------------------------------ @@ -291,18 +291,17 @@ ppr_dec _ (ClassD ctxt c xs fds ds) $$ where_clause ds ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i $$ where_clause ds -ppr_dec _ (SigD f t) = pprPrefixOcc f <+> text "::" <+> ppr t +ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t ppr_dec _ (ForeignD f) = ppr f ppr_dec _ (InfixD fx n) = pprFixity n fx ppr_dec _ (PragmaD p) = ppr p -ppr_dec isTop (FamilyD flav tc tvs k) - = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind +ppr_dec isTop (DataFamilyD tc tvs kind) + = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind where maybeFamily | isTop = text "family" | otherwise = empty - - maybeKind | (Just k') <- k = text "::" <+> ppr k' - | otherwise = empty + maybeKind | (Just k') <- kind = dcolon <+> ppr k' + | otherwise = empty ppr_dec isTop (DataInstD ctxt tc tys cs decs) = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) cs decs where @@ -318,13 +317,21 @@ ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs)) where maybeInst | isTop = text "instance" | otherwise = empty -ppr_dec _ (ClosedTypeFamilyD tc tvs mkind eqns) - = hang (hsep [ text "type family", ppr tc, hsep (map ppr tvs), maybeKind - , text "where" ]) +ppr_dec isTop (OpenTypeFamilyD tc tvs res inj) + = text "type" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> + ppr res <+> maybeInj + where + maybeFamily | isTop = text "family" + | otherwise = empty + maybeInj | (Just inj') <- inj = ppr inj' + | otherwise = empty +ppr_dec _ (ClosedTypeFamilyD tc tvs res inj eqns) + = hang (hsep [ text "type family", ppr tc, hsep (map ppr tvs), ppr res + , maybeInj, text "where" ]) nestDepth (vcat (map ppr_eqn eqns)) where - maybeKind | (Just k') <- mkind = text "::" <+> ppr k' - | otherwise = empty + maybeInj | (Just inj') <- inj = ppr inj' + | otherwise = empty ppr_eqn (TySynEqn lhs rhs) = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs @@ -335,7 +342,7 @@ ppr_dec _ (StandaloneDerivD cxt ty) = hsep [ text "deriving instance", pprCxt cxt, ppr ty ] ppr_dec _ (DefaultSigD n ty) - = hsep [ text "default", pprPrefixOcc n, text "::", ppr ty ] + = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ] ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc ppr_data maybeInst ctxt t argsDoc cs decs @@ -381,6 +388,17 @@ instance Ppr FamFlavour where ppr TypeFam = text "type" ------------------------------ +instance Ppr FamilyResultSig where + ppr NoSig = empty + ppr (KindSig k) = dcolon <+> ppr k + ppr (TyVarSig bndr) = text "=" <+> ppr bndr + +------------------------------ +instance Ppr InjectivityAnn where + ppr (InjectivityAnn lhs rhs) = + char '|' <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs) + +------------------------------ instance Ppr Foreign where ppr (ImportF callconv safety impent as typ) = text "foreign import" @@ -388,13 +406,13 @@ instance Ppr Foreign where <+> showtextl safety <+> text (show impent) <+> ppr as - <+> text "::" <+> ppr typ + <+> dcolon <+> ppr typ ppr (ExportF callconv expent as typ) = text "foreign export" <+> showtextl callconv <+> text (show expent) <+> ppr as - <+> text "::" <+> ppr typ + <+> dcolon <+> ppr typ ------------------------------ instance Ppr Pragma where @@ -409,7 +427,7 @@ instance Ppr Pragma where = text "{-# SPECIALISE" <+> maybe empty ppr inline <+> ppr phases - <+> sep [ ppr n <+> text "::" + <+> sep [ ppr n <+> dcolon , nest 2 $ ppr ty ] <+> text "#-}" ppr (SpecialiseInstP inst) @@ -450,7 +468,7 @@ instance Ppr Phases where ------------------------------ instance Ppr RuleBndr where ppr (RuleVar n) = ppr n - ppr (TypedRuleVar n ty) = parens $ ppr n <+> text "::" <+> ppr ty + ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty ------------------------------ instance Ppr Clause where @@ -471,7 +489,7 @@ instance Ppr Con where ------------------------------ pprVarStrictType :: (Name, Strict, Type) -> Doc -- Slight infelicity: with print non-atomic type with parens -pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t) +pprVarStrictType (v, str, t) = ppr v <+> dcolon <+> pprStrictType (str, t) ------------------------------ pprStrictType :: (Strict, Type) -> Doc @@ -524,7 +542,6 @@ parens around it. E.g. the parens are required here: type instance F Int = (Bool :: *) So we always print a SigT with parens (see Trac #10050). -} - pprTyApp :: (Type, [Type]) -> Doc pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] pprTyApp (EqualityT, [arg1, arg2]) = @@ -558,7 +575,7 @@ instance Ppr TyLit where ------------------------------ instance Ppr TyVarBndr where ppr (PlainTV nm) = ppr nm - ppr (KindedTV nm k) = parens (ppr nm <+> text "::" <+> ppr k) + ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k) instance Ppr Role where ppr NominalR = text "nominal" diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs index 68134965a5..8019e48205 100644 --- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs @@ -10,7 +10,7 @@ module Language.Haskell.TH.PprLib ( -- * Primitive Documents empty, - semi, comma, colon, space, equals, arrow, + semi, comma, colon, dcolon, space, equals, arrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, -- * Converting values into documents @@ -27,7 +27,7 @@ module Language.Haskell.TH.PprLib ( fsep, fcat, nest, hang, punctuate, - + -- * Predicates on documents isEmpty, @@ -63,6 +63,7 @@ empty :: Doc; -- ^ An empty document semi :: Doc; -- ^ A ';' character comma :: Doc; -- ^ A ',' character colon :: Doc; -- ^ A ':' character +dcolon :: Doc; -- ^ A "::" string space :: Doc; -- ^ A space character equals :: Doc; -- ^ A '=' character arrow :: Doc; -- ^ A "->" string @@ -171,6 +172,7 @@ empty = return HPJ.empty semi = return HPJ.semi comma = return HPJ.comma colon = return HPJ.colon +dcolon = return $ HPJ.text "::" space = return HPJ.space equals = return HPJ.equals arrow = return $ HPJ.text "->" diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 9f7b5107f0..82e22dd212 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1367,9 +1367,10 @@ data Dec -- | pragmas | PragmaD Pragma -- ^ @{ {\-# INLINE [1] foo #-\} }@ - -- | type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') - | FamilyD FamFlavour Name - [TyVarBndr] (Maybe Kind) -- ^ @{ type family T a b c :: * }@ + -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD') + | DataFamilyD Name [TyVarBndr] + (Maybe Kind) + -- ^ @{ data family T a b c :: * }@ | DataInstD Cxt Name [Type] [Con] [Name] -- ^ @{ data instance Cxt x => T [x] = A x @@ -1380,9 +1381,17 @@ data Dec -- deriving (Z,W)}@ | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ + -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') + | OpenTypeFamilyD Name + [TyVarBndr] FamilyResultSig + (Maybe InjectivityAnn) + -- ^ @{ type family T a b c = (r :: *) | r -> a b }@ + | ClosedTypeFamilyD Name - [TyVarBndr] (Maybe Kind) - [TySynEqn] -- ^ @{ type family F a b :: * where ... }@ + [TyVarBndr] FamilyResultSig + (Maybe InjectivityAnn) + [TySynEqn] + -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@ | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@ | StandaloneDerivD Cxt Type -- ^ @{ deriving instance Ord a => Ord (Foo a) }@ @@ -1493,6 +1502,16 @@ data TyVarBndr = PlainTV Name -- ^ @a@ | KindedTV Name Kind -- ^ @(a :: k)@ deriving( Show, Eq, Ord, Data, Typeable, Generic ) +-- | Type family result signature +data FamilyResultSig = NoSig -- ^ no signature + | KindSig Kind -- ^ @k@ + | TyVarSig TyVarBndr -- ^ @= r, = (r :: k)@ + deriving( Show, Eq, Ord, Data, Typeable, Generic ) + +-- | Injectivity annotation +data InjectivityAnn = InjectivityAnn Name [Name] + deriving ( Show, Eq, Ord, Data, Typeable, Generic ) + data TyLit = NumTyLit Integer -- ^ @2@ | StrTyLit String -- ^ @"Hello"@ deriving ( Show, Eq, Ord, Data, Typeable, Generic ) diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr index 39bc29fae9..5c1822456e 100644 --- a/testsuite/tests/ghci.debugger/scripts/print019.stderr +++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr @@ -7,7 +7,7 @@ Potential instances: instance Show TyCon -- Defined in ‘Data.Typeable.Internal’ instance Show TypeRep -- Defined in ‘Data.Typeable.Internal’ - instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ + instance Show Ordering -- Defined in ‘GHC.Show’ ...plus 30 others (use -fprint-potential-instances to see them all) In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci/scripts/T6018ghci.script b/testsuite/tests/ghci/scripts/T6018ghci.script new file mode 100644 index 0000000000..4615be2d04 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T6018ghci.script @@ -0,0 +1,22 @@ +:set -XTypeFamilies +:set -XDataKinds +:set -XUndecidableInstances +:set -XPolyKinds + +type family F a b c = (result :: k) | result -> a b c +type instance F Int Char Bool = Bool +type instance F Char Bool Int = Int +type instance F Bool Int Char = Char +type instance F Bool Int Char = Char + +type family I (a :: k) b (c :: k) = r | r -> a b +type instance I Int Char Bool = Bool +type instance I Int Char Int = Bool +type instance I Bool Int Int = Int + +type family J a (b :: k) = r | r -> a +type instance J Int b = Char + +type MaybeSyn a = Maybe a +type family K a = r | r -> a +type instance K a = MaybeSyn a diff --git a/testsuite/tests/ghci/scripts/T6018ghci.stdout b/testsuite/tests/ghci/scripts/T6018ghci.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T6018ghci.stdout diff --git a/testsuite/tests/ghci/scripts/T6018ghcifail.script b/testsuite/tests/ghci/scripts/T6018ghcifail.script new file mode 100644 index 0000000000..c0e073457f --- /dev/null +++ b/testsuite/tests/ghci/scripts/T6018ghcifail.script @@ -0,0 +1,114 @@ +:set -XTypeFamilies +:set -XDataKinds +:set -XUndecidableInstances +:set -XPolyKinds + + + +type family F a b c = (result :: *) | result -> a b c +type instance F Int Char Bool = Bool +type instance F Char Bool Int = Int +type instance F Bool Int Char = Int + + + +type family I a b c = r | r -> a b +type instance I Int Char Bool = Bool +type instance I Int Int Int = Bool +type instance I Bool Int Int = Int + +-- Id is injective... +type family Id a = result | result -> a +type instance Id a = a + +-- ...but despite that we disallow a call to Id +type family IdProxy a = r | r -> a +type instance IdProxy a = Id a + +data N = Z | S N + +-- P is not injective, although the user declares otherwise. This +-- should be rejected on the grounds of calling a type family in the +-- RHS. +type family P (a :: N) (b :: N) = (r :: N) | r -> a b +type instance P Z m = m +type instance P (S n) m = S (P n m) + +-- this is not injective - not all injective type variables mentioned +-- on LHS are mentioned on RHS +type family J a b c = r | r -> a b +type instance J Int b c = Char + +-- same as above, but tyvar is now nested inside a tycon +type family K (a :: N) (b :: N) = (r :: N) | r -> a b +type instance K (S n) m = S m + +-- Make sure we look through type synonyms to catch errors +type MaybeSyn a = Id a +type family L a = r | r -> a +type instance L a = MaybeSyn a + +-- These should fail because given the RHS kind there is no way to determine LHS +-- kind +class PolyKindVarsC a where { type PolyKindVarsF a = (r :: k) | r -> a } + +instance PolyKindVarsC '[] where { type PolyKindVarsF '[] = '[] } + + + +type family PolyKindVars (a :: k0) = (r :: k1) | r -> a +type instance PolyKindVars '[] = '[] + +-- This should fail because there is no way to determine k from the RHS +type family Fc (a :: k) (b :: k) = r | r -> k +type instance Fc a b = Int + +-- This should fail because there is no way to determine a, b and k from the RHS +type family Gc (a :: k) (b :: k) = r | r -> a b +type instance Gc a b = Int + +type family GF1 a = r | r -> a +type instance GF1 Int = Bool + +type family GF2 a = r | r -> a +type instance GF2 Int = Bool + +type family HF1 a +type instance HF1 Bool = Bool + +-- fails because injectivity is not compositional in this case +type family F1 a = r | r -> a +type instance F1 [a] = Maybe (GF1 a) +type instance F1 (Maybe a) = Maybe (GF2 a) + +type family W1 a = r | r -> a +type instance W1 [a] = a + +type family W2 a = r | r -> a +type instance W2 [a] = W2 a + +-- not injective because of infinite types +type family Z1 a = r | r -> a +type instance Z1 [a] = (a, a) +type instance Z1 (Maybe b) = (b, [b]) + +type family G1 a = r | r -> a +type instance G1 [a] = [a] +type instance G1 (Maybe b) = [(b, b)] + +type family G3 a b = r | r -> b +type instance G3 a Int = (a, Int) +type instance G3 a Bool = (Bool, a) + +type family G4 a b = r | r -> a b +type instance G4 a b = [a] + +type family G5 a = r | r -> a +type instance G5 [a] = [GF1 a] -- GF1 injective +type instance G5 Int = [Bool] + +type family G6 a = r | r -> a +type instance G6 [a] = [HF1 a] -- HF1 not injective +type instance G6 Bool = Int + + diff --git a/testsuite/tests/ghci/scripts/T6018ghcifail.stderr b/testsuite/tests/ghci/scripts/T6018ghcifail.stderr new file mode 100644 index 0000000000..e1c0055349 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T6018ghcifail.stderr @@ -0,0 +1,111 @@ + +<interactive>:10:15: + Type family equations violate injectivity annotation: + F Char Bool Int = Int + F Bool Int Char = Int + +<interactive>:16:15: + Type family equations violate injectivity annotation: + I Int Char Bool = Bool + I Int Int Int = Bool + +<interactive>:26:15: + Type family equation violates injectivity annotation. + RHS of injective type family equation cannot be a type family: + IdProxy a = Id a + +<interactive>:34:15: + Type family equation violates injectivity annotation. + RHS of injective type family equation is a bare type variable + but these LHS type and kind patterns are not bare variables: ‘'Z’ + P 'Z m = m + +<interactive>:40:15: + Type family equation violates injectivity annotation. + Injective type variable ‘b’ does not appear on injective position. + In the RHS of type family equation: + J Int b c = Char + +<interactive>:44:15: + Type family equation violates injectivity annotation. + Injective type variable ‘n’ does not appear on injective position. + In the RHS of type family equation: + K ('S n) m = 'S m + +<interactive>:49:15: + Type family equation violates injectivity annotation. + RHS of injective type family equation cannot be a type family: + L a = MaybeSyn a + +<interactive>:55:41: + Type family equation violates injectivity annotation. + Injective kind variable ‘k1’ is not inferable from the RHS type variables. + In the RHS of type family equation: + PolyKindVarsF '[] = '[] + +<interactive>:60:15: + Type family equation violates injectivity annotation. + Injective kind variable ‘k1’ is not inferable from the RHS type variables. + In the RHS of type family equation: + PolyKindVars '[] = '[] + +<interactive>:64:15: + Type family equation violates injectivity annotation. + Injective kind variable ‘k’ is not inferable from the RHS type variables. + In the RHS of type family equation: + forall (k :: BOX) (a :: k) (b :: k). Fc a b = Int + +<interactive>:68:15: + Type family equation violates injectivity annotation. + Injective type variables ‘a’, ‘b’ do not appear on injective position. + Injective kind variable ‘k’ is not inferable from the RHS type variables. + In the RHS of type family equation: + forall (k :: BOX) (a :: k) (b :: k). Gc a b = Int + +<interactive>:81:15: + Type family equations violate injectivity annotation: + F1 [a] = Maybe (GF1 a) + F1 (Maybe a) = Maybe (GF2 a) + +<interactive>:85:15: + Type family equation violates injectivity annotation. + RHS of injective type family equation is a bare type variable + but these LHS type and kind patterns are not bare variables: ‘[a]’ + W1 [a] = a + +<interactive>:88:15: + Type family equation violates injectivity annotation. + RHS of injective type family equation cannot be a type family: + W2 [a] = W2 a + +<interactive>:92:15: + Type family equations violate injectivity annotation: + Z1 [a] = (a, a) + Z1 (Maybe b) = (b, [b]) + +<interactive>:96:15: + Type family equations violate injectivity annotation: + G1 [a] = [a] + G1 (Maybe b) = [(b, b)] + +<interactive>:100:15: + Type family equations violate injectivity annotation: + G3 a Int = (a, Int) + G3 a Bool = (Bool, a) + +<interactive>:104:15: + Type family equation violates injectivity annotation. + Injective type variable ‘b’ does not appear on injective position. + In the RHS of type family equation: + G4 a b = [a] + +<interactive>:107:15: + Type family equations violate injectivity annotation: + G5 [a] = [GF1 a] + G5 Int = [Bool] + +<interactive>:111:15: + Type family equation violates injectivity annotation. + Injective type variable ‘a’ does not appear on injective position. + In the RHS of type family equation: + G6 [a] = [HF1 a] diff --git a/testsuite/tests/ghci/scripts/T6018ghcirnfail.script b/testsuite/tests/ghci/scripts/T6018ghcirnfail.script new file mode 100644 index 0000000000..f1a5fa469a --- /dev/null +++ b/testsuite/tests/ghci/scripts/T6018ghcirnfail.script @@ -0,0 +1,42 @@ +:set -XTypeFamilies +:set -XDataKinds +:set -XUndecidableInstances +:set -XPolyKinds +:set -XMultiParamTypeClasses + +-- IA = injectivity annotation `| foo -> bar` + +-- use incorrect tyvar in LHS of IA +type family F a = r | a -> a +type family Fc a = r | a -> a where { Fc a = a } +class Fcl a where { type Ft a = r | a -> a } + +-- declare result tyvar to be duplicate (without IA) +type family G a = a +type family Gc a = a where { Gc a = a } + +-- declare result tyvar to be duplicate (with IA) +type family Gb a = a | a -> a +type family Gcb a = a | a -> a where { Gcb a = a } +class Gclb a where { type Gtb a = a | a -> a } -- here we want two errors + +-- not in-scope tyvar in RHS of IA +type family I a b = r | r -> c +type family Ic a b = r | r -> c where { Ic a b = a } +class Icl a b where { type It a b = r | r -> c } + +-- repeated tyvar on RHS of IA +type family J a b = r | r -> a a +type family Jc a b = r | r -> a a where { Jc a b = a } +class Jcl a b where { type Jt a b = r | r -> a a } + +-- not in-scope tyvar in LHS of IA +type family L a b = r | c -> a +type family Lc a b = r | c -> a where { Lc a b = a } +class Lcl a b where { type Lt a b = r | c -> a } + +-- result variable shadows variable in class head +class M a b where { type Mt b = a | a -> b } + +-- here b is out-of-scope +class N a b where { type Nt a = r | r -> a b } diff --git a/testsuite/tests/ghci/scripts/T6018ghcirnfail.stderr b/testsuite/tests/ghci/scripts/T6018ghcirnfail.stderr new file mode 100644 index 0000000000..87f5a040b1 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T6018ghcirnfail.stderr @@ -0,0 +1,63 @@ + +<interactive>:10:23: + Incorrect type variable on the LHS of injectivity condition + Expected : r + Actual : a + +<interactive>:11:24: + Incorrect type variable on the LHS of injectivity condition + Expected : r + Actual : a + +<interactive>:12:37: + Incorrect type variable on the LHS of injectivity condition + Expected : r + Actual : a + +<interactive>:15:19: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +<interactive>:16:20: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +<interactive>:19:20: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +<interactive>:19:24: + Unknown type variable on the RHS of injectivity condition: a + +<interactive>:20:21: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +<interactive>:20:25: + Unknown type variable on the RHS of injectivity condition: a + +<interactive>:21:35: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +<interactive>:21:39: + Unknown type variable on the RHS of injectivity condition: a + +<interactive>:24:1: Not in scope: type variable ‘c’ + +<interactive>:25:1: Not in scope: type variable ‘c’ + +<interactive>:26:23: Not in scope: type variable ‘c’ + +<interactive>:34:1: Not in scope: type variable ‘c’ + +<interactive>:35:1: Not in scope: type variable ‘c’ + +<interactive>:36:23: Not in scope: type variable ‘c’ + +<interactive>:39:33: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +<interactive>:42:37: + Unknown type variable on the RHS of injectivity condition: b diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index bbd69ee014..d2244c1790 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -161,6 +161,9 @@ test('T7627', normal, ghci_script, ['T7627.script']) test('T7627b', normal, ghci_script, ['T7627b.script']) test('T7586', normal, ghci_script, ['T7586.script']) test('T4175', normal, ghci_script, ['T4175.script']) +test('T6018ghci', normal, ghci_script, ['T6018ghci.script']) +test('T6018ghcifail', normal, ghci_script, ['T6018ghcifail.script']) +test('T6018ghcirnfail', normal, ghci_script, ['T6018ghcirnfail.script']) test('T7730', combined_output, ghci_script, ['T7730.script']) test('T7872', normal, ghci_script, ['T7872.script']) test('T7873', normal, ghci_script, ['T7873.script']) diff --git a/testsuite/tests/indexed-types/should_compile/T9085.stderr b/testsuite/tests/indexed-types/should_compile/T9085.stderr index ee968e0d79..8a4ebdbb7a 100644 --- a/testsuite/tests/indexed-types/should_compile/T9085.stderr +++ b/testsuite/tests/indexed-types/should_compile/T9085.stderr @@ -1,4 +1,4 @@ T9085.hs:7:3: Warning: - Overlapped type family instance equation: + Type family instance equation is overlapped: F Bool = Bool diff --git a/testsuite/tests/indexed-types/should_fail/T9160.hs b/testsuite/tests/indexed-types/should_fail/T9160.hs index 64ae3b9f9c..7daa6b815d 100644 --- a/testsuite/tests/indexed-types/should_fail/T9160.hs +++ b/testsuite/tests/indexed-types/should_fail/T9160.hs @@ -8,7 +8,7 @@ $( do { cls_nm <- newName "C" ; k_nm <- newName "k" ; f_nm <- newName "F" ; return [ClassD [] cls_nm [KindedTV a_nm (VarT k_nm)] [] - [FamilyD TypeFam f_nm [] (Just (VarT k_nm))]] } ) + [OpenTypeFamilyD f_nm [] (KindSig (VarT k_nm)) Nothing ]] } ) -- Splices in: -- class C (a :: k) where @@ -16,4 +16,3 @@ $( do { cls_nm <- newName "C" instance C (a :: *) where type F = Maybe -- Should be illegal - diff --git a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr index 79b78658b3..75abc3b0e6 100644 --- a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr +++ b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr @@ -4,8 +4,8 @@ overloadedlistsfail01.hs:5:8: error: The type variable ‘a0’ is ambiguous Potential instances: instance [safe] Show Version -- Defined in ‘Data.Version’ - instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ instance Show Ordering -- Defined in ‘GHC.Show’ + instance Show Integer -- Defined in ‘GHC.Show’ ...plus 23 others (use -fprint-potential-instances to see them all) In the expression: print [1] diff --git a/testsuite/tests/quotes/TH_localname.stderr b/testsuite/tests/quotes/TH_localname.stderr index 76bfeea8a2..c764f576ef 100644 --- a/testsuite/tests/quotes/TH_localname.stderr +++ b/testsuite/tests/quotes/TH_localname.stderr @@ -8,9 +8,8 @@ TH_localname.hs:3:11: error: Potential instances: instance (Lift a, Lift b) => Lift (Either a b) -- Defined in ‘Language.Haskell.TH.Syntax’ - instance Lift a => Lift (Maybe a) - -- Defined in ‘Language.Haskell.TH.Syntax’ instance Lift Int16 -- Defined in ‘Language.Haskell.TH.Syntax’ + instance Lift Int32 -- Defined in ‘Language.Haskell.TH.Syntax’ ...plus 24 others (use -fprint-potential-instances to see them all) In the expression: lift y diff --git a/testsuite/tests/rename/should_fail/T6018rnfail.hs b/testsuite/tests/rename/should_fail/T6018rnfail.hs new file mode 100644 index 0000000000..14d1929ed2 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T6018rnfail.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeFamilies, PolyKinds #-} + +module T6018rnfail where + +-- IA = injectivity annotation `| foo -> bar` + +-- use incorrect tyvar in LHS of IA +type family F a = r | a -> a +type family Fc a = r | a -> a where + Fc a = a +class Fcl a where + type Ft a = r | a -> a + +-- declare result tyvar to be duplicate (without IA) +type family G a = a +type family Gc a = a where + Gc a = a + +-- declare result tyvar to be duplicate (with IA) +type family Gb a = a | a -> a +type family Gcb a = a | a -> a where + Gcb a = a +class Gclb a where -- here we want two errors + type Gtb a = a | a -> a + +-- not in-scope tyvar in RHS of IA +type family I a b = r | r -> c +type family Ic a b = r | r -> c where + Ic a b = a +class Icl a b where + type It a b = r | r -> c + +-- not in-scope tyvar in LHS of IA +type family L a b = r | c -> a +type family Lc a b = r | c -> a where + Lc a b = a +class Lcl a b where + type Lt a b = r | c -> a + +-- result variable shadows variable in class head +class M a b where + type Mt b = a | a -> b + +-- here b is out-of-scope +class N a b where + type Nt a = r | r -> a b + +-- result is out of scope. Not possible for associated types +type family O1 a | r -> a +type family Oc1 a | r -> a where + Oc1 a = a +type family O2 a :: * | r -> a +type family Oc2 a :: * | r -> a where + Oc2 a = a diff --git a/testsuite/tests/rename/should_fail/T6018rnfail.stderr b/testsuite/tests/rename/should_fail/T6018rnfail.stderr new file mode 100644 index 0000000000..2628024b83 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T6018rnfail.stderr @@ -0,0 +1,71 @@ + +T6018rnfail.hs:8:23: + Incorrect type variable on the LHS of injectivity condition + Expected : r + Actual : a + +T6018rnfail.hs:9:24: + Incorrect type variable on the LHS of injectivity condition + Expected : r + Actual : a + +T6018rnfail.hs:12:19: + Incorrect type variable on the LHS of injectivity condition + Expected : r + Actual : a + +T6018rnfail.hs:15:19: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +T6018rnfail.hs:16:20: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +T6018rnfail.hs:20:20: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +T6018rnfail.hs:20:24: + Unknown type variable on the RHS of injectivity condition: a + +T6018rnfail.hs:21:21: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +T6018rnfail.hs:21:25: + Unknown type variable on the RHS of injectivity condition: a + +T6018rnfail.hs:24:16: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +T6018rnfail.hs:24:20: + Unknown type variable on the RHS of injectivity condition: a + +T6018rnfail.hs:27:1: Not in scope: type variable ‘c’ + +T6018rnfail.hs:28:1: Not in scope: type variable ‘c’ + +T6018rnfail.hs:31:3: Not in scope: type variable ‘c’ + +T6018rnfail.hs:34:1: Not in scope: type variable ‘c’ + +T6018rnfail.hs:35:1: Not in scope: type variable ‘c’ + +T6018rnfail.hs:38:3: Not in scope: type variable ‘c’ + +T6018rnfail.hs:42:15: + Type variable ‘a’, naming a type family result, + shadows an already bound type variable + +T6018rnfail.hs:46:19: + Unknown type variable on the RHS of injectivity condition: b + +T6018rnfail.hs:49:21: Not in scope: type variable ‘r’ + +T6018rnfail.hs:50:21: Not in scope: type variable ‘r’ + +T6018rnfail.hs:52:26: Not in scope: type variable ‘r’ + +T6018rnfail.hs:53:26: Not in scope: type variable ‘r’ diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index 23648c93c8..bd717dd8d5 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -101,6 +101,7 @@ test('T5745', test('T5892a', normal, compile_fail, ['-package containers']) test('T5892b', normal, compile_fail, ['-package containers']) test('T5951', normal, compile_fail, ['']) +test('T6018rnfail', normal, compile_fail, ['']) test('T6060', normal, compile_fail, ['']) test('T6148', normal, compile_fail, ['']) test('T7164', normal, compile_fail, ['']) diff --git a/testsuite/tests/rename/should_fail/mc14.stderr b/testsuite/tests/rename/should_fail/mc14.stderr index 3f52be33c6..bb02f9bafb 100644 --- a/testsuite/tests/rename/should_fail/mc14.stderr +++ b/testsuite/tests/rename/should_fail/mc14.stderr @@ -1,10 +1,9 @@ - mc14.hs:14:16: error: No instance for (Functor t0) arising from a use of ‘fmap’ The type variable ‘t0’ is ambiguous Potential instances: - instance Functor Maybe -- Defined in ‘GHC.Base’ instance Functor IO -- Defined in ‘GHC.Base’ + instance Functor Maybe -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ ...plus two others (use -fprint-potential-instances to see them all) diff --git a/testsuite/tests/th/ClosedFam2TH.hs b/testsuite/tests/th/ClosedFam2TH.hs index cd2dc2de60..bb355a2790 100644 --- a/testsuite/tests/th/ClosedFam2TH.hs +++ b/testsuite/tests/th/ClosedFam2TH.hs @@ -4,16 +4,18 @@ module ClosedFam2 where import Language.Haskell.TH -$( return [ ClosedTypeFamilyD (mkName "Equals") - [ KindedTV (mkName "a") (VarT (mkName "k")) - , KindedTV (mkName "b") (VarT (mkName "k")) ] - Nothing - [ TySynEqn [ (VarT (mkName "a")) - , (VarT (mkName "a")) ] - (ConT (mkName "Int")) - , TySynEqn [ (VarT (mkName "a")) - , (VarT (mkName "b")) ] - (ConT (mkName "Bool")) ] ]) +$( return [ ClosedTypeFamilyD + (mkName "Equals") + [ KindedTV (mkName "a") (VarT (mkName "k")) + , KindedTV (mkName "b") (VarT (mkName "k")) ] + ( TyVarSig (KindedTV (mkName "r") (VarT (mkName "k")))) + Nothing + [ TySynEqn [ (VarT (mkName "a")) + , (VarT (mkName "a")) ] + (ConT (mkName "Int")) + , TySynEqn [ (VarT (mkName "a")) + , (VarT (mkName "b")) ] + (ConT (mkName "Bool")) ] ]) a :: Equals b b a = (5 :: Int) diff --git a/testsuite/tests/th/T10306.hs b/testsuite/tests/th/T10306.hs index b93114b61c..b74eb591e9 100644 --- a/testsuite/tests/th/T10306.hs +++ b/testsuite/tests/th/T10306.hs @@ -9,6 +9,6 @@ import GHC.TypeLits -- caused a crash, because it has no equations $(do x <- reify ''(+) case x of - FamilyI (ClosedTypeFamilyD _ _ _ []) _ -> return [] - _ -> error $ show x + FamilyI (ClosedTypeFamilyD _ _ _ _ []) _ -> return [] + _ -> error $ show x ) diff --git a/testsuite/tests/th/T6018th.hs b/testsuite/tests/th/T6018th.hs new file mode 100644 index 0000000000..32053636e2 --- /dev/null +++ b/testsuite/tests/th/T6018th.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds #-} + +module T6018th where + +import Language.Haskell.TH + +-- Test that injectivity works correct with TH. This test is not as exhaustive +-- as the original T6018 test. + +-- type family F a b c = (result :: k) | result -> a b c +-- type instance F Int Char Bool = Bool +-- type instance F Char Bool Int = Int +-- type instance F Bool Int Char = Char +$( return + [ OpenTypeFamilyD + (mkName "F") + [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] + (TyVarSig (KindedTV (mkName "result") (VarT (mkName "k")))) + (Just $ InjectivityAnn (mkName "result") + [(mkName "a"), (mkName "b"), (mkName "c") ]) + , TySynInstD + (mkName "F") + (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Bool")] + ( ConT (mkName "Bool"))) + , TySynInstD + (mkName "F") + (TySynEqn [ ConT (mkName "Char"), ConT (mkName "Bool") + , ConT (mkName "Int")] + ( ConT (mkName "Int"))) + , TySynInstD + (mkName "F") + (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") + , ConT (mkName "Char")] + ( ConT (mkName "Char"))) + ] ) + +-- this is injective - a type variables mentioned on LHS is not mentioned on RHS +-- but we don't claim injectivity in that argument. +-- +-- type family J a (b :: k) = r | r -> a +---type instance J Int b = Char +$( return + [ OpenTypeFamilyD + (mkName "J") + [ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ] + (TyVarSig (PlainTV (mkName "r"))) + (Just $ InjectivityAnn (mkName "r") [mkName "a"]) + , TySynInstD + (mkName "J") + (TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ] + ( ConT (mkName "Int"))) + ] ) + +-- Closed type families + +-- type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where +-- IClosed Int Char Bool = Bool +-- IClosed Int Char Int = Bool +-- IClosed Bool Int Int = Int + +$( return + [ ClosedTypeFamilyD + (mkName "I") + [ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT + , KindedTV (mkName "c") StarT ] + (TyVarSig (PlainTV (mkName "r"))) + (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]) + [ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Bool")] + ( ConT (mkName "Bool")) + , TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Int")] + ( ConT (mkName "Bool")) + , TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") + , ConT (mkName "Int")] + ( ConT (mkName "Int")) + ] + ] ) + +-- reification test +$( do { decl@([ClosedTypeFamilyD _ _ _ (Just inj) _]) <- + [d| type family Bak a = r | r -> a where + Bak Int = Char + Bak Char = Int + Bak a = a |] + ; runIO $ putStrLn (pprint inj) + ; return decl + } + ) + +-- Check whether incorrect injectivity declarations are caught + +-- type family I a b c = r | r -> a b +-- type instance I Int Char Bool = Bool +-- type instance I Int Int Int = Bool +-- type instance I Bool Int Int = Int +$( return + [ OpenTypeFamilyD + (mkName "H") + [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] + (TyVarSig (PlainTV (mkName "r"))) + (Just $ InjectivityAnn (mkName "r") + [(mkName "a"), (mkName "b") ]) + , TySynInstD + (mkName "H") + (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Bool")] + ( ConT (mkName "Bool"))) + , TySynInstD + (mkName "H") + (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Int") + , ConT (mkName "Int")] + ( ConT (mkName "Bool"))) + , TySynInstD + (mkName "H") + (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") + , ConT (mkName "Int")] + ( ConT (mkName "Int"))) + ] ) diff --git a/testsuite/tests/th/T6018th.stderr b/testsuite/tests/th/T6018th.stderr new file mode 100644 index 0000000000..98c318b63d --- /dev/null +++ b/testsuite/tests/th/T6018th.stderr @@ -0,0 +1,6 @@ +| r_0 -> a_1 + +T6018th.hs:98:4: + Type family equations violate injectivity annotation: + H Int Int Int = Bool + H Int Char Bool = Bool diff --git a/testsuite/tests/th/T8028.hs b/testsuite/tests/th/T8028.hs index 6145428aaf..c54f0e3dcf 100644 --- a/testsuite/tests/th/T8028.hs +++ b/testsuite/tests/th/T8028.hs @@ -12,6 +12,6 @@ $(x) -- subsequently be reified $(do f <- reify ''F case f of - FamilyI (ClosedTypeFamilyD _ _ _ []) _ -> return [] - _ -> error $ show f + FamilyI (ClosedTypeFamilyD _ _ _ _ []) _ -> return [] + _ -> error $ show f ) diff --git a/testsuite/tests/th/T8028a.hs b/testsuite/tests/th/T8028a.hs index 928a96e52c..7845c13b71 100644 --- a/testsuite/tests/th/T8028a.hs +++ b/testsuite/tests/th/T8028a.hs @@ -3,4 +3,4 @@ module T8028a where import Language.Haskell.TH x = do n <- newName "F" - return [ClosedTypeFamilyD n [] Nothing []] + return [ClosedTypeFamilyD n [] NoSig Nothing []] diff --git a/testsuite/tests/th/T8884.hs b/testsuite/tests/th/T8884.hs index ca6ed9c4b1..acbd6208df 100644 --- a/testsuite/tests/th/T8884.hs +++ b/testsuite/tests/th/T8884.hs @@ -5,19 +5,20 @@ module T8884 where import Language.Haskell.TH import System.IO -type family Foo a where +type family Foo a = r | r -> a where Foo x = x -type family Baz (a :: k) +type family Baz (a :: k) = (r :: k) | r -> a type instance Baz x = x -$( do FamilyI foo@(ClosedTypeFamilyD _ tvbs1 m_kind1 eqns1) [] <- reify ''Foo - FamilyI baz@(FamilyD TypeFam _ tvbs2 m_kind2) +$( do FamilyI foo@(ClosedTypeFamilyD _ tvbs1 res1 m_kind1 eqns1) + [] <- reify ''Foo + FamilyI baz@(OpenTypeFamilyD _ tvbs2 res2 m_kind2) [inst@(TySynInstD _ eqn2)] <- reify ''Baz runIO $ putStrLn $ pprint foo runIO $ putStrLn $ pprint baz runIO $ putStrLn $ pprint inst runIO $ hFlush stdout - return [ ClosedTypeFamilyD (mkName "Foo'") tvbs1 m_kind1 eqns1 - , FamilyD TypeFam (mkName "Baz'") tvbs2 m_kind2 + return [ ClosedTypeFamilyD (mkName "Foo'") tvbs1 res1 m_kind1 eqns1 + , OpenTypeFamilyD (mkName "Baz'") tvbs2 res2 m_kind2 , TySynInstD (mkName "Baz'") eqn2 ] ) diff --git a/testsuite/tests/th/T8884.stderr b/testsuite/tests/th/T8884.stderr index 24fc15a81f..28be29951d 100644 --- a/testsuite/tests/th/T8884.stderr +++ b/testsuite/tests/th/T8884.stderr @@ -1,3 +1,4 @@ -type family T8884.Foo (a_0 :: k_1) :: k_1 where T8884.Foo x_2 = x_2 -type family T8884.Baz (a_0 :: k_1) :: * -type instance T8884.Baz (x_0 :: *) = x_0 +type family T8884.Foo (a_0 :: k_1) = (r_2 :: k_1) | r_2 -> k_1 a_0 where + T8884.Foo x_3 = x_3 +type family T8884.Baz (a_0 :: k_1) = (r_2 :: k_1) | r_2 -> k_1 a_0 +type instance T8884.Baz (x_0 :: k_1) = x_0 diff --git a/testsuite/tests/th/TH_RichKinds2.hs b/testsuite/tests/th/TH_RichKinds2.hs index b804688b6a..c77988c3bc 100644 --- a/testsuite/tests/th/TH_RichKinds2.hs +++ b/testsuite/tests/th/TH_RichKinds2.hs @@ -12,13 +12,13 @@ import Data.Char import Data.List import Language.Haskell.TH -$(return [FamilyD TypeFam (mkName "Map") [KindedTV (mkName "f") +$(return [OpenTypeFamilyD (mkName "Map") [KindedTV (mkName "f") (AppT (AppT ArrowT (VarT (mkName "k1"))) (VarT (mkName "k2"))), KindedTV (mkName "l") (AppT ListT (VarT (mkName "k1")))] - (Just (AppT ListT (VarT (mkName "k2"))))]) + (KindSig (AppT ListT (VarT (mkName "k2")))) Nothing]) $( let fixKs :: String -> String -- need to remove TH renaming index from k variables fixKs s = diff --git a/testsuite/tests/th/TH_reifyDecl1.hs b/testsuite/tests/th/TH_reifyDecl1.hs index 7e7c9f40b9..c4ae3c065d 100644 --- a/testsuite/tests/th/TH_reifyDecl1.hs +++ b/testsuite/tests/th/TH_reifyDecl1.hs @@ -84,5 +84,3 @@ test = $(let ; display ''DF1 ; display ''DF2 ; [| () |] }) - - diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index a43cf57f3d..dada44a325 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -351,3 +351,4 @@ test('T10704', extra_clean(['T10704a.o','T10704a.hi']), multimod_compile_and_run, ['T10704', '-v0']) +test('T6018th', normal, compile_fail, ['-v0']) diff --git a/testsuite/tests/typecheck/should_compile/T6018.hs b/testsuite/tests/typecheck/should_compile/T6018.hs new file mode 100644 index 0000000000..523bc968d0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T6018.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module T6018 where + +import T6018a -- defines G, identical to F + +type family F a b c = (result :: k) | result -> a b c +type instance F Int Char Bool = Bool +type instance F Char Bool Int = Int +type instance F Bool Int Char = Char + + +type instance G Bool Int Char = Char + +type family I (a :: k) b (c :: k) = r | r -> a b +type instance I Int Char Bool = Bool +type instance I Int Char Int = Bool +type instance I Bool Int Int = Int + +-- this is injective - a type variable introduced in the LHS is not mentioned on +-- RHS but we don't claim injectivity in that argument. +type family J a (b :: k) = r | r -> a +type instance J Int b = Char + +type MaybeSyn a = Maybe a +newtype MaybeNew a = MaybeNew (Maybe a) + +-- make sure we look through type synonyms... +type family K a = r | r -> a +type instance K a = MaybeSyn a + +-- .. but not newtypes +type family M a = r | r -> a +type instance M (Maybe a) = MaybeSyn a +type instance M (MaybeNew a) = MaybeNew a + +-- Closed type families + +-- these are simple conversions from open type families. They should behave the +-- same +type family FClosed a b c = result | result -> a b c where + FClosed Int Char Bool = Bool + FClosed Char Bool Int = Int + FClosed Bool Int Char = Char + +type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where + IClosed Int Char Bool = Bool + IClosed Int Char Int = Bool + IClosed Bool Int Int = Int + +type family JClosed a (b :: k) = r | r -> a where + JClosed Int b = Char + +type family KClosed a = r | r -> a where + KClosed a = MaybeSyn a + +-- Here the last equation might return both Int and Char but we have to +-- recognize that it is not possible due to equation overlap +type family Bak a = r | r -> a where + Bak Int = Char + Bak Char = Int + Bak a = a + +-- This is similar, except that the last equation contains concrete type. Since +-- it is overlapped it should be dropped with a warning +type family Foo a = r | r -> a where + Foo Int = Bool + Foo Bool = Int + Foo Bool = Bool + +-- this one was tricky in the early implementation of injectivity. Now it is +-- identical to the above but we still keep it as a regression test. +type family Bar a = r | r -> a where + Bar Int = Bool + Bar Bool = Int + Bar Bool = Char + +-- Now let's use declared type families. All the below definitions should work + +-- No ambiguity for any of the arguments - all are injective +f :: F a b c -> F a b c +f x = x + +-- From 1st instance of F: a ~ Int, b ~ Char, c ~ Bool +fapp :: Bool +fapp = f True + +-- now the closed variant of F +fc :: FClosed a b c -> FClosed a b c +fc x = x + +fcapp :: Bool +fcapp = fc True + +-- The last argument is not injective so it must be instantiated +i :: I a b Int -> I a b Int +i x = x + +-- From 1st instance of I: a ~ Int, b ~ Char +iapp :: Bool +iapp = i True + +-- again, closed variant of I +ic :: IClosed a b Int -> IClosed a b Int +ic x = x + +icapp :: Bool +icapp = ic True + +-- Now we have to test weird closed type families: +bak :: Bak a -> Bak a +bak x = x + +bakapp1 :: Char +bakapp1 = bak 'c' + +bakapp2 :: Double +bakapp2 = bak 1.0 + +bakapp3 :: () +bakapp3 = bak () + +foo :: Foo a -> Foo a +foo x = x + +fooapp1 :: Bool +fooapp1 = foo True + +bar :: Bar a -> Bar a +bar x = x + +barapp1 :: Bool +barapp1 = bar True + +barapp2 :: Int +barapp2 = bar 1 + +-- Declarations below test more liberal RHSs of injectivity annotations: +-- permiting variables to appear in different order than the one in which they +-- were declared. +type family H a b = r | r -> b a +type family Hc a b = r | r -> b a where + Hc a b = a b +class Hcl a b where + type Ht a b = r | r -> b a + +-- repeated tyvars in the RHS of injectivity annotation: no warnings or errors +-- (consistent with behaviour for functional dependencies) +type family Jx a b = r | r -> a a +type family Jcx a b = r | r -> a a where + Jcx a b = a b +class Jcl a b where + type Jt a b = r | r -> a a + +type family Kx a b = r | r -> a b b +type family Kcx a b = r | r -> a b b where + Kcx a b = a b +class Kcl a b where + type Kt a b = r | r -> a b b + +-- Declaring kind injectivity. Here we only claim that knowing the RHS +-- determines the LHS kind but not the type. +type family L (a :: k1) = (r :: k2) | r -> k1 where + L 'True = Int + L 'False = Int + L Maybe = 3 + L IO = 3 + +data KProxy (a :: *) = KProxy +type family KP (kproxy :: KProxy k) = r | r -> k +type instance KP ('KProxy :: KProxy Bool) = Int +type instance KP ('KProxy :: KProxy *) = Char + +kproxy_id :: KP ('KProxy :: KProxy k) -> KP ('KProxy :: KProxy k) +kproxy_id x = x + +kproxy_id_use = kproxy_id 'a' + +-- Now test some awkward cases from The Injectivity Paper. All should be +-- accepted. +type family Gx a +type family Hx a +type family Gi a = r | r -> a +type instance Gi Int = Char +type family Hi a = r | r -> a + +type family F2 a = r | r -> a +type instance F2 [a] = [Gi a] +type instance F2 (Maybe a) = Hi a -> Int + +type family F4 a = r | r -> a +type instance F4 [a] = (Gx a, a, a, a) +type instance F4 (Maybe a) = (Hx a, a, Int, Bool) + +type family G2 a b = r | r -> a b +type instance G2 a Bool = (a, a) +type instance G2 Bool b = (b, Bool) + +type family G6 a = r | r -> a +type instance G6 [a] = [Gi a] +type instance G6 Bool = Int + +g6_id :: G6 a -> G6 a +g6_id x = x + +g6_use :: [Char] +g6_use = g6_id "foo" + +-- A sole exception to "bare variables in the RHS" rule +type family Id (a :: k) = (result :: k) | result -> a +type instance Id a = a + +-- This makes sure that over-saturated type family applications at the top-level +-- are accepted. +type family IdProxy (a :: k) b = r | r -> a +type instance IdProxy a b = (Id a) b + +-- make sure we look through type synonyms properly +type IdSyn a = Id a +type family IdProxySyn (a :: k) b = r | r -> a +type instance IdProxySyn a b = (IdSyn a) b + +-- this has bare variable in the RHS but all LHS varaiables are also bare so it +-- should be accepted +type family Fa (a :: k) (b :: k) = (r :: k2) | r -> k +type instance Fa a b = a + +-- Taken from #9587. This exposed a bug in the solver. +type family Arr (repr :: * -> *) (a :: *) (b :: *) = (r :: *) | r -> repr a b + +class ESymantics repr where + int :: Int -> repr Int + add :: repr Int -> repr Int -> repr Int + + lam :: (repr a -> repr b) -> repr (Arr repr a b) + app :: repr (Arr repr a b) -> repr a -> repr b + +te4 = let c3 = lam (\f -> lam (\x -> f `app` (f `app` (f `app` x)))) + in (c3 `app` (lam (\x -> x `add` int 14))) `app` (int 0) + +-- This used to fail during development +class Manifold' a where + type Base a = r | r -> a + project :: a -> Base a + unproject :: Base a -> a + +id' :: forall a. ( Manifold' a ) => Base a -> Base a +id' = project . unproject diff --git a/testsuite/tests/typecheck/should_compile/T6018.hs-boot b/testsuite/tests/typecheck/should_compile/T6018.hs-boot new file mode 100644 index 0000000000..8ac5ce9e51 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T6018.hs-boot @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, PolyKinds #-} + +module T6018 where + +-- this declaration uses different type variables than the one in the source +-- file but it should be accepted nevertheless +type family F d e f = (r :: k) | r -> d e f diff --git a/testsuite/tests/typecheck/should_compile/T6018.stderr b/testsuite/tests/typecheck/should_compile/T6018.stderr new file mode 100644 index 0000000000..41e94d8670 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T6018.stderr @@ -0,0 +1,11 @@ +[1 of 3] Compiling T6018[boot] ( T6018.hs-boot, T6018.o-boot ) +[2 of 3] Compiling T6018a ( T6018a.hs, T6018a.o ) +[3 of 3] Compiling T6018 ( T6018.hs, T6018.o ) + +T6018.hs:75:5: Warning: + Type family instance equation is overlapped: + Foo Bool = Bool + +T6018.hs:82:5: Warning: + Type family instance equation is overlapped: + Bar Bool = Char diff --git a/testsuite/tests/typecheck/should_compile/T6018a.hs b/testsuite/tests/typecheck/should_compile/T6018a.hs new file mode 100644 index 0000000000..beecb57c65 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T6018a.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018a where + +import {-# SOURCE #-} T6018 -- test support for hs-boot files + +type family G a b c = (result :: *) | result -> a b c +type instance G Int Char Bool = Bool +type instance G Char Bool Int = Int + +type instance F Bool Int Char = Char diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index b469689445..eff84032b1 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -358,6 +358,7 @@ test('tc263', extra_clean(['Tc263_Help.o','Tc263_Help.hi']), multimod_compile, ['tc263','-v0']) test('tc264', normal, multimod_compile, ['tc264.hsig', '-sig-of "ShouldCompile is base:Data.STRef"']) +test('tc265', compile_timeout_multiplier(0.01), compile, ['']) test('GivenOverlapping', normal, compile, ['']) test('GivenTypeSynonym', normal, compile, ['']) @@ -385,6 +386,9 @@ test('T6055', normal, compile, ['']) test('DfltProb1', normal, compile, ['']) test('DfltProb2', normal, compile, ['']) test('T6134', normal, compile, ['']) +test('T6018', extra_clean(['T6018.hi' , 'T6018.o' + ,'T6018A.hi', 'T6018A.o']) + , multimod_compile, ['T6018', '']) test('TcLambdaCase', when(compiler_lt('ghc', '7.5'), skip), compile, ['']) test('T7147', normal, compile, ['']) test('T7171',normal,run_command, diff --git a/testsuite/tests/typecheck/should_compile/holes2.stderr b/testsuite/tests/typecheck/should_compile/holes2.stderr index 392b69992d..ad5b530fae 100644 --- a/testsuite/tests/typecheck/should_compile/holes2.stderr +++ b/testsuite/tests/typecheck/should_compile/holes2.stderr @@ -3,9 +3,9 @@ holes2.hs:3:5: warning: No instance for (Show a0) arising from a use of ‘show’ The type variable ‘a0’ is ambiguous Potential instances: - instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ instance Show Ordering -- Defined in ‘GHC.Show’ instance Show Integer -- Defined in ‘GHC.Show’ + instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ ...plus 22 others (use -fprint-potential-instances to see them all) In the expression: show _ diff --git a/testsuite/tests/typecheck/should_compile/tc265.hs b/testsuite/tests/typecheck/should_compile/tc265.hs new file mode 100644 index 0000000000..eff43d8b42 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc265.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +module Tc265 where + +data T a = MkT (F a) +type family F a where + F (T a) = a + F (T Int) = Bool diff --git a/testsuite/tests/typecheck/should_compile/tc265.stderr b/testsuite/tests/typecheck/should_compile/tc265.stderr new file mode 100644 index 0000000000..64099721b8 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc265.stderr @@ -0,0 +1,4 @@ + +tc265.hs:8:3: warning: + Type family instance equation is overlapped: + F (T Int) = Bool diff --git a/testsuite/tests/typecheck/should_fail/T6018Afail.hs b/testsuite/tests/typecheck/should_fail/T6018Afail.hs new file mode 100644 index 0000000000..95184a177c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018Afail.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018Afail where + +type family G a b c = (result :: *) | result -> a b c +type instance G Int Char Bool = Bool +type instance G Char Bool Int = Int diff --git a/testsuite/tests/typecheck/should_fail/T6018Bfail.hs b/testsuite/tests/typecheck/should_fail/T6018Bfail.hs new file mode 100644 index 0000000000..ef2460187f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018Bfail.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018Bfail where + +type family H a b c = (result :: *) | result -> a b c diff --git a/testsuite/tests/typecheck/should_fail/T6018Cfail.hs b/testsuite/tests/typecheck/should_fail/T6018Cfail.hs new file mode 100644 index 0000000000..b7a790824c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018Cfail.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018Cfail where + +import T6018Bfail + +type instance H Int Char Bool = Bool +type instance H Char Bool Int = Int diff --git a/testsuite/tests/typecheck/should_fail/T6018Dfail.hs b/testsuite/tests/typecheck/should_fail/T6018Dfail.hs new file mode 100644 index 0000000000..ec69833f1d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018Dfail.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018Dfail where + +import T6018Bfail + +type instance H Bool Int Char = Int diff --git a/testsuite/tests/typecheck/should_fail/T6018fail.hs b/testsuite/tests/typecheck/should_fail/T6018fail.hs new file mode 100644 index 0000000000..ead4dd354f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018fail.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds, + MultiParamTypeClasses, FlexibleInstances #-} + +module T6018fail where + +import T6018Afail -- defines G, identical to F +import T6018Cfail -- imports H from T6018Bfail, defines some equations for H +import T6018Dfail -- imports H from T6018Bfail, defines conflicting eqns + +type family F a b c = (result :: *) | result -> a b c +type instance F Int Char Bool = Bool +type instance F Char Bool Int = Int +type instance F Bool Int Char = Int + +type instance G Bool Int Char = Int + +type family I a b c = r | r -> a b +type instance I Int Char Bool = Bool +type instance I Int Int Int = Bool +type instance I Bool Int Int = Int + +-- Id is injective... +type family Id a = result | result -> a +type instance Id a = a + +-- ...but despite that we disallow a call to Id +type family IdProxy a = r | r -> a +type instance IdProxy a = Id a + +data N = Z | S N + +-- P is not injective, although the user declares otherwise. This +-- should be rejected on the grounds of calling a type family in the +-- RHS. +type family P (a :: N) (b :: N) = (r :: N) | r -> a b +type instance P Z m = m +type instance P (S n) m = S (P n m) + +-- this is not injective - not all injective type variables mentioned +-- on LHS are mentioned on RHS +type family J a b c = r | r -> a b +type instance J Int b c = Char + +-- same as above, but tyvar is now nested inside a tycon +type family K (a :: N) (b :: N) = (r :: N) | r -> a b +type instance K (S n) m = S m + +-- Make sure we look through type synonyms to catch errors +type MaybeSyn a = Id a +type family L a = r | r -> a +type instance L a = MaybeSyn a + +-- These should fail because given the RHS kind there is no way to determine LHS +-- kind +class PolyKindVarsC a where + type PolyKindVarsF a = (r :: k) | r -> a + +instance PolyKindVarsC '[] where + type PolyKindVarsF '[] = '[] + +type family PolyKindVars (a :: k0) = (r :: k1) | r -> a +type instance PolyKindVars '[] = '[] + +-- This should fail because there is no way to determine k from the RHS +type family Fc (a :: k) (b :: k) = r | r -> k +type instance Fc a b = Int + +-- This should fail because there is no way to determine a, b and k from the RHS +type family Gc (a :: k) (b :: k) = r | r -> a b +type instance Gc a b = Int + +-- fails because injectivity is not compositional in this case +type family F1 a = r | r -> a +type instance F1 [a] = Maybe (GF1 a) +type instance F1 (Maybe a) = Maybe (GF2 a) + +type family GF1 a = r | r -> a +type instance GF1 Int = Bool + +type family GF2 a = r | r -> a +type instance GF2 Int = Bool + +type family HF1 a +type instance HF1 Bool = Bool + +type family W1 a = r | r -> a +type instance W1 [a] = a + +type family W2 a = r | r -> a +type instance W2 [a] = W2 a + +-- not injective because of infinite types +type family Z1 a = r | r -> a +type instance Z1 [a] = (a, a) +type instance Z1 (Maybe b) = (b, [b]) + +type family G1 a = r | r -> a +type instance G1 [a] = [a] +type instance G1 (Maybe b) = [(b, b)] + +type family G3 a b = r | r -> b +type instance G3 a Int = (a, Int) +type instance G3 a Bool = (Bool, a) + +type family G4 a b = r | r -> a b +type instance G4 a b = [a] + +type family G5 a = r | r -> a +type instance G5 [a] = [GF1 a] -- GF1 injective +type instance G5 Int = [Bool] + +type family G6 a = r | r -> a +type instance G6 [a] = [HF1 a] -- HF1 not injective +type instance G6 Bool = Int + +type family G7a a b (c :: k) = r | r -> a b +type family G7 a b (c :: k) = r | r -> a b c +type instance G7 a b c = [G7a a b c] + +class C a b where + type FC a (b :: *) = r | r -> b + type instance FC a b = b + +instance C Int Char where + type FC Int Char = Bool + +-- this should fail because the default instance conflicts with one of the +-- earlier instances +instance C Int Bool {- where + type FC Int Bool = Bool-} + +-- and this should fail because it violates "bare variable in the RHS" +-- restriction +instance C Char a diff --git a/testsuite/tests/typecheck/should_fail/T6018fail.stderr b/testsuite/tests/typecheck/should_fail/T6018fail.stderr new file mode 100644 index 0000000000..440ddacd91 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018fail.stderr @@ -0,0 +1,149 @@ +[1 of 5] Compiling T6018Bfail ( T6018Bfail.hs, T6018Bfail.o ) +[2 of 5] Compiling T6018Dfail ( T6018Dfail.hs, T6018Dfail.o ) +[3 of 5] Compiling T6018Cfail ( T6018Cfail.hs, T6018Cfail.o ) +[4 of 5] Compiling T6018Afail ( T6018Afail.hs, T6018Afail.o ) +[5 of 5] Compiling T6018fail ( T6018fail.hs, T6018fail.o ) + +T6018Afail.hs:7:15: + Type family equations violate injectivity annotation: + G Char Bool Int = Int + G Bool Int Char = Int + +T6018Dfail.hs:7:15: + Type family equations violate injectivity annotation: + T6018Bfail.H Bool Int Char = Int + T6018Bfail.H Char Bool Int = Int + +T6018fail.hs:13:15: + Type family equations violate injectivity annotation: + F Bool Int Char = Int + F Char Bool Int = Int + +T6018fail.hs:19:15: + Type family equations violate injectivity annotation: + I Int Int Int = Bool + I Int Char Bool = Bool + +T6018fail.hs:28:15: + Type family equation violates injectivity annotation. + RHS of injective type family equation cannot be a type family: + IdProxy a = Id a + +T6018fail.hs:36:15: + Type family equation violates injectivity annotation. + RHS of injective type family equation is a bare type variable + but these LHS type and kind patterns are not bare variables: ‘'Z’ + P 'Z m = m + +T6018fail.hs:37:15: + Type family equations violate injectivity annotation: + P ('S n) m = 'S (P n m) + P 'Z m = m + +T6018fail.hs:42:15: + Type family equation violates injectivity annotation. + Injective type variable ‘b’ does not appear on injective position. + In the RHS of type family equation: + J Int b c = Char + +T6018fail.hs:46:15: + Type family equation violates injectivity annotation. + Injective type variable ‘n’ does not appear on injective position. + In the RHS of type family equation: + K ('S n) m = 'S m + +T6018fail.hs:51:15: + Type family equation violates injectivity annotation. + RHS of injective type family equation cannot be a type family: + L a = MaybeSyn a + +T6018fail.hs:59:10: + Type family equation violates injectivity annotation. + Injective kind variable ‘k1’ is not inferable from the RHS type variables. + In the RHS of type family equation: + PolyKindVarsF '[] = '[] + +T6018fail.hs:62:15: + Type family equation violates injectivity annotation. + Injective kind variable ‘k1’ is not inferable from the RHS type variables. + In the RHS of type family equation: + PolyKindVars '[] = '[] + +T6018fail.hs:66:15: + Type family equation violates injectivity annotation. + Injective kind variable ‘k’ is not inferable from the RHS type variables. + In the RHS of type family equation: + forall (k :: BOX) (a :: k) (b :: k). Fc a b = Int + +T6018fail.hs:70:15: + Type family equation violates injectivity annotation. + Injective type variables ‘a’, ‘b’ do not appear on injective position. + Injective kind variable ‘k’ is not inferable from the RHS type variables. + In the RHS of type family equation: + forall (k :: BOX) (a :: k) (b :: k). Gc a b = Int + +T6018fail.hs:75:15: + Type family equations violate injectivity annotation: + F1 (Maybe a) = Maybe (GF2 a) + F1 [a] = Maybe (GF1 a) + +T6018fail.hs:87:15: + Type family equation violates injectivity annotation. + RHS of injective type family equation is a bare type variable + but these LHS type and kind patterns are not bare variables: ‘[a]’ + W1 [a] = a + +T6018fail.hs:90:15: + Type family equation violates injectivity annotation. + RHS of injective type family equation cannot be a type family: + W2 [a] = W2 a + +T6018fail.hs:95:15: + Type family equations violate injectivity annotation: + Z1 (Maybe b) = (b, [b]) + Z1 [a] = (a, a) + +T6018fail.hs:99:15: + Type family equations violate injectivity annotation: + G1 (Maybe b) = [(b, b)] + G1 [a] = [a] + +T6018fail.hs:103:15: + Type family equations violate injectivity annotation: + G3 a Bool = (Bool, a) + G3 a Int = (a, Int) + +T6018fail.hs:106:15: + Type family equation violates injectivity annotation. + Injective type variable ‘b’ does not appear on injective position. + In the RHS of type family equation: + G4 a b = [a] + +T6018fail.hs:110:15: + Type family equations violate injectivity annotation: + G5 Int = [Bool] + G5 [a] = [GF1 a] + +T6018fail.hs:113:15: + Type family equation violates injectivity annotation. + Injective type variable ‘a’ does not appear on injective position. + In the RHS of type family equation: + G6 [a] = [HF1 a] + +T6018fail.hs:118:15: + Type family equation violates injectivity annotation. + Injective type variable ‘c’ does not appear on injective position. + Injective kind variable ‘k’ is not inferable from the RHS type variables. + In the RHS of type family equation: + forall (k :: BOX) a b (c :: k). G7 a b c = [G7a a b c] + +T6018fail.hs:129:1: + Type family equations violate injectivity annotation: + FC Int Bool = Bool + FC Int Char = Bool + +T6018fail.hs:134:1: + Type family equation violates injectivity annotation. + RHS of injective type family equation is a bare type variable + but these LHS type and kind patterns are not bare variables: ‘*’, ‘Char’ + FC Char a = a diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed1.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed1.hs new file mode 100644 index 0000000000..c650781847 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-} + +module T6018failclosed1 where + +-- Id is injective... +type family IdClosed a = result | result -> a where + IdClosed a = a + +-- ...but despite that we disallow a call to Id +type family IdProxyClosed a = r | r -> a where + IdProxyClosed a = IdClosed a diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed1.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed1.stderr new file mode 100644 index 0000000000..968e9e797b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed1.stderr @@ -0,0 +1,7 @@ + +T6018failclosed1.hs:11:5: + Type family equation violates injectivity annotation. + RHS of injective type family equation cannot be a type family: + IdProxyClosed a = IdClosed a + In the equations for closed type family ‘IdProxyClosed’ + In the type family declaration for ‘IdProxyClosed’ diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed10.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed10.hs new file mode 100644 index 0000000000..99828c6809 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed10.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-} + +module T6018failclosed10 where + +-- this one is a strange beast. Last equation is unreachable and thus it is +-- removed. It is then impossible to typecheck barapp and thus we generate an +-- error +type family Bar a = r | r -> a where + Bar Int = Bool + Bar Bool = Int + Bar Bool = Char + +bar :: Bar a -> Bar a +bar x = x + +barapp :: Char +barapp = bar 'c' diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed10.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed10.stderr new file mode 100644 index 0000000000..6248f97a47 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed10.stderr @@ -0,0 +1,9 @@ + +T6018failclosed10.hs:17:14: + Couldn't match expected type ‘Bar a0’ with actual type ‘Char’ + The type variable ‘a0’ is ambiguous + In the first argument of ‘bar’, namely ‘'c'’ + In the expression: bar 'c' + In an equation for ‘barapp’: barapp = bar 'c' + + diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed11.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed11.hs new file mode 100644 index 0000000000..566551cfef --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed11.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018failclosed12 where + +-- This exposed a subtle bug in the implementation during development. After +-- unifying the RHS of (1) and (2) the LHS substitution was done only in (2) +-- which made it look like an overlapped equation. This is not the case and this +-- definition should be rejected. The first two equations are here to make sure +-- that the internal implementation does list indexing corrcectly (this is a bit +-- tricky because the list is kept in reverse order). +type family F a b = r | r -> a b where + F Float IO = Float + F Bool IO = Bool + F a IO = IO a -- (1) + F Char b = b Int -- (2) diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed11.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed11.stderr new file mode 100644 index 0000000000..7c7496b819 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed11.stderr @@ -0,0 +1,7 @@ + +T6018failclosed11.hs:14:3: + Type family equations violate injectivity annotation: + F a IO = IO a + F Char b = b Int + In the equations for closed type family ‘F’ + In the type family declaration for ‘F’ diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed12.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed12.hs new file mode 100644 index 0000000000..9ff9a396a0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed12.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds #-} + +module T6018failclosed12 where + +-- This should fail because there is no way to determine a, b and k from the RHS +type family Gc (a :: k) (b :: k) = r | r -> k where + Gc a b = Int diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed12.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed12.stderr new file mode 100644 index 0000000000..2ad07aa2a4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed12.stderr @@ -0,0 +1,8 @@ + +T6018failclosed12.hs:7:5: + Type family equation violates injectivity annotation. + Injective kind variable ‘k’ is not inferable from the RHS type variables. + In the RHS of type family equation: + forall (k :: BOX) (a :: k) (b :: k). Gc a b = Int + In the equations for closed type family ‘Gc’ + In the type family declaration for ‘Gc’ diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed2.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed2.hs new file mode 100644 index 0000000000..44abb06b16 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed2.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-} + +module T6018failclosed2 where + +data N = Z | S N + +-- PClosed is not injective, although the user declares otherwise. This +-- should be rejected on the grounds of calling a type family in the +-- RHS. +type family PClosed (a :: N) (b :: N) = (r :: N) | r -> a b where + PClosed Z m = m + PClosed (S n) m = S (PClosed n m) diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed2.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed2.stderr new file mode 100644 index 0000000000..11ece3d7f5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed2.stderr @@ -0,0 +1,16 @@ + +T6018failclosed2.hs:11:5: + Type family equation violates injectivity annotation. + RHS of injective type family equation is a bare type variable + but these LHS type and kind patterns are not bare variables: ‘'Z’ + PClosed 'Z m = m + In the equations for closed type family ‘PClosed’ + In the type family declaration for ‘PClosed’ + +T6018failclosed2.hs:11:5: + Type family equations violate injectivity annotation: + PClosed 'Z m = m + PClosed ('S n) m = 'S (PClosed n m) + In the equations for closed type family ‘PClosed’ + In the type family declaration for ‘PClosed’ + diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed3.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed3.hs new file mode 100644 index 0000000000..e43ee75e1f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed3.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-} + +module T6018failclosed3 where + +-- this is not injective - not all injective type variables mentioned +-- on LHS are mentioned on RHS +type family JClosed a b c = r | r -> a b where + JClosed Int b c = Char diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed3.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed3.stderr new file mode 100644 index 0000000000..968dd76323 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed3.stderr @@ -0,0 +1,8 @@ + +T6018failclosed3.hs:8:5: + Type family equation violates injectivity annotation. + Injective type variable ‘b’ does not appear on injective position. + In the RHS of type family equation: + JClosed Int b c = Char + In the equations for closed type family ‘JClosed’ + In the type family declaration for ‘JClosed’ diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed4.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed4.hs new file mode 100644 index 0000000000..116a9c6df4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed4.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-} + +module T6018failclosed4 where + +data N = Z | S N + +-- this is not injective - not all injective type variables mentioned +-- on LHS are mentioned on RHS (tyvar is now nested inside a tycon) +type family KClosed (a :: N) (b :: N) = (r :: N) | r -> a b where + KClosed (S n) m = S m diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed4.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed4.stderr new file mode 100644 index 0000000000..5db55db602 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed4.stderr @@ -0,0 +1,8 @@ + +T6018failclosed4.hs:10:5: + Type family equation violates injectivity annotation. + Injective type variable ‘n’ does not appear on injective position. + In the RHS of type family equation: + KClosed ('S n) m = 'S m + In the equations for closed type family ‘KClosed’ + In the type family declaration for ‘KClosed’ diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed5.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed5.hs new file mode 100644 index 0000000000..9665365a2f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed5.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-} + +module T6018failclosed5 where + +-- Id is injective... +type family IdClosed a = result | result -> a where + IdClosed a = a + +-- hiding a type family application behind a type synonym should be rejected +type MaybeSynClosed a = IdClosed a +type family LClosed a = r | r -> a where + LClosed a = MaybeSynClosed a diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed5.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed5.stderr new file mode 100644 index 0000000000..57ab357bc2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed5.stderr @@ -0,0 +1,8 @@ + +T6018failclosed5.hs:12:2: + Type family equation violates injectivity annotation. + RHS of injective type family equation cannot be a type family: + LClosed a = MaybeSynClosed a + In the equations for closed type family ‘LClosed’ + In the type family declaration for ‘LClosed’ + diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed6.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed6.hs new file mode 100644 index 0000000000..ef55b558e1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed6.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds #-} + +module T6018failclosed6 where + +-- This should fail because there is no way to determine a, b and k from the RHS +type family Gc (a :: k) (b :: k) = r | r -> a b where + Gc a b = Int diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed6.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed6.stderr new file mode 100644 index 0000000000..be8a763ad4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed6.stderr @@ -0,0 +1,9 @@ + +T6018failclosed6.hs:7:5: + Type family equation violates injectivity annotation. + Injective type variables ‘a’, ‘b’ do not appear on injective position. + Injective kind variable ‘k’ is not inferable from the RHS type variables. + In the RHS of type family equation: + forall (k :: BOX) (a :: k) (b :: k). Gc a b = Int + In the equations for closed type family ‘Gc’ + In the type family declaration for ‘Gc’ diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed7.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed7.hs new file mode 100644 index 0000000000..a82c323509 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed7.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-} + +module T6018failclosed7 where + +type family FClosed a b c = (result :: *) | result -> a b c where + FClosed Int Char Bool = Bool + FClosed Char Bool Int = Int + FClosed Bool Int Char = Int diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed7.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed7.stderr new file mode 100644 index 0000000000..6cdfed528a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed7.stderr @@ -0,0 +1,7 @@ + +T6018failclosed7.hs:7:5: + Type family equations violate injectivity annotation: + FClosed Char Bool Int = Int + FClosed Bool Int Char = Int + In the equations for closed type family ‘FClosed’ + In the type family declaration for ‘FClosed’ diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed8.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed8.hs new file mode 100644 index 0000000000..8936427547 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed8.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-} + +module T6018failclosed8 where + +type family IClosed a b c = r | r -> a b where + IClosed Int Char Bool = Bool + IClosed Int Int Int = Bool + IClosed Bool Int Int = Int diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed8.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed8.stderr new file mode 100644 index 0000000000..046eed7830 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed8.stderr @@ -0,0 +1,7 @@ + +T6018failclosed8.hs:6:5: + Type family equations violate injectivity annotation: + IClosed Int Char Bool = Bool + IClosed Int Int Int = Bool + In the equations for closed type family ‘IClosed’ + In the type family declaration for ‘IClosed’ diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed9.hs b/testsuite/tests/typecheck/should_fail/T6018failclosed9.hs new file mode 100644 index 0000000000..5ec59066b2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed9.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-} + +module T6018failclosed9 where + +type family E2 (a :: Bool) = r | r -> a where + E2 False = True + E2 True = False + E2 a = False diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed9.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed9.stderr new file mode 100644 index 0000000000..325d9c03ed --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed9.stderr @@ -0,0 +1,8 @@ + +T6018failclosed9.hs:8:3: + Type family equation violates injectivity annotation. + Injective type variable ‘a’ does not appear on injective position. + In the RHS of type family equation: + E2 a = 'False + In the equations for closed type family ‘E2’ + In the type family declaration for ‘E2’ diff --git a/testsuite/tests/typecheck/should_fail/T9201.stderr b/testsuite/tests/typecheck/should_fail/T9201.stderr index 44e338a697..5f16dcaedd 100644 --- a/testsuite/tests/typecheck/should_fail/T9201.stderr +++ b/testsuite/tests/typecheck/should_fail/T9201.stderr @@ -1,5 +1,5 @@ -T9201.hs:6:17: +T9201.hs:6:17: error: The first argument of ‘f’ should have kind ‘x1’, but ‘a’ has kind ‘y1’ In the type ‘d a (f a)’ diff --git a/testsuite/tests/typecheck/should_fail/T9260.stderr b/testsuite/tests/typecheck/should_fail/T9260.stderr index 4d1a94a4bd..a163b16cbd 100644 --- a/testsuite/tests/typecheck/should_fail/T9260.stderr +++ b/testsuite/tests/typecheck/should_fail/T9260.stderr @@ -1,8 +1,7 @@ T9260.hs:12:8: error: - Couldn't match type ‘(n0 + 1) + 1’ with ‘1’ - The type variable ‘n0’ is ambiguous + Couldn't match type ‘2’ with ‘1’ Expected type: Fin 1 - Actual type: Fin ((n0 + 1) + 1) + Actual type: Fin (1 + 1) In the expression: Fsucc Fzero In an equation for ‘test’: test = Fsucc Fzero diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 1a2ff9aa81..85532dede5 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -277,6 +277,24 @@ test('T5957', normal, compile_fail, ['']) test('T6001', normal, compile_fail, ['']) test('T6022', normal, compile_fail, ['']) test('T5853', normal, compile_fail, ['']) +test('T6018fail', extra_clean([ 'T6018fail.hi' , 'T6018fail.o' + , 'T6018Afail.hi', 'T6018Afail.o' + , 'T6018Bfail.hi', 'T6018Bfail.o' + , 'T6018Cfail.hi', 'T6018Cfail.o' + , 'T6018Dfail.hi', 'T6018Dfail.o']) + , multimod_compile_fail, ['T6018fail', '-no-hs-main -c']) +test('T6018failclosed1', normal, compile_fail, ['']) +test('T6018failclosed2', normal, compile_fail, ['']) +test('T6018failclosed3', normal, compile_fail, ['']) +test('T6018failclosed4', normal, compile_fail, ['']) +test('T6018failclosed5', normal, compile_fail, ['']) +test('T6018failclosed6', normal, compile_fail, ['']) +test('T6018failclosed7', normal, compile_fail, ['']) +test('T6018failclosed8', normal, compile_fail, ['']) +test('T6018failclosed9', normal, compile_fail, ['']) +test('T6018failclosed10', normal, compile_fail, ['']) +test('T6018failclosed11', normal, compile_fail, ['']) +test('T6018failclosed12', normal, compile_fail, ['']) test('T6078', normal, compile_fail, ['']) test('FDsFromGivens', normal, compile_fail, ['']) test('FDsFromGivens2', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail072.stderr b/testsuite/tests/typecheck/should_fail/tcfail072.stderr index f3386f164b..3f40718428 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail072.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail072.stderr @@ -7,10 +7,10 @@ tcfail072.hs:23:13: error: at tcfail072.hs:22:6-38 The type variable ‘p0’ is ambiguous Potential instances: - instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’ instance Ord Ordering -- Defined in ‘GHC.Classes’ instance Ord Integer -- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’ + instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’ ...plus 22 others ...plus one instance involving out-of-scope types (use -fprint-potential-instances to see them all) diff --git a/testsuite/tests/typecheck/should_fail/tcfail133.stderr b/testsuite/tests/typecheck/should_fail/tcfail133.stderr index 1869cea44b..bba5889603 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail133.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail133.stderr @@ -6,9 +6,10 @@ tcfail133.hs:68:7: error: No instance for (Show r0) arising from a use of ‘show’ The type variable ‘r0’ is ambiguous Potential instances: - instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ instance Show Ordering -- Defined in ‘GHC.Show’ instance Show Integer -- Defined in ‘GHC.Show’ + instance (Show a, Show b, Number a, Digit b) => Show (a :@ b) + -- Defined at tcfail133.hs:11:54 ...plus 25 others (use -fprint-potential-instances to see them all) In the expression: show diff --git a/testsuite/tests/typecheck/should_fail/tcfail181.stderr b/testsuite/tests/typecheck/should_fail/tcfail181.stderr index 3d3507f256..70dbbd5508 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail181.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail181.stderr @@ -7,8 +7,8 @@ tcfail181.hs:17:9: error: at tcfail181.hs:17:1-30 The type variable ‘m0’ is ambiguous Potential instances: - instance Monad Maybe -- Defined in ‘GHC.Base’ instance Monad IO -- Defined in ‘GHC.Base’ + instance Monad Maybe -- Defined in ‘GHC.Base’ instance Monad ((->) r) -- Defined in ‘GHC.Base’ ...plus two others (use -fprint-potential-instances to see them all) diff --git a/utils/haddock b/utils/haddock -Subproject 7570ed8595402bcd354b7b24de1f4b0e3e527a5 +Subproject ad49d1608f406dc83f64f65920f1c6aa2f75403 |