From 91923f12046713b115003e184f7098ee00c00028 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 20:17:27 +0000 Subject: [PATCH] Adding FamInstEnv & FamInst modules - They got lost during manual patching, as they are file additions. --- compiler/typecheck/FamInst.lhs | 91 +++++++++++++++++++++++++++ compiler/types/FamInstEnv.lhs | 134 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 225 insertions(+) create mode 100644 compiler/typecheck/FamInst.lhs create mode 100644 compiler/types/FamInstEnv.lhs diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs new file mode 100644 index 0000000..68c4096 --- /dev/null +++ b/compiler/typecheck/FamInst.lhs @@ -0,0 +1,91 @@ +\section[FamInst]{The @FamInst@ type: family instance heads} + +\begin{code} +module FamInst ( + tcExtendLocalFamInstEnv + ) where + +#include "HsVersions.h" + +import FamInstEnv ( FamInstEnv, FamInst(..), famInstTyCon, extendFamInstEnv, + pprFamInst, pprFamInsts ) +import TcMType ( tcInstSkolType ) +import TcType ( SkolemInfo(..), tcSplitTyConApp ) +import TcRnMonad ( TcM, TcGblEnv(..), setGblEnv, getGblEnv, foldlM, + setSrcSpan, addErr ) +import TyCon ( tyConFamInst_maybe ) +import Type ( mkTyConApp ) +import Name ( getSrcLoc ) +import SrcLoc ( mkSrcSpan ) +import Outputable +\end{code} + + +%************************************************************************ +%* * + Extending the family instance environment +%* * +%************************************************************************ + +\begin{code} + +-- Add new locally-defined family instances +tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a +tcExtendLocalFamInstEnv fam_insts thing_inside + = do { env <- getGblEnv + ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts + ; let env' = env { tcg_fam_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + + +-- Check that the proposed new instance is OK, +-- and then add it to the home inst env +addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv +addLocalFamInst home_fie famInst + = do { -- Instantiate the family instance type extend the instance + -- envt with completely fresh template variables + -- This is important because the template variables must + -- not overlap with anything in the things being looked up + -- (since we do unification). + -- We use tcInstSkolType because we don't want to allocate + -- fresh *meta* type variables. + let tycon = famInstTyCon famInst + ty = case tyConFamInst_maybe tycon of + Nothing -> panic "FamInst.addLocalFamInst" + Just (tc, tys) -> tc `mkTyConApp` tys + ; (tvs', theta', tau') <- tcInstSkolType (FamInstSkol tycon) ty + + ; let (fam, tys') = tcSplitTyConApp tau' + +{- !!!TODO: Need to complete this: + -- Load imported instances, so that we report + -- overlaps correctly + ; eps <- getEps + ; let inst_envs = (eps_fam_inst_env eps, home_fie) + + -- Check for overlapping instance decls + ; let { (matches, _) = lookupFamInstEnv inst_envs fam tys' + ; dup_ispecs = [ dup_ispec --!!!adapt + | (_, dup_ispec) <- matches + , let (_,_,_,dup_tys) = instanceHead dup_ispec + , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] } + -- Find memebers of the match list which ispec itself matches. + -- If the match is 2-way, it's a duplicate + ; case dup_ispecs of + dup_ispec : _ -> dupInstErr famInst dup_ispec + [] -> return () + -} + + -- OK, now extend the envt + ; return (extendFamInstEnv home_fie famInst) } + +overlapErr famInst dupFamInst + = addFamInstLoc famInst $ + addErr (hang (ptext SLIT("Overlapping family instance declarations:")) + 2 (pprFamInsts [famInst, dupFamInst])) + +addFamInstLoc famInst thing_inside + = setSrcSpan (mkSrcSpan loc loc) thing_inside + where + loc = getSrcLoc famInst +\end{code} diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs new file mode 100644 index 0000000..ec50fbc --- /dev/null +++ b/compiler/types/FamInstEnv.lhs @@ -0,0 +1,134 @@ +\section[FamInstEnv]{Type checked family instance declarations} + +\begin{code} +module FamInstEnv ( + FamInst(..), famInstTyCon, extractFamInsts, + pprFamInst, pprFamInstHdr, pprFamInsts, + {-famInstHead, mkLocalFamInst, mkImportedFamInst-} + + FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList, + famInstEnvElts, familyInstances, + {-lookupFamInstEnv-} + ) where + +#include "HsVersions.h" + +import TcType ( Type ) +import Type ( TyThing (ATyCon), pprParendType ) +import TyCon ( TyCon, isDataTyCon, isNewTyCon, isSynTyCon, + tyConName, tyConTyVars, tyConFamInst_maybe ) +import VarSet ( TyVarSet, mkVarSet ) +import Name ( Name, getOccName, NamedThing(..), getSrcLoc ) +import OccName ( parenSymOcc ) +import SrcLoc ( pprDefnLoc ) +import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM ) +import Outputable + +import Monad ( mzero ) +\end{code} + + +%************************************************************************ +%* * +\subsection{Type checked family instance heads} +%* * +%************************************************************************ + +\begin{code} +data FamInst + = FamInst { fi_fam :: Name -- Family name + , fi_tvs :: TyVarSet -- Template tyvars for full match + , fi_tys :: [Type] -- Full arg types + + , fi_tycon :: TyCon -- Representation tycon + } + +-- Obtain the representation tycon of a family instance. +-- +famInstTyCon :: FamInst -> TyCon +famInstTyCon = fi_tycon + +-- Extract all family instances. +-- +extractFamInsts :: [TyThing] -> [FamInst] +extractFamInsts tythings + = do { ATyCon tycon <- tythings + ; case tyConFamInst_maybe tycon of + Nothing -> mzero + Just (fam, tys) -> + return $ FamInst { fi_fam = tyConName fam + , fi_tvs = mkVarSet . tyConTyVars $ tycon + , fi_tys = tys + , fi_tycon = tycon + } + } +\end{code} + +\begin{code} +instance NamedThing FamInst where + getName = getName . fi_tycon + +instance Outputable FamInst where + ppr = pprFamInst + +-- Prints the FamInst as a family instance declaration +pprFamInst :: FamInst -> SDoc +pprFamInst famInst + = hang (pprFamInstHdr famInst) + 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc famInst))) + +pprFamInstHdr :: FamInst -> SDoc +pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) + = pprTyConSort <+> pprHead + where + pprHead = parenSymOcc (getOccName fam) (ppr fam) <+> + sep (map pprParendType tys) + pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance") + | isNewTyCon tycon = ptext SLIT("newtype instance") + | isSynTyCon tycon = ptext SLIT("type instance") + | otherwise = panic "FamInstEnv.pprFamInstHdr" + +pprFamInsts :: [FamInst] -> SDoc +pprFamInsts finsts = vcat (map pprFamInst finsts) +\end{code} + + +%************************************************************************ +%* * + FamInstEnv +%* * +%************************************************************************ + +InstEnv maps a family name to the list of known instances for that family. + +\begin{code} +type FamInstEnv = UniqFM [FamInst] -- Maps a family to its instances + +-- INVARIANTS: +-- * The fs_tvs are distinct in each FamInst +-- of a range value of the map (so we can safely unify them) + +emptyFamInstEnv :: FamInstEnv +emptyFamInstEnv = emptyUFM + +famInstEnvElts :: FamInstEnv -> [FamInst] +famInstEnvElts = concat . eltsUFM + +familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] +familyInstances (pkg_fie, home_fie) fam + = get home_fie ++ get pkg_fie + where + get env = case lookupUFM env fam of + Just insts -> insts + Nothing -> [] + +extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv +extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis + +extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm}) + = addToUFM_C add inst_env cls_nm [ins_item] + where + add items _ = ins_item:items +\end{code} + -- 1.7.10.4