Implement TH reification of instances (Trac #1835)

Accompanying patch for template-haskell package is reqd

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 0ab26ee..cc54b84 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -7,7 +7,8 @@ This module converts Template Haskell syntax into HsSyn
 
 \begin{code}
 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
 
 \begin{code}
 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,

-                convertToHsType, thRdrNameGuesses ) where
+                convertToHsType, convertToHsPred,
+                thRdrNameGuesses ) where

 
 import HsSyn as Hs
 import qualified Class
 
 import HsSyn as Hs
 import qualified Class

@@ -58,6 +59,10 @@ convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
 convertToHsType loc t
   = initCvt loc $ wrapMsg "type" t $ cvtType t
 
 convertToHsType loc t
   = initCvt loc $ wrapMsg "type" t $ cvtType t
 

+convertToHsPred :: SrcSpan -> TH.Pred -> Either Message (LHsPred RdrName)
+convertToHsPred loc t
+  = initCvt loc $ wrapMsg "type" t $ cvtPred t
+

 -------------------------------------------------------------------
 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
        -- Push down the source location;
 -------------------------------------------------------------------
 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
        -- Push down the source location;

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index b275d2d..a818135 100644 (file)
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -7,7 +7,7 @@
 module RnTypes ( 
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
 module RnTypes ( 
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,

-       rnHsSigType, rnHsTypeFVs, rnConDeclFields,
+       rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred,

 
        -- Precence related stuff
        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
 
        -- Precence related stuff
        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index b27d26a..50cc4d6 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -16,7 +16,7 @@ module TcHsType (
        
                -- Typechecking kinded types
        tcHsKindedContext, tcHsKindedType, tcHsBangType,
        
                -- Typechecking kinded types
        tcHsKindedContext, tcHsKindedType, tcHsBangType,

-       tcTyVarBndrs, dsHsType, 
+       tcTyVarBndrs, dsHsType, kcHsLPred, dsHsLPred,

        tcDataKindSig, ExpKind(..), EkCtxt(..),
 
                -- Pattern type signatures
        tcDataKindSig, ExpKind(..), EkCtxt(..),
 
                -- Pattern type signatures

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 0744dae..aa5e9a1 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -44,6 +44,7 @@ import TcMType
 import TcHsType
 import TcIface
 import TypeRep
 import TcHsType
 import TcIface
 import TypeRep

+import InstEnv 

 import Name
 import NameEnv
 import NameSet
 import Name
 import NameEnv
 import NameSet

@@ -874,6 +875,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
                                  , TH.loc_end = (srcSpanEndLine   l, srcSpanEndCol   l) }) }
                
   qReify v = reify v
                                  , TH.loc_end = (srcSpanEndLine   l, srcSpanEndCol   l) }) }
                
   qReify v = reify v

+  qClassInstances = lookupClassInstances

 
        -- For qRecover, discard error messages if 
        -- the recovery action is chosen.  Otherwise
 
        -- For qRecover, discard error messages if 
        -- the recovery action is chosen.  Otherwise

@@ -917,6 +919,33 @@ illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (withou
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

+           Instance Testing
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.Name]
+lookupClassInstances c ts
+   = do { loc <- getSrcSpanM
+        ; case convertToHsPred loc (TH.ClassP c ts) of
+            Left msg -> failWithTc msg
+            Right rdr_pred -> do
+        { rn_pred <- rnLPred doc rdr_pred      -- Rename
+        ; kc_pred <- kcHsLPred rn_pred         -- Kind check
+        ; ClassP cls tys <- dsHsLPred kc_pred  -- Type check
+
+       -- Now look up instances
+        ; inst_envs <- tcGetInstEnvs
+        ; let (matches, unifies) = lookupInstEnv inst_envs cls tys
+              dfuns = map is_dfun (map fst matches ++ unifies)
+        ; return (map reifyName dfuns) } }
+  where
+    doc = ptext (sLit "TcSplice.classInstances")
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *

                        Reification
 %*                                                                     *
 %************************************************************************
                        Reification
 %*                                                                     *
 %************************************************************************

@@ -1103,8 +1132,11 @@ reifyDataCon tys dc
 reifyClass :: Class -> TcM TH.Info
 reifyClass cls 
   = do { cxt <- reifyCxt theta
 reifyClass :: Class -> TcM TH.Info
 reifyClass cls 
   = do { cxt <- reifyCxt theta

+        ; inst_envs <- tcGetInstEnvs
+        ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls)

        ; ops <- mapM reify_op op_stuff
        ; ops <- mapM reify_op op_stuff

-       ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
+        ; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops
+       ; return (TH.ClassI dec insts ) }

   where
     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
     fds' = map reifyFunDep fds
   where
     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
     fds' = map reifyFunDep fds

@@ -1112,7 +1144,22 @@ reifyClass cls
                          ; return (TH.SigD (reifyName op) ty) }
 
 ------------------------------
                          ; return (TH.SigD (reifyName op) ty) }
 
 ------------------------------

+reifyClassInstance :: Instance -> TcM TH.ClassInstance
+reifyClassInstance i
+  = do { cxt <- reifyCxt theta
+       ; thtypes <- reifyTypes types
+       ; return $ (TH.ClassInstance { 
+            TH.ci_tvs = reifyTyVars tvs,
+            TH.ci_cxt = cxt,
+            TH.ci_tys = thtypes,
+            TH.ci_cls = reifyName cls,
+            TH.ci_dfun = reifyName (is_dfun i) }) }
+  where
+     (tvs, theta, cls, types) = instanceHead i
+
+------------------------------

 reifyType :: TypeRep.Type -> TcM TH.Type
 reifyType :: TypeRep.Type -> TcM TH.Type

+-- Monadic only because of failure

 reifyType ty@(ForAllTy _ _)        = reify_for_all ty
 reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty          -- Types like ((?x::Int) => Char -> Char)
 reifyType (TyVarTy tv)     = return (TH.VarT (reifyName tv))
 reifyType ty@(ForAllTy _ _)        = reify_for_all ty
 reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty          -- Types like ((?x::Int) => Char -> Char)
 reifyType (TyVarTy tv)     = return (TH.VarT (reifyName tv))