-----------------------------------------------------------------------------
-module DsMeta( dsBracket,
+module DsMeta( dsBracket, dsReify,
templateHaskellNames, qTyConName,
- liftName, exprTyConName, declTyConName ) where
+ liftName, exprTyConName, declTyConName, typeTyConName,
+ decTyConName, typTyConName ) where
#include "HsVersions.h"
import {-# SOURCE #-} DsExpr ( dsExpr )
-import DsUtils ( mkListExpr, mkStringLit, mkCoreTup,
- mkIntExpr, mkCharExpr )
+import MatchLit ( dsLit )
+import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
import DsMonad
import qualified Language.Haskell.THSyntax as M
HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
HsBinds(..), MonoBinds(..), HsConDetails(..),
TyClDecl(..), HsGroup(..),
+ HsReify(..), ReifyFlavour(..),
HsType(..), HsContext(..), HsPred(..), HsTyOp(..),
HsTyVarBndr(..), Sig(..), ForeignDecl(..),
InstDecl(..), ConDecl(..), BangType(..),
PendingSplice, splitHsInstDeclTy,
placeHolderType, tyClDeclNames,
collectHsBinders, collectPatBinders, collectPatsBinders,
- hsTyVarName, hsConArgs, getBangType
+ hsTyVarName, hsConArgs, getBangType,
+ toHsType
)
-import PrelNames ( mETA_META_Name, varQual, tcQual )
+import PrelNames ( mETA_META_Name, rationalTyConName, negateName )
+import MkIface ( ifaceTyThing )
import Name ( Name, nameOccName, nameModule )
import OccName ( isDataOcc, isTvOcc, occNameUserString )
-import Module ( moduleUserString )
-import Id ( Id )
+-- 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 Module ( Module, mkThPkgModule, moduleUserString )
+import Id ( Id, idType )
+import Name ( mkKnownKeyExternalName )
+import OccName ( mkOccFS )
import NameEnv
import NameSet
-import Type ( Type, mkGenTyConApp )
+import Type ( Type, TyThing(..), mkGenTyConApp )
import TyCon ( DataConDetails(..) )
import TysWiredIn ( stringTy )
import CoreSyn
import Maybe ( catMaybes )
import Panic ( panic )
import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
-import BasicTypes ( NewOrData(..), StrictnessMark(..) )
+import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
import Outputable
import FastString ( mkFastString )
do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 }
do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
+-----------------------------------------------------------------------------
+dsReify :: HsReify Id -> DsM CoreExpr
+-- Returns a CoreExpr of type reifyType --> M.Type
+-- reifyDecl --> M.Decl
+-- 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 |]
-- Declarations
-------------------------------------------------------
-repTopDs :: HsGroup Name -> DsM (Core [M.Decl])
+repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
repTopDs group
= do { let { bndrs = groupBinders group } ;
ss <- mkGenSyms bndrs ;
+ -- Bind all the names mainly to avoid repeated use of explicit strings.
+ -- Thus we get
+ -- do { t :: String <- genSym "T" ;
+ -- return (Data t [] ...more t's... }
+ -- The other important reason is that the output must mention
+ -- only "T", not "Foo.T" where Foo is the current module
+
+
decls <- addBinds ss (do {
val_ds <- rep_binds (hs_valds group) ;
tycl_ds <- mapM repTyClD (hs_tyclds group) ;
-- more needed
return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
- core_list <- coreList declTyConName decls ;
- wrapNongenSyms ss core_list
+ decl_ty <- lookupType declTyConName ;
+ let { core_list = coreList' decl_ty decls } ;
+ q_decs <- repSequenceQ decl_ty core_list ;
+
+ wrapNongenSyms ss q_decs
-- Do *not* gensym top-level binders
}
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]
+{- Note [Binders and occurrences]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we desugar [d| data T = MkT |]
+we want to get
+ Data "T" [] [Con "MkT" []] []
+and *not*
+ Data "Foo:T" [] [Con "Foo:MkT" []] []
+That is, the new data decl should fit into whatever new module it is
+asked to fit in. We do *not* clone, though; no need for this:
+ Data "T79" ....
+
+But if we see this:
+ data T = MkT
+ foo = reifyDecl T
+
+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
+in repTyClD and repC.
+
+-}
+
repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))
repTyClD (TyData { tcdND = DataType, tcdCtxt = [],
tcdName = tc, tcdTyVars = tvs,
tcdCons = DataCons cons, tcdDerivs = mb_derivs })
- = do { tc1 <- lookupBinder tc ;
+ = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
tvs1 <- repTvs tvs ;
cons1 <- mapM repC cons ;
cons2 <- coreList consTyConName cons1 ;
tcdTyVars = tvs, tcdFDs = [],
tcdSigs = sigs, tcdMeths = Just binds
})
- = do { cls1 <- lookupBinder cls ;
+ = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences]
tvs1 <- repTvs tvs ;
cxt1 <- repCtxt cxt ;
sigs1 <- rep_sigs sigs ;
repC :: ConDecl Name -> DsM (Core M.Cons)
repC (ConDecl con [] [] details loc)
- = do { con1 <- lookupBinder con ;
+ = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
arg_tys <- mapM (repBangTy con) (hsConArgs details) ;
arg_tys1 <- coreList typeTyConName arg_tys ;
repConstr con1 arg_tys1 }
repTy other_ty = pprPanic "repTy" (ppr other_ty) -- HsForAllTy, HsKindSig
------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
-- Expressions
------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
repEs es = do { es' <- mapM repE es ;
coreList exprTyConName 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.Expr)
-repE (HsVar x)
- = do { mb_val <- dsLookupMetaEnv x
- ; case mb_val of
- Nothing -> do { str <- globalVar x
- ; repVarOrCon x str }
- Just (Bound y) -> repVarOrCon x (coreVar y)
- Just (Splice e) -> do { e' <- dsExpr e
- ; return (MkC e') } }
-
-repE (HsIPVar x) = panic "Can't represent implicit parameters"
-repE (HsLit l) = do { a <- repLiteral l; repLit a }
-repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
-
-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 (HsLam m) = repLambda m
-repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
-repE (NegApp x nm) = panic "No negate yet"
-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 (OpApp e1 (HsVar op) fix e2)
- = do { arg1 <- repE e1;
- arg2 <- repE e2;
- the_op <- lookupOcc op ;
- repInfixApp arg1 the_op arg2 }
-
-repE (HsCase e ms loc)
- = do { arg <- repE e
- ; ms2 <- mapM repMatchTup ms
- ; repCaseE arg (nonEmptyCoreList ms2) }
-
--- I havn't got the types here right yet
-repE (HsDo DoExpr sts _ ty loc) = do { (ss,zs) <- repSts sts;
- e <- repDoE (nonEmptyCoreList zs);
- wrapGenSyns expTyConName ss e }
-repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts;
- e <- repComp (nonEmptyCoreList zs);
- wrapGenSyns expTyConName ss e }
-
-repE (ArithSeqIn (From e)) = do { ds1 <- repE e; repFrom ds1 }
-repE (ArithSeqIn (FromThen e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
- repFromThen ds1 ds2 }
-repE (ArithSeqIn (FromTo e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
- repFromTo ds1 ds2 }
-repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2;
- ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 }
-
-repE (HsIf x y z loc) = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c }
-
-repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
- ; e2 <- addBinds ss (repE e)
- ; z <- repLetE ds e2
- ; wrapGenSyns expTyConName ss z }
-repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
-repE (ExplicitTuple es boxed) = do { xs <- repEs es; repTup xs }
-
-repE (HsWith _ _ _) = panic "No with for implicit parameters yet"
-repE (ExplicitPArr ty es) = panic "No parallel arrays yet"
-repE (RecordConOut _ _ _) = panic "No record construction yet"
-repE (RecordUpdOut _ _ _ _) = panic "No record update yet"
-repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet"
-
+repE (HsVar x) =
+ do { mb_val <- dsLookupMetaEnv x
+ ; case mb_val of
+ Nothing -> do { str <- globalVar x
+ ; repVarOrCon x str }
+ Just (Bound y) -> repVarOrCon x (coreVar y)
+ Just (Splice e) -> do { e' <- dsExpr e
+ ; return (MkC e') } }
+repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
+
+ -- Remember, we're desugaring renamer output here, so
+ -- HsOverlit can definitely occur
+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 (OpApp e1 op fix e2) =
+ case op of
+ HsVar op -> do { arg1 <- repE e1;
+ arg2 <- repE e2;
+ the_op <- lookupOcc op ;
+ repInfixApp arg1 the_op arg2 }
+ _ -> panic "DsMeta.repE: Operator is not a variable"
+repE (NegApp x nm) = do
+ a <- repE 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
+ ; ms2 <- mapM repMatchTup ms
+ ; repCaseE arg (nonEmptyCoreList ms2) }
+repE (HsIf x y z loc) = do
+ a <- repE x
+ b <- repE y
+ c <- repE z
+ repCond a b c
+repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
+ ; e2 <- addBinds ss (repE e)
+ ; z <- repLetE ds e2
+ ; wrapGenSyns expTyConName ss z }
+-- FIXME: I haven't got the types here right yet
+repE (HsDo DoExpr sts _ ty loc)
+ = do { (ss,zs) <- repSts sts;
+ e <- repDoE (nonEmptyCoreList zs);
+ wrapGenSyns expTyConName ss e }
+repE (HsDo ListComp sts _ ty loc)
+ = do { (ss,zs) <- repSts sts;
+ e <- repComp (nonEmptyCoreList zs);
+ wrapGenSyns expTyConName ss e }
+repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
+repE (ExplicitList ty es) = do { xs <- repEs 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 }
+ | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
+repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet"
+repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
+
+repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
+repE (ArithSeqIn aseq) =
+ case aseq of
+ From e -> do { ds1 <- repE e; repFrom ds1 }
+ FromThen e1 e2 -> do
+ ds1 <- repE e1
+ ds2 <- repE e2
+ repFromThen ds1 ds2
+ FromTo e1 e2 -> do
+ ds1 <- repE e1
+ ds2 <- repE e2
+ repFromTo ds1 ds2
+ FromThenTo e1 e2 e3 -> do
+ ds1 <- repE e1
+ ds2 <- repE e2
+ ds3 <- repE e3
+ repFromThenTo ds1 ds2 ds3
+repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
+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)
-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt,
= do { core1 <- rep_monobind bs
; core2 <- rep_sigs sigs
; return (core1 ++ core2) }
+rep_binds (IPBinds _ _)
+ = panic "DsMeta:repBinds: can't do implicit parameters"
rep_monobind :: MonoBinds Name -> DsM [Core M.Decl]
rep_monobind EmptyMonoBinds = return []
RecCon pairs -> error "No records in template haskell yet"
InfixCon p1 p2 -> do { qs <- repPs [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.Patt)
addBinds :: [GenSymBind] -> DsM a -> DsM a
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
-lookupBinder :: Name -> DsM (Core String)
-lookupBinder n
- = do { mb_val <- dsLookupMetaEnv n;
- case mb_val of
- Just (Bound id) -> return (MkC (Var id))
- other -> pprPanic "Failed binder lookup:" (ppr n) }
-
mkGenSym :: Name -> DsM GenSymBind
mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
mkGenSyms :: [Name] -> DsM [GenSymBind]
mkGenSyms ns = mapM mkGenSym ns
+lookupBinder :: Name -> DsM (Core String)
+lookupBinder n
+ = do { mb_val <- dsLookupMetaEnv n;
+ case mb_val of
+ Just (Bound x) -> return (coreVar x)
+ other -> pprPanic "Failed binder lookup:" (ppr n) }
+
+lookupOcc :: Name -> DsM (Core String)
+-- Lookup an occurrence; it can't be a splice.
+-- Use the in-scope bindings if they exist
+lookupOcc n
+ = do { mb_val <- dsLookupMetaEnv n ;
+ case mb_val of
+ Nothing -> globalVar n
+ Just (Bound x) -> return (coreVar x)
+ 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.Expr)
-> DsM Type -- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
-- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name
-- Only used for [Decl]
-wrapNongenSyms :: [GenSymBind]
- -> Core [M.Decl] -> DsM (Core [M.Decl])
-wrapNongenSyms binds body@(MkC b)
- = go binds
+wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
+wrapNongenSyms binds (MkC body)
+ = do { binds' <- mapM do_one binds ;
+ return (MkC (mkLets binds' body)) }
where
- go [] = return body
- go ((name,id) : binds)
- = do { MkC body' <- go binds
- ; MkC lit_str <- localVar name -- No gensym
- ; return (MkC (Let (NonRec id lit_str) body'))
- }
+ do_one (name,id)
+ = do { MkC lit_str <- localVar name -- No gensym
+ ; return (NonRec id lit_str) }
void = placeHolderType
repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
repListExp (MkC es) = rep2 listExpName [es]
+repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
+repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
+
repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
-- Literals
repLiteral :: HsLit -> DsM (Core M.Lit)
-repLiteral (HsInt i) = rep2 intLName [mkIntExpr i]
-repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
-repLiteral x = panic "trying to represent exotic literal"
-
-repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
-repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i]
-repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
-
+repLiteral lit
+ = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] }
+ where
+ lit_name = case lit of
+ HsInteger _ -> integerLName
+ HsChar _ -> charLName
+ HsString _ -> stringLName
+ HsRat _ _ -> rationalLName
+ other -> uh_oh
+ 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) }
+ -- The type Rational will be in the environment, becuase
+ -- the smart constructor 'THSyntax.rationalL' uses it in its type,
+ -- and rationalL is sucked in when any TH stuff is used
--------------- Miscellaneous -------------------
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 ty_a (MkC list)
+ = rep2 sequenceQName [Type ty_a, list]
+
------------ Lists and Tuples -------------------
-- turn a list of patterns into a single pattern matching a list
corePair :: (Core a, Core b) -> Core (a,b)
corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
-lookupOcc :: Name -> DsM (Core String)
--- Lookup an occurrence; it can't be a splice.
--- Use the in-scope bindings if they exist
-lookupOcc n
- = do { mb_val <- dsLookupMetaEnv n ;
- case mb_val of
- Nothing -> globalVar n
- Just (Bound x) -> return (coreVar x)
- other -> 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))
-
coreStringLit :: String -> DsM (Core String)
coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
-- The names that are implicitly mentioned by ``bracket''
-- Should stay in sync with the import list of DsMeta
templateHaskellNames
- = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName,
+ = mkNameSet [ integerLName,charLName, stringLName, rationalLName,
+ plitName, pvarName, ptupName,
pconName, ptildeName, paspatName, pwildName,
varName, conName, litName, appName, infixEName, lamName,
tupName, doEName, compName,
- listExpName, condName, letEName, caseEName,
- infixAppName, sectionLName, sectionRName, guardedName, normalName,
+ listExpName, sigExpName, condName, letEName, caseEName,
+ infixAppName, sectionLName, sectionRName,
+ guardedName, normalName,
bindStName, letStName, noBindStName, parStName,
fromName, fromThenName, fromToName, fromThenToName,
funName, valName, liftName,
- gensymName, returnQName, bindQName,
+ gensymName, returnQName, bindQName, sequenceQName,
matchName, clauseName, funName, valName, dataDName, classDName,
instName, protoName, tvarName, tconName, tappName,
arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
constrName,
exprTyConName, declTyConName, pattTyConName, mtchTyConName,
clseTyConName, stmtTyConName, consTyConName, typeTyConName,
- qTyConName, expTyConName, matTyConName, clsTyConName ]
-
-
-
-intLName = varQual mETA_META_Name FSLIT("intL") intLIdKey
-charLName = varQual mETA_META_Name FSLIT("charL") charLIdKey
-plitName = varQual mETA_META_Name FSLIT("plit") plitIdKey
-pvarName = varQual mETA_META_Name FSLIT("pvar") pvarIdKey
-ptupName = varQual mETA_META_Name FSLIT("ptup") ptupIdKey
-pconName = varQual mETA_META_Name FSLIT("pcon") pconIdKey
-ptildeName = varQual mETA_META_Name FSLIT("ptilde") ptildeIdKey
-paspatName = varQual mETA_META_Name FSLIT("paspat") paspatIdKey
-pwildName = varQual mETA_META_Name FSLIT("pwild") pwildIdKey
-varName = varQual mETA_META_Name FSLIT("var") varIdKey
-conName = varQual mETA_META_Name FSLIT("con") conIdKey
-litName = varQual mETA_META_Name FSLIT("lit") litIdKey
-appName = varQual mETA_META_Name FSLIT("app") appIdKey
-infixEName = varQual mETA_META_Name FSLIT("infixE") infixEIdKey
-lamName = varQual mETA_META_Name FSLIT("lam") lamIdKey
-tupName = varQual mETA_META_Name FSLIT("tup") tupIdKey
-doEName = varQual mETA_META_Name FSLIT("doE") doEIdKey
-compName = varQual mETA_META_Name FSLIT("comp") compIdKey
-listExpName = varQual mETA_META_Name FSLIT("listExp") listExpIdKey
-condName = varQual mETA_META_Name FSLIT("cond") condIdKey
-letEName = varQual mETA_META_Name FSLIT("letE") letEIdKey
-caseEName = varQual mETA_META_Name FSLIT("caseE") caseEIdKey
-infixAppName = varQual mETA_META_Name FSLIT("infixApp") infixAppIdKey
-sectionLName = varQual mETA_META_Name FSLIT("sectionL") sectionLIdKey
-sectionRName = varQual mETA_META_Name FSLIT("sectionR") sectionRIdKey
-guardedName = varQual mETA_META_Name FSLIT("guarded") guardedIdKey
-normalName = varQual mETA_META_Name FSLIT("normal") normalIdKey
-bindStName = varQual mETA_META_Name FSLIT("bindSt") bindStIdKey
-letStName = varQual mETA_META_Name FSLIT("letSt") letStIdKey
-noBindStName = varQual mETA_META_Name FSLIT("noBindSt") noBindStIdKey
-parStName = varQual mETA_META_Name FSLIT("parSt") parStIdKey
-fromName = varQual mETA_META_Name FSLIT("from") fromIdKey
-fromThenName = varQual mETA_META_Name FSLIT("fromThen") fromThenIdKey
-fromToName = varQual mETA_META_Name FSLIT("fromTo") fromToIdKey
-fromThenToName = varQual mETA_META_Name FSLIT("fromThenTo") fromThenToIdKey
-liftName = varQual mETA_META_Name FSLIT("lift") liftIdKey
-gensymName = varQual mETA_META_Name FSLIT("gensym") gensymIdKey
-returnQName = varQual mETA_META_Name FSLIT("returnQ") returnQIdKey
-bindQName = varQual mETA_META_Name FSLIT("bindQ") bindQIdKey
+ qTyConName, expTyConName, matTyConName, clsTyConName,
+ decTyConName, typTyConName ]
+
+
+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
+
+integerLName = varQual FSLIT("integerL") integerLIdKey
+charLName = varQual FSLIT("charL") charLIdKey
+stringLName = varQual FSLIT("stringL") stringLIdKey
+rationalLName = varQual FSLIT("rationalL") rationalLIdKey
+plitName = varQual FSLIT("plit") plitIdKey
+pvarName = varQual FSLIT("pvar") pvarIdKey
+ptupName = varQual FSLIT("ptup") ptupIdKey
+pconName = varQual FSLIT("pcon") pconIdKey
+ptildeName = varQual FSLIT("ptilde") ptildeIdKey
+paspatName = varQual FSLIT("paspat") paspatIdKey
+pwildName = varQual FSLIT("pwild") pwildIdKey
+varName = varQual FSLIT("var") varIdKey
+conName = varQual FSLIT("con") conIdKey
+litName = varQual FSLIT("lit") litIdKey
+appName = varQual FSLIT("app") appIdKey
+infixEName = varQual FSLIT("infixE") infixEIdKey
+lamName = varQual FSLIT("lam") lamIdKey
+tupName = varQual FSLIT("tup") tupIdKey
+doEName = varQual FSLIT("doE") doEIdKey
+compName = varQual FSLIT("comp") compIdKey
+listExpName = varQual FSLIT("listExp") listExpIdKey
+sigExpName = varQual FSLIT("sigExp") sigExpIdKey
+condName = varQual FSLIT("cond") condIdKey
+letEName = varQual FSLIT("letE") letEIdKey
+caseEName = varQual FSLIT("caseE") caseEIdKey
+infixAppName = varQual FSLIT("infixApp") infixAppIdKey
+sectionLName = varQual FSLIT("sectionL") sectionLIdKey
+sectionRName = varQual FSLIT("sectionR") sectionRIdKey
+guardedName = varQual FSLIT("guarded") guardedIdKey
+normalName = varQual FSLIT("normal") normalIdKey
+bindStName = varQual FSLIT("bindSt") bindStIdKey
+letStName = varQual FSLIT("letSt") letStIdKey
+noBindStName = varQual FSLIT("noBindSt") noBindStIdKey
+parStName = varQual FSLIT("parSt") parStIdKey
+fromName = varQual FSLIT("from") fromIdKey
+fromThenName = varQual FSLIT("fromThen") fromThenIdKey
+fromToName = varQual FSLIT("fromTo") fromToIdKey
+fromThenToName = varQual FSLIT("fromThenTo") fromThenToIdKey
+liftName = varQual FSLIT("lift") liftIdKey
+gensymName = varQual FSLIT("gensym") gensymIdKey
+returnQName = varQual FSLIT("returnQ") returnQIdKey
+bindQName = varQual FSLIT("bindQ") bindQIdKey
+sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey
-- type Mat = ...
-matchName = varQual mETA_META_Name FSLIT("match") matchIdKey
-
--- type Cls = ...
-clauseName = varQual mETA_META_Name FSLIT("clause") clauseIdKey
-
--- data Dec = ...
-funName = varQual mETA_META_Name FSLIT("fun") funIdKey
-valName = varQual mETA_META_Name FSLIT("val") valIdKey
-dataDName = varQual mETA_META_Name FSLIT("dataD") dataDIdKey
-classDName = varQual mETA_META_Name FSLIT("classD") classDIdKey
-instName = varQual mETA_META_Name FSLIT("inst") instIdKey
-protoName = varQual mETA_META_Name FSLIT("proto") protoIdKey
-
--- data Typ = ...
-tvarName = varQual mETA_META_Name FSLIT("tvar") tvarIdKey
-tconName = varQual mETA_META_Name FSLIT("tcon") tconIdKey
-tappName = varQual mETA_META_Name FSLIT("tapp") tappIdKey
-
--- data Tag = ...
-arrowTyConName = varQual mETA_META_Name FSLIT("arrowTyCon") arrowIdKey
-tupleTyConName = varQual mETA_META_Name FSLIT("tupleTyCon") tupleIdKey
-listTyConName = varQual mETA_META_Name FSLIT("listTyCon") listIdKey
-namedTyConName = varQual mETA_META_Name FSLIT("namedTyCon") namedTyConIdKey
-
--- data Con = ...
-constrName = varQual mETA_META_Name FSLIT("constr") constrIdKey
-
-exprTyConName = tcQual mETA_META_Name FSLIT("Expr") exprTyConKey
-declTyConName = tcQual mETA_META_Name FSLIT("Decl") declTyConKey
-pattTyConName = tcQual mETA_META_Name FSLIT("Patt") pattTyConKey
-mtchTyConName = tcQual mETA_META_Name FSLIT("Mtch") mtchTyConKey
-clseTyConName = tcQual mETA_META_Name FSLIT("Clse") clseTyConKey
-stmtTyConName = tcQual mETA_META_Name FSLIT("Stmt") stmtTyConKey
-consTyConName = tcQual mETA_META_Name FSLIT("Cons") consTyConKey
-typeTyConName = tcQual mETA_META_Name FSLIT("Type") typeTyConKey
-
-qTyConName = tcQual mETA_META_Name FSLIT("Q") qTyConKey
-expTyConName = tcQual mETA_META_Name FSLIT("Exp") expTyConKey
-matTyConName = tcQual mETA_META_Name FSLIT("Mat") matTyConKey
-clsTyConName = tcQual mETA_META_Name FSLIT("Cls") clsTyConKey
+matchName = varQual FSLIT("match") matchIdKey
+
+-- type Cls = ...
+clauseName = varQual FSLIT("clause") clauseIdKey
+
+-- data Dec = ...
+funName = varQual FSLIT("fun") funIdKey
+valName = varQual FSLIT("val") valIdKey
+dataDName = varQual FSLIT("dataD") dataDIdKey
+classDName = varQual FSLIT("classD") classDIdKey
+instName = varQual FSLIT("inst") instIdKey
+protoName = varQual FSLIT("proto") protoIdKey
+
+-- data Typ = ...
+tvarName = varQual FSLIT("tvar") tvarIdKey
+tconName = varQual FSLIT("tcon") tconIdKey
+tappName = varQual FSLIT("tapp") tappIdKey
+
+-- data Tag = ...
+arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey
+tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey
+listTyConName = varQual FSLIT("listTyCon") listIdKey
+namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey
+
+-- data Con = ...
+constrName = varQual FSLIT("constr") constrIdKey
+
+exprTyConName = tcQual FSLIT("Expr") exprTyConKey
+declTyConName = tcQual FSLIT("Decl") declTyConKey
+pattTyConName = tcQual FSLIT("Patt") pattTyConKey
+mtchTyConName = tcQual FSLIT("Mtch") mtchTyConKey
+clseTyConName = tcQual FSLIT("Clse") clseTyConKey
+stmtTyConName = tcQual FSLIT("Stmt") stmtTyConKey
+consTyConName = tcQual FSLIT("Cons") consTyConKey
+typeTyConName = tcQual FSLIT("Type") typeTyConKey
+
+qTyConName = tcQual FSLIT("Q") qTyConKey
+expTyConName = tcQual FSLIT("Exp") expTyConKey
+decTyConName = tcQual FSLIT("Dec") decTyConKey
+typTyConName = tcQual FSLIT("Typ") typTyConKey
+matTyConName = tcQual FSLIT("Mat") matTyConKey
+clsTyConName = tcQual FSLIT("Cls") clsTyConKey
-- TyConUniques available: 100-119
-- Check in PrelNames if you want to change this
stmtTyConKey = mkPreludeTyConUnique 109
consTyConKey = mkPreludeTyConUnique 110
typeTyConKey = mkPreludeTyConUnique 111
+typTyConKey = mkPreludeTyConUnique 112
+decTyConKey = mkPreludeTyConUnique 113
+
-- IdUniques available: 200-299
protoIdKey = mkPreludeMiscIdUnique 210
matchIdKey = mkPreludeMiscIdUnique 211
clauseIdKey = mkPreludeMiscIdUnique 212
-intLIdKey = mkPreludeMiscIdUnique 213
+integerLIdKey = mkPreludeMiscIdUnique 213
charLIdKey = mkPreludeMiscIdUnique 214
classDIdKey = mkPreludeMiscIdUnique 215
instIdKey = mkPreludeMiscIdUnique 216
dataDIdKey = mkPreludeMiscIdUnique 217
+sequenceQIdKey = mkPreludeMiscIdUnique 218
plitIdKey = mkPreludeMiscIdUnique 220
pvarIdKey = mkPreludeMiscIdUnique 221
letEIdKey = mkPreludeMiscIdUnique 239
caseEIdKey = mkPreludeMiscIdUnique 240
infixAppIdKey = mkPreludeMiscIdUnique 241
-sectionLIdKey = mkPreludeMiscIdUnique 242
-sectionRIdKey = mkPreludeMiscIdUnique 243
-guardedIdKey = mkPreludeMiscIdUnique 244
-normalIdKey = mkPreludeMiscIdUnique 245
-bindStIdKey = mkPreludeMiscIdUnique 246
-letStIdKey = mkPreludeMiscIdUnique 247
-noBindStIdKey = mkPreludeMiscIdUnique 248
-parStIdKey = mkPreludeMiscIdUnique 249
-
-tvarIdKey = mkPreludeMiscIdUnique 250
-tconIdKey = mkPreludeMiscIdUnique 251
-tappIdKey = mkPreludeMiscIdUnique 252
-
-arrowIdKey = mkPreludeMiscIdUnique 253
-tupleIdKey = mkPreludeMiscIdUnique 254
-listIdKey = mkPreludeMiscIdUnique 255
-namedTyConIdKey = mkPreludeMiscIdUnique 256
-
-constrIdKey = mkPreludeMiscIdUnique 257
+-- 242 unallocated
+sectionLIdKey = mkPreludeMiscIdUnique 243
+sectionRIdKey = mkPreludeMiscIdUnique 244
+guardedIdKey = mkPreludeMiscIdUnique 245
+normalIdKey = mkPreludeMiscIdUnique 246
+bindStIdKey = mkPreludeMiscIdUnique 247
+letStIdKey = mkPreludeMiscIdUnique 248
+noBindStIdKey = mkPreludeMiscIdUnique 249
+parStIdKey = mkPreludeMiscIdUnique 250
+
+tvarIdKey = mkPreludeMiscIdUnique 251
+tconIdKey = mkPreludeMiscIdUnique 252
+tappIdKey = mkPreludeMiscIdUnique 253
+
+arrowIdKey = mkPreludeMiscIdUnique 254
+tupleIdKey = mkPreludeMiscIdUnique 255
+listIdKey = mkPreludeMiscIdUnique 256
+namedTyConIdKey = mkPreludeMiscIdUnique 257
+
+constrIdKey = mkPreludeMiscIdUnique 258
+
+stringLIdKey = mkPreludeMiscIdUnique 259
+rationalLIdKey = mkPreludeMiscIdUnique 260
+
+sigExpIdKey = mkPreludeMiscIdUnique 261
+
+
-- %************************************************************************
-- %* *
projects / ghc-hetmet.git / blobdiff