#ifdef GHCI
-- Template Haskell stuff iff bootstrapped
-import DsMeta ( dsBracket )
+import DsMeta ( dsBracket, dsReify )
#endif
import HsSyn ( failureFreePat,
#ifdef GHCI /* Only if bootstrapping */
dsExpr (HsBracketOut x ps) = dsBracket x ps
+dsExpr (HsReify r) = dsReify r
dsExpr (HsSplice n e _) = pprPanic "dsExpr:splice" (ppr e)
#endif
-----------------------------------------------------------------------------
-module DsMeta( dsBracket,
+module DsMeta( dsBracket, dsReify,
templateHaskellNames, qTyConName,
- liftName, exprTyConName, declTyConName ) where
+ liftName, exprTyConName, declTyConName,
+ decTyConName, typTyConName ) where
#include "HsVersions.h"
HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
HsBinds(..), MonoBinds(..), HsConDetails(..),
TyClDecl(..), HsGroup(..),
+ HsReify(..), ReifyFlavour(..),
HsType(..), HsContext(..), HsPred(..), HsTyOp(..),
HsTyVarBndr(..), Sig(..), ForeignDecl(..),
InstDecl(..), ConDecl(..), BangType(..),
PendingSplice, splitHsInstDeclTy,
placeHolderType, tyClDeclNames,
collectHsBinders, collectPatBinders, collectPatsBinders,
- hsTyVarName, hsConArgs, getBangType
+ hsTyVarName, hsConArgs, getBangType,
+ toHsType
)
import PrelNames ( mETA_META_Name, varQual, tcQual )
+import MkIface ( ifaceTyThing )
import Name ( Name, nameOccName, nameModule )
import OccName ( isDataOcc, isTvOcc, occNameUserString )
import Module ( moduleUserString )
-import Id ( Id )
+import Id ( Id, idType )
import NameEnv
import NameSet
-import Type ( Type, mkGenTyConApp )
+import Type ( Type, TyThing(..), mkGenTyConApp )
import TyCon ( DataConDetails(..) )
import TysWiredIn ( stringTy )
import CoreSyn
do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 }
do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
+-----------------------------------------------------------------------------
+dsReify :: HsReify Id -> DsM CoreExpr
+-- Returns a CoreExpr of type reifyType --> M.Typ
+-- reifyDecl --> M.Dec
+-- reifyFixty --> M.Fix
+dsReify (ReifyOut ReifyType (AnId id))
+ = do { MkC e <- repTy (toHsType (idType id)) ;
+ return e }
+
+dsReify r@(ReifyOut ReifyDecl thing)
+ = do { mb_d <- repTyClD (ifaceTyThing thing) ;
+ case mb_d of
+ Just (MkC d) -> return d
+ Nothing -> pprPanic "dsReify" (ppr r)
+ }
+
{- -------------- Examples --------------------
[| \x -> x |]
constrName,
exprTyConName, declTyConName, pattTyConName, mtchTyConName,
clseTyConName, stmtTyConName, consTyConName, typeTyConName,
- qTyConName, expTyConName, matTyConName, clsTyConName ]
+ qTyConName, expTyConName, matTyConName, clsTyConName,
+ decTyConName, typTyConName ]
qTyConName = tcQual mETA_META_Name FSLIT("Q") qTyConKey
expTyConName = tcQual mETA_META_Name FSLIT("Exp") expTyConKey
+decTyConName = tcQual mETA_META_Name FSLIT("Dec") decTyConKey
+typTyConName = tcQual mETA_META_Name FSLIT("Typ") typTyConKey
matTyConName = tcQual mETA_META_Name FSLIT("Mat") matTyConKey
clsTyConName = tcQual mETA_META_Name FSLIT("Cls") clsTyConKey
stmtTyConKey = mkPreludeTyConUnique 109
consTyConKey = mkPreludeTyConUnique 110
typeTyConKey = mkPreludeTyConUnique 111
+typTyConKey = mkPreludeTyConUnique 112
+decTyConKey = mkPreludeTyConUnique 113
+
-- IdUniques available: 200-299
import HscTypes ( TyThing(..) )
import Bag ( emptyBag, snocBag, Bag )
import TyCon ( TyCon )
-import ErrUtils ( WarnMsg )
import Id ( mkSysLocal, setIdUnique, Id )
import Module ( Module )
import Var ( TyVar, setTyVarUnique )
-- others:
import ForeignCall ( Safety )
import PprType ( pprParendType )
-import Type ( Type )
+import Type ( Type, TyThing )
import Var ( TyVar, Id )
import Name ( Name )
import DataCon ( DataCon )
| HsSplice id (HsExpr id) SrcLoc -- $z or $(f 4)
-- The id is just a unique name to
-- identify this splice point
+
+ | HsReify (HsReify id) -- reifyType t, reifyDecl i, reifyFixity
\end{code}
ppr_expr (HsSplice n e _) = char '$' <> brackets (ppr n) <> pprParendExpr e
ppr_expr (HsBracket b _) = pprHsBracket b
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps
+ppr_expr (HsReify r) = ppr r
-- add parallel array brackets around a document
--
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
pp_body <+> ptext SLIT("|]")
+
+data HsReify id = Reify ReifyFlavour id -- Pre typechecking
+ | ReifyOut ReifyFlavour TyThing -- Post typechecking
+
+data ReifyFlavour = ReifyDecl | ReifyType | ReifyFixity
+
+instance Outputable id => Outputable (HsReify id) where
+ ppr (Reify flavour id) = ppr flavour <+> ppr id
+ ppr (ReifyOut flavour thing) = ppr flavour <+> ppr thing
+
+instance Outputable ReifyFlavour where
+ ppr ReifyDecl = ptext SLIT("reifyDecl")
+ ppr ReifyType = ptext SLIT("reifyType")
+ ppr ReifyFixity = ptext SLIT("reifyFixity")
\end{code}
%************************************************************************
import Id ( Id )
import Class ( Class, classSelIds )
import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons_maybe )
+import Type ( TyThing(..), isTyClThing )
import DataCon ( dataConWorkId, dataConWrapId )
import Packages ( PackageName, preludePackage )
import CmdLineOpts ( DynFlags )
%************************************************************************
\begin{code}
-data TyThing = AnId Id
- | ATyCon TyCon
- | AClass Class
-
-isTyClThing :: TyThing -> Bool
-isTyClThing (ATyCon _) = True
-isTyClThing (AClass _) = True
-isTyClThing (AnId _) = False
-
-instance NamedThing TyThing where
- getName (AnId id) = getName id
- getName (ATyCon tc) = getName tc
- getName (AClass cl) = getName cl
-
-instance Outputable TyThing where
- ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
- ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
- ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
-
-
typeEnvElts :: TypeEnv -> [TyThing]
typeEnvClasses :: TypeEnv -> [Class]
typeEnvTyCons :: TypeEnv -> [TyCon]
| ITcloseQuote -- |]
| ITidEscape FastString -- $x
| ITparenEscape -- $(
+ | ITreifyType
+ | ITreifyDecl
+ | ITreifyFixity
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
( "dotnet", ITdotnet, bit ffiBit),
+ ( "reifyDecl", ITreifyDecl, bit glaExtsBit),
+ ( "reifyType", ITreifyType, bit glaExtsBit),
+ ( "reifyFixity",ITreifyFixity, bit glaExtsBit),
("_ccall_", ITccall (False, False, PlayRisky),
bit glaExtsBit),
("_ccall_GC_", ITccall (False, False, PlaySafe False),
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.109 2002/10/11 08:48:13 simonpj Exp $
+$Id: Parser.y,v 1.110 2002/10/11 14:46:04 simonpj Exp $
Haskell grammar.
'[t|' { ITopenTypQuote }
'[d|' { ITopenDecQuote }
'|]' { ITcloseQuote }
-ID_SPLICE { ITidEscape $$ } -- $x
-'$(' { ITparenEscape } -- $( exp )
+ID_SPLICE { ITidEscape $$ } -- $x
+'$(' { ITparenEscape } -- $( exp )
+REIFY_TYPE { ITreifyType }
+REIFY_DECL { ITreifyDecl }
+REIFY_FIXITY { ITreifyFixity }
%monad { P } { thenP } { returnP }
%lexer { lexer } { ITeof }
then HsSCC $1 $2
else HsPar $2 }
+ | reifyexp { HsReify $1 }
| fexp { $1 }
scc_annot :: { FastString }
: fexp aexp { (HsApp $1 $2) }
| aexp { $1 }
+reifyexp :: { HsReify RdrName }
+ : REIFY_DECL gtycon { Reify ReifyDecl $2 }
+ | REIFY_DECL qvar { Reify ReifyDecl $2 }
+ | REIFY_TYPE qcname { Reify ReifyType $2 }
+ | REIFY_FIXITY qcname { Reify ReifyFixity $2 }
+
aexps0 :: { [RdrNameHsExpr] }
: aexps { reverse $1 }
returnM (HsBracket body' loc, fvs_e `addOneFV` qTyConName)
-- We use the Q tycon as a proxy to haul in all the smart
-- constructors; see the hack in RnIfaces
-#endif
rnExpr (HsSplice n e loc)
= addSrcLoc loc $
rnExpr e `thenM` \ (e', fvs_e) ->
returnM (HsSplice n' e' loc, fvs_e)
+rnExpr (HsReify (Reify flavour name))
+ = checkGHCI (thErr "reify") `thenM_`
+ lookupGlobalOccRn name `thenM` \ name' ->
+ -- For now, we can only reify top-level things
+ returnM (HsReify (Reify flavour name'), mkFVs [name', qTyConName])
+ -- The qTyCon brutally pulls in all the meta stuff
+#endif
+
rnExpr section@(SectionL expr op)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
rnExpr op `thenM` \ (op', fvs_op) ->
import CmdLineOpts ( DynFlag(..) )
-import HsSyn ( HsDecl(..), IE(..), ieName, ImportDecl(..),
+import HsSyn ( IE(..), ieName, ImportDecl(..),
ForeignDecl(..), HsGroup(..),
collectLocatedHsBinders, tyClDeclNames
)
-import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsDecl )
+import RdrHsSyn ( RdrNameIE, RdrNameImportDecl )
import RnEnv
import TcRnMonad
#ifdef GHCI /* Only if bootstrapped */
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
-import TcEnv ( bracketOK )
+import HsSyn ( HsReify(..), ReifyFlavour(..) )
+import TcEnv ( bracketOK, tcMetaTy )
import TcSimplify ( tcSimplifyBracket )
-import DsMeta ( liftName )
+import qualified DsMeta
#endif
-import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
+import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
mkMonoBind, recBindFields
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
)
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
- tcLookupTyCon, tcLookupDataCon, tcLookupId,
+ tcLookupTyCon, tcLookupDataCon, tcLookupId, tcLookupGlobal,
wellStaged, metaLevel
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts )
readMutVar pending_splices `thenM` \ pendings ->
returnM (HsBracketOut brack pendings)
}
+
+tcMonoExpr (HsReify (Reify flavour name)) res_ty
+ = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $
+ tcLookupGlobal name `thenM` \ thing ->
+ -- For now, we can only reify top-level things
+ -- The complication for non-top-level things is just that
+ -- they might be a TcId, and need zonking etc.
+
+ tcMetaTy tycon_name `thenM` \ reify_ty ->
+ unifyTauTy res_ty reify_ty `thenM_`
+
+ returnM (HsReify (ReifyOut flavour thing))
+ where
+ tycon_name = case flavour of
+ ReifyDecl -> DsMeta.decTyConName
+ ReifyType -> DsMeta.typTyConName
+ ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
#endif GHCI
\end{code}
-- just going to flag an error for now
setLIEVar lie_var (
- newMethodFromName orig id_ty liftName `thenM` \ lift ->
+ newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
-- Put the 'lift' constraint into the right LIE
-- Update the pending splices
zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
returnM (n,e')
+zonkExpr env (HsReify r) = returnM (HsReify r) -- Nothing to zonk; only top
+ -- level things can be reified (for now)
zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen
returnM (HsSplice n e loc)
mkArrowKind, mkAppTy )
import TcBinds ( tcBindsAndThen )
import TcUnify ( unifyPArrTy,subFunTy, unifyListTy, unifyTauTy,
- checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>), unifyTauTyLists )
+ checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import Name ( Name )
import PrelNames ( monadNames, mfixName )
-- friends:
-- (PprType can see all the representations it's trying to print)
import TypeRep ( Type(..), TyNote(..), Kind ) -- friend
-import Type ( SourceType(..) )
+import Type ( SourceType(..), TyThing(..) )
import TcType ( ThetaType, PredType,
tcSplitSigmaTy, isPredTy, isDictTy,
tcSplitTyConApp_maybe, tcSplitFunTy_maybe
instance Outputable name => OutputableBndr (IPName name) where
pprBndr _ n = ppr n -- Simple for now
+
+instance Outputable TyThing where
+ ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
+ ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
+ ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
\end{code}
Type, PredType, ThetaType,
Kind, TyVarSubst,
+ TyThing(..), isTyClThing,
+
superKind, superBoxity, -- KX and BX respectively
liftedBoxity, unliftedBoxity, -- :: BX
openKindCon, -- :: KX
import {-# SOURCE #-} Subst ( substTyWith )
-- friends:
-import Var ( TyVar, tyVarKind, tyVarName, setTyVarName )
+import Var ( Id, TyVar, tyVarKind, tyVarName, setTyVarName )
import VarEnv
import VarSet
import Name ( NamedThing(..), mkInternalName, tidyOccName )
-import Class ( classTyCon )
+import Class ( Class, classTyCon )
import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isNewTyCon, newTyConRep,
%************************************************************************
%* *
+ TyThing
+%* *
+%************************************************************************
+
+\begin{code}
+data TyThing = AnId Id
+ | ATyCon TyCon
+ | AClass Class
+
+isTyClThing :: TyThing -> Bool
+isTyClThing (ATyCon _) = True
+isTyClThing (AClass _) = True
+isTyClThing (AnId _) = False
+
+instance NamedThing TyThing where
+ getName (AnId id) = getName id
+ getName (ATyCon tc) = getName tc
+ getName (AClass cl) = getName cl
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Stuff to do with kinds.}
%* *
%************************************************************************
projects / ghc-hetmet.git / commitdiff