Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Alex D
GHC
Commits
2b8358cf
Commit
2b8358cf
authored
Sep 15, 2010
by
simonpj@microsoft.com
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Implement TH reification of instances (Trac #1835)
Accompanying patch for template-haskell package is reqd
parent
0cbb1f34
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
56 additions
and
4 deletions
+56
-4
compiler/hsSyn/Convert.lhs
compiler/hsSyn/Convert.lhs
+6
-1
compiler/rename/RnTypes.lhs
compiler/rename/RnTypes.lhs
+1
-1
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcHsType.lhs
+1
-1
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcSplice.lhs
+48
-1
No files found.
compiler/hsSyn/Convert.lhs
View file @
2b8358cf
...
...
@@ -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;
...
...
compiler/rename/RnTypes.lhs
View file @
2b8358cf
...
...
@@ -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,
...
...
compiler/typecheck/TcHsType.lhs
View file @
2b8358cf
...
...
@@ -16,7 +16,7 @@ module TcHsType (
-- Typechecking kinded types
tcHsKindedContext, tcHsKindedType, tcHsBangType,
tcTyVarBndrs, dsHsType,
tcTyVarBndrs, dsHsType,
kcHsLPred, dsHsLPred,
tcDataKindSig, ExpKind(..), EkCtxt(..),
-- Pattern type signatures
...
...
compiler/typecheck/TcSplice.lhs
View file @
2b8358cf
...
...
@@ -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))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment