Commit 37445780 authored by Jan Stolarek's avatar Jan Stolarek

Injective type families

For details see #6018, Phab:D202 and the wiki page:

https://ghc.haskell.org/trac/ghc/wiki/InjectiveTypeFamilies

This patch also wires-in Maybe data type and updates haddock submodule.

Test Plan: ./validate

Reviewers: simonpj, goldfire, austin, bgamari

Subscribers: mpickering, bgamari, alanz, thomie, goldfire, simonmar,
             carter

Differential Revision: https://phabricator.haskell.org/D202

GHC Trac Issues: #6018
parent bd16e0bc
......@@ -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
......
......@@ -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
......
......@@ -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,
......@@ -602,6 +605,24 @@ mkBuildExpr elt_ty mk_build_inside = do
uniqs <- getUniquesM
return (zipWith setTyVarUnique tyvar_tmpls uniqs)
{-
************************************************************************
* *
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]
{-
************************************************************************
* *
......
This diff is collapsed.
......@@ -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
......
This diff is collapsed.
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 )
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
This diff is collapsed.
......@@ -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)
......