Commit 2b8358cf authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Implement TH reification of instances (Trac #1835)

Accompanying patch for template-haskell package is reqd
parent 0cbb1f34
......@@ -7,7 +7,8 @@ This module converts Template Haskell syntax into HsSyn
\begin{code}
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType, thRdrNameGuesses ) where
convertToHsType, convertToHsPred,
thRdrNameGuesses ) where
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
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;
......
......@@ -7,7 +7,7 @@
module RnTypes (
-- Type related stuff
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsSigType, rnHsTypeFVs, rnConDeclFields,
rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred,
-- Precence related stuff
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
......
......@@ -16,7 +16,7 @@ module TcHsType (
-- Typechecking kinded types
tcHsKindedContext, tcHsKindedType, tcHsBangType,
tcTyVarBndrs, dsHsType,
tcTyVarBndrs, dsHsType, kcHsLPred, dsHsLPred,
tcDataKindSig, ExpKind(..), EkCtxt(..),
-- Pattern type signatures
......
......@@ -44,6 +44,7 @@ import TcMType
import TcHsType
import TcIface
import TypeRep
import InstEnv
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
qClassInstances = lookupClassInstances
-- For qRecover, discard error messages if
-- the recovery action is chosen. Otherwise
......@@ -915,6 +917,33 @@ illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (withou
\end{code}
%************************************************************************
%* *
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
......@@ -1103,16 +1132,34 @@ reifyDataCon tys dc
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
; 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
reify_op (op, _) = do { ty <- reifyType (idType op)
; 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
-- 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))
......
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