module FamInst (
FamInstEnvs, tcGetFamInstEnvs,
checkFamInstConsistency, tcExtendLocalFamInstEnv,
tcLookupFamInst,
tcLookupDataFamInst, tcLookupDataFamInst_maybe,
tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
newFamInst
) where
import HscTypes
import FamInstEnv
import InstEnv( roughMatchTcs )
import Coercion hiding ( substTy )
import TcEvidence
import LoadIface
import TcRnMonad
import TyCon
import CoAxiom
import DynFlags
import Module
import Outputable
import UniqFM
import FastString
import Util
import RdrName
import DataCon ( dataConName )
import Maybes
import TcMType
import TcType
import Name
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Control.Arrow ( first, second )
#include "HsVersions.h"
newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst
newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch
, co_ax_tc = fam_tc })
| CoAxBranch { cab_tvs = tvs
, cab_lhs = lhs
, cab_rhs = rhs } <- branch
= do { (subst, tvs') <- freshenTyVarBndrs tvs
; return (FamInst { fi_fam = tyConName fam_tc
, fi_flavor = flavor
, fi_tcs = roughMatchTcs lhs
, fi_tvs = tvs'
, fi_tys = substTys subst lhs
, fi_rhs = substTy subst rhs
, fi_axiom = axiom }) }
data ModulePair = ModulePair Module Module
canon :: ModulePair -> (Module, Module)
canon (ModulePair m1 m2) | m1 < m2 = (m1, m2)
| otherwise = (m2, m1)
instance Eq ModulePair where
mp1 == mp2 = canon mp1 == canon mp2
instance Ord ModulePair where
mp1 `compare` mp2 = canon mp1 `compare` canon mp2
instance Outputable ModulePair where
ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2)
type ModulePairSet = Map ModulePair ()
listToSet :: [ModulePair] -> ModulePairSet
listToSet l = Map.fromList (zip l (repeat ()))
checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
checkFamInstConsistency famInstMods directlyImpMods
= do { dflags <- getDynFlags
; (eps, hpt) <- getEpsAndHpt
; let {
modIface mod =
case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
Nothing -> panic "FamInst.checkFamInstConsistency"
Just iface -> iface
; hmiModule = mi_module . hm_iface
; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
. md_fam_insts . hm_details
; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
| hmi <- eltsUFM hpt]
; groups = map (dep_finsts . mi_deps . modIface)
directlyImpMods
; okPairs = listToSet $ concatMap allPairs groups
; criticalPairs = listToSet $ allPairs famInstMods
; toCheckPairs = Map.keys $ criticalPairs `Map.difference` okPairs
}
; mapM_ (check hpt_fam_insts) toCheckPairs
}
where
allPairs [] = []
allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
check hpt_fam_insts (ModulePair m1 m2)
= do { env1 <- getFamInsts hpt_fam_insts m1
; env2 <- getFamInsts hpt_fam_insts m2
; mapM_ (checkForConflicts (emptyFamInstEnv, env2))
(famInstEnvElts env1) }
getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
getFamInsts hpt_fam_insts mod
| Just env <- lookupModuleEnv hpt_fam_insts mod = return env
| otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
; eps <- getEps
; return (expectJust "checkFamInstConsistency" $
lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
where
doc = ppr mod <+> ptext (sLit "is a family-instance module")
tcLookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> Maybe FamInstMatch
tcLookupFamInst fam_envs tycon tys
| not (isOpenFamilyTyCon tycon)
= Nothing
| otherwise
= case lookupFamInstEnv fam_envs tycon tys of
match : _ -> Just match
[] -> Nothing
tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)
tcInstNewTyCon_maybe tc tys = fmap (second TcCoercion) $
instNewTyCon_maybe tc tys
tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]
-> (TyCon, [TcType], TcCoercion)
tcLookupDataFamInst fam_inst_envs tc tc_args
| Just (rep_tc, rep_args, co)
<- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
= (rep_tc, rep_args, TcCoercion co)
| otherwise
= (tc, tc_args, mkTcRepReflCo (mkTyConApp tc tc_args))
tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType]
-> Maybe (TyCon, [TcType], Coercion)
tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
| isDataFamilyTyCon tc
, match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args
, FamInstMatch { fim_instance = rep_fam
, fim_tys = rep_args } <- match
, let co_tc = famInstAxiom rep_fam
rep_tc = dataFamInstRepTyCon rep_fam
co = mkUnbranchedAxInstCo Representational co_tc rep_args
= Just (rep_tc, rep_args, co)
| otherwise
= Nothing
tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs
-> GlobalRdrEnv
-> Type
-> Maybe (TcCoercion, Type)
tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
= fmap (first TcCoercion) $ topNormaliseTypeX_maybe stepper ty
where
stepper
= unwrap_newtype
`composeSteppers`
\ rec_nts tc tys ->
case tcLookupDataFamInst_maybe faminsts tc tys of
Just (tc', tys', co) ->
modifyStepResultCo (co `mkTransCo`)
(unwrap_newtype rec_nts tc' tys')
Nothing -> NS_Done
unwrap_newtype rec_nts tc tys
| data_cons_in_scope tc
= unwrapNewTypeStepper rec_nts tc tys
| otherwise
= NS_Done
data_cons_in_scope :: TyCon -> Bool
data_cons_in_scope tc
= isWiredInName (tyConName tc) ||
(not (isAbstractTyCon tc) && all in_scope data_con_names)
where
data_con_names = map dataConName (tyConDataCons tc)
in_scope dc = not $ null $ lookupGRE_Name rdr_env dc
tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv fam_insts thing_inside
= do { env <- getGblEnv
; (inst_env', fam_insts') <- foldlM addLocalFamInst
(tcg_fam_inst_env env, tcg_fam_insts env)
fam_insts
; let env' = env { tcg_fam_insts = fam_insts'
, tcg_fam_inst_env = inst_env' }
; setGblEnv env' thing_inside
}
addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst])
addLocalFamInst (home_fie, my_fis) fam_inst
= do { traceTc "addLocalFamInst" (ppr fam_inst)
; isGHCi <- getIsGHCi
; mod <- getModule
; traceTc "alfi" (ppr mod $$ ppr isGHCi)
; let home_fie'
| isGHCi = deleteFromFamInstEnv home_fie fam_inst
| otherwise = home_fie
; eps <- getEps
; let inst_envs = (eps_fam_inst_env eps, home_fie')
home_fie'' = extendFamInstEnv home_fie fam_inst
; no_conflict <- checkForConflicts inst_envs fam_inst
; if no_conflict then
return (home_fie'', fam_inst : my_fis)
else
return (home_fie, my_fis) }
checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool
checkForConflicts inst_envs fam_inst
= do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst
no_conflicts = null conflicts
; traceTc "checkForConflicts" $
vcat [ ppr (map fim_instance conflicts)
, ppr fam_inst
]
; unless no_conflicts $ conflictInstErr fam_inst conflicts
; return no_conflicts }
conflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()
conflictInstErr fam_inst conflictingMatch
| (FamInstMatch { fim_instance = confInst }) : _ <- conflictingMatch
= addFamInstsErr (ptext (sLit "Conflicting family instance declarations:"))
[fam_inst, confInst]
| otherwise
= panic "conflictInstErr"
addFamInstsErr :: SDoc -> [FamInst] -> TcRn ()
addFamInstsErr herald insts
= ASSERT( not (null insts) )
setSrcSpan srcSpan $ addErr $
hang herald
2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) 0
| fi <- sorted ])
where
getSpan = getSrcLoc . famInstAxiom
sorted = sortWith getSpan insts
fi1 = head sorted
srcSpan = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
tcGetFamInstEnvs :: TcM FamInstEnvs
tcGetFamInstEnvs
= do { eps <- getEps; env <- getGblEnv
; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }