X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMeta.hs;h=4bcb32efb3fbea9b62054e20de1f40d8c403ced5;hb=623e5fbbbec02e1cc5d80f0685919ecb6b845d35;hp=7cda61d3c9c43733a1f579f75dac1f0c78f08999;hpb=cb51a09231da94d729bcd62177cbdec1a888a180;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 7cda61d..4bcb32e 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,101 +25,57 @@ import MatchLit ( dsLit ) import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr ) import DsMonad -import qualified Language.Haskell.THSyntax as M - -import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..), - Match(..), GRHSs(..), GRHS(..), HsBracket(..), - HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..), - HsBinds(..), MonoBinds(..), HsConDetails(..), - TyClDecl(..), HsGroup(..), - HsReify(..), ReifyFlavour(..), - HsType(..), HsContext(..), HsPred(..), HsTyOp(..), - HsTyVarBndr(..), Sig(..), ForeignDecl(..), - InstDecl(..), ConDecl(..), BangType(..), - PendingSplice, splitHsInstDeclTy, - placeHolderType, tyClDeclNames, - collectHsBinders, collectPatBinders, collectPatsBinders, - hsTyVarName, hsConArgs, getBangType, - toHsType - ) - -import PrelNames ( mETA_META_Name, rationalTyConName, negateName, - parrTyConName ) -import MkIface ( ifaceTyThing ) -import Name ( Name, nameOccName, nameModule, getSrcLoc ) +import qualified Language.Haskell.TH as TH + +import HsSyn +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, mkThPkgModule, moduleUserString ) -import Id ( Id, idType ) -import Name ( mkKnownKeyExternalName ) +import Module ( Module, mkModule, mkModuleName, moduleUserString ) +import Id ( Id, mkLocalId ) import OccName ( mkOccFS ) +import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule, + isExternalName, getSrcLoc ) import NameEnv -import NameSet import Type ( Type, mkGenTyConApp ) -import TcType ( TyThing(..), tcTyConAppArgs ) -import TyCon ( DataConDetails(..) ) -import TysWiredIn ( stringTy ) +import TcType ( tcTyConAppArgs ) +import TyCon ( tyConName ) +import TysWiredIn ( parrTyCon ) import CoreSyn import CoreUtils ( exprType ) -import SrcLoc ( noSrcLoc ) -import Maybes ( orElse ) -import Maybe ( catMaybes, fromMaybe ) -import Panic ( panic ) -import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique ) -import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) -import SrcLoc ( SrcLoc ) - +import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan ) +import Maybe ( catMaybes ) +import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) ) +import BasicTypes ( NewOrData(..), isBoxed ) +import Packages ( thPackage ) import Outputable -import FastString ( mkFastString ) +import Bag ( bagToList ) 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! dsBracket brack splices = dsExtendMetaEnv new_bit (do_brack brack) where - new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices] + new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices] - do_brack (ExpBr e) = do { MkC e1 <- repE e ; return e1 } - do_brack (PatBr p) = do { MkC p1 <- repP p ; return p1 } - do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 } + do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 } + do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 } + do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 } ------------------------------------------------------------------------------ -dsReify :: HsReify Id -> DsM CoreExpr --- Returns a CoreExpr of type reifyType --> M.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 thing) ; - case mb_d of - Just (MkC d) -> return d - Nothing -> pprPanic "dsReify" (ppr r) - } - {- -------------- Examples -------------------- [| \x -> x |] @@ -138,10 +95,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 } ; - ss <- mkGenSyms bndrs ; + = do { let { bndrs = map unLoc (groupBinders group) } ; + ss <- mkGenSyms bndrs ; -- Bind all the names mainly to avoid repeated use of explicit strings. -- Thus we get @@ -152,11 +109,11 @@ repTopDs group decls <- addBinds ss (do { - val_ds <- rep_binds' (hs_valds group) ; - tycl_ds <- mapM repTyClD' (hs_tyclds group) ; + val_ds <- mapM rep_bind_group (hs_valds group) ; + tycl_ds <- mapM repTyClD (hs_tyclds group) ; inst_ds <- mapM repInstD' (hs_instds group) ; -- more needed - return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ; + return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -171,9 +128,9 @@ repTopDs group groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) -- Collect the binders of a Group - = collectHsBinders val_decls ++ - [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++ - [n | ForeignImport n _ _ _ _ <- foreign_decls] + = collectGroupBinders val_decls ++ + [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++ + [n | L _ (ForeignImport n _ _ _) <- foreign_decls] {- Note [Binders and occurrences] @@ -194,145 +151,143 @@ 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 decl = do x <- repTyClD' decl - return (fmap snd x) - -repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ)) +repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, - tcdName = tc, tcdTyVars = tvs, - tcdCons = DataCons cons, tcdDerivs = mb_derivs, - tcdLoc = loc}) - = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] +repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, + tcdLName = tc, tcdTyVars = tvs, + tcdCons = cons, tcdDerivs = mb_derivs })) + = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { - cxt1 <- repContext cxt ; + cxt1 <- repLContext 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, - tcdName = tc, tcdTyVars = tvs, - tcdCons = DataCons [con], tcdDerivs = mb_derivs, - tcdLoc = loc}) - = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] +repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, + tcdLName = tc, tcdTyVars = tvs, + tcdCons = [con], tcdDerivs = mb_derivs })) + = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { - cxt1 <- repContext cxt ; + cxt1 <- repLContext 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] +repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty })) + = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { - ty1 <- repTy ty ; - repTySyn tc1 (coreList' stringTy bndrs) ty1 } ; + ty1 <- repLTy ty ; + bndrs1 <- coreList nameTyConName bndrs ; + repTySyn tc1 bndrs1 ty1 } ; return (Just (loc, dec)) } -repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls, +repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tvs, tcdFDs = [], -- We don't understand functional dependencies - tcdSigs = sigs, tcdMeths = mb_meth_binds, - tcdLoc = loc}) - = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences] + tcdSigs = sigs, tcdMeths = meth_binds })) + = do { cls1 <- lookupLOcc cls ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { - cxt1 <- repContext cxt ; + cxt1 <- repLContext cxt ; sigs1 <- rep_sigs sigs ; - binds1 <- rep_monobind meth_binds ; + binds1 <- rep_binds 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) } - where - -- If the user quotes a class decl, it'll have default-method - -- bindings; but if we (reifyDecl C) where C is a class, we - -- won't be given the default methods (a definite infelicity). - meth_binds = mb_meth_binds `orElse` EmptyMonoBinds -- Un-handled cases -repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ; - return Nothing - } +repTyClD (L loc d) = do { dsWarn (loc, hang msg 4 (ppr d)) ; + return Nothing + } where msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") -repInstD' (InstDecl ty binds _ _ loc) - -- Ignore user pragmas for now - = do { cxt1 <- repContext cxt ; - inst_ty1 <- repPred (HsClassP cls tys) ; - binds1 <- rep_monobind binds ; - decls1 <- coreList decQTyConName binds1 ; - i <- repInst cxt1 inst_ty1 decls1; - return (loc, i)} +repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now + = do { i <- addTyVarBinds tvs $ \tv_bndrs -> + -- We must bring the type variables into scope, so their occurrences + -- don't fail, even though the binders don't appear in the resulting + -- data structure + do { cxt1 <- repContext cxt + ; inst_ty1 <- repPred (HsClassP cls tys) + ; ss <- mkGenSyms (collectHsBindBinders binds) + ; binds1 <- addBinds ss (rep_binds binds) + ; decls1 <- coreList decQTyConName binds1 + ; decls2 <- wrapNongenSyms ss decls1 + -- wrapNonGenSyms: do not clone the class op names! + -- They must be called 'op' etc, not 'op34' + ; repInst cxt1 inst_ty1 decls2 } + + ; return (loc, i)} where - (tvs, cxt, cls, tys) = splitHsInstDeclTy ty - + (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty) ------------------------------------------------------- -- Constructors ------------------------------------------------------- -repC :: ConDecl Name -> DsM (Core M.ConQ) -repC (ConDecl con [] [] details loc) - = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences] +repC :: LConDecl Name -> DsM (Core TH.ConQ) +repC (L loc (ConDecl con [] (L _ []) details)) + = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences] repConstr con1 details } -repBangTy :: BangType Name -> DsM (Core (M.StrictTypeQ)) -repBangTy (BangType str ty) = do MkC s <- rep2 strName [] - MkC t <- repTy ty - rep2 strictTypeName [s, t] - where strName = case str of - NotMarkedStrict -> notStrictName - _ -> isStrictName +repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) +repBangTy (L _ (BangType str ty)) = do + MkC s <- rep2 strName [] + MkC t <- repLTy ty + rep2 strictTypeName [s, t] + where strName = case str of + HsNoBang -> notStrictName + other -> isStrictName ------------------------------------------------------- -- Deriving clause ------------------------------------------------------- -repDerivs :: Maybe (HsContext Name) -> DsM (Core [String]) -repDerivs Nothing = return (coreList' stringTy []) -repDerivs (Just ctxt) +repDerivs :: Maybe (LHsContext Name) -> DsM (Core [TH.Name]) +repDerivs Nothing = coreList nameTyConName [] +repDerivs (Just (L _ ctxt)) = do { strs <- mapM rep_deriv ctxt ; - return (coreList' stringTy strs) } + coreList nameTyConName strs } where - rep_deriv :: HsPred Name -> DsM (Core String) + rep_deriv :: LHsPred 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" + rep_deriv (L _ (HsClassP cls [])) = lookupOcc cls + rep_deriv other = panic "rep_deriv" ------------------------------------------------------- -- Signatures in a class decl, or a group of bindings ------------------------------------------------------- -rep_sigs :: [Sig Name] -> DsM [Core M.DecQ] +rep_sigs :: [LSig 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' :: [LSig Name] -> DsM [(SrcSpan, 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 :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (ClassOpSig nm _ ty loc) = rep_proto nm ty loc -rep_sig (Sig nm ty loc) = rep_proto nm ty loc -rep_sig other = return [] +rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc +rep_sig other = return [] -rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)] -rep_proto nm ty loc = do { nm1 <- lookupOcc nm ; - ty1 <- repTy ty ; +rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] +rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; + ty1 <- repLTy ty ; sig <- repProto nm1 ty1 ; return [(loc, sig)] } @@ -345,12 +300,12 @@ rep_proto nm ty loc = do { nm1 <- lookupOcc nm ; -- the computations passed as the second argument is executed in that extended -- 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)) +addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added + -> ([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 names = map (hsTyVarName.unLoc) tvs freshNames <- mkGenSyms names term <- addBinds freshNames $ do bndrs <- mapM lookupBinder names @@ -359,35 +314,45 @@ addTyVarBinds tvs m = -- represent a type context -- -repContext :: HsContext Name -> DsM (Core M.CxtQ) +repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) +repLContext (L _ ctxt) = repContext ctxt + +repContext :: HsContext Name -> DsM (Core TH.CxtQ) repContext ctxt = do - preds <- mapM repPred ctxt + preds <- mapM repLPred ctxt predList <- coreList typeQTyConName preds repCtxt predList -- represent a type predicate -- -repPred :: HsPred Name -> DsM (Core M.TypeQ) +repLPred :: LHsPred Name -> DsM (Core TH.TypeQ) +repLPred (L _ p) = repPred p + +repPred :: HsPred Name -> DsM (Core TH.TypeQ) repPred (HsClassP cls tys) = do tcon <- repTy (HsTyVar cls) - tys1 <- repTys tys + tys1 <- repLTys tys repTapps tcon tys1 repPred (HsIParam _ _) = panic "DsMeta.repTy: Can't represent predicates with implicit parameters" -- yield the representation of a list of types -- -repTys :: [HsType Name] -> DsM [Core M.TypeQ] -repTys tys = mapM repTy tys +repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] +repLTys tys = mapM repLTy tys -- represent a type -- -repTy :: HsType Name -> DsM (Core M.TypeQ) -repTy (HsForAllTy bndrs ctxt ty) = - addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do - ctxt' <- repContext ctxt - ty' <- repTy ty - repTForall (coreList' stringTy bndrs') ctxt' ty' +repLTy :: LHsType Name -> DsM (Core TH.TypeQ) +repLTy (L _ ty) = repTy ty + +repTy :: HsType Name -> DsM (Core TH.TypeQ) +repTy (HsForAllTy _ tvs ctxt ty) = + addTyVarBinds tvs $ \bndrs -> do + ctxt1 <- repLContext ctxt + ty1 <- repLTy ty + bndrs1 <- coreList nameTyConName bndrs + repTForall bndrs1 ctxt1 ty1 repTy (HsTyVar n) | isTvOcc (nameOccName n) = do @@ -397,33 +362,32 @@ repTy (HsTyVar n) tc1 <- lookupOcc n repNamedTyCon tc1 repTy (HsAppTy f a) = do - f1 <- repTy f - a1 <- repTy a + f1 <- repLTy f + a1 <- repLTy a repTapp f1 a1 repTy (HsFunTy f a) = do - f1 <- repTy f - a1 <- repTy a + f1 <- repLTy f + a1 <- repLTy a tcon <- repArrowTyCon repTapps tcon [f1, a1] repTy (HsListTy t) = do - t1 <- repTy t + t1 <- repLTy t tcon <- repListTyCon repTapp tcon t1 repTy (HsPArrTy t) = do - t1 <- repTy t - tcon <- repTy (HsTyVar parrTyConName) + t1 <- repLTy t + tcon <- repTy (HsTyVar (tyConName parrTyCon)) repTapp tcon t1 repTy (HsTupleTy tc tys) = do - tys1 <- repTys tys + tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2) -repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) - `HsAppTy` ty2) -repTy (HsParTy t) = repTy t +repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) + `nlHsAppTy` ty2) +repTy (HsParTy t) = repLTy t repTy (HsNumTy i) = panic "DsMeta.repTy: Can't represent number types (for generics)" -repTy (HsPredTy pred) = repPred pred +repTy (HsPredTy pred) = repLPred pred repTy (HsKindSig ty kind) = panic "DsMeta.repTy: Can't represent explicit kind signatures yet" @@ -432,14 +396,17 @@ repTy (HsKindSig ty kind) = -- Expressions ----------------------------------------------------------------------------- -repEs :: [HsExpr Name] -> DsM (Core [M.ExpQ]) -repEs es = do { es' <- mapM repE es ; - coreList expQTyConName es' } +repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ]) +repLEs es = do { es' <- mapM repLE 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) +repLE :: LHsExpr Name -> DsM (Core TH.ExpQ) +repLE (L _ e) = repE e + +repE :: HsExpr Name -> DsM (Core TH.ExpQ) repE (HsVar x) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of @@ -455,136 +422,135 @@ repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters" repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit l) = do { a <- repLiteral l; repLit a } repE (HsLam m) = repLambda m -repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b} +repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} repE (OpApp e1 op fix e2) = - do { arg1 <- repE e1; - arg2 <- repE e2; - the_op <- repE op ; + do { arg1 <- repLE e1; + arg2 <- repLE e2; + the_op <- repLE op ; repInfixApp arg1 the_op arg2 } repE (NegApp x nm) = do - a <- repE x + a <- repLE x negateVar <- lookupOcc negateName >>= repVar negateVar `repApp` a -repE (HsPar x) = repE x -repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b } -repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b } -repE (HsCase e ms loc) = do { arg <- repE e +repE (HsPar x) = repLE x +repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } +repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } +repE (HsCase e ms) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; repCaseE arg (nonEmptyCoreList ms2) } -repE (HsIf x y z loc) = do - a <- repE x - b <- repE y - c <- repE z +repE (HsIf x y z) = do + a <- repLE x + b <- repLE y + c <- repLE z repCond a b c repE (HsLet bs e) = do { (ss,ds) <- repBinds bs - ; e2 <- addBinds ss (repE e) + ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyns ss z } -- FIXME: I haven't got the types here right yet -repE (HsDo DoExpr sts _ ty loc) - = do { (ss,zs) <- repSts sts; +repE (HsDo DoExpr sts _ ty) + = do { (ss,zs) <- repLSts sts; e <- repDoE (nonEmptyCoreList zs); wrapGenSyns ss e } -repE (HsDo ListComp sts _ ty loc) - = do { (ss,zs) <- repSts sts; +repE (HsDo ListComp sts _ ty) + = do { (ss,zs) <- repLSts sts; e <- repComp (nonEmptyCoreList zs); wrapGenSyns ss e } -repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet" -repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } +repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet" +repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitPArr ty es) = panic "DsMeta.repE: No explicit parallel arrays yet" repE (ExplicitTuple es boxed) - | isBoxed boxed = do { xs <- repEs es; repTup xs } + | isBoxed boxed = do { xs <- repLEs es; repTup xs } | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples" repE (RecordCon c flds) - = do { x <- lookupOcc c; + = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } repE (RecordUpd e flds) - = do { x <- repE e; + = do { x <- repLE e; fs <- repFields flds; repRecUpd x fs } -repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 } +repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 } repE (ArithSeqIn aseq) = case aseq of - From e -> do { ds1 <- repE e; repFrom ds1 } + From e -> do { ds1 <- repLE e; repFrom ds1 } FromThen e1 e2 -> do - ds1 <- repE e1 - ds2 <- repE e2 + ds1 <- repLE e1 + ds2 <- repLE e2 repFromThen ds1 ds2 FromTo e1 e2 -> do - ds1 <- repE e1 - ds2 <- repE e2 + ds1 <- repLE e1 + ds2 <- repLE e2 repFromTo ds1 ds2 FromThenTo e1 e2 e3 -> do - ds1 <- repE e1 - ds2 <- repE e2 - ds3 <- repE e3 + ds1 <- repLE e1 + ds2 <- repLE e2 + ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing" repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations -repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__" repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC" -repE (HsBracketOut _ _) = - panic "DsMeta.repE: Can't represent Oxford brackets" -repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n - ; case mb_val of - Just (Splice e) -> do { e' <- dsExpr e - ; return (MkC e') } - other -> pprPanic "HsSplice" (ppr n) } -repE (HsReify _) = panic "DsMeta.repE: Can't represent reification" -repE e = - pprPanic "DsMeta.repE: Illegal expression form" (ppr e) +repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets" +repE (HsSpliceE (HsSplice n _)) + = do { mb_val <- dsLookupMetaEnv n + ; case mb_val of + Just (Splice e) -> do { e' <- dsExpr e + ; return (MkC e') } + other -> pprPanic "HsSplice" (ppr n) } + +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 [p] ty (GRHSs guards wheres ty2)) = +repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ) +repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { - ; p1 <- repP p + ; p1 <- repLP p ; (ss2,ds) <- repBinds wheres ; addBinds ss2 $ do { ; gs <- repGuards guards ; match <- repMatch p1 gs ds ; wrapGenSyns (ss1++ss2) match }}} -repClauseTup :: Match Name -> DsM (Core M.ClauseQ) -repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = +repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) +repClauseTup (L _ (Match ps ty (GRHSs guards wheres ty2))) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { - ps1 <- repPs ps + ps1 <- repLPs ps ; (ss2,ds) <- repBinds wheres ; addBinds ss2 $ do { gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyns (ss1++ss2) clause }}} -repGuards :: [GRHS Name] -> DsM (Core M.BodyQ) -repGuards [GRHS [ResultStmt e loc] loc2] - = do {a <- repE e; repNormal a } +repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ) +repGuards [L _ (GRHS [L _ (ResultStmt e)])] + = do {a <- repLE e; repNormal a } repGuards other = do { zs <- mapM process other; repGuarded (nonEmptyCoreList (map corePair zs)) } where - process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _) - = do { x <- repE e1; y <- repE e2; return (x, y) } + process (L _ (GRHS [L _ (ExprStmt e1 ty), + L _ (ResultStmt e2)])) + = do { x <- repLE e1; y <- repLE e2; return (x, y) } process other = panic "Non Haskell 98 guarded body" -repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FieldExp]) +repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.FieldExp]) repFields flds = do - fnames <- mapM lookupOcc (map fst flds) - es <- mapM repE (map snd flds) + fnames <- mapM lookupLOcc (map fst flds) + es <- mapM repLE (map snd flds) fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es coreList fieldExpTyConName fs ----------------------------------------------------------------------------- -- Representing Stmt's is tricky, especially if bound variables --- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] +-- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] -- First gensym new names for every variable in any of the patterns. -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) -- if variables didn't shaddow, the static gensym wouldn't be necessary @@ -607,16 +573,19 @@ 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 [ResultStmt e loc] = - do { a <- repE e +repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repLSts stmts = repSts (map unLoc stmts) + +repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repSts [ResultStmt e] = + do { a <- repLE e ; e1 <- repNoBindSt a ; return ([], [e1]) } -repSts (BindStmt p e loc : ss) = - do { e2 <- repE e +repSts (BindStmt p e : ss) = + do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { - ; p1 <- repP p; + ; p1 <- repLP p; ; (ss2,zs) <- repSts ss ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }} @@ -625,8 +594,8 @@ repSts (LetStmt bs : ss) = ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } -repSts (ExprStmt e ty loc : ss) = - do { e2 <- repE e +repSts (ExprStmt e ty : ss) = + do { e2 <- repLE e ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } @@ -637,76 +606,77 @@ repSts other = panic "Exotic Stmt in meta brackets" -- Bindings ----------------------------------------------------------- -repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ]) +repBinds :: [HsBindGroup Name] -> DsM ([GenSymBind], Core [TH.DecQ]) repBinds decs - = do { let { bndrs = collectHsBinders decs } ; - 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 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' EmptyBinds = return [] -rep_binds' (ThenBinds x y) - = do { core1 <- rep_binds' x - ; core2 <- rep_binds' y - ; return (core1 ++ core2) } -rep_binds' (MonoBind bs sigs _) - = do { core1 <- rep_monobind' bs + = do { let { bndrs = map unLoc (collectGroupBinders 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 + ; ss <- mkGenSyms bndrs + ; core <- addBinds ss (rep_bind_groups decs) + ; core_list <- coreList decQTyConName core + ; return (ss, core_list) } + +rep_bind_groups :: [HsBindGroup Name] -> DsM [Core TH.DecQ] +-- Assumes: all the binders of the binding are alrady in the meta-env +rep_bind_groups binds = do + locs_cores_s <- mapM rep_bind_group binds + return $ de_loc $ sort_by_loc (concat locs_cores_s) + +rep_bind_group :: HsBindGroup Name -> DsM [(SrcSpan, Core TH.DecQ)] +-- Assumes: all the binders of the binding are alrady in the meta-env +rep_bind_group (HsBindGroup bs sigs _) + = do { core1 <- mapM rep_bind (bagToList bs) ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_binds' (IPBinds _ _) +rep_bind_group (HsIPBinds _) = panic "DsMeta:repBinds: can't do implicit parameters" -rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ] -rep_monobind binds = do locs_cores <- rep_monobind' binds - return $ de_loc $ sort_by_loc locs_cores +rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] +-- Assumes: all the binders of the binding are alrady in the meta-env +rep_binds binds = do + locs_cores <- mapM rep_bind (bagToList binds) + return $ de_loc $ sort_by_loc locs_cores -rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)] -rep_monobind' EmptyMonoBinds = return [] -rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x; - y1 <- rep_monobind' y; - return (x1 ++ y1) } +rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) +-- Assumes: all the binders of the binding are alrady in the meta-env -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_monobind' (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc) +rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))])) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) - ; fn' <- lookupBinder fn + ; fn' <- lookupLBinder fn ; p <- repPvar fn' ; ans <- repVal p guardcore wherecore - ; return [(loc, ans)] } + ; return (loc, ans) } -rep_monobind' (FunMonoBind fn infx ms loc) +rep_bind (L loc (FunBind fn infx ms)) = do { ms1 <- mapM repClauseTup ms - ; fn' <- lookupBinder fn + ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) - ; return [(loc, ans)] } + ; return (loc, ans) } -rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc) - = do { patcore <- repP pat +rep_bind (L loc (PatBind pat (GRHSs guards wheres ty2))) + = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore - ; return [(loc, ans)] } + ; return (loc, ans) } -rep_monobind' (VarMonoBind v e) +rep_bind (L loc (VarBind v e)) = do { v' <- lookupBinder v - ; e2 <- repE e + ; e2 <- repLE e ; x <- repNormal e2 ; patcore <- repPvar v' ; empty_decls <- coreList decQTyConName [] ; ans <- repVal patcore x empty_decls - ; return [(getSrcLoc v, ans)] } + ; return (srcLocSpan (getSrcLoc v), ans) } ----------------------------------------------------------------------------- --- Since everything in a MonoBind is mutually recursive we need rename all +-- Since everything in a Bind is mutually recursive we need rename all -- all the variables simultaneously. For example: -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to -- do { f'1 <- gensym "f" @@ -729,13 +699,12 @@ 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 ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ] - EmptyBinds _)) +repLambda :: LMatch Name -> DsM (Core TH.ExpQ) +repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [] _))) = do { let bndrs = collectPatsBinders ps ; - ; ss <- mkGenSyms bndrs + ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( - do { xs <- repPs ps; body <- repE e; repLam xs body }) + do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyns ss lam } repLambda z = panic "Can't represent a guarded lambda in Template Haskell" @@ -749,83 +718,84 @@ 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 ps = do { ps' <- mapM repP ps ; - coreList patTyConName ps' } +repLPs :: [LPat Name] -> DsM (Core [TH.Pat]) +repLPs ps = do { ps' <- mapM repLP ps ; + coreList patTyConName ps' } + +repLP :: LPat Name -> DsM (Core TH.Pat) +repLP (L _ p) = repP p -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' } -repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 } -repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 } -repP (ParPat p) = repP p -repP (ListPat ps _) = repListPat ps -repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs } +repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } +repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } +repP (ParPat p) = repLP p +repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } +repP (TuplePat ps _) = do { qs <- repLPs ps; repPtup qs } repP (ConPatIn dc details) - = do { con_str <- lookupOcc dc + = do { con_str <- lookupLOcc dc ; case details of - PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs } - RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs) - ; ps <- sequence $ map repP (map snd pairs) + PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } + RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs) + ; ps <- sequence $ map repLP (map snd pairs) ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps ; fps' <- coreList fieldPatTyConName fps ; repPrec con_str fps' } - InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs } + InfixCon p1 p2 -> do { qs <- repLPs [p1,p2]; repPcon con_str qs } } repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))" repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a } repP other = panic "Exotic pattern inside meta brackets" -repListPat :: [Pat Name] -> DsM (Core M.Pat) -repListPat [] = do { nil_con <- coreStringLit "[]" - ; nil_args <- coreList patTyConName [] - ; repPcon nil_con nil_args } -repListPat (p:ps) = do { p2 <- repP p - ; ps2 <- repListPat ps - ; cons_con <- coreStringLit ":" - ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) } - - ---------------------------------------------------------- -- Declaration ordering helpers -sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)] +sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)] sort_by_loc xs = sortBy comp xs where comp x y = compare (fst x) (fst y) -de_loc :: [(SrcLoc, a)] -> [a] +de_loc :: [(a, b)] -> [b] de_loc = map snd ---------------------------------------------------------- -- The meta-environment -- A name/identifier association for fresh names of locally bound entities --- type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id -- I.e. (x, x_id) means -- let x_id = gensym "x" in ... -- Generate a fresh name for a locally bound entity --- -mkGenSym :: Name -> DsM GenSymBind -mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) } --- Ditto for a list of names --- mkGenSyms :: [Name] -> DsM [GenSymBind] -mkGenSyms ns = mapM mkGenSym ns - --- Add a list of fresh names for locally bound entities to the meta --- environment (which is part of the state carried around by the desugarer --- monad) +-- 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 +-- +-- 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 +-- meta environment (which is part of the state carried around +-- by the desugarer monad) addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m -- Look up a locally bound name -- -lookupBinder :: Name -> DsM (Core String) +lookupLBinder :: Located Name -> DsM (Core TH.Name) +lookupLBinder (L _ n) = lookupBinder n + +lookupBinder :: Name -> DsM (Core TH.Name) lookupBinder n = do { mb_val <- dsLookupMetaEnv n; case mb_val of @@ -837,9 +807,12 @@ 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) +lookupLOcc :: Located Name -> DsM (Core TH.Name) -- Lookup an occurrence; it can't be a splice. -- Use the in-scope bindings if they exist +lookupLOcc (L _ n) = lookupOcc n + +lookupOcc :: Name -> DsM (Core TH.Name) lookupOcc n = do { mb_val <- dsLookupMetaEnv n ; case mb_val of @@ -848,59 +821,74 @@ 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 (TH.Q a) -> DsM (Core (TH.Q a)) -- wrapGenSyns [(nm1,id1), (nm2,id2)] y -- --> bindQ (gensym nm1) (\ id1 -> -- bindQ (gensym nm2 (\ id2 -> -- y)) -wrapGenSyns :: [GenSymBind] - -> Core (M.Q a) -> DsM (Core (M.Q a)) 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 --- Instead use the existing name --- Only used for [Decl] +-- Instead use the existing name: +-- let x = "x" in ... +-- Only used for [Decl], and for the class ops in class +-- and instance decls wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a) wrapNongenSyms binds (MkC body) = do { binds' <- mapM do_one binds ; 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) } -void = placeHolderType - -string :: String -> HsExpr Id -string s = HsLit (HsString (mkFastString s)) +occNameLit :: Name -> DsM (Core String) +occNameLit n = coreStringLit (occNameUserString (nameOccName n)) -- %********************************************************************* @@ -931,164 +919,167 @@ 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 [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 (LBangType Name) + -> DsM (Core TH.ConQ) repConstr con (PrefixCon ps) = do arg_tys <- mapM repBangTy ps arg_tys1 <- coreList strictTypeQTyConName arg_tys rep2 normalCName [unC con, unC arg_tys1] repConstr con (RecCon ips) - = do arg_vs <- mapM lookupOcc (map fst ips) + = do arg_vs <- mapM lookupLOcc (map fst ips) arg_tys <- mapM repBangTy (map snd ips) arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y]) arg_vs arg_tys @@ -1101,54 +1092,52 @@ 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 -> return $ HsInteger i - HsInt i -> return $ HsInteger i - HsFloatPrim r -> do rat_ty <- lookupType rationalTyConName - return $ HsRat r rat_ty - HsDoublePrim r -> do rat_ty <- lookupType rationalTyConName - return $ HsRat r rat_ty + HsIntPrim i -> mk_integer i + HsInt i -> mk_integer i + HsFloatPrim r -> mk_rational r + HsDoublePrim r -> mk_rational r _ -> return lit lit_expr <- dsLit lit' rep2 lit_name [lit_expr] where lit_name = case lit of - HsInteger _ -> integerLName + HsInteger _ _ -> integerLName HsInt _ -> integerLName HsIntPrim _ -> intPrimLName HsFloatPrim _ -> floatPrimLName @@ -1160,28 +1149,29 @@ repLiteral lit uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal" (ppr lit) -repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit) -repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInteger i) -repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ; - repLiteral (HsRat f rat_ty) } +mk_integer i = do integer_ty <- lookupType integerTyConName + return $ HsInteger i integer_ty +mk_rational r = do rat_ty <- lookupType rationalTyConName + return $ HsRat r rat_ty + +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 - -- the smart constructor 'THSyntax.rationalL' uses it in its type, + -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used --------------- Miscellaneous ------------------- -repLift :: Core e -> DsM (Core M.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] @@ -1209,7 +1199,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) @@ -1226,18 +1219,20 @@ coreVar id = MkC (Var id) -- 2) Make a "Name" -- 3) Add the name to knownKeyNames -templateHaskellNames :: NameSet +templateHaskellNames :: [Name] -- The names that are implicitly mentioned by ``bracket'' -- Should stay in sync with the import list of DsMeta -templateHaskellNames = mkNameSet [ - returnQName, bindQName, sequenceQName, gensymName, liftName, +templateHaskellNames = [ + returnQName, bindQName, sequenceQName, newNameName, liftName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameUName, + -- Lit charLName, stringLName, integerLName, intPrimLName, floatPrimLName, doublePrimLName, rationalLName, -- Pat litPName, varPName, tupPName, conPName, tildePName, - asPName, wildPName, recPName, + asPName, wildPName, recPName, listPName, -- FieldPat fieldPatName, -- Match @@ -1274,152 +1269,169 @@ templateHaskellNames = mkNameSet [ 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 - -thModule :: Module --- NB: the THSyntax module comes from the "haskell-src" package -thModule = mkThPkgModule mETA_META_Name - -mk_known_key_name space str uniq - = mkKnownKeyExternalName thModule (mkOccFS space str) uniq - -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 - +tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax" +tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib" + +thSyn :: Module +-- NB: the TH.Syntax module comes from the "haskell-src" package +thSyn = mkModule thPackage tH_SYN_Name +thLib = mkModule thPackage tH_LIB_Name + +mk_known_key_name mod space str uniq + = mkExternalName uniq mod (mkOccFS space str) + Nothing noSrcLoc + +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 + +-------------------- TH.Syntax ----------------------- +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 + + +-------------------- TH.Lib ----------------------- -- 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 +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 @@ -1442,6 +1454,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 @@ -1449,8 +1462,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 @@ -1470,15 +1489,16 @@ tildePIdKey = mkPreludeMiscIdUnique 224 asPIdKey = mkPreludeMiscIdUnique 225 wildPIdKey = mkPreludeMiscIdUnique 226 recPIdKey = mkPreludeMiscIdUnique 227 +listPIdKey = mkPreludeMiscIdUnique 228 -- type FieldPat = ... -fieldPatIdKey = mkPreludeMiscIdUnique 228 +fieldPatIdKey = mkPreludeMiscIdUnique 230 -- data Match = ... -matchIdKey = mkPreludeMiscIdUnique 229 +matchIdKey = mkPreludeMiscIdUnique 231 -- data Clause = ... -clauseIdKey = mkPreludeMiscIdUnique 230 +clauseIdKey = mkPreludeMiscIdUnique 232 -- data Exp = ... varEIdKey = mkPreludeMiscIdUnique 240 @@ -1554,14 +1574,3 @@ tupleTIdKey = mkPreludeMiscIdUnique 294 arrowTIdKey = mkPreludeMiscIdUnique 295 listTIdKey = mkPreludeMiscIdUnique 296 appTIdKey = mkPreludeMiscIdUnique 293 - --- %************************************************************************ --- %* * --- Other utilities --- %* * --- %************************************************************************ - --- It is rather usatisfactory that we don't have a SrcLoc -addDsWarn :: SDoc -> DsM () -addDsWarn msg = dsWarn (noSrcLoc, msg) -