From 1f5e55804b97d2b9a77207d568d602ba88d8855d Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 6 Nov 2003 17:10:01 +0000 Subject: [PATCH] [project @ 2003-11-06 17:09:50 by simonpj] ------------------------------------ Major increment for Template Haskell ------------------------------------ 1. New abstract data type "Name" which appears where String used to be. E.g. data Exp = VarE Name | ... 2. New syntax 'x and ''T, for quoting Names. It's rather like [| x |] and [t| T |] respectively, except that a) it's non-monadic: 'x :: Name b) you get a Name not an Exp or Type 3. reify is an ordinary function reify :: Name -> Q Info New data type Info which tells what TH knows about Name 4. Local variables work properly. So this works now (crashed before): f x = $( [| x |] ) 5. THSyntax is split up into three modules: Language.Haskell.TH TH "clients" import this Language.Haskell.TH.THSyntax data type declarations and internal stuff Language.Haskell.TH.THLib Support library code (all re-exported by TH), including smart constructors and pretty printer 6. Error reporting and recovery are in (not yet well tested) report :: Bool {- True <=> fatal -} -> String -> Q () recover :: Q a -> Q a -> Q a 7. Can find current module currentModule :: Q String Much other cleaning up, needless to say. --- ghc/compiler/basicTypes/Name.lhs | 2 +- ghc/compiler/basicTypes/OccName.lhs | 14 +- ghc/compiler/basicTypes/RdrName.lhs | 6 +- ghc/compiler/basicTypes/UniqSupply.lhs | 4 +- ghc/compiler/basicTypes/Unique.lhs | 19 +- ghc/compiler/basicTypes/Var.lhs | 16 +- ghc/compiler/deSugar/DsExpr.lhs | 3 +- ghc/compiler/deSugar/DsForeign.lhs | 4 +- ghc/compiler/deSugar/DsMeta.hs | 618 +++++++++++++++++--------------- ghc/compiler/deSugar/DsMonad.lhs | 6 +- ghc/compiler/hsSyn/Convert.lhs | 153 ++++---- ghc/compiler/hsSyn/HsExpr.lhs | 19 - ghc/compiler/iface/LoadIface.lhs | 2 +- ghc/compiler/main/ErrUtils.lhs | 12 +- ghc/compiler/parser/Lexer.x | 92 +++-- ghc/compiler/parser/Parser.y | 22 +- ghc/compiler/prelude/PrelNames.lhs | 3 - ghc/compiler/rename/RnEnv.lhs | 40 +-- ghc/compiler/rename/RnExpr.lhs | 8 +- ghc/compiler/rename/RnSource.lhs | 3 + ghc/compiler/typecheck/TcClassDcl.lhs | 2 +- ghc/compiler/typecheck/TcExpr.lhs | 12 - ghc/compiler/typecheck/TcHsSyn.lhs | 2 - ghc/compiler/typecheck/TcHsType.lhs | 4 +- ghc/compiler/typecheck/TcRnDriver.lhs | 1 + ghc/compiler/typecheck/TcRnMonad.lhs | 7 +- ghc/compiler/typecheck/TcSplice.lhs | 350 ++++++++++++------ ghc/compiler/typecheck/TcUnify.lhs | 2 +- ghc/compiler/utils/UniqFM.lhs | 32 +- 29 files changed, 793 insertions(+), 665 deletions(-) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index dc8ee65..b98a491 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -252,7 +252,7 @@ localiseName n = n { n_sort = Internal } \begin{code} hashName :: Name -> Int -hashName name = iBox (getKey (nameUnique name)) +hashName name = getKey (nameUnique name) \end{code} diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index cbbb433..d0b1128 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -26,7 +26,7 @@ module OccName ( 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, @@ -34,7 +34,7 @@ module OccName ( 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, @@ -200,7 +200,7 @@ pprOccName (OccName sp occ) %* * \subsection{Construction} %* * -%************************************************************************ +%*****p******************************************************************* *Sys* things do no encoding; the caller should ensure that the thing is already encoded @@ -235,6 +235,9 @@ mkKindOccFS occ_sp fs = OccName occ_sp fs 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) @@ -372,7 +375,10 @@ briefNameSpaceFlavour TcClsName = "tc" \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 diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index cc58eb1..df4b4d1 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -300,9 +300,9 @@ extendLocalRdrEnv env names = 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 diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 73b2b63..6992751 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -90,8 +90,8 @@ splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) \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} %************************************************************************ diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index eba88fb..b73b38c 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -22,7 +22,8 @@ module Unique ( 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 @@ -77,9 +78,9 @@ The stuff about unique *supplies* is handled further down this module. 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 @@ -90,10 +91,12 @@ isTupleKey :: Unique -> Bool \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#) @@ -152,10 +155,10 @@ hasKey :: Uniquable a => a -> Unique -> Bool 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} diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 66876c6..d2c22f3 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -43,7 +43,7 @@ import Name ( Name, OccName, NamedThing(..), setNameUnique, setNameOcc, nameUnique, mkSystemTvNameEncoded, ) -import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey ) +import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# ) import FastTypes import Outputable @@ -143,16 +143,16 @@ instance Ord Var where \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 @@ -184,7 +184,7 @@ setTyVarName = setVarName \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) @@ -192,7 +192,7 @@ mkTyVar name kind = Var { varName = 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) @@ -203,7 +203,7 @@ mkSysTyVar uniq kind = Var { varName = 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) @@ -284,7 +284,7 @@ maybeModifyIdInfo fn var@(Var {varInfo = info}) = case fn info of 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 } diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 1e9c6e1..f447d9d 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -22,7 +22,7 @@ import DsMonad #ifdef GHCI -- Template Haskell stuff iff bootstrapped -import DsMeta ( dsBracket, dsReify ) +import DsMeta ( dsBracket ) #endif import HsSyn ( HsExpr(..), Pat(..), ArithSeqInfo(..), @@ -555,7 +555,6 @@ Here is where we desugar the Template Haskell brackets and escapes #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 diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index a832499..77aa412 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -102,8 +102,8 @@ dsForeigns fos 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} diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index a0d7cbf..f1a83e9 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -11,10 +11,11 @@ ----------------------------------------------------------------------------- -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" @@ -24,14 +25,13 @@ import MatchLit ( dsLit ) 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(..), @@ -42,19 +42,19 @@ import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..), 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 ) @@ -67,19 +67,20 @@ import SrcLoc ( noSrcLoc ) 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! @@ -94,33 +95,6 @@ dsBracket brack splices 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 |] @@ -140,10 +114,10 @@ dsReify r@(ReifyOut ReifyDecl name) -- 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 @@ -196,17 +170,17 @@ But if we see this: 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, @@ -214,11 +188,12 @@ repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, 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, @@ -230,15 +205,17 @@ 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, @@ -252,7 +229,8 @@ 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 @@ -266,7 +244,7 @@ repInstD' (InstDecl ty binds _ loc) -- 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 @@ -282,12 +260,12 @@ repInstD' (InstDecl ty binds _ loc) -- 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] @@ -299,13 +277,13 @@ repBangTy (BangType str ty) = do MkC s <- rep2 strName [] -- 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" @@ -315,22 +293,22 @@ repDerivs (Just ctxt) -- 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 ; @@ -346,12 +324,12 @@ rep_proto nm ty loc = do { nm1 <- lookupOcc nm ; -- 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 @@ -359,7 +337,7 @@ addTyVarBinds tvs m = -- 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 @@ -367,7 +345,7 @@ repContext ctxt = do -- 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 @@ -377,17 +355,18 @@ repPred (HsIParam _ _) = -- 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 @@ -431,14 +410,14 @@ repTy (HsKindSig ty kind) = -- 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 @@ -532,16 +511,15 @@ repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n 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 @@ -550,9 +528,9 @@ repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = ; 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 @@ -561,7 +539,7 @@ repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = ; 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 @@ -572,7 +550,7 @@ 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) @@ -605,14 +583,14 @@ repFields flds = do -- 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 @@ -635,24 +613,24 @@ repSts other = panic "Exotic Stmt in meta brackets" -- 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) @@ -666,12 +644,12 @@ rep_binds' (MonoBind bs sigs _) 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; @@ -735,11 +713,11 @@ rep_monobind' (VarMonoBind v e) -- 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 } @@ -755,11 +733,11 @@ repLambda z = panic "Can't represent a guarded lambda in Template Haskell" -- 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' } @@ -803,21 +781,20 @@ type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id -- 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 @@ -827,7 +804,7 @@ addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m -- 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 @@ -839,7 +816,7 @@ lookupBinder n -- * If it is a global name, generate the "original name" representation (ie, -- the : 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 @@ -850,41 +827,55 @@ 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 @@ -898,8 +889,12 @@ wrapNongenSyms binds (MkC body) 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 @@ -935,161 +930,161 @@ rep2 n xs = do { id <- dsLookupGlobalId n -- %********************************************************************* --------------- 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 @@ -1108,40 +1103,40 @@ repConstr con (InfixCon st1 st2) ------------ 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 @@ -1170,7 +1165,7 @@ mk_integer i = do integer_ty <- lookupType integerTyConName 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 @@ -1179,18 +1174,18 @@ repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral --------------- 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] @@ -1218,7 +1213,10 @@ corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y]) 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) @@ -1240,7 +1238,9 @@ templateHaskellNames :: [Name] -- 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, @@ -1283,154 +1283,169 @@ templateHaskellNames = [ 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 @@ -1453,6 +1468,7 @@ varStrictTypeQTyConKey = mkPreludeTyConUnique 114 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 @@ -1460,8 +1476,14 @@ fieldPatTyConKey = mkPreludeTyConUnique 117 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 diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index c916626..531f729 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -90,7 +90,7 @@ type DsMetaEnv = NameEnv DsMetaVal 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 @@ -174,7 +174,9 @@ putSrcLocDs :: SrcLoc -> DsM a -> DsM a 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} diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 5098901..110cda9 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -10,7 +10,8 @@ module Convert( convertToHsExpr, convertToHsDecls ) where #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(..), @@ -24,12 +25,14 @@ import HsSyn as Hs 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(..)) @@ -38,12 +41,15 @@ import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..), 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 @@ -68,9 +74,9 @@ 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) @@ -100,7 +106,7 @@ cvt_top (InstanceD tys ty decs) (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 @@ -116,7 +122,7 @@ cvt_top (ForeignD (ImportF callconv safety from nm typ)) 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') @@ -170,7 +176,7 @@ noExistentials = [] noFunDeps = [] ------------------------------------------------------------------- -convertToHsExpr :: Meta.Exp -> HsExpr RdrName +convertToHsExpr :: TH.Exp -> HsExpr RdrName convertToHsExpr = cvt cvt (VarE s) = HsVar (vName s) @@ -199,7 +205,7 @@ cvt (SigE e t) = ExprWithTySig (cvt e) (cvtType t) 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 @@ -210,27 +216,27 @@ cvtBindsAndSigs ds 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) @@ -243,23 +249,23 @@ cvtdd (FromToR x y) = (FromTo (cvt x) (cvt y)) 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 @@ -276,46 +282,46 @@ cvtLit (DoublePrimL f) = HsDoublePrim f 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 @@ -325,7 +331,7 @@ cvtType ty = trans (root ty []) 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) @@ -333,7 +339,7 @@ split_ty_app ty = go ty [] ----------------------------------------------------------- sigP :: Dec -> Bool -sigP (Meta.SigD _ _) = True +sigP (TH.SigD _ _) = True sigP other = False @@ -345,8 +351,8 @@ cvtPanic herald thing ----------------------------------------------------------- -- 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 @@ -360,46 +366,45 @@ void = placeHolderType 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} diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 2d33d02..e484ad7 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -191,8 +191,6 @@ data HsExpr id -- The id is just a unique name to -- identify this splice point - | HsReify (HsReify id) -- reifyType t, reifyDecl i, reifyFixity - ----------------------------------------------------------- -- Arrow notation extension @@ -443,7 +441,6 @@ ppr_expr (HsType id) = ppr id 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] @@ -833,22 +830,6 @@ pprHsBracket (VarBr n) = char '\'' <> ppr n 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} %************************************************************************ diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index 9f15797..74f41b0 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -29,7 +29,7 @@ import HscTypes ( HscEnv(..), ModIface(..), emptyModIface, lookupIfaceByModName, emptyPackageIfaceTable, IsBootInterface, mkIfaceFixCache, Pool(..), DeclPool, InstPool, - RulePool, Gated, addRuleToPool, RulePoolContents + RulePool, addRuleToPool, RulePoolContents ) import BasicTypes ( Version, Fixity(..), FixityDirection(..) ) diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 3a04c50..fa34674 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -9,7 +9,7 @@ module ErrUtils ( Messages, errorsFound, emptyMessages, addShortErrLocLine, addShortWarnLocLine, - addErrLocHdrLine, addWarnLocHdrLine, + addErrLocHdrLine, printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, @@ -50,7 +50,6 @@ addShortWarnLocLine :: SrcLoc -> PrintUnqualified -> Message -> WarnMsg -- 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 @@ -67,18 +66,11 @@ addShortWarnLocLine locn print_unqual msg 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} diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x index 97dbd77..81f0f27 100644 --- a/ghc/compiler/parser/Lexer.x +++ b/ghc/compiler/parser/Lexer.x @@ -421,9 +421,8 @@ data Token__ | ITcloseQuote -- |] | ITidEscape FastString -- $x | ITparenEscape -- $( - | ITreifyType - | ITreifyDecl - | ITreifyFixity + | ITvarQuote -- ' + | ITtyQuote -- '' -- Arrow notation extension | ITproc @@ -498,9 +497,6 @@ reservedWordsFM = listToUFM $ ( "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), @@ -862,6 +858,13 @@ lex_string s = do 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 @@ -872,34 +875,61 @@ lex_stringgap s = do 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 diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index a4a8f9c..68cc7ea 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-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. @@ -208,11 +208,10 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002] '[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 } @@ -932,7 +931,6 @@ exp10 :: { RdrNameHsExpr } | '{-# CORE' STRING '#-}' exp { HsCoreAnn $2 $4 } -- hdaume: core annotation - | reifyexp { HsReify $1 } | fexp { $1 } scc_annot :: { FastString } @@ -943,12 +941,6 @@ fexp :: { RdrNameHsExpr } : 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 -} { [] } @@ -985,8 +977,12 @@ aexp2 :: { RdrNameHsExpr } | '_' { 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 -> diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index e2e250f..947feba 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -315,9 +315,6 @@ dOTNET = mkBasePkgModule dOTNET_Name 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 diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 708f509..d69d5c0 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -42,7 +42,7 @@ import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, 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 ) @@ -124,10 +124,10 @@ lookupTopBndrRn :: RdrName -> RnM Name 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 @@ -135,7 +135,7 @@ lookupTopBndrRn rdr_name -- 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 @@ -492,29 +492,25 @@ lookupSyntaxNames std_names %********************************************************* \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 diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 78d8c00..0b78b1a 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -228,12 +228,6 @@ rnExpr e@(HsSplice n splice loc) 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) -> @@ -625,6 +619,8 @@ rnRbinds str rbinds %************************************************************************ \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) -> diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 8a7e7b2..1fb0189 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -87,7 +87,9 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, $ 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 @@ -117,6 +119,7 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, 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) }}} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 3971330..6a3af2e 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -61,7 +61,7 @@ import Var ( TyVar ) 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 ) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index d3c6ee7..6ea75a2 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -10,7 +10,6 @@ module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where #ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) -import HsSyn ( HsReify(..), ReifyFlavour(..) ) import Id ( Id ) import TcType ( isTauTy ) import TcEnv ( tcMetaTy, checkWellStaged ) @@ -564,17 +563,6 @@ tcMonoExpr (PArrSeqIn _) _ 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} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index dcdb63a..62c9c7a 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -508,8 +508,6 @@ zonkExpr env (HsBracketOut body bs) 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) diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 0861e8c..473166d 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -43,14 +43,12 @@ import TcType ( Type, PredType(..), ThetaType, TyVarDetails(..), 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 ) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 92526ee..7fbbc32 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -688,6 +688,7 @@ rnTopSrcDecls group 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 diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index de3390c..8f8a6df 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -385,8 +385,8 @@ addErrs msgs = mappM_ add msgs 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 ; @@ -394,6 +394,9 @@ addWarn msg (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) diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 7dda60c..b7b3c29 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -1,4 +1,4 @@ -2% +% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcSplice]{Template Haskell splices} @@ -13,32 +13,51 @@ import TcRnDriver ( tcTopSrcDecls ) -- 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} @@ -96,9 +115,8 @@ tcBracket brack res_ty } 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) @@ -179,7 +197,7 @@ tcTopSplice expr res_ty runMetaE zonked_q_expr `thenM` \ simple_expr -> let - -- simple_expr :: Meta.Exp + -- simple_expr :: TH.Exp expr2 :: RdrNameHsExpr expr2 = convertToHsExpr simple_expr @@ -232,7 +250,7 @@ tcSpliceDecls 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_` @@ -256,127 +274,56 @@ tcSpliceDecls expr \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} %************************************************************************ @@ -402,3 +349,168 @@ illegalSplice level #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 diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 04a804d..85d89d4 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -30,7 +30,7 @@ module TcUnify ( 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, diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index e38f4f5..18efa0e 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -48,7 +48,7 @@ module UniqFM ( import {-# SOURCE #-} Name ( Name ) -import Unique ( Uniquable(..), Unique, getKey, mkUniqueGrimily ) +import Unique ( Uniquable(..), Unique, getKey#, mkUniqueGrimily ) import Panic import FastTypes import Outputable @@ -220,8 +220,8 @@ First the ways of building a UniqFM. \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 @@ -240,20 +240,20 @@ could be optimised using it. \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} @@ -262,8 +262,8 @@ Now ways of removing things from UniqFM. \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 @@ -541,20 +541,20 @@ looking up in a hurry is the {\em whole point} of this binary tree lark. 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 @@ -578,9 +578,9 @@ folds are *wonderful* things. \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 -- 1.7.10.4