Commit 98a642cf authored by Simon Peyton Jones's avatar Simon Peyton Jones

Major refactoring of CoAxioms

This patch should have no user-visible effect.  It implements a
significant internal refactoring of the way that FC axioms are
handled.  The ultimate goal is to put us in a position to implement
"pattern-matching axioms".  But the changes here are only does
refactoring; there is no change in functionality.

Specifically:

 * We now treat data/type family instance declarations very,
   very similarly to types class instance declarations:

   - Renamed InstEnv.Instance as InstEnv.ClsInst, for symmetry with
     FamInstEnv.FamInst.  This change does affect the GHC API, but
     for the better I think.

   - Previously, each family type/data instance declaration gave rise
     to a *TyCon*; typechecking a type/data instance decl produced
     that TyCon.  Now, each type/data instance gives rise to
     a *FamInst*, by direct analogy with each class instance
     declaration giving rise to a ClsInst.

   - Just as each ClsInst contains its evidence, a DFunId, so each FamInst
     contains its evidence, a CoAxiom.  See Note [FamInsts and CoAxioms]
     in FamInstEnv.  The CoAxiom is a System-FC thing, and can relate any
     two types, whereas the FamInst relates directly to the Haskell source
     language construct, and always has a function (F tys) on the LHS.

   - Just as a DFunId has its own declaration in an interface file, so now
     do CoAxioms (see IfaceSyn.IfaceAxiom).

   These changes give rise to almost all the refactoring.

 * We used to have a hack whereby a type family instance produced a dummy
   type synonym, thus
      type instance F Int = Bool -> Bool
   translated to
      axiom FInt :: F Int ~ R:FInt
      type R:FInt = Bool -> Bool
   This was always a hack, and now it's gone.  Instead the type instance
   declaration produces a FamInst, whose axiom has kind
      axiom FInt :: F Int ~ Bool -> Bool
   just as you'd expect.

 * Newtypes are done just as before; they generate a CoAxiom. These
   CoAxioms are "implicit" (do not generate an IfaceAxiom declaration),
   unlike the ones coming from family instance declarations.  See
   Note [Implicit axioms] in TyCon

On the whole the code gets significantly nicer.  There were consequential
tidy-ups in the vectoriser, but I think I got them right.
parent dc6f3a48
......@@ -26,6 +26,7 @@ module MkId (
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
wrapFamInstBody, unwrapFamInstScrut,
wrapTypeFamInstBody, unwrapTypeFamInstScrut,
mkUnpackCase, mkProductBox,
-- And some particular Ids; see below for why they are wired in
......@@ -227,7 +228,7 @@ mkDataConIds wrap_name wkr_name data_con
= DCIds Nothing nt_work_id
| any isBanged all_strict_marks -- Algebraic, needs wrapper
|| not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs
|| not (null eq_spec) -- NB: LoadIface.ifaceDeclImplicitBndrs
|| isFamInstTyCon tycon -- depends on this test
= DCIds (Just alg_wrap_id) wrk_id
......@@ -709,12 +710,22 @@ wrapFamInstBody tycon args body
| otherwise
= body
-- Same as `wrapFamInstBody`, but for type family instances, which are
-- represented by a `CoAxiom`, and not a `TyCon`
wrapTypeFamInstBody :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom args body
= mkCast body (mkSymCo (mkAxInstCo axiom args))
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
| Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCast scrut (mkAxInstCo co_con args)
| otherwise
= scrut
unwrapTypeFamInstScrut :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeFamInstScrut axiom args scrut
= mkCast scrut (mkAxInstCo axiom args)
\end{code}
......
......@@ -209,7 +209,7 @@ pprNameSpaceBrief TcClsName = ptext (sLit "tc")
-- demoteNameSpace lowers the NameSpace if possible. We can not know
-- in advance, since a TvName can appear in an HsTyVar.
-- see Note [Demotion]
-- See Note [Demotion] in RnEnv
demoteNameSpace :: NameSpace -> Maybe NameSpace
demoteNameSpace VarName = Nothing
demoteNameSpace DataName = Nothing
......@@ -217,24 +217,6 @@ demoteNameSpace TvName = Nothing
demoteNameSpace TcClsName = Just DataName
\end{code}
Note [Demotion]
~~~~~~~~~~~~~~~
When the user writes:
data Nat = Zero | Succ Nat
foo :: f Zero -> Int
'Zero' in the type signature of 'foo' is parsed as:
HsTyVar ("Zero", TcClsName)
When the renamer hits this occurence of 'Zero' it's going to realise
that it's not in scope. But because it is renaming a type, it knows
that 'Zero' might be a promoted data constructor, so it will demote
its namespace to DataName and do a second lookup.
The final result (after the renamer) will be:
HsTyVar ("Zero", DataName)
%************************************************************************
%* *
......@@ -371,7 +353,7 @@ sequentially starting at 0.
So we can make a Unique using
mkUnique ns key :: Unique
where 'ns' is a Char reprsenting the name space. This in turn makes it
where 'ns' is a Char representing the name space. This in turn makes it
easy to build an OccEnv.
\begin{code}
......
......@@ -447,12 +447,12 @@ data CoreRule
ru_act :: Activation, -- ^ When the rule is active
-- Rough-matching stuff
-- see comments with InstEnv.Instance( is_cls, is_rough )
-- see comments with InstEnv.ClsInst( is_cls, is_rough )
ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule
ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side
-- Proper-matching stuff
-- see comments with InstEnv.Instance( is_tvs, is_tys )
-- see comments with InstEnv.ClsInst( is_tvs, is_tys )
ru_bndrs :: [CoreBndr], -- ^ Variables quantified over
ru_args :: [CoreExpr], -- ^ Left hand side arguments
......
......@@ -1096,7 +1096,7 @@ data VectDecl name
| HsVectInstIn -- pre type-checking (always SCALAR)
(LHsType name)
| HsVectInstOut -- post type-checking (always SCALAR)
Instance
ClsInst
deriving (Data, Typeable)
lvectDeclName :: NamedThing name => LVectDecl name -> Name
......
......@@ -1391,13 +1391,12 @@ instance Binary IfaceDecl where
put_ bh a6
put_ bh a7
put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
put_ bh (IfaceSyn a1 a2 a3 a4) = do
putByte bh 3
put_ bh (occNameFS a1)
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh a5
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 4
......@@ -1409,6 +1408,13 @@ instance Binary IfaceDecl where
put_ bh a6
put_ bh a7
put_ bh (IfaceAxiom a1 a2 a3 a4) = do
putByte bh 5
put_ bh (occNameFS a1)
put_ bh a2
put_ bh a3
put_ bh a4
get bh = do
h <- getByte bh
case h of
......@@ -1432,10 +1438,9 @@ instance Binary IfaceDecl where
a2 <- get bh
a3 <- get bh
a4 <- get bh
a5 <- get bh
occ <- return $! mkOccNameFS tcName a1
return (IfaceSyn occ a2 a3 a4 a5)
_ -> do a1 <- get bh
return (IfaceSyn occ a2 a3 a4)
4 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
......@@ -1444,9 +1449,15 @@ instance Binary IfaceDecl where
a7 <- get bh
occ <- return $! mkOccNameFS clsName a2
return (IfaceClass a1 occ a3 a4 a5 a6 a7)
_ -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
occ <- return $! mkOccNameFS tcName a1
return (IfaceAxiom occ a2 a3 a4)
instance Binary IfaceInst where
put_ bh (IfaceInst cls tys dfun flag orph) = do
instance Binary IfaceClsInst where
put_ bh (IfaceClsInst cls tys dfun flag orph) = do
put_ bh cls
put_ bh tys
put_ bh dfun
......@@ -1458,18 +1469,20 @@ instance Binary IfaceInst where
dfun <- get bh
flag <- get bh
orph <- get bh
return (IfaceInst cls tys dfun flag orph)
return (IfaceClsInst cls tys dfun flag orph)
instance Binary IfaceFamInst where
put_ bh (IfaceFamInst fam tys tycon) = do
put_ bh (IfaceFamInst fam tys name orph) = do
put_ bh fam
put_ bh tys
put_ bh tycon
put_ bh name
put_ bh orph
get bh = do
fam <- get bh
tys <- get bh
tycon <- get bh
return (IfaceFamInst fam tys tycon)
name <- get bh
orph <- get bh
return (IfaceFamInst fam tys name orph)
instance Binary OverlapFlag where
put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b
......@@ -1486,14 +1499,14 @@ instance Binary OverlapFlag where
instance Binary IfaceConDecls where
put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
put_ bh IfOpenDataTyCon = putByte bh 1
put_ bh IfDataFamTyCon = putByte bh 1
put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs
put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c
get bh = do
h <- getByte bh
case h of
0 -> get bh >>= (return . IfAbstractTyCon)
1 -> return IfOpenDataTyCon
1 -> return IfDataFamTyCon
2 -> get bh >>= (return . IfDataTyCon)
_ -> get bh >>= (return . IfNewTyCon)
......
......@@ -51,66 +51,25 @@ buildSynTyCon :: Name -> [TyVar]
-> SynTyConRhs
-> Kind -- ^ Kind of the RHS
-> TyConParent
-> Maybe (TyCon, [Type]) -- ^ family instance if applicable
-> TcRnIf m n TyCon
buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family
| Just fam_inst_info <- mb_family
= ASSERT( isNoParent parent )
fixM $ \ tycon_rec -> do
{ fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
; return (mkSynTyCon tc_name kind tvs rhs fam_parent) }
| otherwise
buildSynTyCon tc_name tvs rhs rhs_kind parent
= return (mkSynTyCon tc_name kind tvs rhs parent)
where kind = mkPiKinds tvs rhs_kind
------------------------------------------------------
buildAlgTyCon :: Name -> [TyVar] -- ^ Kind variables adn type variables
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
-> Bool -- ^ True <=> was declared in GADT syntax
-> TyConParent
-> Maybe (TyCon, [Type]) -- ^ family instance if applicable
-> TcRnIf m n TyCon
buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn
parent mb_family
| Just fam_inst_info <- mb_family
= -- We need to tie a knot as the coercion of a data instance depends
-- on the instance representation tycon and vice versa.
ASSERT( isNoParent parent )
fixM $ \ tycon_rec -> do
{ fam_parent <- mkFamInstParentInfo tc_name ktvs fam_inst_info tycon_rec
; return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs
fam_parent is_rec gadt_syn) }
| otherwise
= return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs
parent is_rec gadt_syn)
where kind = mkPiKinds ktvs liftedTypeKind
-- | If a family tycon with instance types is given, the current tycon is an
-- instance of that family and we need to
--
-- (1) create a coercion that identifies the family instance type and the
-- representation type from Step (1); ie, it is of the form
-- `Co tvs :: F ts ~ R tvs', where `Co' is the name of the coercion,
-- `F' the family tycon and `R' the (derived) representation tycon,
-- and
-- (2) produce a `TyConParent' value containing the parent and coercion
-- information.
--
mkFamInstParentInfo :: Name -> [TyVar]
-> (TyCon, [Type])
-> TyCon
-> TcRnIf m n TyConParent
mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon
= do { -- Create the coercion
; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
; let co_tycon = mkFamInstCo co_tycon_name tvs
family instTys rep_tycon
; return $ FamInstTyCon family instTys co_tycon }
buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn parent
= mkAlgTyCon tc_name kind ktvs stupid_theta rhs parent is_rec gadt_syn
where
kind = mkPiKinds ktvs liftedTypeKind
------------------------------------------------------
distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
......
......@@ -20,13 +20,13 @@ module IfaceSyn (
IfaceBinding(..), IfaceConAlt(..),
IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceInst(..), IfaceFamInst(..), IfaceTickish(..),
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
-- Misc
ifaceDeclSubBndrs, visibleIfConDecls,
ifaceDeclImplicitBndrs, visibleIfConDecls,
-- Free Names
freeNamesIfDecl, freeNamesIfRule,
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
-- Pretty printing
pprIfaceExpr, pprIfaceDeclHead
......@@ -70,26 +70,19 @@ data IfaceDecl
| IfaceData { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifCtxt :: IfaceContext, -- The "stupid theta"
ifCons :: IfaceConDecls, -- Includes new/data info
ifCons :: IfaceConDecls, -- Includes new/data/data family info
ifRec :: RecFlag, -- Recursive or not?
ifGadtSyntax :: Bool, -- True <=> declared using
-- GADT syntax
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
-- Invariant:
-- ifCons /= IfOpenDataTyCon
-- for family instances
ifAxiom :: Maybe IfExtName -- The axiom, for a newtype,
-- or data/newtype family instance
}
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn
-- Nothing for an open family
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
-- Invariant: ifOpenSyn == False
-- for family instances
ifSynRhs :: Maybe IfaceType -- Just rhs for an ordinary synonyn
-- Nothing for an type family declaration
}
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
......@@ -102,6 +95,11 @@ data IfaceDecl
-- with the class recursive?
}
| IfaceAxiom { ifName :: OccName -- Axiom name
, ifTyVars :: [IfaceTvBndr] -- Axiom tyvars
, ifLHS :: IfaceType -- Axiom LHS
, ifRHS :: IfaceType } -- and RHS
| IfaceForeign { ifName :: OccName, -- Needs expanding when we move
-- beyond .NET
ifExtName :: Maybe FastString }
......@@ -123,13 +121,13 @@ data IfaceATDefault = IfaceATD [IfaceTvBndr] [IfaceType] IfaceType
data IfaceConDecls
= IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon
| IfOpenDataTyCon -- Open data family
| IfDataTyCon [IfaceConDecl] -- data type decls
| IfNewTyCon IfaceConDecl -- newtype decls
| IfDataFamTyCon -- Data family
| IfDataTyCon [IfaceConDecl] -- Data type decls
| IfNewTyCon IfaceConDecl -- Newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls (IfAbstractTyCon {}) = []
visibleIfConDecls IfOpenDataTyCon = []
visibleIfConDecls IfDataFamTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
......@@ -147,9 +145,9 @@ data IfaceConDecl
ifConStricts :: [HsBang]} -- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
data IfaceInst
= IfaceInst { ifInstCls :: IfExtName, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
data IfaceClsInst
= IfaceClsInst { ifInstCls :: IfExtName, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst
ifDFun :: IfExtName, -- The dfun
ifOFlag :: OverlapFlag, -- Overlap flag
ifInstOrph :: Maybe OccName } -- See Note [Orphans]
......@@ -161,9 +159,10 @@ data IfaceInst
-- and if the head does not change it won't be used if it wasn't before
data IfaceFamInst
= IfaceFamInst { ifFamInstFam :: IfExtName -- Family tycon
= IfaceFamInst { ifFamInstFam :: IfExtName -- Family name
, ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
, ifFamInstTyCon :: IfaceTyCon -- Instance decl
, ifFamInstAxiom :: IfExtName -- The axiom
, ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst
}
data IfaceRule
......@@ -175,7 +174,7 @@ data IfaceRule
ifRuleArgs :: [IfaceExpr], -- Args of LHS
ifRuleRhs :: IfaceExpr,
ifRuleAuto :: Bool,
ifRuleOrph :: Maybe OccName -- Just like IfaceInst
ifRuleOrph :: Maybe OccName -- Just like IfaceClsInst
}
data IfaceAnnotation
......@@ -375,38 +374,34 @@ See [http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationA
-- -----------------------------------------------------------------------------
-- Utils on IfaceSyn
ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
-- *Excludes* the 'main' name, but *includes* the implicitly-bound names
-- Deeply revolting, because it has to predict what gets bound,
-- especially the question of whether there's a wrapper for a datacon
-- See Note [Implicit TyThings] in HscTypes
-- N.B. the set of names returned here *must* match the set of
-- TyThings returned by HscTypes.implicitTyThings, in the sense that
-- 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.
ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon {}} = []
ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = []
-- Newtype
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (
IfCon { ifConOcc = con_occ }),
ifFamInst = famInst})
= -- implicit coerion and (possibly) family instance coercion
(mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
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]
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifCons = IfDataTyCon cons,
ifFamInst = famInst})
= -- (possibly) family instance coercion;
-- there is no implicit coercion for non-newtypes
famInstCo famInst tc_occ
-- for each data constructor in order,
ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
ifCons = IfDataTyCon cons })
= -- for each data constructor in order,
-- data constructor, worker, and (possibly) wrapper
++ concatMap dc_occs cons
concatMap dc_occs cons
where
dc_occs con_decl
| has_wrapper = [con_occ, work_occ, wrap_occ]
......@@ -418,7 +413,7 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
has_wrapper = ifConWrapper con_decl -- This is the reason for
-- having the ifConWrapper field!
ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
ifSigs = sigs, ifATs = ats })
= -- (possibly) newtype coercion
co_occs ++
......@@ -441,16 +436,7 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
dc_occ = mkClassDataConOcc cls_tc_occ
is_newtype = n_sigs + n_ctxt == 1 -- Sigh
ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
ifFamInst = famInst})
= famInstCo famInst tc_occ
ifaceDeclSubBndrs _ = []
-- coercion for data/newtype family instances
famInstCo :: Maybe (IfaceTyCon, [IfaceType]) -> OccName -> [OccName]
famInstCo Nothing _ = []
famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
ifaceDeclImplicitBndrs _ = []
----------------------------- Printing IfaceDecl ------------------------------
......@@ -468,10 +454,9 @@ pprIfaceDecl (IfaceForeign {ifName = tycon})
= hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifSynRhs = Just mono_ty,
ifFamInst = mbFamInst})
ifSynRhs = Just mono_ty})
= hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
4 (vcat [equals <+> ppr mono_ty])
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifSynRhs = Nothing, ifSynKind = kind })
......@@ -480,14 +465,14 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
ifRec = isrec, ifFamInst = mbFamInst})
ifRec = isrec, ifAxiom = mbAxiom})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
4 (vcat [pprRec isrec, pp_condecls tycon condecls,
pprFamily mbFamInst])
pprAxiom mbAxiom])
where
pp_nd = case condecls of
IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis)
IfOpenDataTyCon -> ptext (sLit "data family")
IfDataFamTyCon -> ptext (sLit "data family")
IfDataTyCon _ -> ptext (sLit "data")
IfNewTyCon _ -> ptext (sLit "newtype")
......@@ -499,12 +484,17 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
sep (map ppr ats),
sep (map ppr sigs)])
pprIfaceDecl (IfaceAxiom {ifName = name, ifTyVars = tyvars,
ifLHS = lhs, ifRHS = rhs})
= hang (ptext (sLit "axiom") <+> ppr name <+> ppr tyvars)
2 (dcolon <+> ppr lhs <+> text "~#" <+> ppr rhs)
pprRec :: RecFlag -> SDoc
pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
pprFamily Nothing = ptext (sLit "FamilyInstance: none")
pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
pprAxiom :: Maybe Name -> SDoc
pprAxiom Nothing = ptext (sLit "FamilyInstance: none")
pprAxiom (Just ax) = ptext (sLit "FamilyInstance:") <+> ppr ax
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
......@@ -522,7 +512,7 @@ pprIfaceDeclHead context thing tyvars
pp_condecls :: OccName -> IfaceConDecls -> SDoc
pp_condecls _ (IfAbstractTyCon {}) = empty
pp_condecls _ IfOpenDataTyCon = empty
pp_condecls _ IfDataFamTyCon = empty
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
(map (pprIfaceConDecl tc) cs))
......@@ -571,8 +561,8 @@ instance Outputable IfaceRule where
ptext (sLit "=") <+> ppr rhs])
]
instance Outputable IfaceInst where
ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
instance Outputable IfaceClsInst where
ppr (IfaceClsInst {ifDFun = dfun_id, ifOFlag = flag,
ifInstCls = cls, ifInstTys = mb_tcs})
= hang (ptext (sLit "instance") <+> ppr flag
<+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
......@@ -580,10 +570,10 @@ instance Outputable IfaceInst where
instance Outputable IfaceFamInst where
ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
ifFamInstTyCon = tycon_id})
ifFamInstAxiom = tycon_ax})
= hang (ptext (sLit "family instance") <+>
ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr tycon_id)
2 (equals <+> ppr tycon_ax)
ppr_rough :: Maybe IfaceTyCon -> SDoc
ppr_rough Nothing = dot
......@@ -741,13 +731,12 @@ freeNamesIfDecl IfaceForeign{} =
emptyNameSet
freeNamesIfDecl d@IfaceData{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfTcFam (ifFamInst d) &&&
maybe emptyNameSet unitNameSet (ifAxiom d) &&&
freeNamesIfContext (ifCtxt d) &&&
freeNamesIfConDecls (ifCons d)
freeNamesIfDecl d@IfaceSyn{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfSynRhs (ifSynRhs d) &&&
freeNamesIfTcFam (ifFamInst d) &&&
freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we
-- return names in the kind signature
freeNamesIfDecl d@IfaceClass{} =
......@@ -755,6 +744,10 @@ freeNamesIfDecl d@IfaceClass{} =
freeNamesIfContext (ifCtxt d) &&&
fnList freeNamesIfAT (ifATs d) &&&
fnList freeNamesIfClsSig (ifSigs d)
freeNamesIfDecl d@IfaceAxiom{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfType (ifLHS d) &&&
freeNamesIfType (ifRHS d)
freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc
......@@ -765,12 +758,6 @@ freeNamesIfSynRhs :: Maybe IfaceType -> NameSet
freeNamesIfSynRhs (Just ty) = freeNamesIfType ty
freeNamesIfSynRhs Nothing = emptyNameSet
freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet
freeNamesIfTcFam (Just (tc,tys)) =
freeNamesIfTc tc &&& fnList freeNamesIfType tys
freeNamesIfTcFam Nothing =
emptyNameSet
freeNamesIfContext :: IfaceContext -> NameSet
freeNamesIfContext = fnList freeNamesIfType
......@@ -903,6 +890,12 @@ freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
fnList freeNamesIfExpr es &&&
freeNamesIfExpr rhs
freeNamesIfFamInst :: IfaceFamInst -> NameSet
freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
, ifFamInstAxiom = axName })
= unitNameSet famName &&&
unitNameSet axName
-- helpers
(&&&) :: NameSet -> NameSet -> NameSet
(&&&) = unionNameSets
......
......@@ -236,7 +236,7 @@ loadInterface doc_str mod from
--
-- The main thing is to add the ModIface to the PIT, but
-- we also take the
-- IfaceDecls, IfaceInst, IfaceFamInst, IfaceRules, IfaceVectInfo
-- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, IfaceVectInfo
-- out of the ModIface and put them into the big EPS pools
-- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
......@@ -372,7 +372,7 @@ loadDecl ignore_prags mod (_version, decl)
-- the names associated with the decl
main_name <- lookupOrig mod (ifName decl)
-- ; traceIf (text "Loading decl for " <> ppr main_name)
; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs decl)
; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl)
-- Typecheck the thing, lazily
-- NB. Firstly, the laziness is there in case we never need the
......@@ -402,7 +402,7 @@ loadDecl ignore_prags mod (_version, decl)
-- (where the "MkT" is the *Name* associated with MkT, etc.)
--
-- We do this by mapping the implict_names to the associated
-- TyThings. By the invariant on ifaceDeclSubBndrs and
-- TyThings. By the invariant on ifaceDeclImplicitBndrs and
-- implicitTyThings, we can use getOccName on the implicit
-- TyThings to make this association: each Name's OccName should
-- be the OccName of exactly one implictTyThing. So the key is
......
......@@ -68,6 +68,7 @@ import CoreFVs
import Class
import Kind
import TyCon
import Coercion ( coAxiomSplitLHS )
import DataCon
import Type
import TcType
......@@ -261,8 +262,9 @@ mkIface_ hsc_env maybe_old_fingerprint
; iface_insts = map instanceToIfaceInst insts
; iface_fam_insts = map famInstToIfaceFamInst fam_insts
; iface_vect_info = flattenVectInfo vect_info
-- Check if we are in Safe Inference mode but we failed to pass
-- the muster
-- Check if we are in Safe Inference mode
-- but we failed to pass the muster
; safeMode = if safeInferOn dflags && not safeInf
then Sf_None
else safeHaskell dflags
......@@ -361,7 +363,7 @@ mkIface_ hsc_env maybe_old_fingerprint
deliberatelyOmitted :: String -> a