Injective type families
authorJan Stolarek <jan.stolarek@p.lodz.pl>
Fri, 11 Jul 2014 11:54:45 +0000 (13:54 +0200)
committerJan Stolarek <jan.stolarek@p.lodz.pl>
Thu, 3 Sep 2015 03:55:15 +0000 (05:55 +0200)
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:
compiler/basicTypes/MkId.hs
compiler/basicTypes/VarSet.hs
compiler/coreSyn/MkCore.hs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/PlaceHolder.hs
compiler/iface/BuildTyCl.hs
compiler/iface/IfaceSyn.hs
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/main/GHC.hs
compiler/parser/ApiAnnotation.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/prelude/PrelNames.hs
compiler/prelude/THNames.hs
compiler/prelude/TysPrim.hs
compiler/prelude/TysWiredIn.hs
compiler/rename/RnSource.hs
compiler/rename/RnTypes.hs
compiler/typecheck/FamInst.hs
compiler/typecheck/TcCanonical.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcEvidence.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTypeNats.hs
compiler/typecheck/TcValidity.hs
compiler/types/CoAxiom.hs
compiler/types/Coercion.hs
compiler/types/FamInstEnv.hs
compiler/types/Kind.hs
compiler/types/OptCoercion.hs
compiler/types/TyCon.hs
compiler/types/TypeRep.hs
compiler/types/TypeRep.hs-boot
compiler/types/Unify.hs
compiler/utils/Outputable.hs
compiler/utils/UniqFM.hs
docs/users_guide/7.12.1-notes.xml
docs/users_guide/glasgow_exts.xml
libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/PprLib.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/ghci.debugger/scripts/print019.stderr
testsuite/tests/ghci/scripts/T6018ghci.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/T6018ghci.stdout [new file with mode: 0644]
testsuite/tests/ghci/scripts/T6018ghcifail.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/T6018ghcifail.stderr [new file with mode: 0644]
testsuite/tests/ghci/scripts/T6018ghcirnfail.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/T6018ghcirnfail.stderr [new file with mode: 0644]
testsuite/tests/ghci/scripts/all.T
testsuite/tests/indexed-types/should_compile/T9085.stderr
testsuite/tests/indexed-types/should_fail/T9160.hs
testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
testsuite/tests/quotes/TH_localname.stderr
testsuite/tests/rename/should_fail/T6018rnfail.hs [new file with mode: 0644]
testsuite/tests/rename/should_fail/T6018rnfail.stderr [new file with mode: 0644]
testsuite/tests/rename/should_fail/all.T
testsuite/tests/rename/should_fail/mc14.stderr
testsuite/tests/th/ClosedFam2TH.hs
testsuite/tests/th/T10306.hs
testsuite/tests/th/T6018th.hs [new file with mode: 0644]
testsuite/tests/th/T6018th.stderr [new file with mode: 0644]
testsuite/tests/th/T8028.hs
testsuite/tests/th/T8028a.hs
testsuite/tests/th/T8884.hs
testsuite/tests/th/T8884.stderr
testsuite/tests/th/TH_RichKinds2.hs
testsuite/tests/th/TH_reifyDecl1.hs
testsuite/tests/th/all.T
testsuite/tests/typecheck/should_compile/T6018.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T6018.hs-boot [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T6018.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T6018a.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T
testsuite/tests/typecheck/should_compile/holes2.stderr
testsuite/tests/typecheck/should_compile/tc265.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/tc265.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018Afail.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018Bfail.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018Cfail.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018Dfail.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018fail.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018fail.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed1.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed1.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed10.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed10.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed11.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed11.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed12.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed12.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed2.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed2.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed3.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed3.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed4.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed4.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed5.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed5.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed6.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed6.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed7.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed7.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed8.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed8.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed9.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T6018failclosed9.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T9201.stderr
testsuite/tests/typecheck/should_fail/T9260.stderr
testsuite/tests/typecheck/should_fail/all.T
testsuite/tests/typecheck/should_fail/tcfail072.stderr
testsuite/tests/typecheck/should_fail/tcfail133.stderr
testsuite/tests/typecheck/should_fail/tcfail181.stderr
utils/haddock

index ad584a3..36d0794 100644 (file)
@@ -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
 
index 7adc898..f5ea6ed 100644 (file)
@@ -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
index 3c115f4..69410cd 100644 (file)
@@ -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
 *                                                                      *
 ************************************************************************
index c222b33..867f900 100644 (file)
@@ -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)
index db4ae97..9466ab0 100644 (file)
@@ -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
index 7b263ab..aefbfa6 100644 (file)
@@ -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
index 2a09ebf..0393cca 100644 (file)
@@ -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
index 00a2cdf..91d37ea 100644 (file)
@@ -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
index 640ad9b..8efd342 100644 (file)
@@ -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
 
 
index fc5053b..6371c43 100644 (file)
@@ -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
index f594181..e8b37ce 100644 (file)
@@ -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
 
index 2cd256b..b601dc6 100644 (file)
@@ -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
index 4b72098..f6c1cec 100644 (file)
@@ -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 )
index 5ae1d04..7376e30 100644 (file)
@@ -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
index 1b4df16..7e7f579 100644 (file)
@@ -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
index 18890b5..edc8a63 100644 (file)
@@ -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
index e56307f..1684a2f 100644 (file)
@@ -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
index cd65385..9367d4b 100644 (file)
@@ -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
index 5ce89ad..d66b48e 100644 (file)
@@ -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)
 
index 449377d..97c84cd 100644 (file)
@@ -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
 *                                                                      *
index 1a6fa17..820f0b0 100644 (file)
@@ -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]
 ~~~~~~~~~~~~~~~~~~~
index 5dfd3fa..090ed64 100644 (file)
@@ -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
index 3af2358..49fc5fe 100644 (file)
@@ -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
index ed3955d..3f0a198 100644 (file)
@@ -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.
 
index e39fbf9..fa67d49 100644 (file)
@@ -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,
index e08d0d5..83bbcca 100644 (file)
@@ -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]
index 39ab4e6..2f42791 100644 (file)
@@ -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]
index 461eb5a..328a8cf 100644 (file)
@@ -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)
index 6feb3f0..261d9af 100644 (file)
@@ -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)
index 455c956..a9c608d 100644 (file)
@@ -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)
index 6e3fd81..1595eef 100644 (file)
@@ -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)
index c1392f4..2492c55 100644 (file)
@@ -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
index 3721975..80437ff 100644 (file)
@@ -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
index a018e4a..52b52db 100644 (file)
@@ -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
index 2eb2daf..19af9f0 100644 (file)
@@ -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)
index 18d3b32..1f31d56 100644 (file)
@@ -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
 
 
 
index 122b286..c1b8a09 100644 (file)
@@ -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") <>
index 9a85185..66cec4c 100644 (file)
@@ -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)
index 80fdcc6..5d4329d 100644 (file)
@@ -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]
 
index 11e93df..9822236 100644 (file)
@@ -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) 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
 
 {-
 ************************************************************************
index e65c834..342cab5 100644 (file)
@@ -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,
index 35d1781..e112a20 100644 (file)
@@ -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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 683c939..c10c7ba 100644 (file)
@@ -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) } }
+
 {-
 ************************************************************************
 *                                                                      *
index 291e14c..b732247 100644 (file)
@@ -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
index e4117de..42b8a70 100644 (file)
@@ -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
index fa80584..b816558 100644 (file)
@@ -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]
index 93645d3..cb42d75 100644 (file)
@@ -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")
+
 {-
 ************************************************************************
 *                                                                      *
index e24c717..db578c3 100644 (file)
@@ -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
index fa3ea01..5a6670d 100644 (file)
@@ -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
                 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>
 
index 1a4fbdb..931706b 100644 (file)
@@ -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>
 
 
index 6472104..4db92b7 100644 (file)
@@ -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,
index 5d2b08c..fd5dd70 100644 (file)
@@ -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
index 5fb7197..589382a 100644 (file)
@@ -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"
index 6813496..8019e48 100644 (file)
@@ -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 "->"
index 9f7b510..82e22dd 100644 (file)
@@ -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 )
index 39bc29f..5c18224 100644 (file)
@@ -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 (file)
index 0000000..4615be2
--- /dev/null
@@ -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 (file)
index 0000000..e69de29
diff --git a/testsuite/tests/ghci/scripts/T6018ghcifail.script b/testsuite/tests/ghci/scripts/T6018ghcifail.script
new file mode 100644 (file)
index 0000000..c0e0734
--- /dev/null
@@ -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 (file)
index 0000000..e1c0055
--- /dev/null
@@ -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 (file)
index 0000000..f1a5fa4
--- /dev/null
@@ -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 (file)
index 0000000..87f5a04
--- /dev/null
@@ -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
index bbd69ee..d2244c1 100755 (executable)
@@ -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'])
index ee968e0..8a4ebdb 100644 (file)
@@ -1,4 +1,4 @@
 
 T9085.hs:7:3: Warning:
-    Overlapped type family instance equation:
+    Type family instance equation is overlapped:
       F Bool = Bool
index 64ae3b9..7daa6b8 100644 (file)
@@ -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
-
index 79b7865..75abc3b 100644 (file)
@@ -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]
index 76bfeea..c764f57 100644 (file)
@@ -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 (file)
index 0000000..14d1929
--- /dev/null
@@ -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 (file)
index 0000000..2628024
--- /dev/null
@@ -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’
index 23648c9..bd717dd 100644 (file)
@@ -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, [''])
index 3f52be3..bb02f9b 100644 (file)
@@ -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)
index cd2dc2d..bb355a2 100644 (file)
@@ -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)
index b93114b..b74eb59 100644 (file)
@@ -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 (file)
index 0000000..3205363
--- /dev/null
@@ -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 (file)
index 0000000..98c318b
--- /dev/null
@@ -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
index 6145428..c54f0e3 100644 (file)
@@ -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
  )
index 928a96e..7845c13 100644 (file)
@@ -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 []]
index ca6ed9c..acbd620 100644 (file)
@@ -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 ] )
index 24fc15a..28be299 100644 (file)
@@ -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