\begin{code}
hashName :: Name -> Int
-hashName name = iBox (getKey (nameUnique name))
+hashName name = getKey (nameUnique name)
\end{code}
unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts,
foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet,
- mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS,
+ mkOccName, mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS,
mkVarOcc, mkVarOccEncoded,
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkGenOcc1, mkGenOcc2, mkLocalOcc, mkDataTOcc, mkDataCOcc,
mkDataConWrapperOcc, mkDataConWorkerOcc,
- isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
+ isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
reportIfUnused,
occNameFS, occNameString, occNameUserString, occNameSpace,
%* *
\subsection{Construction}
%* *
-%************************************************************************
+%*****p*******************************************************************
*Sys* things do no encoding; the caller should ensure that the thing is
already encoded
mkOccFS :: NameSpace -> UserFS -> OccName
mkOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs)
+mkOccName :: NameSpace -> String -> OccName
+mkOccName ns s = mkSysOcc ns (encode s)
+
mkVarOcc :: UserFS -> OccName
mkVarOcc fs = mkSysOccFS varName (encodeFS fs)
\end{code}
\begin{code}
-isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool
+isVarOcc, isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool
+
+isVarOcc (OccName VarName _) = True
+isVarOcc other = False
isTvOcc (OccName TvName _) = True
isTvOcc other = False
= extendOccEnvList env [(nameOccName n, n) | n <- names]
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
-lookupLocalRdrEnv env rdr_name
- | isUnqual rdr_name = lookupOccEnv env (rdrNameOcc rdr_name)
- | otherwise = Nothing
+lookupLocalRdrEnv env (Exact name) = Just name
+lookupLocalRdrEnv env (Unqual occ) = lookupOccEnv env occ
+lookupLocalRdrEnv env other = Nothing
elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
elemLocalRdrEnv rdr_name env
\end{code}
\begin{code}
-uniqFromSupply (MkSplitUniqSupply (I# n) _ _) = mkUniqueGrimily n
-uniqsFromSupply (MkSplitUniqSupply (I# n) _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
+uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n
+uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
\end{code}
%************************************************************************
mkUnique, -- Used in UniqSupply
mkUniqueGrimily, -- Used in UniqSupply only!
- getKey, -- Used in Var, UniqFM, Name only!
+ getKey, getKey#, -- Used in Var, UniqFM, Name only!
+ unpkUnique,
incrUnique, -- Used for renumbering
deriveUnique, -- Ditto
mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
unpkUnique :: Unique -> (Char, Int) -- The reverse
-mkUniqueGrimily :: Int# -> Unique -- A trap-door for UniqSupply
-
-getKey :: Unique -> Int# -- for Var
+mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
+getKey :: Unique -> Int -- for Var
+getKey# :: Unique -> Int# -- for Var
incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique
\begin{code}
-mkUniqueGrimily x = MkUnique x
+mkUniqueGrimily (I# x) = MkUnique x
{-# INLINE getKey #-}
-getKey (MkUnique x) = x
+getKey (MkUnique x) = I# x
+{-# INLINE getKey# #-}
+getKey# (MkUnique x) = x
incrUnique (MkUnique i) = MkUnique (i +# 1#)
x `hasKey` k = getUnique x == k
instance Uniquable FastString where
- getUnique fs = mkUniqueGrimily (uniqueOfFS fs)
+ getUnique fs = mkUniqueGrimily (I# (uniqueOfFS fs))
instance Uniquable Int where
- getUnique (I# i#) = mkUniqueGrimily i#
+ getUnique i = mkUniqueGrimily i
\end{code}
setNameUnique, setNameOcc, nameUnique,
mkSystemTvNameEncoded,
)
-import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
+import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# )
import FastTypes
import Outputable
\begin{code}
varUnique :: Var -> Unique
-varUnique (Var {realUnique = uniq}) = mkUniqueGrimily uniq
+varUnique (Var {realUnique = uniq}) = mkUniqueGrimily (iBox uniq)
setVarUnique :: Var -> Unique -> Var
setVarUnique var@(Var {varName = name}) uniq
- = var {realUnique = getKey uniq,
+ = var {realUnique = getKey# uniq,
varName = setNameUnique name uniq}
setVarName :: Var -> Name -> Var
setVarName var new_name
- = var { realUnique = getKey (getUnique new_name), varName = new_name }
+ = var { realUnique = getKey# (getUnique new_name), varName = new_name }
setVarOcc :: Var -> OccName -> Var
setVarOcc var new_occ
\begin{code}
mkTyVar :: Name -> Kind -> TyVar
mkTyVar name kind = Var { varName = name
- , realUnique = getKey (nameUnique name)
+ , realUnique = getKey# (nameUnique name)
, varType = kind
, varDetails = TyVar
, varInfo = pprPanic "mkTyVar" (ppr name)
mkSysTyVar :: Unique -> Kind -> TyVar
mkSysTyVar uniq kind = Var { varName = name
- , realUnique = getKey uniq
+ , realUnique = getKey# uniq
, varType = kind
, varDetails = TyVar
, varInfo = pprPanic "mkSysTyVar" (ppr name)
mkMutTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar
mkMutTyVar name kind details ref
= Var { varName = name
- , realUnique = getKey (nameUnique name)
+ , realUnique = getKey# (nameUnique name)
, varType = kind
, varDetails = MutTyVar ref details
, varInfo = pprPanic "newMutTyVar" (ppr name)
mkId :: Name -> Type -> VarDetails -> IdInfo -> Id
mkId name ty details info
= Var { varName = name,
- realUnique = getKey (nameUnique name), -- Cache the unique
+ realUnique = getKey# (nameUnique name), -- Cache the unique
varType = ty,
varDetails = details,
varInfo = info }
#ifdef GHCI
-- Template Haskell stuff iff bootstrapped
-import DsMeta ( dsBracket, dsReify )
+import DsMeta ( dsBracket )
#endif
import HsSyn ( HsExpr(..), Pat(..), ArithSeqInfo(..),
#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
warnDepr False _ = returnDs ()
warnDepr True loc = dsWarn (loc, msg)
- where
- msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
+ where
+ msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
\end{code}
-----------------------------------------------------------------------------
-module DsMeta( dsBracket, dsReify,
- templateHaskellNames, qTyConName,
+module DsMeta( dsBracket,
+ templateHaskellNames, qTyConName, nameTyConName,
liftName, expQTyConName, decQTyConName, typeQTyConName,
- decTyConName, typeTyConName ) where
+ decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
+ ) where
#include "HsVersions.h"
import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
import DsMonad
-import qualified Language.Haskell.THSyntax as M
+import qualified Language.Haskell.TH as TH
import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
Match(..), GRHSs(..), GRHS(..), HsBracket(..),
HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
HsBinds(..), MonoBinds(..), HsConDetails(..),
TyClDecl(..), HsGroup(..), HsBang(..),
- HsReify(..), ReifyFlavour(..),
HsType(..), HsContext(..), HsPred(..),
HsTyVarBndr(..), Sig(..), ForeignDecl(..),
InstDecl(..), ConDecl(..), BangType(..),
hsTyVarName, hsConArgs
)
-import PrelNames ( mETA_META_Name, rationalTyConName, integerTyConName, negateName )
-import Name ( Name, nameOccName, nameModule, getSrcLoc )
+import PrelNames ( rationalTyConName, integerTyConName, negateName )
import OccName ( isDataOcc, isTvOcc, occNameUserString )
-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
-- we do this by removing varName from the import of OccName above, making
-- a qualified instance of OccName and using OccNameAlias.varName where varName
-- ws previously used in this file.
-import qualified OccName( varName, tcName )
+import qualified OccName
-import Module ( Module, mkModule, moduleUserString )
+import Module ( Module, mkModule, mkModuleName, moduleUserString )
import Id ( Id, idType, mkLocalId )
-import Name ( mkExternalName )
import OccName ( mkOccFS )
+import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
+ isExternalName, getSrcLoc )
import NameEnv
import NameSet
import Type ( Type, mkGenTyConApp )
import Maybes ( orElse )
import Maybe ( catMaybes, fromMaybe )
import Panic ( panic )
-import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
+import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
import SrcLoc ( SrcLoc )
import Packages ( thPackage )
import Outputable
import FastString ( mkFastString )
+import FastTypes ( iBox )
import Monad ( zipWithM )
import List ( sortBy )
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
--- Returns a CoreExpr of type M.ExpQ
+-- Returns a CoreExpr of type TH.ExpQ
-- The quoted thing is parameterised over Name, even though it has
-- been type checked. We don't want all those type decorations!
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
-dsReify r = panic "dsReify" -- To be re-done
-
--- Returns a CoreExpr of type reifyType --> M.TypeQ
--- reifyDecl --> M.DecQ
--- reifyFixty --> Q M.Fix
-{-
-dsReify (ReifyOut ReifyType name)
- = do { thing <- dsLookupGlobal name ;
- -- By deferring the lookup until now (rather than doing it
- -- in the type checker) we ensure that all zonking has
- -- been done.
- case thing of
- AnId id -> do { MkC e <- repTy (toHsType (idType id)) ;
- return e }
- other -> pprPanic "dsReify: reifyType" (ppr name)
- }
-
-dsReify r@(ReifyOut ReifyDecl name)
- = do { thing <- dsLookupGlobal name ;
- mb_d <- repTyClD (ifaceTyThing True{-omit pragmas-} thing) ;
- case mb_d of
- Just (MkC d) -> return d
- Nothing -> pprPanic "dsReify" (ppr r)
- }
--}
{- -------------- Examples --------------------
[| \x -> x |]
-- Declarations
-------------------------------------------------------
-repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
+repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
repTopDs group
= do { let { bndrs = groupBinders group } ;
- let { ss = mkGenSyms bndrs } ;
+ ss <- mkGenSyms bndrs ;
-- Bind all the names mainly to avoid repeated use of explicit strings.
-- Thus we get
then we must desugar to
foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
-So in repTopDs we bring the binders into scope with mkGenSyms and addBinds,
-but in dsReify we do not. And we use lookupOcc, rather than lookupBinder
+So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
+And we use lookupOcc, rather than lookupBinder
in repTyClD and repC.
-}
-repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.DecQ))
+repTyClD :: TyClDecl Name -> DsM (Maybe (Core TH.DecQ))
repTyClD decl = do x <- repTyClD' decl
return (fmap snd x)
-repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ))
+repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core TH.DecQ))
repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt,
tcdName = tc, tcdTyVars = tvs,
tcdLoc = loc})
= do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
dec <- addTyVarBinds tvs $ \bndrs -> do {
- cxt1 <- repContext cxt ;
+ cxt1 <- repContext cxt ;
cons1 <- mapM repC cons ;
cons2 <- coreList conQTyConName cons1 ;
derivs1 <- repDerivs mb_derivs ;
- repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
return $ Just (loc, dec) }
repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt,
cxt1 <- repContext cxt ;
con1 <- repC con ;
derivs1 <- repDerivs mb_derivs ;
- repNewtype cxt1 tc1 (coreList' stringTy bndrs) con1 derivs1 } ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
return $ Just (loc, dec) }
repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty,
tcdLoc = loc})
= do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
dec <- addTyVarBinds tvs $ \bndrs -> do {
- ty1 <- repTy ty ;
- repTySyn tc1 (coreList' stringTy bndrs) ty1 } ;
+ ty1 <- repTy ty ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repTySyn tc1 bndrs1 ty1 } ;
return (Just (loc, dec)) }
repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls,
sigs1 <- rep_sigs sigs ;
binds1 <- rep_monobind meth_binds ;
decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
- repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repClass cxt1 cls1 bndrs1 decls1 } ;
return $ Just (loc, dec) }
-- Un-handled cases
-- Ignore user pragmas for now
= do { cxt1 <- repContext cxt
; inst_ty1 <- repPred (HsClassP cls tys)
- ; let ss = mkGenSyms (collectMonoBinders binds)
+ ; ss <- mkGenSyms (collectMonoBinders binds)
; binds1 <- addBinds ss (rep_monobind binds)
; decls1 <- coreList decQTyConName binds1
; decls2 <- wrapNongenSyms ss decls1
-- Constructors
-------------------------------------------------------
-repC :: ConDecl Name -> DsM (Core M.ConQ)
+repC :: ConDecl Name -> DsM (Core TH.ConQ)
repC (ConDecl con [] [] details loc)
= do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
repConstr con1 details }
-repBangTy :: BangType Name -> DsM (Core (M.StrictTypeQ))
+repBangTy :: BangType Name -> DsM (Core (TH.StrictTypeQ))
repBangTy (BangType str ty) = do MkC s <- rep2 strName []
MkC t <- repTy ty
rep2 strictTypeName [s, t]
-- Deriving clause
-------------------------------------------------------
-repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
-repDerivs Nothing = return (coreList' stringTy [])
+repDerivs :: Maybe (HsContext Name) -> DsM (Core [TH.Name])
+repDerivs Nothing = coreList nameTyConName []
repDerivs (Just ctxt)
= do { strs <- mapM rep_deriv ctxt ;
- return (coreList' stringTy strs) }
+ coreList nameTyConName strs }
where
- rep_deriv :: HsPred Name -> DsM (Core String)
+ rep_deriv :: HsPred Name -> DsM (Core TH.Name)
-- Deriving clauses must have the simple H98 form
rep_deriv (HsClassP cls []) = lookupOcc cls
rep_deriv other = panic "rep_deriv"
-- Signatures in a class decl, or a group of bindings
-------------------------------------------------------
-rep_sigs :: [Sig Name] -> DsM [Core M.DecQ]
+rep_sigs :: [Sig Name] -> DsM [Core TH.DecQ]
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
return $ de_loc $ sort_by_loc locs_cores
-rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core M.DecQ)]
+rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core TH.DecQ)]
-- We silently ignore ones we don't recognise
rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
return (concat sigs1) }
-rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)]
+rep_sig :: Sig Name -> DsM [(SrcLoc, Core TH.DecQ)]
-- Singleton => Ok
-- Empty => Too hard, signature ignored
rep_sig (Sig nm ty loc) = rep_proto nm ty loc
rep_sig other = return []
-rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)]
+rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core TH.DecQ)]
rep_proto nm ty loc = do { nm1 <- lookupOcc nm ;
ty1 <- repTy ty ;
sig <- repProto nm1 ty1 ;
-- meta environment and gets the *new* names on Core-level as an argument
--
addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
- -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
- -> DsM (Core (M.Q a))
+ -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
+ -> DsM (Core (TH.Q a))
addTyVarBinds tvs m =
do
let names = map hsTyVarName tvs
- let freshNames = mkGenSyms names
+ freshNames <- mkGenSyms names
term <- addBinds freshNames $ do
bndrs <- mapM lookupBinder names
m bndrs
-- represent a type context
--
-repContext :: HsContext Name -> DsM (Core M.CxtQ)
+repContext :: HsContext Name -> DsM (Core TH.CxtQ)
repContext ctxt = do
preds <- mapM repPred ctxt
predList <- coreList typeQTyConName preds
-- represent a type predicate
--
-repPred :: HsPred Name -> DsM (Core M.TypeQ)
+repPred :: HsPred Name -> DsM (Core TH.TypeQ)
repPred (HsClassP cls tys) = do
tcon <- repTy (HsTyVar cls)
tys1 <- repTys tys
-- yield the representation of a list of types
--
-repTys :: [HsType Name] -> DsM [Core M.TypeQ]
+repTys :: [HsType Name] -> DsM [Core TH.TypeQ]
repTys tys = mapM repTy tys
-- represent a type
--
-repTy :: HsType Name -> DsM (Core M.TypeQ)
-repTy (HsForAllTy _ bndrs ctxt ty) =
- addTyVarBinds bndrs $ \bndrs' -> do
- ctxt' <- repContext ctxt
- ty' <- repTy ty
- repTForall (coreList' stringTy bndrs') ctxt' ty'
+repTy :: HsType Name -> DsM (Core TH.TypeQ)
+repTy (HsForAllTy _ tvs ctxt ty) =
+ addTyVarBinds tvs $ \bndrs -> do
+ ctxt1 <- repContext ctxt
+ ty1 <- repTy ty
+ bndrs1 <- coreList nameTyConName bndrs
+ repTForall bndrs1 ctxt1 ty1
repTy (HsTyVar n)
| isTvOcc (nameOccName n) = do
-- Expressions
-----------------------------------------------------------------------------
-repEs :: [HsExpr Name] -> DsM (Core [M.ExpQ])
+repEs :: [HsExpr Name] -> DsM (Core [TH.ExpQ])
repEs es = do { es' <- mapM repE es ;
coreList expQTyConName es' }
-- FIXME: some of these panics should be converted into proper error messages
-- unless we can make sure that constructs, which are plainly not
-- supported in TH already lead to error messages at an earlier stage
-repE :: HsExpr Name -> DsM (Core M.ExpQ)
+repE :: HsExpr Name -> DsM (Core TH.ExpQ)
repE (HsVar x) =
do { mb_val <- dsLookupMetaEnv x
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') }
other -> pprPanic "HsSplice" (ppr n) }
-repE (HsReify _) = panic "DsMeta.repE: Can't represent reification"
repE e =
pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt,
-repMatchTup :: Match Name -> DsM (Core M.MatchQ)
+repMatchTup :: Match Name -> DsM (Core TH.MatchQ)
repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
- do { let ss1 = mkGenSyms (collectPatBinders p)
+ do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repP p
; (ss2,ds) <- repBinds wheres
; match <- repMatch p1 gs ds
; wrapGenSyns (ss1++ss2) match }}}
-repClauseTup :: Match Name -> DsM (Core M.ClauseQ)
+repClauseTup :: Match Name -> DsM (Core TH.ClauseQ)
repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
- do { let ss1 = mkGenSyms (collectPatsBinders ps)
+ do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
ps1 <- repPs ps
; (ss2,ds) <- repBinds wheres
; clause <- repClause ps1 gs ds
; wrapGenSyns (ss1++ss2) clause }}}
-repGuards :: [GRHS Name] -> DsM (Core M.BodyQ)
+repGuards :: [GRHS Name] -> DsM (Core TH.BodyQ)
repGuards [GRHS [ResultStmt e loc] loc2]
= do {a <- repE e; repNormal a }
repGuards other
= do { x <- repE e1; y <- repE e2; return (x, y) }
process other = panic "Non Haskell 98 guarded body"
-repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FieldExp])
+repFields :: [(Name,HsExpr Name)] -> DsM (Core [TH.FieldExp])
repFields flds = do
fnames <- mapM lookupOcc (map fst flds)
es <- mapM repE (map snd flds)
-- The helper function repSts computes the translation of each sub expression
-- and a bunch of prefix bindings denoting the dynamic renaming.
-repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.StmtQ])
+repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
repSts [ResultStmt e loc] =
do { a <- repE e
; e1 <- repNoBindSt a
; return ([], [e1]) }
repSts (BindStmt p e loc : ss) =
do { e2 <- repE e
- ; let ss1 = mkGenSyms (collectPatBinders p)
+ ; ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repP p;
; (ss2,zs) <- repSts ss
-- Bindings
-----------------------------------------------------------
-repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ])
+repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
repBinds decs
= do { let { bndrs = collectHsBinders decs }
-- No need to worrry about detailed scopes within
-- the binding group, because we are talking Names
-- here, so we can safely treat it as a mutually
-- recursive group
- ; let ss = mkGenSyms bndrs
+ ; ss <- mkGenSyms bndrs
; core <- addBinds ss (rep_binds decs)
; core_list <- coreList decQTyConName core
; return (ss, core_list) }
-rep_binds :: HsBinds Name -> DsM [Core M.DecQ]
+rep_binds :: HsBinds Name -> DsM [Core TH.DecQ]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_binds binds = do locs_cores <- rep_binds' binds
return $ de_loc $ sort_by_loc locs_cores
-rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
+rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core TH.DecQ)]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_binds' EmptyBinds = return []
rep_binds' (ThenBinds x y)
rep_binds' (IPBinds _)
= panic "DsMeta:repBinds: can't do implicit parameters"
-rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ]
+rep_monobind :: MonoBinds Name -> DsM [Core TH.DecQ]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_monobind binds = do locs_cores <- rep_monobind' binds
return $ de_loc $ sort_by_loc locs_cores
-rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
+rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core TH.DecQ)]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_monobind' EmptyMonoBinds = return []
rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x;
-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
-- (\ p1 .. pn -> exp) by causing an error.
-repLambda :: Match Name -> DsM (Core M.ExpQ)
+repLambda :: Match Name -> DsM (Core TH.ExpQ)
repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
EmptyBinds _))
= do { let bndrs = collectPatsBinders ps ;
- ; let ss = mkGenSyms bndrs
+ ; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
do { xs <- repPs ps; body <- repE e; repLam xs body })
; wrapGenSyns ss lam }
-- variable should already appear in the environment.
-- Process a list of patterns
-repPs :: [Pat Name] -> DsM (Core [M.Pat])
+repPs :: [Pat Name] -> DsM (Core [TH.Pat])
repPs ps = do { ps' <- mapM repP ps ;
coreList patTyConName ps' }
-repP :: Pat Name -> DsM (Core M.Pat)
+repP :: Pat Name -> DsM (Core TH.Pat)
repP (WildPat _) = repPwild
repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
-- Generate a fresh name for a locally bound entity
-mkGenSym :: Name -> GenSymBind
--- Does not need to be monadic, becuase we can use the
--- existing name. For example:
+mkGenSyms :: [Name] -> DsM [GenSymBind]
+-- We can use the existing name. For example:
-- [| \x_77 -> x_77 + x_77 |]
-- desugars to
-- do { x_77 <- genSym "x"; .... }
-- We use the same x_77 in the desugared program, but with the type Bndr
-- instead of Int
-
-mkGenSym nm = (nm, mkLocalId nm stringTy)
-
--- Ditto for a list of names
--
-mkGenSyms :: [Name] -> [GenSymBind]
-mkGenSyms ns = map mkGenSym ns
+-- We do make it an Internal name, though (hence localiseName)
+--
+-- Nevertheless, it's monadic because we have to generate nameTy
+mkGenSyms ns = do { var_ty <- lookupType nameTyConName
+ ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
+
addBinds :: [GenSymBind] -> DsM a -> DsM a
-- Add a list of fresh names for locally bound entities to the
-- Look up a locally bound name
--
-lookupBinder :: Name -> DsM (Core String)
+lookupBinder :: Name -> DsM (Core TH.Name)
lookupBinder n
= do { mb_val <- dsLookupMetaEnv n;
case mb_val of
-- * If it is a global name, generate the "original name" representation (ie,
-- the <module>:<name> form) for the associated entity
--
-lookupOcc :: Name -> DsM (Core String)
+lookupOcc :: Name -> DsM (Core TH.Name)
-- Lookup an occurrence; it can't be a splice.
-- Use the in-scope bindings if they exist
lookupOcc n
Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
}
-globalVar :: Name -> DsM (Core String)
-globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
- where
- name_mod = moduleUserString (nameModule n)
- name_occ = occNameUserString (nameOccName n)
-
-localVar :: Name -> DsM (Core String)
-localVar n = coreStringLit (occNameUserString (nameOccName n))
-
-lookupType :: Name -- Name of type constructor (e.g. M.ExpQ)
+globalVar :: Name -> DsM (Core TH.Name)
+-- Not bound by the meta-env
+-- Could be top-level; or could be local
+-- f x = $(g [| x |])
+-- Here the x will be local
+globalVar name
+ | isExternalName name
+ = do { MkC mod <- coreStringLit name_mod
+ ; MkC occ <- occNameLit name
+ ; rep2 mk_varg [mod,occ] }
+ | otherwise
+ = do { MkC occ <- occNameLit name
+ ; MkC uni <- coreIntLit (getKey (getUnique name))
+ ; rep2 mkNameUName [occ,uni] }
+ where
+ name_mod = moduleUserString (nameModule name)
+ name_occ = nameOccName name
+ mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
+ | OccName.isVarOcc name_occ = mkNameG_vName
+ | OccName.isTcOcc name_occ = mkNameG_tcName
+ | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
+
+lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
-> DsM Type -- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
return (mkGenTyConApp tc []) }
wrapGenSyns :: [GenSymBind]
- -> Core (M.Q a) -> DsM (Core (M.Q a))
+ -> Core (TH.Q a) -> DsM (Core (TH.Q a))
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y
-- --> bindQ (gensym nm1) (\ id1 ->
-- bindQ (gensym nm2 (\ id2 ->
-- y))
wrapGenSyns binds body@(MkC b)
- = go binds
+ = do { var_ty <- lookupType nameTyConName
+ ; go var_ty binds }
where
[elt_ty] = tcTyConAppArgs (exprType b)
-- b :: Q a, so we can get the type 'a' by looking at the
-- argument type. NB: this relies on Q being a data/newtype,
-- not a type synonym
- go [] = return body
- go ((name,id) : binds)
- = do { MkC body' <- go binds
- ; lit_str <- localVar name
+ go var_ty [] = return body
+ go var_ty ((name,id) : binds)
+ = do { MkC body' <- go var_ty binds
+ ; lit_str <- occNameLit name
; gensym_app <- repGensym lit_str
- ; repBindQ stringTy elt_ty
+ ; repBindQ var_ty elt_ty
gensym_app (MkC (Lam id body')) }
-- Just like wrapGenSym, but don't actually do the gensym
return (MkC (mkLets binds' body)) }
where
do_one (name,id)
- = do { MkC lit_str <- localVar name -- No gensym
- ; return (NonRec id lit_str) }
+ = do { MkC lit_str <- occNameLit name
+ ; MkC var <- rep2 mkNameName [lit_str]
+ ; return (NonRec id var) }
+
+occNameLit :: Name -> DsM (Core String)
+occNameLit n = coreStringLit (occNameUserString (nameOccName n))
void = placeHolderType
-- %*********************************************************************
--------------- Patterns -----------------
-repPlit :: Core M.Lit -> DsM (Core M.Pat)
+repPlit :: Core TH.Lit -> DsM (Core TH.Pat)
repPlit (MkC l) = rep2 litPName [l]
-repPvar :: Core String -> DsM (Core M.Pat)
+repPvar :: Core TH.Name -> DsM (Core TH.Pat)
repPvar (MkC s) = rep2 varPName [s]
-repPtup :: Core [M.Pat] -> DsM (Core M.Pat)
+repPtup :: Core [TH.Pat] -> DsM (Core TH.Pat)
repPtup (MkC ps) = rep2 tupPName [ps]
-repPcon :: Core String -> Core [M.Pat] -> DsM (Core M.Pat)
+repPcon :: Core TH.Name -> Core [TH.Pat] -> DsM (Core TH.Pat)
repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
-repPrec :: Core String -> Core [(String,M.Pat)] -> DsM (Core M.Pat)
+repPrec :: Core TH.Name -> Core [(TH.Name,TH.Pat)] -> DsM (Core TH.Pat)
repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
-repPtilde :: Core M.Pat -> DsM (Core M.Pat)
+repPtilde :: Core TH.Pat -> DsM (Core TH.Pat)
repPtilde (MkC p) = rep2 tildePName [p]
-repPaspat :: Core String -> Core M.Pat -> DsM (Core M.Pat)
+repPaspat :: Core TH.Name -> Core TH.Pat -> DsM (Core TH.Pat)
repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
-repPwild :: DsM (Core M.Pat)
+repPwild :: DsM (Core TH.Pat)
repPwild = rep2 wildPName []
-repPlist :: Core [M.Pat] -> DsM (Core M.Pat)
+repPlist :: Core [TH.Pat] -> DsM (Core TH.Pat)
repPlist (MkC ps) = rep2 listPName [ps]
--------------- Expressions -----------------
-repVarOrCon :: Name -> Core String -> DsM (Core M.ExpQ)
+repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
| otherwise = repVar str
-repVar :: Core String -> DsM (Core M.ExpQ)
+repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
repVar (MkC s) = rep2 varEName [s]
-repCon :: Core String -> DsM (Core M.ExpQ)
+repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
repCon (MkC s) = rep2 conEName [s]
-repLit :: Core M.Lit -> DsM (Core M.ExpQ)
+repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
repLit (MkC c) = rep2 litEName [c]
-repApp :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repApp (MkC x) (MkC y) = rep2 appEName [x,y]
-repLam :: Core [M.Pat] -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repLam :: Core [TH.Pat] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
-repTup :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
+repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repTup (MkC es) = rep2 tupEName [es]
-repCond :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
-repLetE :: Core [M.DecQ] -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
-repCaseE :: Core M.ExpQ -> Core [M.MatchQ] -> DsM( Core M.ExpQ)
+repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
-repDoE :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
+repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
repDoE (MkC ss) = rep2 doEName [ss]
-repComp :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
+repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
repComp (MkC ss) = rep2 compEName [ss]
-repListExp :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
+repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repListExp (MkC es) = rep2 listEName [es]
-repSigExp :: Core M.ExpQ -> Core M.TypeQ -> DsM (Core M.ExpQ)
+repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
-repRecCon :: Core String -> Core [M.FieldExp]-> DsM (Core M.ExpQ)
+repRecCon :: Core TH.Name -> Core [TH.FieldExp]-> DsM (Core TH.ExpQ)
repRecCon (MkC c) (MkC fs) = rep2 recCName [c,fs]
-repRecUpd :: Core M.ExpQ -> Core [M.FieldExp] -> DsM (Core M.ExpQ)
+repRecUpd :: Core TH.ExpQ -> Core [TH.FieldExp] -> DsM (Core TH.ExpQ)
repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
-repInfixApp :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
-repSectionL :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
-repSectionR :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
------------ Right hand sides (guarded expressions) ----
-repGuarded :: Core [(M.ExpQ, M.ExpQ)] -> DsM (Core M.BodyQ)
+repGuarded :: Core [(TH.ExpQ, TH.ExpQ)] -> DsM (Core TH.BodyQ)
repGuarded (MkC pairs) = rep2 guardedBName [pairs]
-repNormal :: Core M.ExpQ -> DsM (Core M.BodyQ)
+repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
repNormal (MkC e) = rep2 normalBName [e]
------------- Stmts -------------------
-repBindSt :: Core M.Pat -> Core M.ExpQ -> DsM (Core M.StmtQ)
+repBindSt :: Core TH.Pat -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
-repLetSt :: Core [M.DecQ] -> DsM (Core M.StmtQ)
+repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
repLetSt (MkC ds) = rep2 letSName [ds]
-repNoBindSt :: Core M.ExpQ -> DsM (Core M.StmtQ)
+repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
repNoBindSt (MkC e) = rep2 noBindSName [e]
-------------- Range (Arithmetic sequences) -----------
-repFrom :: Core M.ExpQ -> DsM (Core M.ExpQ)
+repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
repFrom (MkC x) = rep2 fromEName [x]
-repFromThen :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
-repFromTo :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
-repFromThenTo :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
+repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
------------ Match and Clause Tuples -----------
-repMatch :: Core M.Pat -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.MatchQ)
+repMatch :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
-repClause :: Core [M.Pat] -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.ClauseQ)
+repClause :: Core [TH.Pat] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
-------------- Dec -----------------------------
-repVal :: Core M.Pat -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
+repVal :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
-repFun :: Core String -> Core [M.ClauseQ] -> DsM (Core M.DecQ)
+repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
-repData :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.ConQ] -> Core [String] -> DsM (Core M.DecQ)
+repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
= rep2 dataDName [cxt, nm, tvs, cons, derivs]
-repNewtype :: Core M.CxtQ -> Core String -> Core [String] -> Core M.ConQ -> Core [String] -> DsM (Core M.DecQ)
+repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
= rep2 newtypeDName [cxt, nm, tvs, con, derivs]
-repTySyn :: Core String -> Core [String] -> Core M.TypeQ -> DsM (Core M.DecQ)
+repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
-repInst :: Core M.CxtQ -> Core M.TypeQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
+repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
-repClass :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.DecQ] -> DsM (Core M.DecQ)
+repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
-repProto :: Core String -> Core M.TypeQ -> DsM (Core M.DecQ)
+repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
-repCtxt :: Core [M.TypeQ] -> DsM (Core M.CxtQ)
+repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
repCtxt (MkC tys) = rep2 cxtName [tys]
-repConstr :: Core String -> HsConDetails Name (BangType Name)
- -> DsM (Core M.ConQ)
+repConstr :: Core TH.Name -> HsConDetails Name (BangType Name)
+ -> DsM (Core TH.ConQ)
repConstr con (PrefixCon ps)
= do arg_tys <- mapM repBangTy ps
arg_tys1 <- coreList strictTypeQTyConName arg_tys
------------ Types -------------------
-repTForall :: Core [String] -> Core M.CxtQ -> Core M.TypeQ -> DsM (Core M.TypeQ)
+repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
repTForall (MkC tvars) (MkC ctxt) (MkC ty)
= rep2 forallTName [tvars, ctxt, ty]
-repTvar :: Core String -> DsM (Core M.TypeQ)
+repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
repTvar (MkC s) = rep2 varTName [s]
-repTapp :: Core M.TypeQ -> Core M.TypeQ -> DsM (Core M.TypeQ)
+repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
-repTapps :: Core M.TypeQ -> [Core M.TypeQ] -> DsM (Core M.TypeQ)
+repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
repTapps f [] = return f
repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
--------- Type constructors --------------
-repNamedTyCon :: Core String -> DsM (Core M.TypeQ)
+repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
repNamedTyCon (MkC s) = rep2 conTName [s]
-repTupleTyCon :: Int -> DsM (Core M.TypeQ)
+repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
-- Note: not Core Int; it's easier to be direct here
repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
-repArrowTyCon :: DsM (Core M.TypeQ)
+repArrowTyCon :: DsM (Core TH.TypeQ)
repArrowTyCon = rep2 arrowTName []
-repListTyCon :: DsM (Core M.TypeQ)
+repListTyCon :: DsM (Core TH.TypeQ)
repListTyCon = rep2 listTName []
----------------------------------------------------------
-- Literals
-repLiteral :: HsLit -> DsM (Core M.Lit)
+repLiteral :: HsLit -> DsM (Core TH.Lit)
repLiteral lit
= do lit' <- case lit of
HsIntPrim i -> mk_integer i
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
-repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
+repOverloadedLiteral :: HsOverLit -> DsM (Core TH.Lit)
repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
-- The type Rational will be in the environment, becuase
--------------- Miscellaneous -------------------
-repLift :: Core e -> DsM (Core M.ExpQ)
+repLift :: Core e -> DsM (Core TH.ExpQ)
repLift (MkC x) = rep2 liftName [x]
-repGensym :: Core String -> DsM (Core (M.Q String))
-repGensym (MkC lit_str) = rep2 gensymName [lit_str]
+repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
+repGensym (MkC lit_str) = rep2 newNameName [lit_str]
repBindQ :: Type -> Type -- a and b
- -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
+ -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
repBindQ ty_a ty_b (MkC x) (MkC y)
= rep2 bindQName [Type ty_a, Type ty_b, x, y]
-repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
+repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
repSequenceQ ty_a (MkC list)
= rep2 sequenceQName [Type ty_a, list]
coreStringLit :: String -> DsM (Core String)
coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
-coreVar :: Id -> Core String -- The Id has type String
+coreIntLit :: Int -> DsM (Core Int)
+coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
+
+coreVar :: Id -> Core TH.Name -- The Id has type Name
coreVar id = MkC (Var id)
-- Should stay in sync with the import list of DsMeta
templateHaskellNames = [
- returnQName, bindQName, sequenceQName, gensymName, liftName,
+ returnQName, bindQName, sequenceQName, newNameName, liftName,
+ mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameUName,
+
-- Lit
charLName, stringLName, integerLName, intPrimLName,
floatPrimLName, doublePrimLName, rationalLName,
tupleTName, arrowTName, listTName,
-- And the tycons
- qTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
+ qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
decQTyConName, conQTyConName, strictTypeQTyConName,
varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, matchTyConName, clauseTyConName]
-varQual = mk_known_key_name OccName.varName
-tcQual = mk_known_key_name OccName.tcName
+tH_SYN_Name = mkModuleName "Language.Haskell.TH.THSyntax"
+tH_LIB_Name = mkModuleName "Language.Haskell.TH.THLib"
-thModule :: Module
+thSyn :: Module
-- NB: the THSyntax module comes from the "haskell-src" package
-thModule = mkModule thPackage mETA_META_Name
+thSyn = mkModule thPackage tH_SYN_Name
+thLib = mkModule thPackage tH_LIB_Name
-mk_known_key_name space str uniq
- = mkExternalName uniq thModule (mkOccFS space str)
+mk_known_key_name mod space str uniq
+ = mkExternalName uniq mod (mkOccFS space str)
Nothing noSrcLoc
-returnQName = varQual FSLIT("returnQ") returnQIdKey
-bindQName = varQual FSLIT("bindQ") bindQIdKey
-sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey
-gensymName = varQual FSLIT("gensym") gensymIdKey
-liftName = varQual FSLIT("lift") liftIdKey
-
+libFun = mk_known_key_name thLib OccName.varName
+libTc = mk_known_key_name thLib OccName.tcName
+thFun = mk_known_key_name thSyn OccName.varName
+thTc = mk_known_key_name thSyn OccName.tcName
+
+-------------------- THSyntax -----------------------
+qTyConName = thTc FSLIT("Q") qTyConKey
+nameTyConName = thTc FSLIT("Name") nameTyConKey
+fieldExpTyConName = thTc FSLIT("FieldExp") fieldExpTyConKey
+patTyConName = thTc FSLIT("Pat") patTyConKey
+fieldPatTyConName = thTc FSLIT("FieldPat") fieldPatTyConKey
+expTyConName = thTc FSLIT("Exp") expTyConKey
+decTyConName = thTc FSLIT("Dec") decTyConKey
+typeTyConName = thTc FSLIT("Type") typeTyConKey
+matchTyConName = thTc FSLIT("Match") matchTyConKey
+clauseTyConName = thTc FSLIT("Clause") clauseTyConKey
+
+returnQName = thFun FSLIT("returnQ") returnQIdKey
+bindQName = thFun FSLIT("bindQ") bindQIdKey
+sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
+newNameName = thFun FSLIT("newName") newNameIdKey
+liftName = thFun FSLIT("lift") liftIdKey
+mkNameName = thFun FSLIT("mkName") mkNameIdKey
+mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey
+mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey
+mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
+mkNameUName = thFun FSLIT("mkNameU") mkNameUIdKey
+
+
+-------------------- THLib -----------------------
-- data Lit = ...
-charLName = varQual FSLIT("charL") charLIdKey
-stringLName = varQual FSLIT("stringL") stringLIdKey
-integerLName = varQual FSLIT("integerL") integerLIdKey
-intPrimLName = varQual FSLIT("intPrimL") intPrimLIdKey
-floatPrimLName = varQual FSLIT("floatPrimL") floatPrimLIdKey
-doublePrimLName = varQual FSLIT("doublePrimL") doublePrimLIdKey
-rationalLName = varQual FSLIT("rationalL") rationalLIdKey
+charLName = libFun FSLIT("charL") charLIdKey
+stringLName = libFun FSLIT("stringL") stringLIdKey
+integerLName = libFun FSLIT("integerL") integerLIdKey
+intPrimLName = libFun FSLIT("intPrimL") intPrimLIdKey
+floatPrimLName = libFun FSLIT("floatPrimL") floatPrimLIdKey
+doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
+rationalLName = libFun FSLIT("rationalL") rationalLIdKey
-- data Pat = ...
-litPName = varQual FSLIT("litP") litPIdKey
-varPName = varQual FSLIT("varP") varPIdKey
-tupPName = varQual FSLIT("tupP") tupPIdKey
-conPName = varQual FSLIT("conP") conPIdKey
-tildePName = varQual FSLIT("tildeP") tildePIdKey
-asPName = varQual FSLIT("asP") asPIdKey
-wildPName = varQual FSLIT("wildP") wildPIdKey
-recPName = varQual FSLIT("recP") recPIdKey
-listPName = varQual FSLIT("listP") listPIdKey
+litPName = libFun FSLIT("litP") litPIdKey
+varPName = libFun FSLIT("varP") varPIdKey
+tupPName = libFun FSLIT("tupP") tupPIdKey
+conPName = libFun FSLIT("conP") conPIdKey
+tildePName = libFun FSLIT("tildeP") tildePIdKey
+asPName = libFun FSLIT("asP") asPIdKey
+wildPName = libFun FSLIT("wildP") wildPIdKey
+recPName = libFun FSLIT("recP") recPIdKey
+listPName = libFun FSLIT("listP") listPIdKey
-- type FieldPat = ...
-fieldPatName = varQual FSLIT("fieldPat") fieldPatIdKey
+fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
-- data Match = ...
-matchName = varQual FSLIT("match") matchIdKey
+matchName = libFun FSLIT("match") matchIdKey
-- data Clause = ...
-clauseName = varQual FSLIT("clause") clauseIdKey
+clauseName = libFun FSLIT("clause") clauseIdKey
-- data Exp = ...
-varEName = varQual FSLIT("varE") varEIdKey
-conEName = varQual FSLIT("conE") conEIdKey
-litEName = varQual FSLIT("litE") litEIdKey
-appEName = varQual FSLIT("appE") appEIdKey
-infixEName = varQual FSLIT("infixE") infixEIdKey
-infixAppName = varQual FSLIT("infixApp") infixAppIdKey
-sectionLName = varQual FSLIT("sectionL") sectionLIdKey
-sectionRName = varQual FSLIT("sectionR") sectionRIdKey
-lamEName = varQual FSLIT("lamE") lamEIdKey
-tupEName = varQual FSLIT("tupE") tupEIdKey
-condEName = varQual FSLIT("condE") condEIdKey
-letEName = varQual FSLIT("letE") letEIdKey
-caseEName = varQual FSLIT("caseE") caseEIdKey
-doEName = varQual FSLIT("doE") doEIdKey
-compEName = varQual FSLIT("compE") compEIdKey
+varEName = libFun FSLIT("varE") varEIdKey
+conEName = libFun FSLIT("conE") conEIdKey
+litEName = libFun FSLIT("litE") litEIdKey
+appEName = libFun FSLIT("appE") appEIdKey
+infixEName = libFun FSLIT("infixE") infixEIdKey
+infixAppName = libFun FSLIT("infixApp") infixAppIdKey
+sectionLName = libFun FSLIT("sectionL") sectionLIdKey
+sectionRName = libFun FSLIT("sectionR") sectionRIdKey
+lamEName = libFun FSLIT("lamE") lamEIdKey
+tupEName = libFun FSLIT("tupE") tupEIdKey
+condEName = libFun FSLIT("condE") condEIdKey
+letEName = libFun FSLIT("letE") letEIdKey
+caseEName = libFun FSLIT("caseE") caseEIdKey
+doEName = libFun FSLIT("doE") doEIdKey
+compEName = libFun FSLIT("compE") compEIdKey
-- ArithSeq skips a level
-fromEName = varQual FSLIT("fromE") fromEIdKey
-fromThenEName = varQual FSLIT("fromThenE") fromThenEIdKey
-fromToEName = varQual FSLIT("fromToE") fromToEIdKey
-fromThenToEName = varQual FSLIT("fromThenToE") fromThenToEIdKey
+fromEName = libFun FSLIT("fromE") fromEIdKey
+fromThenEName = libFun FSLIT("fromThenE") fromThenEIdKey
+fromToEName = libFun FSLIT("fromToE") fromToEIdKey
+fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
-- end ArithSeq
-listEName = varQual FSLIT("listE") listEIdKey
-sigEName = varQual FSLIT("sigE") sigEIdKey
-recConEName = varQual FSLIT("recConE") recConEIdKey
-recUpdEName = varQual FSLIT("recUpdE") recUpdEIdKey
+listEName = libFun FSLIT("listE") listEIdKey
+sigEName = libFun FSLIT("sigE") sigEIdKey
+recConEName = libFun FSLIT("recConE") recConEIdKey
+recUpdEName = libFun FSLIT("recUpdE") recUpdEIdKey
-- type FieldExp = ...
-fieldExpName = varQual FSLIT("fieldExp") fieldExpIdKey
+fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
-- data Body = ...
-guardedBName = varQual FSLIT("guardedB") guardedBIdKey
-normalBName = varQual FSLIT("normalB") normalBIdKey
+guardedBName = libFun FSLIT("guardedB") guardedBIdKey
+normalBName = libFun FSLIT("normalB") normalBIdKey
-- data Stmt = ...
-bindSName = varQual FSLIT("bindS") bindSIdKey
-letSName = varQual FSLIT("letS") letSIdKey
-noBindSName = varQual FSLIT("noBindS") noBindSIdKey
-parSName = varQual FSLIT("parS") parSIdKey
+bindSName = libFun FSLIT("bindS") bindSIdKey
+letSName = libFun FSLIT("letS") letSIdKey
+noBindSName = libFun FSLIT("noBindS") noBindSIdKey
+parSName = libFun FSLIT("parS") parSIdKey
-- data Dec = ...
-funDName = varQual FSLIT("funD") funDIdKey
-valDName = varQual FSLIT("valD") valDIdKey
-dataDName = varQual FSLIT("dataD") dataDIdKey
-newtypeDName = varQual FSLIT("newtypeD") newtypeDIdKey
-tySynDName = varQual FSLIT("tySynD") tySynDIdKey
-classDName = varQual FSLIT("classD") classDIdKey
-instanceDName = varQual FSLIT("instanceD") instanceDIdKey
-sigDName = varQual FSLIT("sigD") sigDIdKey
+funDName = libFun FSLIT("funD") funDIdKey
+valDName = libFun FSLIT("valD") valDIdKey
+dataDName = libFun FSLIT("dataD") dataDIdKey
+newtypeDName = libFun FSLIT("newtypeD") newtypeDIdKey
+tySynDName = libFun FSLIT("tySynD") tySynDIdKey
+classDName = libFun FSLIT("classD") classDIdKey
+instanceDName = libFun FSLIT("instanceD") instanceDIdKey
+sigDName = libFun FSLIT("sigD") sigDIdKey
-- type Ctxt = ...
-cxtName = varQual FSLIT("cxt") cxtIdKey
+cxtName = libFun FSLIT("cxt") cxtIdKey
-- data Strict = ...
-isStrictName = varQual FSLIT("isStrict") isStrictKey
-notStrictName = varQual FSLIT("notStrict") notStrictKey
+isStrictName = libFun FSLIT("isStrict") isStrictKey
+notStrictName = libFun FSLIT("notStrict") notStrictKey
-- data Con = ...
-normalCName = varQual FSLIT("normalC") normalCIdKey
-recCName = varQual FSLIT("recC") recCIdKey
-infixCName = varQual FSLIT("infixC") infixCIdKey
+normalCName = libFun FSLIT("normalC") normalCIdKey
+recCName = libFun FSLIT("recC") recCIdKey
+infixCName = libFun FSLIT("infixC") infixCIdKey
-- type StrictType = ...
-strictTypeName = varQual FSLIT("strictType") strictTKey
+strictTypeName = libFun FSLIT("strictType") strictTKey
-- type VarStrictType = ...
-varStrictTypeName = varQual FSLIT("varStrictType") varStrictTKey
+varStrictTypeName = libFun FSLIT("varStrictType") varStrictTKey
-- data Type = ...
-forallTName = varQual FSLIT("forallT") forallTIdKey
-varTName = varQual FSLIT("varT") varTIdKey
-conTName = varQual FSLIT("conT") conTIdKey
-tupleTName = varQual FSLIT("tupleT") tupleTIdKey
-arrowTName = varQual FSLIT("arrowT") arrowTIdKey
-listTName = varQual FSLIT("listT") listTIdKey
-appTName = varQual FSLIT("appT") appTIdKey
+forallTName = libFun FSLIT("forallT") forallTIdKey
+varTName = libFun FSLIT("varT") varTIdKey
+conTName = libFun FSLIT("conT") conTIdKey
+tupleTName = libFun FSLIT("tupleT") tupleTIdKey
+arrowTName = libFun FSLIT("arrowT") arrowTIdKey
+listTName = libFun FSLIT("listT") listTIdKey
+appTName = libFun FSLIT("appT") appTIdKey
-qTyConName = tcQual FSLIT("Q") qTyConKey
-patTyConName = tcQual FSLIT("Pat") patTyConKey
-fieldPatTyConName = tcQual FSLIT("FieldPat") fieldPatTyConKey
-matchQTyConName = tcQual FSLIT("MatchQ") matchQTyConKey
-clauseQTyConName = tcQual FSLIT("ClauseQ") clauseQTyConKey
-expQTyConName = tcQual FSLIT("ExpQ") expQTyConKey
-fieldExpTyConName = tcQual FSLIT("FieldExp") fieldExpTyConKey
-stmtQTyConName = tcQual FSLIT("StmtQ") stmtQTyConKey
-decQTyConName = tcQual FSLIT("DecQ") decQTyConKey
-conQTyConName = tcQual FSLIT("ConQ") conQTyConKey
-strictTypeQTyConName = tcQual FSLIT("StrictTypeQ") strictTypeQTyConKey
-varStrictTypeQTyConName = tcQual FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
-typeQTyConName = tcQual FSLIT("TypeQ") typeQTyConKey
-
-expTyConName = tcQual FSLIT("Exp") expTyConKey
-decTyConName = tcQual FSLIT("Dec") decTyConKey
-typeTyConName = tcQual FSLIT("Type") typeTyConKey
-matchTyConName = tcQual FSLIT("Match") matchTyConKey
-clauseTyConName = tcQual FSLIT("Clause") clauseTyConKey
+matchQTyConName = libTc FSLIT("MatchQ") matchQTyConKey
+clauseQTyConName = libTc FSLIT("ClauseQ") clauseQTyConKey
+expQTyConName = libTc FSLIT("ExpQ") expQTyConKey
+stmtQTyConName = libTc FSLIT("StmtQ") stmtQTyConKey
+decQTyConName = libTc FSLIT("DecQ") decQTyConKey
+conQTyConName = libTc FSLIT("ConQ") conQTyConKey
+strictTypeQTyConName = libTc FSLIT("StrictTypeQ") strictTypeQTyConKey
+varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
+typeQTyConName = libTc FSLIT("TypeQ") typeQTyConKey
-- TyConUniques available: 100-119
-- Check in PrelNames if you want to change this
strictTypeQTyConKey = mkPreludeTyConUnique 115
fieldExpTyConKey = mkPreludeTyConUnique 116
fieldPatTyConKey = mkPreludeTyConUnique 117
+nameTyConKey = mkPreludeTyConUnique 118
-- IdUniques available: 200-299
-- If you want to change this, make sure you check in PrelNames
returnQIdKey = mkPreludeMiscIdUnique 200
bindQIdKey = mkPreludeMiscIdUnique 201
sequenceQIdKey = mkPreludeMiscIdUnique 202
-gensymIdKey = mkPreludeMiscIdUnique 203
-liftIdKey = mkPreludeMiscIdUnique 204
+liftIdKey = mkPreludeMiscIdUnique 203
+newNameIdKey = mkPreludeMiscIdUnique 204
+mkNameIdKey = mkPreludeMiscIdUnique 205
+mkNameG_vIdKey = mkPreludeMiscIdUnique 206
+mkNameG_dIdKey = mkPreludeMiscIdUnique 207
+mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
+mkNameUIdKey = mkPreludeMiscIdUnique 209
+
-- data Lit = ...
charLIdKey = mkPreludeMiscIdUnique 210
data DsMetaVal
= Bound Id -- Bound by a pattern inside the [| |].
-- Will be dynamically alpha renamed.
- -- The Id has type String
+ -- The Id has type THSyntax.Var
| Splice TypecheckedHsExpr -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
dsWarn :: DsWarning -> DsM ()
-dsWarn warn = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` warn) }
+dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
+ where
+ msg = ptext SLIT("Warning:") <+> warn
\end{code}
\begin{code}
#include "HsVersions.h"
-import Language.Haskell.THSyntax as Meta
+import Language.Haskell.TH.THSyntax as TH
+import Language.Haskell.TH.THLib as TH -- Pretty printing
import HsSyn as Hs
( HsExpr(..), HsLit(..), ArithSeqInfo(..),
mkSimpleMatch, mkImplicitHsForAllTy, mkExplicitHsForAllTy
)
-import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig )
-import Module ( mkModuleName )
+import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName )
+import Module ( ModuleName, mkModuleName )
import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
-import OccName
+import Name ( mkInternalName )
+import qualified OccName
import SrcLoc ( SrcLoc, generatedSrcLoc )
import Type ( Type )
+import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon, falseDataCon )
import BasicTypes( Boxity(..), RecFlag(Recursive), NewOrData(..) )
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
CExportSpec(..))
import FastString( FastString, mkFastString, nilFS )
import Char ( ord, isAscii, isAlphaNum, isAlpha )
import List ( partition )
+import SrcLoc ( noSrcLoc )
+import Unique ( Unique, mkUniqueGrimily )
import ErrUtils (Message)
+import GLAEXTS ( Int#, Int(..) )
import Outputable
-------------------------------------------------------------------
-convertToHsDecls :: [Meta.Dec] -> [Either (HsDecl RdrName) Message]
+convertToHsDecls :: [TH.Dec] -> [Either (HsDecl RdrName) Message]
convertToHsDecls ds = map cvt_top ds
mk_con con = case con of
mk_derivs [] = Nothing
mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]
-cvt_top :: Meta.Dec -> Either (HsDecl RdrName) Message
-cvt_top d@(Meta.ValD _ _ _) = Left $ Hs.ValD (cvtd d)
-cvt_top d@(Meta.FunD _ _) = Left $ Hs.ValD (cvtd d)
+cvt_top :: TH.Dec -> Either (HsDecl RdrName) Message
+cvt_top d@(TH.ValD _ _ _) = Left $ Hs.ValD (cvtd d)
+cvt_top d@(TH.FunD _ _) = Left $ Hs.ValD (cvtd d)
cvt_top (TySynD tc tvs rhs)
= Left $ TyClD (TySynonym (tconName tc) (cvt_tvs tvs) (cvtType rhs) loc0)
(binds, sigs) = cvtBindsAndSigs decs
inst_ty = mkImplicitHsForAllTy (cvt_context tys) (HsPredTy (cvt_pred ty))
-cvt_top (Meta.SigD nm typ) = Left $ Hs.SigD (Sig (vName nm) (cvtType typ) loc0)
+cvt_top (TH.SigD nm typ) = Left $ Hs.SigD (Sig (vName nm) (cvtType typ) loc0)
cvt_top (ForeignD (ImportF callconv safety from nm typ))
= case parsed of
Unsafe -> PlayRisky
Safe -> PlaySafe False
Threadsafe -> PlaySafe True
- parsed = parse_ccall_impent nm from
+ parsed = parse_ccall_impent (TH.nameBase nm) from
cvt_top (ForeignD (ExportF callconv as nm typ))
= let e = CExport (CExportStatic (mkFastString as) callconv')
noFunDeps = []
-------------------------------------------------------------------
-convertToHsExpr :: Meta.Exp -> HsExpr RdrName
+convertToHsExpr :: TH.Exp -> HsExpr RdrName
convertToHsExpr = cvt
cvt (VarE s) = HsVar (vName s)
cvt (RecConE c flds) = RecordCon (cName c) (map (\(x,y) -> (vName x, cvt y)) flds)
cvt (RecUpdE e flds) = RecordUpd (cvt e) (map (\(x,y) -> (vName x, cvt y)) flds)
-cvtdecs :: [Meta.Dec] -> HsBinds RdrName
+cvtdecs :: [TH.Dec] -> HsBinds RdrName
cvtdecs [] = EmptyBinds
cvtdecs ds = MonoBind binds sigs Recursive
where
where
(sigs, non_sigs) = partition sigP ds
-cvtSig (Meta.SigD nm typ) = Hs.Sig (vName nm) (cvtType typ) loc0
+cvtSig (TH.SigD nm typ) = Hs.Sig (vName nm) (cvtType typ) loc0
-cvtds :: [Meta.Dec] -> MonoBinds RdrName
+cvtds :: [TH.Dec] -> MonoBinds RdrName
cvtds [] = EmptyMonoBinds
cvtds (d:ds) = AndMonoBinds (cvtd d) (cvtds ds)
-cvtd :: Meta.Dec -> MonoBinds RdrName
+cvtd :: TH.Dec -> MonoBinds RdrName
-- Used only for declarations in a 'let/where' clause,
-- not for top level decls
-cvtd (Meta.ValD (Meta.VarP s) body ds) = FunMonoBind (vName s) False
+cvtd (TH.ValD (TH.VarP s) body ds) = FunMonoBind (vName s) False
[cvtclause (Clause [] body ds)] loc0
cvtd (FunD nm cls) = FunMonoBind (vName nm) False (map cvtclause cls) loc0
-cvtd (Meta.ValD p body ds) = PatMonoBind (cvtp p) (GRHSs (cvtguard body)
+cvtd (TH.ValD p body ds) = PatMonoBind (cvtp p) (GRHSs (cvtguard body)
(cvtdecs ds)
void) loc0
cvtd d = cvtPanic "Illegal kind of declaration in where clause"
- (text (show (Meta.pprDec d)))
+ (text (show (TH.pprDec d)))
-cvtclause :: Meta.Clause -> Hs.Match RdrName
+cvtclause :: TH.Clause -> Hs.Match RdrName
cvtclause (Clause ps body wheres)
= Hs.Match (map cvtp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
cvtdd (FromThenToR x y z) = (FromThenTo (cvt x) (cvt y) (cvt z))
-cvtstmts :: [Meta.Stmt] -> [Hs.Stmt RdrName]
+cvtstmts :: [TH.Stmt] -> [Hs.Stmt RdrName]
cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
cvtstmts [NoBindS e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt
cvtstmts (NoBindS e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss
-cvtstmts (Meta.BindS p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss
-cvtstmts (Meta.LetS ds : ss) = LetStmt (cvtdecs ds) : cvtstmts ss
-cvtstmts (Meta.ParS dss : ss) = ParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss
+cvtstmts (TH.BindS p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss
+cvtstmts (TH.LetS ds : ss) = LetStmt (cvtdecs ds) : cvtstmts ss
+cvtstmts (TH.ParS dss : ss) = ParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss
-cvtm :: Meta.Match -> Hs.Match RdrName
-cvtm (Meta.Match p body wheres)
+cvtm :: TH.Match -> Hs.Match RdrName
+cvtm (TH.Match p body wheres)
= Hs.Match [cvtp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
-cvtguard :: Meta.Body -> [GRHS RdrName]
+cvtguard :: TH.Body -> [GRHS RdrName]
cvtguard (GuardedB pairs) = map cvtpair pairs
cvtguard (NormalB e) = [GRHS [ ResultStmt (cvt e) loc0 ] loc0]
-cvtpair :: (Meta.Exp,Meta.Exp) -> GRHS RdrName
+cvtpair :: (TH.Exp,TH.Exp) -> GRHS RdrName
cvtpair (x,y) = GRHS [Hs.BindStmt truePat (cvt x) loc0,
ResultStmt (cvt y) loc0] loc0
cvtLit (CharL c) = HsChar (ord c)
cvtLit (StringL s) = HsString (mkFastString s)
-cvtp :: Meta.Pat -> Hs.Pat RdrName
-cvtp (Meta.LitP l)
+cvtp :: TH.Pat -> Hs.Pat RdrName
+cvtp (TH.LitP l)
| overloadedLit l = NPatIn (cvtOverLit l) Nothing -- Not right for negative
-- patterns; need to think
-- about that!
| otherwise = Hs.LitPat (cvtLit l)
-cvtp (Meta.VarP s) = Hs.VarPat(vName s)
+cvtp (TH.VarP s) = Hs.VarPat(vName s)
cvtp (TupP [p]) = cvtp p
cvtp (TupP ps) = TuplePat (map cvtp ps) Boxed
cvtp (ConP s ps) = ConPatIn (cName s) (PrefixCon (map cvtp ps))
cvtp (TildeP p) = LazyPat (cvtp p)
-cvtp (Meta.AsP s p) = AsPat (vName s) (cvtp p)
-cvtp Meta.WildP = WildPat void
+cvtp (TH.AsP s p) = AsPat (vName s) (cvtp p)
+cvtp TH.WildP = WildPat void
cvtp (RecP c fs) = ConPatIn (cName c) $ Hs.RecCon (map (\(s,p) -> (vName s,cvtp p)) fs)
cvtp (ListP ps) = ListPat (map cvtp ps) void
-----------------------------------------------------------
-- Types and type variables
-cvt_tvs :: [String] -> [HsTyVarBndr RdrName]
+cvt_tvs :: [TH.Name] -> [HsTyVarBndr RdrName]
cvt_tvs tvs = map (UserTyVar . tName) tvs
cvt_context :: Cxt -> HsContext RdrName
cvt_context tys = map cvt_pred tys
-cvt_pred :: Meta.Type -> HsPred RdrName
+cvt_pred :: TH.Type -> HsPred RdrName
cvt_pred ty = case split_ty_app ty of
(ConT tc, tys) -> HsClassP (tconName tc) (map cvtType tys)
(VarT tv, tys) -> HsClassP (tName tv) (map cvtType tys)
- other -> cvtPanic "Malformed predicate" (text (show (Meta.pprType ty)))
+ other -> cvtPanic "Malformed predicate" (text (show (TH.pprType ty)))
-cvtType :: Meta.Type -> HsType RdrName
+cvtType :: TH.Type -> HsType RdrName
cvtType ty = trans (root ty [])
where root (AppT a b) zs = root a (cvtType b : zs)
root t zs = (t,zs)
trans (TupleT n,args)
| length args == n = HsTupleTy Boxed args
- | n == 0 = foldl HsAppTy (HsTyVar (tconName "()")) args
- | otherwise = foldl HsAppTy (HsTyVar (tconName ("(" ++ replicate (n-1) ',' ++ ")"))) args
+ | n == 0 = foldl HsAppTy (HsTyVar (getRdrName unitTyCon)) args
+ | otherwise = foldl HsAppTy (HsTyVar (getRdrName (tupleTyCon Boxed n))) args
trans (ArrowT, [x,y]) = HsFunTy x y
trans (ListT, [x]) = HsListTy x
trans (ForallT tvs cxt ty, []) = mkExplicitHsForAllTy
(cvt_tvs tvs) (cvt_context cxt) (cvtType ty)
-split_ty_app :: Meta.Type -> (Meta.Type, [Meta.Type])
+split_ty_app :: TH.Type -> (TH.Type, [TH.Type])
split_ty_app ty = go ty []
where
go (AppT f a) as = go f (a:as)
-----------------------------------------------------------
sigP :: Dec -> Bool
-sigP (Meta.SigD _ _) = True
+sigP (TH.SigD _ _) = True
sigP other = False
-----------------------------------------------------------
-- some useful things
-truePat = ConPatIn (cName "True") (PrefixCon [])
-falsePat = ConPatIn (cName "False") (PrefixCon [])
+truePat = ConPatIn (getRdrName trueDataCon) (PrefixCon [])
+falsePat = ConPatIn (getRdrName falseDataCon) (PrefixCon [])
overloadedLit :: Lit -> Bool
-- True for literals that Haskell treats as overloaded
loc0 :: SrcLoc
loc0 = generatedSrcLoc
+--------------------------------------------------------------------
+-- Turning Name back into RdrName
+--------------------------------------------------------------------
+
-- variable names
-vName :: String -> RdrName
-vName = mkName varName
+vName :: TH.Name -> RdrName
+vName = mk_name OccName.varName
-- Constructor function names; this is Haskell source, hence srcDataName
-cName :: String -> RdrName
-cName = mkName srcDataName
+cName :: TH.Name -> RdrName
+cName = mk_name OccName.srcDataName
-- Type variable names
-tName :: String -> RdrName
-tName = mkName tvName
+tName :: TH.Name -> RdrName
+tName = mk_name OccName.tvName
-- Type Constructor names
-tconName = mkName tcName
+tconName = mk_name OccName.tcName
-mkName :: NameSpace -> String -> RdrName
--- Parse the string to see if it has a "." or ":" in it
--- so we know whether to generate a qualified or original name
--- It's a bit tricky because we need to parse
--- Foo.Baz.x as Qual Foo.Baz x
--- So we parse it from back to front
+mk_name :: OccName.NameSpace -> TH.Name -> RdrName
-mkName ns str
- = split [] (reverse str)
- where
- split occ [] = mkRdrUnqual (mk_occ occ)
- split occ (c:d:rev) -- 'd' is the last char before the separator
- | is_sep c -- E.g. Fo.x d='o'
- && isAlphaNum d -- Fo.+: d='+' perhaps
- = mk_qual (reverse (d:rev)) c occ
- split occ (c:rev) = split (c:occ) rev
-
- mk_qual mod '.' occ = mkRdrQual (mk_mod mod) (mk_occ occ)
- mk_qual mod ':' occ = mkOrig (mk_mod mod) (mk_occ occ)
-
- mk_occ occ = mkOccFS ns (mkFastString occ)
- mk_mod mod = mkModuleName mod
-
- is_sep '.' = True
- is_sep ':' = True
- is_sep other = False
+-- This turns a Name into a RdrName
+-- The last case is slightly interesting. It constructs a
+-- unique name from the unique in the TH thingy, so that the renamer
+-- won't mess about. I hope. (Another possiblity would be to generate
+-- "x_77" etc, but that could conceivably clash.)
+
+mk_name ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
+mk_name ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ns occ)
+mk_name ns (TH.Name occ (TH.NameU uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc)
+
+mk_uniq :: Int# -> Unique
+mk_uniq u = mkUniqueGrimily (I# u)
+
+-- The packing and unpacking is rather turgid :-(
+mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
+mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
+
+mk_mod :: TH.ModName -> ModuleName
+mk_mod mod = mkModuleName (TH.modString mod)
\end{code}
-- The id is just a unique name to
-- identify this splice point
- | HsReify (HsReify id) -- reifyType t, reifyDecl i, reifyFixity
-
-----------------------------------------------------------
-- Arrow notation extension
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
ppr_expr (HsProc pat (HsCmdTop cmd _ _ _) _)
= hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), pprExpr cmd]
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
pp_body <+> ptext SLIT("|]")
-
-data HsReify id = Reify ReifyFlavour id -- Pre typechecking
- | ReifyOut ReifyFlavour Name -- Post typechecking
- -- The Name could be the name of
- -- an Id, TyCon, or Class
-
-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}
%************************************************************************
lookupIfaceByModName, emptyPackageIfaceTable,
IsBootInterface, mkIfaceFixCache,
Pool(..), DeclPool, InstPool,
- RulePool, Gated, addRuleToPool, RulePoolContents
+ RulePool, addRuleToPool, RulePoolContents
)
import BasicTypes ( Version, Fixity(..), FixityDirection(..) )
Messages, errorsFound, emptyMessages,
addShortErrLocLine, addShortWarnLocLine,
- addErrLocHdrLine, addWarnLocHdrLine,
+ addErrLocHdrLine,
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
-- Be refined about qualification, return an ErrMsg
addErrLocHdrLine :: SrcLoc -> Message -> Message -> Message
-addWarnLocHdrLine :: SrcLoc -> Message -> Message -> Message
-- Used by Lint and other system stuff
-- Always print qualified, return a Message
addErrLocHdrLine locn hdr msg
= mkErrDoc locn (hdr $$ msg)
-addWarnLocHdrLine locn hdr msg
- = mkWarnDoc locn (hdr $$ msg)
-
mkErrDoc locn msg
| isGoodSrcLoc locn = hang (ppr locn <> colon) 4 msg
| otherwise = msg
-mkWarnDoc locn msg
- | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 warn_msg
- | otherwise = warn_msg
- where
- warn_msg = ptext SLIT("Warning:") <+> msg
+mkWarnDoc locn msg = mkErrDoc locn msg
\end{code}
\begin{code}
| ITcloseQuote -- |]
| ITidEscape FastString -- $x
| ITparenEscape -- $(
- | ITreifyType
- | ITreifyDecl
- | ITreifyFixity
+ | ITvarQuote -- '
+ | ITtyQuote -- ''
-- Arrow notation extension
| ITproc
( "forall", ITforall, bit glaExtsBit),
( "mdo", ITmdo, bit glaExtsBit),
- ( "reifyDecl", ITreifyDecl, bit thBit),
- ( "reifyType", ITreifyType, bit thBit),
- ( "reifyFixity",ITreifyFixity, bit thBit),
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
c <- lex_char
lex_string (c:s)
+lex_char :: P Char
+lex_char = do
+ mc <- getCharOrFail
+ case mc of
+ '\\' -> lex_escape
+ c | is_any c -> return c
+ _other -> lit_error
lex_stringgap s = do
c <- getCharOrFail
lex_char_tok :: Action
-lex_char_tok loc _end buf len = do
- c <- lex_char
- mc <- getCharOrFail
- case mc of
- '\'' -> do
- glaexts <- extension glaExtsEnabled
- if glaexts
- then do
- i@(end,_) <- getInput
- case alexGetChar i of
+-- Here we are basically parsing character literals, such as 'x' or '\n'
+-- but, when Template Haskell is on, we additionally spot
+-- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
+-- but WIHTOUT CONSUMING the x or T part (the parser does that).
+-- So we have to do two characters of lookahead: when we see 'x we need to
+-- see if there's a trailing quote
+lex_char_tok loc _end buf len = do -- We've seen '
+ i1 <- getInput -- Look ahead to first character
+ case alexGetChar i1 of
+ Nothing -> lit_error
+
+ Just ('\'', i2@(end2,_)) -> do -- We've seen ''
+ th_exts <- extension thEnabled
+ if th_exts then do
+ setInput i2
+ return (T loc end2 ITtyQuote)
+ else lit_error
+
+ Just ('\\', i2@(end2,_)) -> do -- We've seen 'backslash
+ setInput i2
+ lit_ch <- lex_escape
+ mc <- getCharOrFail -- Trailing quote
+ if mc == '\'' then finish_char_tok loc lit_ch
+ else lit_error
+
+ Just (c, i2@(end2,_)) | not (is_any c) -> lit_error
+ | otherwise ->
+
+ -- We've seen 'x, where x is a valid character
+ -- (i.e. not newline etc) but not a quote or backslash
+ case alexGetChar i2 of -- Look ahead one more character
+ Nothing -> lit_error
+ Just ('\'', i3) -> do -- We've seen 'x'
+ setInput i3
+ finish_char_tok loc c
+ _other -> do -- We've seen 'x not followed by quote
+ -- If TH is on, just parse the quote only
+ th_exts <- extension thEnabled
+ if th_exts then return (T loc (fst i1) ITvarQuote)
+ else lit_error
+
+finish_char_tok :: SrcLoc -> Char -> P Token
+finish_char_tok loc ch -- We've already seen the closing quote
+ -- Just need to check for trailing #
+ = do glaexts <- extension glaExtsEnabled
+ if glaexts then do
+ i@(end,_) <- getInput
+ case alexGetChar i of
Just ('#',i@(end,_)) -> do
setInput i
- return (T loc end (ITprimchar c))
+ return (T loc end (ITprimchar ch))
_other ->
- return (T loc end (ITchar c))
- else do
- end <- getSrcLoc
- return (T loc end (ITchar c))
-
- _other -> lit_error
-
-lex_char :: P Char
-lex_char = do
- mc <- getCharOrFail
- case mc of
- '\\' -> lex_escape
- c | is_any c -> return c
- _other -> lit_error
+ return (T loc end (ITchar ch))
+ else do end <- getSrcLoc
+ return (T loc end (ITchar ch))
lex_escape :: P Char
lex_escape = do
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.128 2003/11/04 13:14:06 simonpj Exp $
+$Id: Parser.y,v 1.129 2003/11/06 17:09:53 simonpj Exp $
Haskell grammar.
'[t|' { T _ _ ITopenTypQuote }
'[d|' { T _ _ ITopenDecQuote }
'|]' { T _ _ ITcloseQuote }
-ID_SPLICE { T _ _ (ITidEscape $$) } -- $x
+TH_ID_SPLICE { T _ _ (ITidEscape $$) } -- $x
'$(' { T _ _ ITparenEscape } -- $( exp )
-REIFY_TYPE { T _ _ ITreifyType }
-REIFY_DECL { T _ _ ITreifyDecl }
-REIFY_FIXITY { T _ _ ITreifyFixity }
+TH_VAR_QUOTE { T _ _ ITvarQuote } -- 'x
+TH_TY_QUOTE { T _ _ ITtyQuote } -- ''T
%monad { P } { >>= } { return }
%lexer { lexer } { T _ _ ITeof }
| '{-# CORE' STRING '#-}' exp { HsCoreAnn $2 $4 } -- hdaume: core annotation
- | 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 }
-
aexps :: { [RdrNameHsExpr] }
: aexps aexp { $2 : $1 }
| {- empty -} { [] }
| '_' { EWildPat }
-- MetaHaskell Extension
- | srcloc ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $2)) $1 } -- $x
+ | srcloc TH_ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $2)) $1 } -- $x
| srcloc '$(' exp ')' { mkHsSplice $3 $1 } -- $( exp )
+ | srcloc TH_VAR_QUOTE qvar { HsBracket (VarBr $3) $1 }
+ | srcloc TH_VAR_QUOTE qcon { HsBracket (VarBr $3) $1 }
+ | srcloc TH_TY_QUOTE tyvar { HsBracket (VarBr $3) $1 }
+ | srcloc TH_TY_QUOTE gtycon { HsBracket (VarBr $3) $1 }
| srcloc '[|' exp '|]' { HsBracket (ExpBr $3) $1 }
| srcloc '[t|' ctype '|]' { HsBracket (TypBr $3) $1 }
| srcloc '[p|' infixexp '|]' {% checkPattern $1 $3 >>= \p ->
gLA_EXTS = mkBasePkgModule gLA_EXTS_Name
mONAD_FIX = mkBasePkgModule mONAD_FIX_Name
--- MetaHaskell Extension text2 from Meta/work/gen.hs
-mETA_META_Name = mkModuleName "Language.Haskell.THSyntax"
-
rOOT_MAIN_Name = mkModuleName ":Main" -- Root module for initialisation
rOOT_MAIN = mkHomeModule rOOT_MAIN_Name
-- The ':xxx' makes a moudle name that the user can never
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity )
import TcRnMonad
-import Name ( Name, nameIsLocalOrFrom, mkInternalName,
+import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName,
nameSrcLoc, nameOccName, nameModuleName, nameParent )
import NameSet
import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused )
lookupTopBndrRn rdr_name
| Just name <- isExact_maybe rdr_name
- -- This is here just to catch the PrelBase defn of (say) [] and similar
- -- The parser reads the special syntax and returns an Exact RdrName
- -- But the global_env contains only Qual RdrNames, so we won't
- -- find it there; instead just get the name via the Orig route
+ -- This is here to catch
+ -- (a) Exact-name binders created by Template Haskell
+ -- (b) The PrelBase defn of (say) [] and similar, for which
+ -- the parser reads the special syntax and returns an Exact RdrName
--
-- We are at a binding site for the name, so check first that it
-- the current module is the correct one; otherwise GHC can get
-- data T = (,) Int Int
-- unless we are in GHC.Tup
= getModule `thenM` \ mod ->
- checkErr (moduleName mod == nameModuleName name)
+ checkErr (isInternalName name || moduleName mod == nameModuleName name)
(badOrigBinding rdr_name) `thenM_`
returnM name
%*********************************************************
\begin{code}
-newLocalsRn :: [(RdrName,SrcLoc)]
- -> RnM [Name]
+newLocalsRn :: [(RdrName,SrcLoc)] -> RnM [Name]
newLocalsRn rdr_names_w_loc
- = newUniqueSupply `thenM` \ us ->
- let
- uniqs = uniqsFromSupply us
- names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc
- | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
- ]
- in
- returnM names
-
+ = newUniqueSupply `thenM` \ us ->
+ returnM (zipWith mk rdr_names_w_loc (uniqsFromSupply us))
+ where
+ mk (rdr_name, loc) uniq
+ | Just name <- isExact_maybe rdr_name = name
+ -- This happens in code generated by Template Haskell
+ | otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name )
+ -- We only bind unqualified names here
+ -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName
+ mkInternalName uniq (rdrNameOcc rdr_name) loc
bindLocatedLocalsRn :: SDoc -- Documentation string for error message
-> [(RdrName,SrcLoc)]
-> ([Name] -> RnM a)
-> RnM a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
- = ASSERT2( all (isUnqual . fst) rdr_names_w_loc, ppr rdr_names_w_loc )
- -- We only bind unqualified names here
- -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName
-
- -- Check for duplicate names
+ = -- Check for duplicate names
checkDupNames doc_str rdr_names_w_loc `thenM_`
-- Warn about shadowing, but only in source modules
rnExpr splice `thenM` \ (splice', fvs_e) ->
returnM (HsSplice n' splice' loc, fvs_e)
-rnExpr e@(HsReify (Reify flavour name))
- = checkTH e "reify" `thenM_`
- lookupGlobalOccRn name `thenM` \ name' ->
- -- For now, we can only reify top-level things
- returnM (HsReify (Reify flavour name'), unitFV name')
-
rnExpr section@(SectionL expr op)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
rnExpr op `thenM` \ (op', fvs_op) ->
%************************************************************************
\begin{code}
+rnBracket (VarBr n) = lookupOccRn n `thenM` \ name ->
+ returnM (VarBr name, unitFV name)
rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
returnM (ExpBr e', fvs)
rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
$ do {
-- Rename other declarations
+ traceRn (text "Start rnmono") ;
(rn_val_decls, bind_dus) <- rnTopMonoBinds binds sigs ;
+ traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-- You might think that we could build proper def/use information
-- for type and class declarations, but they can be involved
src_dus = bind_dus `plusDU` usesOnly other_fvs
} ;
+ traceRn (text "finish rnSrc" <+> ppr rn_group) ;
tcg_env <- getGblEnv ;
return (tcg_env `addTcgDUs` src_dus, rn_group)
}}}
import PrelNames ( genericTyConNames )
import CmdLineOpts
import UnicodeUtil ( stringToUtf8 )
-import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
+import ErrUtils ( dumpIfSet_dyn )
import Util ( count, lengthIs, isSingleton, lengthExceeds )
import Unique ( Uniquable(..) )
import ListSetOps ( equivClassesByUniq, minusList )
#ifdef GHCI /* Only if bootstrapped */
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
-import HsSyn ( HsReify(..), ReifyFlavour(..) )
import Id ( Id )
import TcType ( isTauTy )
import TcEnv ( tcMetaTy, checkWellStaged )
tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty)
tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack res_ty)
-
-tcMonoExpr (HsReify (Reify flavour name)) res_ty
- = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $
- tcMetaTy tycon_name `thenM` \ reify_ty ->
- zapExpectedTo res_ty reify_ty `thenM_`
- returnM (HsReify (ReifyOut flavour name))
- where
- tycon_name = case flavour of
- ReifyDecl -> DsMeta.decQTyConName
- ReifyType -> DsMeta.typeQTyConName
- ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
#endif /* GHCI */
\end{code}
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)
mkForAllTys, mkFunTys, tcEqType, isPredTy,
mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
liftedTypeKind, unliftedTypeKind, eqKind,
- tcSplitFunTy_maybe, tcSplitForAllTys, tcSplitSigmaTy,
- pprKind, pprThetaArrow )
+ tcSplitFunTy_maybe, tcSplitForAllTys, pprKind )
import qualified Type ( splitFunTys )
import Inst ( Inst, InstOrigin(..), newMethod, instToId )
import Id ( mkLocalId, idName, idType )
import Var ( TyVar, mkTyVar, tyVarKind )
-import ErrUtils ( Message )
import TyCon ( TyCon, tyConKind )
import Class ( classTyCon )
import Name ( Name )
tcg_imports = imports `plusImportAvails` tcg_imports gbl })
$ do {
+ traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-- Rename the source decls
where
add (loc,msg) = addErrAt loc msg
-addWarn :: Message -> TcRn ()
-addWarn msg
+addReport :: Message -> TcRn ()
+addReport msg
= do { errs_var <- getErrsVar ;
loc <- getSrcLocM ;
rdr_env <- getGlobalRdrEnv ;
(warns, errs) <- readMutVar errs_var ;
writeMutVar errs_var (warns `snocBag` warn, errs) }
+addWarn :: Message -> TcRn ()
+addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)
+
checkErr :: Bool -> Message -> TcRn ()
-- Add the error if the bool is False
checkErr ok msg = checkM ok (addErr msg)
-2%
+%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcSplice]{Template Haskell splices}
-- These imports are the reason that TcSplice
-- is very high up the module hierarchy
-import qualified Language.Haskell.THSyntax as Meta
+import qualified Language.Haskell.TH.THSyntax as TH
+-- THSyntax gives access to internal functions and data types
import HscTypes ( HscEnv(..) )
import HsSyn ( HsBracket(..), HsExpr(..) )
import Convert ( convertToHsExpr, convertToHsDecls )
import RnExpr ( rnExpr )
+import RnEnv ( lookupFixityRn )
import RdrHsSyn ( RdrNameHsExpr, RdrNameHsDecl )
import RnHsSyn ( RenamedHsExpr )
import TcExpr ( tcCheckRho, tcMonoExpr )
import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr )
import TcSimplify ( tcSimplifyTop, tcSimplifyBracket )
import TcUnify ( Expected, zapExpectedTo, zapExpectedType )
-import TcType ( TcType, openTypeKind, mkAppTy )
-import TcEnv ( spliceOK, tcMetaTy, bracketOK )
-import TcMType ( newTyVarTy, UserTypeCtxt(ExprSigCtxt) )
+import TcType ( TcType, openTypeKind, mkAppTy, tcSplitSigmaTy )
+import TcEnv ( spliceOK, tcMetaTy, bracketOK, tcLookup )
+import TcMType ( newTyVarTy, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
import TcHsType ( tcHsSigType )
-import Name ( Name )
+import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification
+import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName )
+import OccName
+import Var ( TyVar, idType )
+import Module ( moduleUserString, mkModuleName )
import TcRnMonad
-
+import IfaceEnv ( lookupOrig )
+
+import Class ( Class, classBigSig )
+import TyCon ( TyCon, tyConTheta, tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons )
+import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks,
+ dataConName, dataConFieldLabels, dataConWrapId )
+import Id ( idName, globalIdDetails )
+import IdInfo ( GlobalIdDetails(..) )
import TysWiredIn ( mkListTy )
-import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName )
-import ErrUtils (Message)
+import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
+import ErrUtils ( Message )
import Outputable
+import Unique ( Unique, Uniquable(..), getKey )
+import IOEnv ( IOEnv )
+import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) )
+import Module ( moduleUserString )
import Panic ( showException )
-import GHC.Base ( unsafeCoerce# ) -- Should have a better home in the module hierarchy
-import Monad (liftM)
+import GHC.Base ( unsafeCoerce#, Int(..) ) -- Should have a better home in the module hierarchy
+import Monad ( liftM )
+import FastString ( LitString )
+import FastTypes ( iBox )
\end{code}
}
tc_bracket :: HsBracket Name -> TcM TcType
-tc_bracket (ExpBr v)
- = panic "tc_bracket"
--- tcMetaTy varTyConName
+tc_bracket (VarBr v)
+ = tcMetaTy nameTyConName
-- Result type is Var (not Q-monadic)
tc_bracket (ExpBr expr)
runMetaE zonked_q_expr `thenM` \ simple_expr ->
let
- -- simple_expr :: Meta.Exp
+ -- simple_expr :: TH.Exp
expr2 :: RdrNameHsExpr
expr2 = convertToHsExpr simple_expr
-- Run the expression
traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
runMetaD zonked_q_expr `thenM` \ simple_expr ->
- -- simple_expr :: [Meta.Dec]
+ -- simple_expr :: [TH.Dec]
-- decls :: [RdrNameHsDecl]
handleErrors (convertToHsDecls simple_expr) `thenM` \ decls ->
traceTc (text "Got result" <+> vcat (map ppr decls)) `thenM_`
\begin{code}
runMetaE :: TypecheckedHsExpr -- Of type (Q Exp)
- -> TcM Meta.Exp -- Of type Exp
+ -> TcM TH.Exp -- Of type Exp
runMetaE e = runMeta e
runMetaD :: TypecheckedHsExpr -- Of type Q [Dec]
- -> TcM [Meta.Dec] -- Of type [Dec]
+ -> TcM [TH.Dec] -- Of type [Dec]
runMetaD e = runMeta e
runMeta :: TypecheckedHsExpr -- Of type X
-> TcM t -- Of type t
runMeta expr
- = getTopEnv `thenM` \ hsc_env ->
- getGblEnv `thenM` \ tcg_env ->
- getModule `thenM` \ this_mod ->
- let
- type_env = tcg_type_env tcg_env
- rdr_env = tcg_rdr_env tcg_env
- in
+ = do { hsc_env <- getTopEnv
+ ; tcg_env <- getGblEnv
+ ; this_mod <- getModule
+ ; let type_env = tcg_type_env tcg_env
+ rdr_env = tcg_rdr_env tcg_env
-- Wrap the compile-and-run in an exception-catcher
-- Compiling might fail if linking fails
-- Running might fail if it throws an exception
- tryM (ioToTcRn (do
- hval <- HscMain.compileExpr
- hsc_env this_mod
- rdr_env type_env expr
- Meta.runQ (unsafeCoerce# hval) -- Coerce it to Q t, and run it
- )) `thenM` \ either_tval ->
-
- case either_tval of
- Left exn -> failWithTc (vcat [text "Exception when trying to run compile-time code:",
- nest 4 (vcat [text "Code:" <+> ppr expr,
+ ; either_tval <- tryM $ do
+ { -- Compile it
+ hval <- ioToTcRn (HscMain.compileExpr
+ hsc_env this_mod
+ rdr_env type_env expr)
+ -- Coerce it to Q t, and run it
+ ; TH.runQ (unsafeCoerce# hval) }
+
+ ; case either_tval of
+ Left exn -> failWithTc (vcat [text "Exception when trying to run compile-time code:",
+ nest 4 (vcat [text "Code:" <+> ppr expr,
text ("Exn: " ++ Panic.showException exn)])])
- Right v -> returnM v
+ Right v -> returnM v }
\end{code}
+To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
+\begin{code}
+instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
+ qNewName s = do { u <- newUnique
+ ; let i = getKey u
+ ; return (TH.mkNameU s i) }
------------------------------------
- Random comments
-
-
- module Foo where
- import Lib( g :: Int -> M Exp )
- h x = not x
- f x y = [| \z -> (x, $(g y), z, map, h) |]
-
- h p = $( (\q r -> if q then [| \s -> (p,r,s) |]
- else ... ) True 3) )
-
-==> core
-
- f :: Liftable a => a -> Int -> M Exp
- f = /\a -> \d::Liftable a ->
- \ x y -> genSym "z" `bindM` \ z::String ->
- g y `bindM` \ vv::Exp ->
- Lam z (Tup [lift d x, v, Var z,
- Glob "Prelude" "map",
- Glob "Foo" "h"])
-
-
- h :: Tree Int -> M Exp
- h = \p -> \s' -> (p,3,s')
-
-
- Bound Used
-
- map: C0 C1 (top-level/imp)
- x: C0 C1 (lam/case)
- y: C0 C0
- z: C1 C1
-
- p: C0 S1
- r: S0 S1
- q: S0 S0
- s: S1 S1
-
--------
-
- f x y = lam "z" (tup [lift x, g y, var "z",
- [| map |], [| h |] ])
-==> core
-
- f = \x y -> lam "z" (tup [lift d x, g y, var "z",
- return (Glob "Prelude" "map"),
- return (Glob "Foo" "h")])
-
-
-
-
-
-
-
- h :: M Exp -> M Exp
- h v = [| \x -> map $v x |]
-
- g :: Tree Int -> M Exp
- g x = $(h [| x |])
-==>
- g x = \x' -> map x x'
-
-*** Simon claims x does not have to be liftable! **
-
-Level 0 compile time
-Level 1 run time
-Level 2 code returned by run time (generation time)
-
-Non-top-level variables
- x occurs at level 1
- inside brackets
- bound at level 0 --> x
- bound at level 1 --> var "x"
-
- not inside brackets --> x
-
- x at level 2
- inside brackets
- bound at level 0 --> x
- bound at level 1 --> var "x"
+ qReport True msg = addErr (text msg)
+ qReport False msg = addReport (text msg)
- f x = x
+ qCurrentModule = do { m <- getModule; return (moduleUserString m) }
+ qReify v = reify v
+ qRecover = recoverM
-Two successive brackets aren't allowed
+ qRunIO io = ioToTcRn io
+\end{code}
%************************************************************************
#endif /* GHCI */
\end{code}
+
+
+%************************************************************************
+%* *
+ Reification
+%* *
+%************************************************************************
+
+
+\begin{code}
+reify :: TH.Name -> TcM TH.Info
+reify (TH.Name occ (TH.NameG th_ns mod))
+ = do { name <- lookupOrig (mkModuleName (TH.modString mod))
+ (OccName.mkOccName ghc_ns (TH.occString occ))
+ ; thing <- tcLookup name
+ ; reifyThing thing
+ }
+ where
+ ghc_ns = case th_ns of
+ TH.DataName -> dataName
+ TH.TcClsName -> tcClsName
+ TH.VarName -> varName
+
+------------------------------
+reifyThing :: TcTyThing -> TcM TH.Info
+-- The only reason this is monadic is for error reporting,
+-- which in turn is mainly for the case when TH can't express
+-- some random GHC extension
+
+reifyThing (AGlobal (AnId id))
+ = do { ty <- reifyType (idType id)
+ ; fix <- reifyFixity (idName id)
+ ; let v = reifyName id
+ ; case globalIdDetails id of
+ ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
+ other -> return (TH.VarI v ty Nothing fix)
+ }
+
+reifyThing (AGlobal (ATyCon tc)) = do { dec <- reifyTyCon tc; return (TH.TyConI dec) }
+reifyThing (AGlobal (AClass cls)) = do { dec <- reifyClass cls; return (TH.ClassI dec) }
+reifyThing (AGlobal (ADataCon dc))
+ = do { let name = dataConName dc
+ ; ty <- reifyType (idType (dataConWrapId dc))
+ ; fix <- reifyFixity name
+ ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
+
+reifyThing (ATcId id _ _)
+ = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
+ -- though it may be incomplete
+ ; ty2 <- reifyType ty1
+ ; fix <- reifyFixity (idName id)
+ ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
+
+reifyThing (ATyVar tv)
+ = do { ty1 <- zonkTcTyVar tv
+ ; ty2 <- reifyType ty1
+ ; return (TH.TyVarI (reifyName tv) ty2) }
+
+------------------------------
+reifyTyCon :: TyCon -> TcM TH.Dec
+reifyTyCon tc
+ | isSynTyCon tc
+ = do { let (tvs, rhs) = getSynTyConDefn tc
+ ; rhs' <- reifyType rhs
+ ; return (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+
+ | isNewTyCon tc
+ = do { cxt <- reifyCxt (tyConTheta tc)
+ ; con <- reifyDataCon (head (tyConDataCons tc))
+ ; return (TH.NewtypeD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
+ con [{- Don't know about deriving -}]) }
+
+ | otherwise -- Algebraic
+ = do { cxt <- reifyCxt (tyConTheta tc)
+ ; cons <- mapM reifyDataCon (tyConDataCons tc)
+ ; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
+ cons [{- Don't know about deriving -}]) }
+
+reifyDataCon :: DataCon -> TcM TH.Con
+reifyDataCon dc
+ = do { arg_tys <- reifyTypes (dataConOrigArgTys dc)
+ ; let stricts = map reifyStrict (dataConStrictMarks dc)
+ fields = dataConFieldLabels dc
+ ; if null fields then
+ return (TH.NormalC (reifyName dc) (stricts `zip` arg_tys))
+ else
+ return (TH.RecC (reifyName dc) (zip3 (map reifyName fields) stricts arg_tys)) }
+ -- NB: we don't remember whether the constructor was declared in an infix way
+
+------------------------------
+reifyClass :: Class -> TcM TH.Dec
+reifyClass cls
+ = do { cxt <- reifyCxt theta
+ ; ops <- mapM reify_op op_stuff
+ ; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) ops) }
+ where
+ (tvs, theta, _, op_stuff) = classBigSig cls
+ reify_op (op, _) = do { ty <- reifyType (idType op)
+ ; return (TH.SigD (reifyName op) ty) }
+
+------------------------------
+reifyType :: TypeRep.Type -> TcM TH.Type
+reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
+reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
+reifyType (NewTcApp tc tys) = reify_tc_app (reifyName tc) tys
+reifyType (NoteTy _ ty) = reifyType ty
+reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
+reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
+reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
+ ; tau' <- reifyType tau
+ ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
+ where
+ (tvs, cxt, tau) = tcSplitSigmaTy ty
+reifyTypes = mapM reifyType
+reifyCxt = mapM reifyPred
+
+reifyTyVars :: [TyVar] -> [TH.Name]
+reifyTyVars = map reifyName
+
+reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
+reify_tc_app tc tys = do { tys' <- reifyTypes tys
+ ; return (foldl TH.AppT (TH.ConT tc) tys') }
+
+reifyPred :: TypeRep.PredType -> TcM TH.Type
+reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
+reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p)
+
+
+------------------------------
+reifyName :: NamedThing n => n -> TH.Name
+reifyName thing
+ | isExternalName name = mk_varg mod occ_str
+ | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
+ where
+ name = getName thing
+ mod = moduleUserString (nameModule name)
+ occ_str = occNameUserString occ
+ occ = nameOccName name
+ mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
+ | OccName.isVarOcc occ = TH.mkNameG_v
+ | OccName.isTcOcc occ = TH.mkNameG_tc
+ | otherwise = pprPanic "reifyName" (ppr name)
+
+------------------------------
+reifyFixity :: Name -> TcM TH.Fixity
+reifyFixity name
+ = do { fix <- lookupFixityRn name
+ ; return (conv_fix fix) }
+ where
+ conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
+ conv_dir BasicTypes.InfixR = TH.InfixR
+ conv_dir BasicTypes.InfixL = TH.InfixL
+ conv_dir BasicTypes.InfixN = TH.InfixN
+
+reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
+reifyStrict MarkedStrict = TH.IsStrict
+reifyStrict MarkedUnboxed = TH.IsStrict
+reifyStrict NotMarkedStrict = TH.NotStrict
+
+------------------------------
+noTH :: LitString -> SDoc -> TcM a
+noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+>
+ ptext SLIT("in Template Haskell:"),
+ nest 2 d])
+\end{code}
\ No newline at end of file
import HsSyn ( HsExpr(..) )
import TcHsSyn ( mkHsLet,
ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) )
-import TypeRep ( Type(..), PredType(..), TyNote(..), typeCon, openKindCon, isSuperKind )
+import TypeRep ( Type(..), PredType(..), TyNote(..), openKindCon, isSuperKind )
import TcRnMonad -- TcType, amongst others
import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
import {-# SOURCE #-} Name ( Name )
-import Unique ( Uniquable(..), Unique, getKey, mkUniqueGrimily )
+import Unique ( Uniquable(..), Unique, getKey#, mkUniqueGrimily )
import Panic
import FastTypes
import Outputable
\begin{code}
emptyUFM = EmptyUFM
-unitUFM key elt = mkLeafUFM (getKey (getUnique key)) elt
-unitDirectlyUFM key elt = mkLeafUFM (getKey key) elt
+unitUFM key elt = mkLeafUFM (getKey# (getUnique key)) elt
+unitDirectlyUFM key elt = mkLeafUFM (getKey# key) elt
listToUFM key_elt_pairs
= addListToUFM_C use_snd EmptyUFM key_elt_pairs
\begin{code}
addToUFM fm key elt = addToUFM_C use_snd fm key elt
-addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey u) elt
+addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey# u) elt
addToUFM_C combiner fm key elt
- = insert_ele combiner fm (getKey (getUnique key)) elt
+ = insert_ele combiner fm (getKey# (getUnique key)) elt
addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
addListToUFM_C combiner fm key_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey (getUnique k)) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# (getUnique k)) e)
fm key_elt_pairs
addListToUFM_directly_C combiner fm uniq_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey k) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# k) e)
fm uniq_elt_pairs
\end{code}
\begin{code}
delListFromUFM fm lst = foldl delFromUFM fm lst
-delFromUFM fm key = delete fm (getKey (getUnique key))
-delFromUFM_Directly fm u = delete fm (getKey u)
+delFromUFM fm key = delete fm (getKey# (getUnique key))
+delFromUFM_Directly fm u = delete fm (getKey# u)
delete EmptyUFM _ = EmptyUFM
delete fm key = del_ele fm
Lookup up a binary tree is easy (and fast).
\begin{code}
-elemUFM key fm = case lookUp fm (getKey (getUnique key)) of
+elemUFM key fm = case lookUp fm (getKey# (getUnique key)) of
Nothing -> False
Just _ -> True
-lookupUFM fm key = lookUp fm (getKey (getUnique key))
-lookupUFM_Directly fm key = lookUp fm (getKey key)
+lookupUFM fm key = lookUp fm (getKey# (getUnique key))
+lookupUFM_Directly fm key = lookUp fm (getKey# key)
lookupWithDefaultUFM fm deflt key
- = case lookUp fm (getKey (getUnique key)) of
+ = case lookUp fm (getKey# (getUnique key)) of
Nothing -> deflt
Just elt -> elt
lookupWithDefaultUFM_Directly fm deflt key
- = case lookUp fm (getKey key) of
+ = case lookUp fm (getKey# key) of
Nothing -> deflt
Just elt -> elt
\begin{code}
eltsUFM fm = foldUFM (:) [] fm
-ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm
+ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily (iBox iu), elt) : rest) [] fm
-keysUFM fm = fold_tree (\ iu elt rest -> mkUniqueGrimily iu : rest) [] fm
+keysUFM fm = fold_tree (\ iu elt rest -> mkUniqueGrimily (iBox iu) : rest) [] fm
fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1
fold_tree f a (LeafUFM iu obj) = f iu obj a
projects / ghc-hetmet.git / commitdiff