Commit 91923f12 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Adding FamInstEnv & FamInst modules

- They got lost during manual patching, as they are file additions.
parent 4b6b4d23
\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}
\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}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment