Commit bbaf76f9 authored by Ben Gamari's avatar Ben Gamari 🐢

Revert "Generate Typeable info at definition sites"

This reverts commit bef2f03e.

This merge was botched

Also reverts haddock submodule.
parent bef2f03e
This diff is collapsed.
......@@ -72,7 +72,6 @@ module OccName (
mkPReprTyConOcc,
mkPADFunOcc,
mkRecFldSelOcc,
mkTyConRepUserOcc, mkTyConRepSysOcc,
-- ** Deconstruction
occNameFS, occNameString, occNameSpace,
......@@ -587,8 +586,7 @@ mkDataConWrapperOcc, mkWorkerOcc,
mkGenR, mkGen1R, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkTyConRepUserOcc, mkTyConRepSysOcc
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
:: OccName -> OccName
-- These derived variables have a prefix that no Haskell value could have
......@@ -611,24 +609,11 @@ mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes
mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions
mkEqPredCoOcc = mk_simple_deriv tcName "$co"
-- Used in derived instances
-- used in derived instances
mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable
-- incluing the wrinkle about mkSpecialTyConRepName
mkTyConRepSysOcc occ = mk_simple_deriv varName prefix occ
where
prefix | isDataOcc occ = "$tc'"
| otherwise = "$tc"
mkTyConRepUserOcc occ = mk_simple_deriv varName prefix occ
where
-- *User-writable* prefix, for types in gHC_TYPES
prefix | isDataOcc occ = "tc'"
| otherwise = "tc"
-- Generic deriving mechanism
-- | Generate a module-unique name, to be used e.g. while generating new names
......
......@@ -48,13 +48,10 @@ module Unique (
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
mkCostCentreUnique,
tyConRepNameUnique,
dataConWorkerUnique, dataConRepNameUnique,
mkBuiltinUnique,
mkPseudoUniqueD,
mkPseudoUniqueE,
......@@ -102,10 +99,9 @@ unpkUnique :: Unique -> (Char, Int) -- The reverse
mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Int -- for Var
incrUnique :: Unique -> Unique
stepUnique :: Unique -> Int -> Unique
deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique
incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique
mkUniqueGrimily = MkUnique
......@@ -113,11 +109,9 @@ mkUniqueGrimily = MkUnique
getKey (MkUnique x) = x
incrUnique (MkUnique i) = MkUnique (i + 1)
stepUnique (MkUnique i) n = MkUnique (i + n)
-- deriveUnique uses an 'X' tag so that it won't clash with
-- any of the uniques produced any other way
-- SPJ says: this looks terribly smelly to me!
deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)
-- newTagUnique changes the "domain" of a unique to a different char
......@@ -311,19 +305,14 @@ mkPArrDataConUnique :: Int -> Unique
mkAlphaTyVarUnique i = mkUnique '1' i
mkPreludeClassUnique i = mkUnique '2' i
--------------------------------------------------
-- Wired-in data constructor keys occupy *three* slots:
-- * u: the DataCon itself
-- * u+1: its worker Id
-- * u+2: the TyConRepName of the promoted TyCon
-- Prelude data constructors are too simple to need wrappers.
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
mkCTupleTyConUnique a = mkUnique 'k' (3*a)
-- Prelude type constructors occupy *three* slots.
-- The first is for the tycon itself; the latter two
-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info.
tyConRepNameUnique :: Unique -> Unique
tyConRepNameUnique u = incrUnique u
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
mkCTupleTyConUnique a = mkUnique 'k' (3*a)
-- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that
......@@ -331,22 +320,10 @@ tyConRepNameUnique u = incrUnique u
-- used for the worker function (the function that builds the constructor
-- representation).
--------------------------------------------------
-- Wired-in data constructor keys occupy *three* slots:
-- * u: the DataCon itself
-- * u+1: its worker Id
-- * u+2: the TyConRepName of the promoted TyCon
-- Prelude data constructors are too simple to need wrappers.
mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a)
dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique
dataConWorkerUnique u = incrUnique u
dataConRepNameUnique u = stepUnique u 2
mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a)
--------------------------------------------------
mkPrimOpIdUnique op = mkUnique '9' op
mkPreludeMiscIdUnique i = mkUnique '0' i
......
......@@ -126,12 +126,12 @@ mkCoreLets binds body = foldr mkCoreLet body binds
-- | Construct an expression which represents the application of one expression
-- to the other
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
-- Respects the let/app invariant by building a case expression where necessary
-- See CoreSyn Note [CoreSyn let/app invariant]
mkCoreApp _ fun (Type ty) = App fun (Type ty)
mkCoreApp _ fun (Coercion co) = App fun (Coercion co)
mkCoreApp d fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
mkCoreApp fun (Type ty) = App fun (Type ty)
mkCoreApp fun (Coercion co) = App fun (Coercion co)
mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
mk_val_app fun arg arg_ty res_ty
where
fun_ty = exprType fun
......
This diff is collapsed.
......@@ -217,8 +217,8 @@ dsExpr (HsLamCase arg matches)
; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
dsExpr e@(HsApp fun arg)
= mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg
dsExpr (HsApp fun arg)
= mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
{-
......@@ -260,15 +260,15 @@ If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out.
-}
dsExpr e@(OpApp e1 op _ e2)
dsExpr (OpApp e1 op _ e2)
= -- for the type of y, we need the type of op's 2nd argument
mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
= mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr
= mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
dsExpr e@(SectionR op expr) = do
dsExpr (SectionR op expr) = do
core_op <- dsLExpr op
-- for the type of x, we need the type of op's 2nd argument
let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
......@@ -277,7 +277,7 @@ dsExpr e@(SectionR op expr) = do
x_id <- newSysLocalDs x_ty
y_id <- newSysLocalDs y_ty
return (bindNonRec y_id y_core $
Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
dsExpr (ExplicitTuple tup_args boxity)
= do { let go (lam_vars, args) (L _ (Missing ty))
......
......@@ -241,7 +241,7 @@ mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
-- let var' = viewExpr var in mr
mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
mkViewMatchResult var' viewExpr var =
adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs (text "mkView" <+> ppr var') viewExpr (Var var))))
adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult var ty
......@@ -343,7 +343,7 @@ mkPatSynCase var ty alt fail = do
matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
let MatchResult _ mkCont = match_result
cont <- mkCoreLams bndrs <$> mkCont fail
return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
where
MkCaseAlt{ alt_pat = psyn,
alt_bndrs = bndrs,
......@@ -536,8 +536,8 @@ into
which stupidly tries to bind the datacon 'True'.
-}
mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
| f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
= Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
where
......@@ -545,10 +545,10 @@ mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
_ -> mkWildValBinder ty1
mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore
mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore
mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
mkCastDs :: CoreExpr -> Coercion -> CoreExpr
-- We define a desugarer-specific verison of CoreUtils.mkCast,
......
......@@ -414,7 +414,6 @@ Library
TcErrors
TcTyClsDecls
TcTyDecls
TcTypeable
TcType
TcEvidence
TcUnify
......
......@@ -41,7 +41,7 @@ module HsUtils(
mkPatSynBind,
-- Literals
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
-- Patterns
mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
......@@ -319,10 +319,6 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
mkHsString :: String -> HsLit
mkHsString s = HsString s (mkFastString s)
mkHsStringPrimLit :: FastString -> HsLit
mkHsStringPrimLit fs
= HsStringPrim (unpackFS fs) (fastStringToByteString fs)
-------------
userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
-- Caller sets location
......
......@@ -14,7 +14,7 @@ module BuildTyCl (
TcMethInfo, buildClass,
distinctAbstractTyConRhs, totallyAbstractTyConRhs,
mkNewTyConRhs, mkDataTyConRhs,
newImplicitBinder, newTyConRepName
newImplicitBinder
) where
#include "HsVersions.h"
......@@ -22,7 +22,6 @@ module BuildTyCl (
import IfaceEnv
import FamInstEnv( FamInstEnvs )
import TysWiredIn( isCTupleTyConName )
import PrelNames( tyConRepModOcc )
import DataCon
import PatSyn
import Var
......@@ -37,7 +36,6 @@ import Id
import Coercion
import TcType
import SrcLoc( noSrcSpan )
import DynFlags
import TcRnMonad
import UniqSupply
......@@ -51,8 +49,7 @@ buildSynonymTyCon :: Name -> [TyVar] -> [Role]
-> TyCon
buildSynonymTyCon tc_name tvs roles rhs rhs_kind
= mkSynonymTyCon tc_name kind tvs roles rhs
where
kind = mkPiKinds tvs rhs_kind
where kind = mkPiKinds tvs rhs_kind
buildFamilyTyCon :: Name -- ^ Type family name
......@@ -60,7 +57,7 @@ buildFamilyTyCon :: Name -- ^ Type family name
-> Maybe Name -- ^ Result variable name
-> FamTyConFlav -- ^ Open, closed or in a boot file?
-> Kind -- ^ Kind of the RHS
-> Maybe Class -- ^ Parent, if exists
-> TyConParent -- ^ Parent, if exists
-> Injectivity -- ^ Injectivity annotation
-- See [Injectivity annotation] in HsDecls
-> TyCon
......@@ -135,9 +132,7 @@ mkNewTyConRhs tycon_name tycon con
------------------------------------------------------
buildDataCon :: FamInstEnvs
-> Name
-> Bool -- Declared infix
-> Promoted TyConRepName -- Promotable
-> Name -> Bool
-> [HsSrcBang]
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
......@@ -153,7 +148,7 @@ buildDataCon :: FamInstEnvs
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
......@@ -161,12 +156,11 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
-- code, which (for Haskell source anyway) will be in the DataName name
-- space, and puts it into the VarName name space
; traceIf (text "buildDataCon 1" <+> ppr src_name)
; us <- newUniqueSupply
; dflags <- getDynFlags
; let
stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
data_con = mkDataCon src_name declared_infix prom_info
data_con = mkDataCon src_name declared_infix
src_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt
arg_tys res_ty rep_tycon
......@@ -175,7 +169,6 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
impl_bangs data_con)
; traceIf (text "buildDataCon 2" <+> ppr src_name)
; return data_con }
......@@ -234,8 +227,7 @@ type TcMethInfo = (Name, DefMethSpec, Type)
-- A temporary intermediate, to communicate between
-- tcClassSigs and buildClass.
buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyVar] -> [Role] -> ThetaType
buildClass :: Name -> [TyVar] -> [Role] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
......@@ -248,7 +240,10 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
do { traceIf (text "buildClass")
; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
; tc_rep_name <- newTyConRepName tycon_name
-- The class name is the 'parent' for this datacon, not its tycon,
-- because one should import the class to get the binding for
-- the datacon
; op_items <- mapM (mk_op_item rec_clas) sig_stuff
-- Build the selector id and default method id
......@@ -287,7 +282,6 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
datacon_name
False -- Not declared infix
NotPromoted -- Class tycons are not promoted
(map (const no_bang) args)
(Just (map (const HsLazy) args))
[{- No fields -}]
......@@ -306,8 +300,9 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
else return (mkDataTyConRhs [dict_con])
; let { clas_kind = mkPiKinds tvs constraintKind
; tycon = mkClassTyCon tycon_name clas_kind tvs roles
rhs rec_clas tc_isrec tc_rep_name
; tycon = mkClassTyCon tycon_name clas_kind tvs roles
rhs rec_clas tc_isrec
-- A class can be recursive, and in the case of newtypes
-- this matters. For example
-- class C a where { op :: C b => a -> b -> Int }
......@@ -371,12 +366,3 @@ newImplicitBinder base_name mk_sys_occ
where
occ = mk_sys_occ (nameOccName base_name)
loc = nameSrcSpan base_name
-- | Make the 'TyConRepName' for this 'TyCon'
newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
newTyConRepName tc_name
| Just mod <- nameModule_maybe tc_name
, (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
= newGlobalBinder mod occ noSrcSpan
| otherwise
= newImplicitBinder tc_name mkTyConRepUserOcc
......@@ -165,8 +165,7 @@ data IfaceTyConParent
IfaceTcArgs
data IfaceFamTyConFlav
= IfaceDataFamilyTyCon -- Data family
| IfaceOpenSynFamilyTyCon
= IfaceOpenSynFamilyTyCon
| IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
-- ^ Name of associated axiom and branches for pretty printing purposes,
-- or 'Nothing' for an empty closed family without an axiom
......@@ -193,6 +192,7 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
data IfaceConDecls
= IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon
| IfDataFamTyCon -- Data family
| IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls
| IfNewTyCon IfaceConDecl Bool [FieldLabelString] -- Newtype decls
......@@ -343,12 +343,14 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls (IfAbstractTyCon {}) = []
visibleIfConDecls IfDataFamTyCon = []
visibleIfConDecls (IfDataTyCon cs _ _) = cs
visibleIfConDecls (IfNewTyCon c _ _) = [c]
ifaceConDeclFields :: IfaceConDecls -> [FieldLbl OccName]
ifaceConDeclFields x = case x of
IfAbstractTyCon {} -> []
IfDataFamTyCon {} -> []
IfDataTyCon cons is_over labels -> map (help cons is_over) labels
IfNewTyCon con is_over labels -> map (help [con] is_over) labels
where
......@@ -366,15 +368,35 @@ ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
-- TyThing.getOccName should define a bijection between the two lists.
-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
-- The order of the list does not matter.
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, ifCons = cons })
= case cons of
IfAbstractTyCon {} -> []
IfNewTyCon cd _ _ -> mkNewTyCoOcc tc_occ : ifaceConDeclImplicitBndrs cd
IfDataTyCon cds _ _ -> concatMap ifaceConDeclImplicitBndrs cds
ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt, ifName = cls_tc_occ
, ifSigs = sigs, ifATs = ats })
ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = []
-- Newtype
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (IfCon { ifConOcc = con_occ }) _ _})
= -- implicit newtype coercion
(mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit
-- data constructor and worker (newtypes don't have a wrapper)
[con_occ, mkDataConWorkerOcc con_occ]
ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
ifCons = IfDataTyCon cons _ _ })
= -- for each data constructor in order,
-- data constructor, worker, and (possibly) wrapper
concatMap dc_occs cons
where
dc_occs con_decl
| has_wrapper = [con_occ, work_occ, wrap_occ]
| otherwise = [con_occ, work_occ]
where
con_occ = ifConOcc con_decl -- DataCon namespace
wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
work_occ = mkDataConWorkerOcc con_occ -- Id namespace
has_wrapper = ifConWrapper con_decl -- This is the reason for
-- having the ifConWrapper field!
ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
ifSigs = sigs, ifATs = ats })
= -- (possibly) newtype coercion
co_occs ++
-- data constructor (DataCon namespace)
......@@ -398,14 +420,6 @@ ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt, ifName = cls_tc_occ
ifaceDeclImplicitBndrs _ = []
ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName]
ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConOcc = con_occ })
= [con_occ, work_occ] ++ wrap_occs
where
work_occ = mkDataConWorkerOcc con_occ -- Id namespace
wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace
| otherwise = []
-- -----------------------------------------------------------------------------
-- The fingerprints of an IfaceDecl
......@@ -671,6 +685,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
pp_nd = case condecls of
IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d))
IfDataFamTyCon -> ptext (sLit "data family")
IfDataTyCon{} -> ptext (sLit "data")
IfNewTyCon{} -> ptext (sLit "newtype")
......@@ -679,7 +694,6 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
pp_prom | is_prom = ptext (sLit "Promotable")
| otherwise = Outputable.empty
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
, ifCtxt = context, ifName = clas
, ifTyVars = tyvars, ifRoles = roles
......@@ -724,12 +738,7 @@ pprIfaceDecl ss (IfaceSynonym { ifName = tc
pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
, ifFamFlav = rhs, ifFamKind = kind
, ifResVar = res_var, ifFamInj = inj })
| IfaceDataFamilyTyCon <- rhs
= ptext (sLit "data family") <+> pprIfaceDeclHead [] ss tycon tyvars
| otherwise
= vcat [ hang (ptext (sLit "type family")
<+> pprIfaceDeclHead [] ss tycon tyvars)
= 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
......@@ -743,13 +752,11 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
[] -> empty
tvs -> hsep [text "|", ppr res, text "->", interppSP (map fst tvs)]
pp_rhs IfaceDataFamilyTyCon
= ppShowIface ss (ptext (sLit "data"))
pp_rhs IfaceOpenSynFamilyTyCon
= ppShowIface ss (ptext (sLit "open"))
pp_rhs IfaceAbstractClosedSynFamilyTyCon
= ppShowIface ss (ptext (sLit "closed, abstract"))
pp_rhs (IfaceClosedSynFamilyTyCon {})
pp_rhs (IfaceClosedSynFamilyTyCon _)
= ptext (sLit "where")
pp_rhs IfaceBuiltInSynFamTyCon
= ppShowIface ss (ptext (sLit "built-in"))
......@@ -1163,13 +1170,12 @@ freeNamesIfIdDetails _ = emptyNameSet
-- All other changes are handled via the version info on the tycon
freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
= unitNameSet ax &&& fnList freeNamesIfAxBranch br
freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
freeNamesIfContext :: IfaceContext -> NameSet
freeNamesIfContext = fnList freeNamesIfType
......@@ -1520,22 +1526,18 @@ instance Binary IfaceDecl where
_ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
instance Binary IfaceFamTyConFlav where
put_ bh IfaceDataFamilyTyCon = putByte bh 0
put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1
put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb
put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3
put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0
put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 1 >> put_ bh mb
put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2
put_ _ IfaceBuiltInSynFamTyCon
= pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
get bh = do { h <- getByte bh
; case h of
0 -> return IfaceDataFamilyTyCon
1 -> return IfaceOpenSynFamilyTyCon
2 -> do { mb <- get bh
0 -> return IfaceOpenSynFamilyTyCon
1 -> do { mb <- get bh
; return (IfaceClosedSynFamilyTyCon mb) }
3 -> return IfaceAbstractClosedSynFamilyTyCon
_ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"
(ppr (fromIntegral h :: Int)) }
_ -> return IfaceAbstractClosedSynFamilyTyCon }
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
......@@ -1574,16 +1576,17 @@ instance Binary IfaceAxBranch where
return (IfaceAxBranch a1 a2 a3 a4 a5)
instance Binary IfaceConDecls where
put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
put_ bh (IfDataTyCon cs b fs) = putByte bh 1 >> put_ bh cs >> put_ bh b >> put_ bh fs
put_ bh (IfNewTyCon c b fs) = putByte bh 2 >> put_ bh c >> put_ bh b >> put_ bh fs
put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
put_ bh IfDataFamTyCon = putByte bh 1
put_ bh (IfDataTyCon cs b fs) = putByte bh 2 >> put_ bh cs >> put_ bh b >> put_ bh fs
put_ bh (IfNewTyCon c b fs) = putByte bh 3 >> put_ bh c >> put_ bh b >> put_ bh fs
get bh = do