Adding FamInstEnv & FamInst modules

- They got lost during manual patching, as they are file additions.

diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
new file mode 100644 (file)
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 (file)
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}                   
+