Commit 1af0d36b authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactoring only

This moves code around to more sensible places.

- Construction for CoAxiom is localised in FamInstEnv

- orphNamesOfxx moves to CoreFVs

- roughMatchTcs, instanceCantMatch moves to Unify

- mkNewTypeCo moves from Coercion to FamInstEnv, and is
  renamed mkNewTypeCoAxiom, which makes more sense
parent fcc7498f
...@@ -30,11 +30,16 @@ module CoreFVs ( ...@@ -30,11 +30,16 @@ module CoreFVs (
idRuleVars, idRuleRhsVars, stableUnfoldingVars, idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
rulesFreeVarsDSet, rulesFreeVarsDSet,
ruleLhsFreeIds, exprsOrphNames, ruleLhsFreeIds,
vectsFreeVars, vectsFreeVars,
expr_fvs, expr_fvs,
-- * Orphan names
orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom,
orphNamesOfTypes, orphNamesOfCoCon,
exprsOrphNames, orphNamesOfFamInst,
-- * Core syntax tree annotation with free variables -- * Core syntax tree annotation with free variables
FVAnn, -- annotation, abstract FVAnn, -- annotation, abstract
CoreExprWithFVs, -- = AnnExpr Id FVAnn CoreExprWithFVs, -- = AnnExpr Id FVAnn
...@@ -59,8 +64,12 @@ import Literal ( literalType ) ...@@ -59,8 +64,12 @@ import Literal ( literalType )
import Name import Name
import VarSet import VarSet
import Var import Var
import TcType
import Type import Type
import TyCoRep
import TyCon
import CoAxiom
import FamInstEnv
import TysPrim( funTyConName )
import Coercion import Coercion
import Maybes( orElse ) import Maybes( orElse )
import Util import Util
...@@ -262,6 +271,96 @@ exprOrphNames e ...@@ -262,6 +271,96 @@ exprOrphNames e
exprsOrphNames :: [CoreExpr] -> NameSet exprsOrphNames :: [CoreExpr] -> NameSet
exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es
{- **********************************************************************
%* *
orphNamesXXX
%* *
%********************************************************************* -}
orphNamesOfTyCon :: TyCon -> NameSet
orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of
Nothing -> emptyNameSet
Just cls -> unitNameSet (getName cls)
orphNamesOfType :: Type -> NameSet
orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty'
-- Look through type synonyms (Trac #4912)
orphNamesOfType (TyVarTy _) = emptyNameSet
orphNamesOfType (LitTy {}) = emptyNameSet
orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
`unionNameSet` orphNamesOfTypes tys
orphNamesOfType (ForAllTy bndr res) = unitNameSet funTyConName -- NB! See Trac #8535
`unionNameSet` orphNamesOfType (binderType bndr)
`unionNameSet` orphNamesOfType res
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co
orphNamesOfType (CoercionTy co) = orphNamesOfCo co
orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet
orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet
orphNamesOfTypes :: [Type] -> NameSet
orphNamesOfTypes = orphNamesOfThings orphNamesOfType
orphNamesOfCo :: Coercion -> NameSet
orphNamesOfCo (Refl _ ty) = orphNamesOfType ty
orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (ForAllCo _ kind_co co)
= orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co
orphNamesOfCo (CoVarCo _) = emptyNameSet
orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2
orphNamesOfCo (SymCo co) = orphNamesOfCo co
orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (NthCo _ co) = orphNamesOfCo co
orphNamesOfCo (LRCo _ co) = orphNamesOfCo co
orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg
orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (KindCo co) = orphNamesOfCo co
orphNamesOfCo (SubCo co) = orphNamesOfCo co
orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs
orphNamesOfProv :: UnivCoProvenance -> NameSet
orphNamesOfProv UnsafeCoerceProv = emptyNameSet
orphNamesOfProv (PhantomProv co) = orphNamesOfCo co
orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
orphNamesOfProv (PluginProv _) = emptyNameSet
orphNamesOfProv (HoleProv _) = emptyNameSet
orphNamesOfCos :: [Coercion] -> NameSet
orphNamesOfCos = orphNamesOfThings orphNamesOfCo
orphNamesOfCoCon :: CoAxiom br -> NameSet
orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
= orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches
orphNamesOfAxiom :: CoAxiom br -> NameSet
orphNamesOfAxiom axiom
= orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom)
`extendNameSet` getName (coAxiomTyCon axiom)
orphNamesOfCoAxBranches :: Branches br -> NameSet
orphNamesOfCoAxBranches
= foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches
orphNamesOfCoAxBranch :: CoAxBranch -> NameSet
orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
= orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs
-- | orphNamesOfAxiom collects the names of the concrete types and
-- type constructors that make up the LHS of a type family instance,
-- including the family name itself.
--
-- For instance, given `type family Foo a b`:
-- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H]
--
-- Used in the implementation of ":info" in GHCi.
orphNamesOfFamInst :: FamInst -> NameSet
orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst)
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -17,7 +17,7 @@ module BuildTyCl ( ...@@ -17,7 +17,7 @@ module BuildTyCl (
#include "HsVersions.h" #include "HsVersions.h"
import IfaceEnv import IfaceEnv
import FamInstEnv( FamInstEnvs ) import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
import TysWiredIn( isCTupleTyConName ) import TysWiredIn( isCTupleTyConName )
import PrelNames( tyConRepModOcc ) import PrelNames( tyConRepModOcc )
import DataCon import DataCon
...@@ -31,7 +31,6 @@ import Class ...@@ -31,7 +31,6 @@ import Class
import TyCon import TyCon
import Type import Type
import Id import Id
import Coercion
import TcType import TcType
import SrcLoc( noSrcSpan ) import SrcLoc( noSrcSpan )
...@@ -65,12 +64,12 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs ...@@ -65,12 +64,12 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
-- because the latter is part of a knot, whereas the former is not. -- because the latter is part of a knot, whereas the former is not.
mkNewTyConRhs tycon_name tycon con mkNewTyConRhs tycon_name tycon con
= do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_roles etad_rhs ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon) ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
; return (NewTyCon { data_con = con, ; return (NewTyCon { data_con = con,
nt_rhs = rhs_ty, nt_rhs = rhs_ty,
nt_etad_rhs = (etad_tvs, etad_rhs), nt_etad_rhs = (etad_tvs, etad_rhs),
nt_co = co_tycon } ) } nt_co = nt_ax } ) }
-- Coreview looks through newtypes with a Nothing -- Coreview looks through newtypes with a Nothing
-- for nt_co, or uses explicit coercions otherwise -- for nt_co, or uses explicit coercions otherwise
where where
......
...@@ -37,6 +37,7 @@ module IfaceSyn ( ...@@ -37,6 +37,7 @@ module IfaceSyn (
#include "HsVersions.h" #include "HsVersions.h"
import IfaceType import IfaceType
import CoreSyn( IsOrphan )
import PprCore() -- Printing DFunArgs import PprCore() -- Printing DFunArgs
import Demand import Demand
import Class import Class
...@@ -60,7 +61,6 @@ import HsBinds ...@@ -60,7 +61,6 @@ import HsBinds
import TyCon ( Role (..), Injectivity(..) ) import TyCon ( Role (..), Injectivity(..) )
import StaticFlags (opt_PprStyle_Debug) import StaticFlags (opt_PprStyle_Debug)
import Util( filterOut, filterByList ) import Util( filterOut, filterByList )
import InstEnv
import DataCon (SrcStrictness(..), SrcUnpackedness(..)) import DataCon (SrcStrictness(..), SrcUnpackedness(..))
import Lexeme (isLexSym) import Lexeme (isLexSym)
......
...@@ -58,7 +58,8 @@ import HsSyn ...@@ -58,7 +58,8 @@ import HsSyn
import HscTypes import HscTypes
import InstEnv import InstEnv
import IfaceEnv ( newInteractiveBinder ) import IfaceEnv ( newInteractiveBinder )
import FamInstEnv ( FamInst, orphNamesOfFamInst ) import FamInstEnv ( FamInst )
import CoreFVs ( orphNamesOfFamInst )
import TyCon import TyCon
import Type hiding( typeKind ) import Type hiding( typeKind )
import TcType hiding( typeKind ) import TcType hiding( typeKind )
......
...@@ -108,8 +108,8 @@ import PrelNames ...@@ -108,8 +108,8 @@ import PrelNames
import TysPrim import TysPrim
-- others: -- others:
import FamInstEnv( mkNewTypeCoAxiom )
import CoAxiom import CoAxiom
import Coercion
import Id import Id
import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
import Module ( Module ) import Module ( Module )
...@@ -1094,7 +1094,7 @@ ipTyCon = mkClassTyCon ipTyConName kind [ip,a] [] rhs ipClass NonRecursive ...@@ -1094,7 +1094,7 @@ ipTyCon = mkClassTyCon ipTyConName kind [ip,a] [] rhs ipClass NonRecursive
rhs = NewTyCon ipDataCon (mkTyVarTy a) ([], mkTyVarTy a) ipCoAxiom rhs = NewTyCon ipDataCon (mkTyVarTy a) ([], mkTyVarTy a) ipCoAxiom
ipCoAxiom :: CoAxiom Unbranched ipCoAxiom :: CoAxiom Unbranched
ipCoAxiom = mkNewTypeCo ipCoName ipTyCon [ip,a] [Nominal, Nominal] (mkTyVarTy a) ipCoAxiom = mkNewTypeCoAxiom ipCoName ipTyCon [ip,a] [Nominal, Nominal] (mkTyVarTy a)
where where
[ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind] [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
......
...@@ -40,6 +40,7 @@ import TcEvidence ...@@ -40,6 +40,7 @@ import TcEvidence
import InstEnv import InstEnv
import DataCon ( dataConWrapId ) import DataCon ( dataConWrapId )
import TysWiredIn ( heqDataCon ) import TysWiredIn ( heqDataCon )
import CoreSyn ( isOrphan )
import FunDeps import FunDeps
import TcMType import TcMType
import Type import Type
......
...@@ -644,8 +644,8 @@ tc_infer_hs_type_ek mode ty ek ...@@ -644,8 +644,8 @@ tc_infer_hs_type_ek mode ty ek
--------------------------- ---------------------------
tupKindSort_maybe :: TcKind -> Maybe TupleSort tupKindSort_maybe :: TcKind -> Maybe TupleSort
tupKindSort_maybe k tupKindSort_maybe k
| Just (k', _) <- tcSplitCastTy_maybe k = tupKindSort_maybe k' | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'
| Just k' <- coreView k = tupKindSort_maybe k' | Just k' <- coreView k = tupKindSort_maybe k'
| isConstraintKind k = Just ConstraintTuple | isConstraintKind k = Just ConstraintTuple
| isLiftedTypeKind k = Just BoxedTuple | isLiftedTypeKind k = Just BoxedTuple
| otherwise = Nothing | otherwise = Nothing
......
...@@ -53,6 +53,7 @@ import TcRnMonad ...@@ -53,6 +53,7 @@ import TcRnMonad
import TcEvidence import TcEvidence
import PprTyThing( pprTyThing ) import PprTyThing( pprTyThing )
import Coercion( pprCoAxiom ) import Coercion( pprCoAxiom )
import CoreFVs( orphNamesOfFamInst )
import FamInst import FamInst
import InstEnv import InstEnv
import FamInstEnv import FamInstEnv
......
...@@ -1032,7 +1032,9 @@ tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_) mb_clsinfo ...@@ -1032,7 +1032,9 @@ tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_) mb_clsinfo
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTvBndrs tvs') ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTvBndrs tvs')
-- don't print out the pats here, as they might be zonked inside the knot -- don't print out the pats here, as they might be zonked inside the knot
; return (mkCoAxBranch tvs' [] pats' rhs_ty loc) } ; return (mkCoAxBranch tvs' [] pats' rhs_ty
(map (const Nominal) tvs')
loc) }
kcDataDefn :: Name -- ^ the family name, for error msgs only kcDataDefn :: Name -- ^ the family name, for error msgs only
-> HsTyPats Name -- ^ the patterns, for error msgs only -> HsTyPats Name -- ^ the patterns, for error msgs only
......
...@@ -63,7 +63,6 @@ module TcType ( ...@@ -63,7 +63,6 @@ module TcType (
tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars, tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
tcGetTyVar_maybe, tcGetTyVar, nextRole, tcGetTyVar_maybe, tcGetTyVar, nextRole,
tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe, tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe,
tcSplitCastTy_maybe,
--------------------------------- ---------------------------------
-- Predicates. -- Predicates.
...@@ -81,7 +80,7 @@ module TcType ( ...@@ -81,7 +80,7 @@ module TcType (
--------------------------------- ---------------------------------
-- Misc type manipulators -- Misc type manipulators
deNoteType, occurCheckExpand, OccCheckResult(..), deNoteType, occurCheckExpand, OccCheckResult(..),
orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo, orphNamesOfType, orphNamesOfCo,
orphNamesOfTypes, orphNamesOfCoCon, orphNamesOfTypes, orphNamesOfCoCon,
getDFunTyKey, getDFunTyKey,
evVarPred_maybe, evVarPred, evVarPred_maybe, evVarPred,
...@@ -188,10 +187,10 @@ import VarSet ...@@ -188,10 +187,10 @@ import VarSet
import Coercion import Coercion
import Type import Type
import TyCon import TyCon
import CoAxiom
-- others: -- others:
import DynFlags import DynFlags
import CoreFVs
import Name -- hiding (varName) import Name -- hiding (varName)
-- We use this to make dictionaries for type literals. -- We use this to make dictionaries for type literals.
-- Perhaps there's a better way to do this? -- Perhaps there's a better way to do this?
...@@ -1226,12 +1225,6 @@ tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as ...@@ -1226,12 +1225,6 @@ tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as
tcIsTyVarTy (TyVarTy _) = True tcIsTyVarTy (TyVarTy _) = True
tcIsTyVarTy _ = False tcIsTyVarTy _ = False
-----------------------
tcSplitCastTy_maybe :: TcType -> Maybe (TcType, Coercion)
tcSplitCastTy_maybe ty | Just ty' <- coreView ty = tcSplitCastTy_maybe ty'
tcSplitCastTy_maybe (CastTy ty co) = Just (ty, co)
tcSplitCastTy_maybe _ = Nothing
----------------------- -----------------------
tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type])
-- Split the type of a dictionary function -- Split the type of a dictionary function
...@@ -2011,83 +2004,6 @@ Find the free tycons and classes of a type. This is used in the front ...@@ -2011,83 +2004,6 @@ Find the free tycons and classes of a type. This is used in the front
end of the compiler. end of the compiler.
-} -}
orphNamesOfTyCon :: TyCon -> NameSet
orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of
Nothing -> emptyNameSet
Just cls -> unitNameSet (getName cls)
orphNamesOfType :: Type -> NameSet
orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty'
-- Look through type synonyms (Trac #4912)
orphNamesOfType (TyVarTy _) = emptyNameSet
orphNamesOfType (LitTy {}) = emptyNameSet
orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
`unionNameSet` orphNamesOfTypes tys
orphNamesOfType (ForAllTy bndr res) = orphNamesOfTyCon funTyCon -- NB! See Trac #8535
`unionNameSet` orphNamesOfType (binderType bndr)
`unionNameSet` orphNamesOfType res
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co
orphNamesOfType (CoercionTy co) = orphNamesOfCo co
orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet
orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet
orphNamesOfTypes :: [Type] -> NameSet
orphNamesOfTypes = orphNamesOfThings orphNamesOfType
orphNamesOfDFunHead :: Type -> NameSet
-- Find the free type constructors and classes
-- of the head of the dfun instance type
-- The 'dfun_head_type' is because of
-- instance Foo a => Baz T where ...
-- The decl is an orphan if Baz and T are both not locally defined,
-- even if Foo *is* locally defined
orphNamesOfDFunHead dfun_ty
= case tcSplitSigmaTy dfun_ty of
(_, _, head_ty) -> orphNamesOfType head_ty
orphNamesOfCo :: Coercion -> NameSet
orphNamesOfCo (Refl _ ty) = orphNamesOfType ty
orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (ForAllCo _ kind_co co)
= orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co
orphNamesOfCo (CoVarCo _) = emptyNameSet
orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2
orphNamesOfCo (SymCo co) = orphNamesOfCo co
orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (NthCo _ co) = orphNamesOfCo co
orphNamesOfCo (LRCo _ co) = orphNamesOfCo co
orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg
orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (KindCo co) = orphNamesOfCo co
orphNamesOfCo (SubCo co) = orphNamesOfCo co
orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs
orphNamesOfProv :: UnivCoProvenance -> NameSet
orphNamesOfProv UnsafeCoerceProv = emptyNameSet
orphNamesOfProv (PhantomProv co) = orphNamesOfCo co
orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
orphNamesOfProv (PluginProv _) = emptyNameSet
orphNamesOfProv (HoleProv _) = emptyNameSet
orphNamesOfCos :: [Coercion] -> NameSet
orphNamesOfCos = orphNamesOfThings orphNamesOfCo
orphNamesOfCoCon :: CoAxiom br -> NameSet
orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
= orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches
orphNamesOfCoAxBranches :: Branches br -> NameSet
orphNamesOfCoAxBranches
= foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches
orphNamesOfCoAxBranch :: CoAxBranch -> NameSet
orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
= orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -206,11 +206,12 @@ of the branches. ...@@ -206,11 +206,12 @@ of the branches.
-- See Note [GHC Formalism] in coreSyn/CoreLint.hs -- See Note [GHC Formalism] in coreSyn/CoreLint.hs
data CoAxiom br data CoAxiom br
= CoAxiom -- Type equality axiom. = CoAxiom -- Type equality axiom.
{ co_ax_unique :: Unique -- unique identifier { co_ax_unique :: Unique -- Unique identifier
, co_ax_name :: Name -- name for pretty-printing , co_ax_name :: Name -- Name for pretty-printing
, co_ax_role :: Role -- role of the axiom's equality , co_ax_role :: Role -- Role of the axiom's equality
, co_ax_tc :: TyCon -- the head of the LHS patterns , co_ax_tc :: TyCon -- The head of the LHS patterns
, co_ax_branches :: Branches br -- the branches that form this axiom -- e.g. the newtype or family tycon
, co_ax_branches :: Branches br -- The branches that form this axiom
, co_ax_implicit :: Bool -- True <=> the axiom is "implicit" , co_ax_implicit :: Bool -- True <=> the axiom is "implicit"
-- See Note [Implicit axioms] -- See Note [Implicit axioms]
-- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1.
...@@ -229,6 +230,7 @@ data CoAxBranch ...@@ -229,6 +230,7 @@ data CoAxBranch
-- in TcTyClsDecls -- in TcTyClsDecls
, cab_roles :: [Role] -- See Note [CoAxBranch roles] , cab_roles :: [Role] -- See Note [CoAxBranch roles]
, cab_lhs :: [Type] -- Type patterns to match against , cab_lhs :: [Type] -- Type patterns to match against
-- See Note [CoAxiom saturation]
, cab_rhs :: Type -- Right-hand side of the equality , cab_rhs :: Type -- Right-hand side of the equality
, cab_incomps :: [CoAxBranch] -- The previous incompatible branches , cab_incomps :: [CoAxBranch] -- The previous incompatible branches
-- See Note [Storing compatibility] -- See Note [Storing compatibility]
...@@ -307,7 +309,10 @@ coAxBranchIncomps = cab_incomps ...@@ -307,7 +309,10 @@ coAxBranchIncomps = cab_incomps
placeHolderIncomps :: [CoAxBranch] placeHolderIncomps :: [CoAxBranch]
placeHolderIncomps = panic "placeHolderIncomps" placeHolderIncomps = panic "placeHolderIncomps"
{- {- Note [CoAxiom saturation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* When co
Note [CoAxBranch type variables] Note [CoAxBranch type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the case of a CoAxBranch of an associated type-family instance, In the case of a CoAxBranch of an associated type-family instance,
......
...@@ -34,7 +34,7 @@ module Coercion ( ...@@ -34,7 +34,7 @@ module Coercion (
mkForAllCo, mkForAllCos, mkHomoForAllCos, mkHomoForAllCos_NoRefl, mkForAllCo, mkForAllCos, mkHomoForAllCos, mkHomoForAllCos_NoRefl,
mkPhantomCo, mkHomoPhantomCo, toPhantomCo, mkPhantomCo, mkHomoPhantomCo, toPhantomCo,
mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo, mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo,
mkNewTypeCo, mkAxiomInstCo, mkProofIrrelCo, mkAxiomInstCo, mkProofIrrelCo,
downgradeRole, maybeSubCo, mkAxiomRuleCo, downgradeRole, maybeSubCo, mkAxiomRuleCo,
mkCoherenceCo, mkCoherenceRightCo, mkCoherenceLeftCo, mkCoherenceCo, mkCoherenceRightCo, mkCoherenceLeftCo,
mkKindCo, castCoercionKind, mkKindCo, castCoercionKind,
...@@ -1194,27 +1194,6 @@ castCoercionKind g h1 h2 ...@@ -1194,27 +1194,6 @@ castCoercionKind g h1 h2
-- See note [Newtype coercions] in TyCon -- See note [Newtype coercions] in TyCon
-- | Create a coercion constructor (axiom) suitable for the given
-- newtype 'TyCon'. The 'Name' should be that of a new coercion
-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and
-- the type the appropriate right hand side of the @newtype@, with
-- the free variables a subset of those 'TyVar's.
mkNewTypeCo :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched
mkNewTypeCo name tycon tvs roles rhs_ty
= CoAxiom { co_ax_unique = nameUnique name
, co_ax_name = name
, co_ax_implicit = True -- See Note [Implicit axioms] in TyCon
, co_ax_role = Representational
, co_ax_tc = tycon
, co_ax_branches = unbranched branch }
where branch = CoAxBranch { cab_loc = getSrcSpan name
, cab_tvs = tvs
, cab_cvs = []
, cab_lhs = mkTyVarTys tvs
, cab_roles = roles
, cab_rhs = rhs_ty
, cab_incomps = [] }
mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos :: Role -> [Var] -> Coercion -> Coercion
mkPiCos r vs co = foldr (mkPiCo r) co vs mkPiCos r vs co = foldr (mkPiCo r) co vs
......
...@@ -12,11 +12,11 @@ module FamInstEnv ( ...@@ -12,11 +12,11 @@ module FamInstEnv (
FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,
extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList, extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList,
identicalFamInstHead, famInstEnvElts, familyInstances, orphNamesOfFamInst, identicalFamInstHead, famInstEnvElts, familyInstances,
-- * CoAxioms -- * CoAxioms
mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom,
computeAxiomIncomps, mkNewTypeCoAxiom,
FamInstMatch(..), FamInstMatch(..),
lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon,
...@@ -38,10 +38,8 @@ module FamInstEnv ( ...@@ -38,10 +38,8 @@ module FamInstEnv (
#include "HsVersions.h" #include "HsVersions.h"
import InstEnv </