-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
-- input HsExpr. We do this in the DsM monad, which supplies access to
-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
+--
+-- It also defines a bunch of knownKeyNames, in the same way as is done
+-- in prelude/PrelNames. It's much more convenient to do it here, becuase
+-- otherwise we have to recompile PrelNames whenever we add a Name, which is
+-- a Royal Pain (triggers other recompilation).
-----------------------------------------------------------------------------
-module DsMeta( dsBracket ) where
+module DsMeta( dsBracket,
+ templateHaskellNames, qTyConName, nameTyConName,
+ liftName, expQTyConName, decQTyConName, typeQTyConName,
+ decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
+ ) where
#include "HsVersions.h"
import {-# SOURCE #-} DsExpr ( dsExpr )
-import DsUtils ( mkListExpr, mkStringLit, mkCoreTup,
- mkIntExpr, mkCharExpr )
+import MatchLit ( dsLit )
+import DsUtils ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
import DsMonad
-import qualified Language.Haskell.THSyntax as M
-
-import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
- Match(..), GRHSs(..), GRHS(..), HsBracket(..),
- HsDoContext(ListComp,DoExpr), ArithSeqInfo(..),
- HsBinds(..), MonoBinds(..), HsConDetails(..),
- HsDecl(..), TyClDecl(..), ForeignDecl(..),
- PendingSplice,
- placeHolderType, tyClDeclNames,
- collectHsBinders, collectMonoBinders,
- collectPatBinders, collectPatsBinders
- )
-
-import Name ( Name, nameOccName, nameModule )
-import OccName ( isDataOcc, occNameUserString )
-import Module ( moduleUserString )
-import PrelNames ( intLName,charLName,
- plitName, pvarName, ptupName, pconName,
- ptildeName, paspatName, pwildName,
- varName, conName, litName, appName, lamName,
- tupName, doEName, compName,
- listExpName, condName, letEName, caseEName,
- infixAppName, guardedName, normalName,
- bindStName, letStName, noBindStName,
- fromName, fromThenName, fromToName, fromThenToName,
- funName, valName, matchName, clauseName,
- liftName, gensymName, bindQName,
- matTyConName, expTyConName, clsTyConName,
- pattTyConName, exprTyConName, declTyConName
- )
-
-import Id ( Id )
+import qualified Language.Haskell.TH as TH
+
+import HsSyn
+import Class (FunDep)
+import PrelNames ( rationalTyConName, integerTyConName, negateName )
+import OccName ( isDataOcc, isTvOcc, occNameString )
+-- 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
+
+import Module ( Module, mkModule, moduleString )
+import Id ( Id, mkLocalId )
+import OccName ( mkOccNameFS )
+import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
+ isExternalName, getSrcLoc )
import NameEnv
-import Type ( Type, mkGenTyConApp )
-import TysWiredIn ( stringTy )
+import Type ( Type, mkTyConApp )
+import TcType ( tcTyConAppArgs )
+import TyCon ( tyConName )
+import TysWiredIn ( parrTyCon )
import CoreSyn
import CoreUtils ( exprType )
-import Panic ( panic )
-
+import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
+import Maybe ( catMaybes )
+import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
+import BasicTypes ( isBoxed )
import Outputable
-import FastString ( mkFastString )
+import Bag ( bagToList, unionManyBags )
+import FastString ( unpackFS )
+import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
+
+import Monad ( zipWithM )
+import List ( sortBy )
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
--- Returns a CoreExpr of type M.Expr
+-- 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 (ExpBr e) splices
- = dsExtendMetaEnv new_bit (repE e) `thenDs` \ (MkC new_e) ->
- returnDs new_e
+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 (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 }
{- -------------- Examples --------------------
-}
------------------------------------------------------------------------------
--- repD
-
-{-
-repDs :: [HsDecl Name] -> DsM (Core [M.Decl])
-repDs decls
- = do { ds' <- mapM repD ds ;
- coreList declTyConName ds' }
-
-repD :: HsDecl Name -> DsM (Core M.Decl)
-repD (TyClD (TyData { tcdND = DataType, tcdCtxt = [],
- tcdName = tc, tcdTyVars = tvs,
- tcdCons = cons, tcdDerivs = mb_derivs }))
- = do { tc1 <- localVar tc ;
- cons1 <- mapM repCon cons ;
- tvs1 <- repTvs tvs ;
- cons2 <- coreList consTyConName cons1 ;
- derivs1 <- repDerivs mb_derivs ;
- derivs2 <- coreList stringTyConName derivs1 ;
- repData tc1 tvs1 cons2 derivs2 }
-
-repD (TyClD (ClassD { tcdCtxt = cxt, tcdName = cls,
- tcdTyVars = tvs, tcdFDs = [],
- tcdSigs = sigs, tcdMeths = Just decls
- }))
- = do { cls1 <- localVar cls ;
- tvs1 <- repTvs tvs ;
- cxt1 <- repCtxt cxt ;
- sigs1 <- repSigs sigs ;
- repClass cxt1 cls1 tvs1 sigs1 }
-
-repD (InstD (InstDecl ty binds _ _ loc))
- -- Ignore user pragmas for now
- = do { cls1 <- localVar cls ;
- cxt1 <- repCtxt cxt ;
- tys1 <- repTys tys ;
- binds1 <- repMonoBind binds ;
- binds2 <- coreList declTyConName binds1 ;
- repInst ... binds2 }
- where
- (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
+-------------------------------------------------------
+-- Declarations
+-------------------------------------------------------
+
+repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
+repTopDs group
+ = 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
+ -- 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_val_binds (hs_valds group) ;
+ tycl_ds <- mapM repTyClD (hs_tyclds group) ;
+ inst_ds <- mapM repInstD' (hs_instds group) ;
+ for_ds <- mapM repForD (hs_fords group) ;
+ -- more needed
+ return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
+
+ decl_ty <- lookupType decQTyConName ;
+ let { core_list = coreList' decl_ty decls } ;
+
+ dec_ty <- lookupType decTyConName ;
+ q_decs <- repSequenceQ dec_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
+ = collectHsValBinders val_decls ++
+ [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
+ [n | L _ (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.
+And we use lookupOcc, rather than lookupBinder
+in repTyClD and repC.
--- Un-handled cases
-repD d = do { dsWarn (hang (ptext SLIT("Cannot desugar this Template Haskell declaration:"))
- 4 (ppr d)) ;
- return (ValD EmptyBinds) -- A sort of empty decl
- }
-
-repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
-repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
- coreList stringTyConName tvs1 }
-
-repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
-repCtxt ctxt
- = do {
-
-repTy :: HsType Name -> DsM (Core M.Type)
-repTy ty@(HsForAllTy _ cxt ty)
- = pprPanic "repTy" (ppr ty)
-
-repTy (HsTyVar tv)
- = do { tv1 <- localVar tv ; repTvar tv1 }
-
-repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a2 }
-repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
-repTy (HsListTy t) = do { t1 <- repTy t ; list <- repListTyCon ; repTapp tcon t1 }
-
-repTy (HsTupleTy tc tys)
- = do
-repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2)
-repTy (HsOpTy ty1 (HsTyOp n) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
-repTy (HsParTy t) = repTy t
-repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsApp (HsTyVar c) tys)
-
- | HsTupleTy HsTupCon
- [HsType name] -- Element types (length gives arity)
-
- | HsKindSig (HsType name) -- (ty :: kind)
- Kind -- A type with a kind signature
-}
------------------------------------------------------------------------------
--- Using the phantom type constructors "repConstructor" we define repE
--- This ensures we keep the types of the CoreExpr objects we build are
--- consistent with their real types.
+repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
+
+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 <- repLContext cxt ;
+ cons1 <- mapM repC cons ;
+ cons2 <- coreList conQTyConName cons1 ;
+ derivs1 <- repDerivs mb_derivs ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
+ return $ Just (loc, dec) }
+
+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 <- repLContext cxt ;
+ con1 <- repC con ;
+ derivs1 <- repDerivs mb_derivs ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
+ return $ Just (loc, dec) }
+
+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 <- repLTy ty ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repTySyn tc1 bndrs1 ty1 } ;
+ return (Just (loc, dec)) }
+
+repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
+ tcdTyVars = tvs,
+ tcdFDs = fds,
+ tcdSigs = sigs, tcdMeths = meth_binds }))
+ = do { cls1 <- lookupLOcc cls ; -- See note [Binders and occurrences]
+ dec <- addTyVarBinds tvs $ \bndrs -> do {
+ cxt1 <- repLContext cxt ;
+ sigs1 <- rep_sigs sigs ;
+ binds1 <- rep_binds meth_binds ;
+ fds1 <- repLFunDeps fds;
+ decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
+ bndrs1 <- coreList nameTyConName bndrs ;
+ repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
+ return $ Just (loc, dec) }
-repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
-repEs es = do { es' <- mapM repE es ;
- coreList exprTyConName es' }
+-- Un-handled cases
+repTyClD (L loc d) = putSrcSpanDs loc $
+ do { dsWarn (hang ds_msg 4 (ppr d))
+ ; return Nothing }
-repE :: HsExpr Name -> DsM (Core M.Expr)
-repE (HsVar x)
- = do { mb_val <- dsLookupMetaEnv x
- ; case mb_val of
- Nothing -> do { str <- globalVar x
- ; if constructor x then
- repCon str
- else
- repVar str }
- Just (Bound y) -> repVar (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)
+-- represent fundeps
+--
+repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
+repLFunDeps fds = do fds' <- mapM repLFunDep fds
+ fdList <- coreList funDepTyConName fds'
+ return fdList
+
+repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
+repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
+ ys' <- mapM lookupBinder ys
+ xs_list <- coreList nameTyConName xs'
+ ys_list <- coreList nameTyConName ys'
+ repFunDep xs_list ys_list
+
+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 (unLoc ty)
+
+repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
+repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis) _))
+ = do MkC name' <- lookupLOcc name
+ MkC typ' <- repLTy typ
+ MkC cc' <- repCCallConv cc
+ MkC s' <- repSafety s
+ MkC str <- coreStringLit $ static
+ ++ unpackFS ch ++ " "
+ ++ unpackFS cn ++ " "
+ ++ conv_cimportspec cis
+ dec <- rep2 forImpDName [cc', s', str, name', typ']
+ return (loc, dec)
+ where
+ conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
+ conv_cimportspec (CFunction DynamicTarget) = "dynamic"
+ conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
+ conv_cimportspec CWrapper = "wrapper"
+ static = case cis of
+ CFunction (StaticTarget _) -> "static "
+ _ -> ""
+
+repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
+repCCallConv CCallConv = rep2 cCallName []
+repCCallConv StdCallConv = rep2 stdCallName []
+
+repSafety :: Safety -> DsM (Core TH.Safety)
+repSafety PlayRisky = rep2 unsafeName []
+repSafety (PlaySafe False) = rep2 safeName []
+repSafety (PlaySafe True) = rep2 threadsafeName []
+
+ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
+
+-------------------------------------------------------
+-- Constructors
+-------------------------------------------------------
+
+repC :: LConDecl Name -> DsM (Core TH.ConQ)
+repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
+ = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
+ repConstr con1 details }
+repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
+ = do { addTyVarBinds tvs $ \bndrs -> do {
+ c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
+ ctxt' <- repContext ctxt;
+ bndrs' <- coreList nameTyConName bndrs;
+ rep2 forallCName [unC bndrs', unC ctxt', unC c']
+ }
+ }
+repC (L loc con_decl) -- GADTs
+ = putSrcSpanDs loc $
+ do { dsWarn (hang ds_msg 4 (ppr con_decl))
+ ; return (panic "DsMeta:repC") }
+
+repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
+repBangTy ty= do
+ MkC s <- rep2 str []
+ MkC t <- repLTy ty'
+ rep2 strictTypeName [s, t]
+ where
+ (str, ty') = case ty of
+ L _ (HsBangTy _ ty) -> (isStrictName, ty)
+ other -> (notStrictName, ty)
+
+-------------------------------------------------------
+-- Deriving clause
+-------------------------------------------------------
+
+repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
+repDerivs Nothing = coreList nameTyConName []
+repDerivs (Just ctxt)
+ = do { strs <- mapM rep_deriv ctxt ;
+ coreList nameTyConName strs }
+ where
+ rep_deriv :: LHsType Name -> DsM (Core TH.Name)
+ -- Deriving clauses must have the simple H98 form
+ rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
+ rep_deriv other = panic "rep_deriv"
+
+
+-------------------------------------------------------
+-- Signatures in a class decl, or a group of bindings
+-------------------------------------------------------
+
+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' :: [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 :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
+ -- Singleton => Ok
+ -- Empty => Too hard, signature ignored
+rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig other = return []
+
+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)] }
+
+
+-------------------------------------------------------
+-- Types
+-------------------------------------------------------
+
+-- gensym a list of type variables and enter them into the meta environment;
+-- 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 :: [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.unLoc) tvs
+ freshNames <- mkGenSyms names
+ term <- addBinds freshNames $ do
+ bndrs <- mapM lookupBinder names
+ m bndrs
+ wrapGenSyns freshNames term
+
+-- represent a type context
+--
+repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
+repLContext (L _ ctxt) = repContext ctxt
+
+repContext :: HsContext Name -> DsM (Core TH.CxtQ)
+repContext ctxt = do
+ preds <- mapM repLPred ctxt
+ predList <- coreList typeQTyConName preds
+ repCtxt predList
+
+-- represent a type predicate
+--
+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 <- 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
+--
+repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
+repLTys tys = mapM repLTy tys
+
+-- represent a type
+--
+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
+ tv1 <- lookupBinder n
+ repTvar tv1
+ | otherwise = do
+ tc1 <- lookupOcc n
+ repNamedTyCon tc1
+repTy (HsAppTy f a) = do
+ f1 <- repLTy f
+ a1 <- repLTy a
+ repTapp f1 a1
+repTy (HsFunTy f a) = do
+ f1 <- repLTy f
+ a1 <- repLTy a
+ tcon <- repArrowTyCon
+ repTapps tcon [f1, a1]
+repTy (HsListTy t) = do
+ t1 <- repLTy t
+ tcon <- repListTyCon
+ repTapp tcon t1
+repTy (HsPArrTy t) = do
+ t1 <- repLTy t
+ tcon <- repTy (HsTyVar (tyConName parrTyCon))
+ repTapp tcon t1
+repTy (HsTupleTy tc tys) = do
+ tys1 <- repLTys tys
+ tcon <- repTupleTyCon (length tys)
+ repTapps tcon tys1
+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 (HsKindSig ty kind) =
+ panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
+
+
+-----------------------------------------------------------------------------
+-- Expressions
+-----------------------------------------------------------------------------
+
+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
+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
+ 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 (MatchGroup [m] _)) = repLambda m
+repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
+
+repE (OpApp e1 op fix e2) =
+ do { arg1 <- repLE e1;
+ arg2 <- repLE e2;
+ the_op <- repLE op ;
+ repInfixApp arg1 the_op arg2 }
+repE (NegApp x nm) = do
+ a <- repLE x
+ negateVar <- lookupOcc negateName >>= repVar
+ negateVar `repApp` a
+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 (MatchGroup ms _)) = do { arg <- repLE e
+ ; ms2 <- mapM repMatchTup ms
+ ; repCaseE arg (nonEmptyCoreList ms2) }
+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 (repLE e)
+ ; z <- repLetE ds e2
+ ; wrapGenSyns ss z }
+-- FIXME: I haven't got the types here right yet
+repE (HsDo DoExpr sts body ty)
+ = do { (ss,zs) <- repLSts sts;
+ body' <- addBinds ss $ repLE body;
+ ret <- repNoBindSt body';
+ e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
+ wrapGenSyns ss e }
+repE (HsDo ListComp sts body ty)
+ = do { (ss,zs) <- repLSts sts;
+ body' <- addBinds ss $ repLE body;
+ ret <- repNoBindSt body';
+ e <- repComp (nonEmptyCoreList (zs ++ [ret]));
+ wrapGenSyns ss e }
+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 <- repLEs es; repTup xs }
+ | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
+repE (RecordCon c _ flds)
+ = do { x <- lookupLOcc c;
+ fs <- repFields flds;
+ repRecCon x fs }
+repE (RecordUpd e flds _ _)
+ = do { x <- repLE e;
+ fs <- repFields flds;
+ repRecUpd x fs }
+
+repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
+repE (ArithSeq _ aseq) =
+ case aseq of
+ From e -> do { ds1 <- repLE e; repFrom ds1 }
+ FromThen e1 e2 -> do
+ ds1 <- repLE e1
+ ds2 <- repLE e2
+ repFromThen ds1 ds2
+ FromTo e1 e2 -> do
+ ds1 <- repLE e1
+ ds2 <- repLE e2
+ repFromTo ds1 ds2
+ FromThenTo e1 e2 e3 -> do
+ ds1 <- repLE e1
+ ds2 <- repLE e2
+ ds3 <- repLE e3
+ repFromThenTo ds1 ds2 ds3
+repE (PArrSeq _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
+repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
+repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
+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 (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;
- mb_val <- dsLookupMetaEnv op;
- the_op <- case mb_val of {
- Nothing -> globalVar op ;
- Just (Bound x) -> return (coreVar x) ;
- other -> pprPanic "repE:OpApp" (ppr 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);
- combine expTyConName ss e }
-repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts;
- e <- repComp (nonEmptyCoreList zs);
- combine 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) <- repDecs bs
- ; e2 <- addBinds ss (repE e)
- ; z <- repLetE ds e2
- ; combine expTyConName ss z }
-repE (HsWith _ _ _) = panic "No with for implicit parameters yet"
-repE (ExplicitList ty es) =
- do { xs <- repEs es; repListExp xs }
-repE (ExplicitTuple es boxed) =
- do { xs <- repEs es; repTup xs }
-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"
+ 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.Mtch)
-repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
+repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
+repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
- ; p1 <- repP p
- ; (ss2,ds) <- repDecs wheres
+ ; p1 <- repLP p
+ ; (ss2,ds) <- repBinds wheres
; addBinds ss2 $ do {
; gs <- repGuards guards
; match <- repMatch p1 gs ds
- ; combine matTyConName (ss1++ss2) match }}}
+ ; wrapGenSyns (ss1++ss2) match }}}
-repClauseTup :: Match Name -> DsM (Core M.Clse)
-repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
+repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
+repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
- ps1 <- repPs ps
- ; (ss2,ds) <- repDecs wheres
+ ps1 <- repLPs ps
+ ; (ss2,ds) <- repBinds wheres
; addBinds ss2 $ do {
gs <- repGuards guards
; clause <- repClause ps1 gs ds
- ; combine clsTyConName (ss1++ss2) clause }}}
+ ; wrapGenSyns (ss1++ss2) clause }}}
-repGuards :: [GRHS Name] -> DsM (Core M.Rihs)
-repGuards [GRHS[ResultStmt e loc] loc2]
- = do {a <- repE e; repNormal a }
+repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
+repGuards [L _ (GRHS [] e)]
+ = do {a <- repLE e; repNormal a }
repGuards other
- = do { zs <- mapM process other;
- repGuarded (nonEmptyCoreList (map corePair zs)) }
+ = do { zs <- mapM process other;
+ let {(xs, ys) = unzip zs};
+ gd <- repGuarded (nonEmptyCoreList ys);
+ wrapGenSyns (concat xs) gd }
where
- process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
- = do { x <- repE e1; y <- repE e2; return (x, y) }
- process other = panic "Non Haskell 98 guarded body"
+ process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+ process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
+ = do { x <- repLNormalGE e1 e2;
+ return ([], x) }
+ process (L _ (GRHS ss rhs))
+ = do (gs, ss') <- repLSts ss
+ rhs' <- addBinds gs $ repLE rhs
+ g <- repPatGE (nonEmptyCoreList ss') rhs'
+ return (gs, g)
+
+repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
+repFields flds = do
+ fnames <- mapM lookupLOcc (map fst flds)
+ es <- mapM repLE (map snd flds)
+ fs <- zipWithM repFieldExp fnames es
+ coreList fieldExpQTyConName 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
-- 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.Stmt])
-repSts [ResultStmt e loc] =
- do { a <- repE e
- ; e1 <- repNoBindSt a
- ; return ([], [e1]) }
-repSts (BindStmt p e loc : ss) =
- do { e2 <- 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 (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) }}
repSts (LetStmt bs : ss) =
- do { (ss1,ds) <- repDecs bs
+ do { (ss1,ds) <- repBinds bs
; 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 _ _ : ss) =
+ do { e2 <- repLE e
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
; return (ss2, z : zs) }
+repSts [] = return ([],[])
repSts other = panic "Exotic Stmt in meta brackets"
-
-repDecs :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
-repDecs decs
- = do { let { bndrs = collectHsBinders decs } ;
- ss <- mkGenSyms bndrs ;
- core <- addBinds ss (rep_decs decs) ;
- core_list <- coreList declTyConName core ;
- return (ss, core_list) }
-
-rep_decs :: HsBinds Name -> DsM [Core M.Decl]
-rep_decs EmptyBinds = return []
-rep_decs (ThenBinds x y)
- = do { core1 <- rep_decs x
- ; core2 <- rep_decs y
- ; return (core1 ++ core2) }
-rep_decs (MonoBind bs sigs _)
- = do { core1 <- repMonoBind bs
- ; core2 <- rep_sigs sigs
+-----------------------------------------------------------
+-- Bindings
+-----------------------------------------------------------
+
+repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
+repBinds EmptyLocalBinds
+ = do { core_list <- coreList decQTyConName []
+ ; return ([], core_list) }
+
+repBinds (HsIPBinds _)
+ = panic "DsMeta:repBinds: can't do implicit parameters"
+
+repBinds (HsValBinds decs)
+ = do { let { bndrs = map unLoc (collectHsValBinders 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
+ ; prs <- addBinds ss (rep_val_binds decs)
+ ; core_list <- coreList decQTyConName
+ (de_loc (sort_by_loc prs))
+ ; return (ss, core_list) }
+
+rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
+-- Assumes: all the binders of the binding are alrady in the meta-env
+rep_val_binds (ValBindsOut binds sigs)
+ = do { core1 <- rep_binds' (unionManyBags (map snd binds))
+ ; core2 <- rep_sigs' sigs
; return (core1 ++ core2) }
-rep_sigs sigs = return [] -- Incomplete!
+rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
+rep_binds binds = do { binds_w_locs <- rep_binds' binds
+ ; return (de_loc (sort_by_loc binds_w_locs)) }
+
+rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_binds' binds = mapM rep_bind (bagToList binds)
-repMonoBind :: MonoBinds Name -> DsM [Core M.Decl]
-repMonoBind EmptyMonoBinds = return []
-repMonoBind (AndMonoBinds x y) = do { x1 <- repMonoBind x;
- y1 <- repMonoBind 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
-repMonoBind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
- = do { (ss,wherecore) <- repDecs wheres
+rep_bind (L loc (FunBind { fun_id = fn,
+ fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
+ = do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
- ; fn' <- lookupBinder fn
- ; p <- repPvar fn'
- ; ans <- repVal p guardcore wherecore
- ; return [ans] }
+ ; fn' <- lookupLBinder fn
+ ; p <- repPvar fn'
+ ; ans <- repVal p guardcore wherecore
+ ; ans' <- wrapGenSyns ss ans
+ ; return (loc, ans') }
-repMonoBind (FunMonoBind fn infx ms loc)
+rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
= do { ms1 <- mapM repClauseTup ms
- ; fn' <- lookupBinder fn
+ ; fn' <- lookupLBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
- ; return [ans] }
+ ; return (loc, ans) }
-repMonoBind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
- = do { patcore <- repP pat
- ; (ss,wherecore) <- repDecs wheres
+rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
+ = do { patcore <- repLP pat
+ ; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
- ; ans <- repVal patcore guardcore wherecore
- ; return [ans] }
+ ; ans <- repVal patcore guardcore wherecore
+ ; ans' <- wrapGenSyns ss ans
+ ; return (loc, ans') }
-repMonoBind (VarMonoBind v e)
+rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
= do { v' <- lookupBinder v
- ; e2 <- repE e
+ ; e2 <- repLE e
; x <- repNormal e2
; patcore <- repPvar v'
- ; empty_decls <- coreList declTyConName []
+ ; empty_decls <- coreList decQTyConName []
; ans <- repVal patcore x empty_decls
- ; return [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"
-- representations we build a shadow datatype MB with the same structure as
-- MonoBinds, but which has slots for the representations
------------------------------------------------------------------------------
--- Gathering binders
-
-hsDeclsBinders :: [HsDecl Name] -> [Name]
-hsDeclsBinders ds = concat (map hsDeclBinders ds)
-
-hsDeclBinders (ValD b) = collectHsBinders b
-hsDeclBinders (TyClD d) = map fst (tyClDeclNames d)
-hsDeclBinders (ForD d) = forDeclBinders d
-hsDeclBinders other = []
-
-forDeclBinders (ForeignImport n _ _ _ _) = [n]
-forDeclBinders other = []
-
-----------------------------------------------------------------------------
--- GHC seems to allow a more general form of lambda abstraction than specified
+-- GHC allows a more general form of lambda abstraction than specified
-- by Haskell 98. In particular it allows guarded lambda's like :
-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
-- 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.Expr)
-repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
- EmptyBinds _))
+repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
= do { let bndrs = collectPatsBinders ps ;
- ; ss <- mkGenSyms bndrs
+ ; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
- do { xs <- repPs ps; body <- repE e; repLam xs body })
- ; combine expTyConName ss lam }
+ 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"
-----------------------------------------------------------------------------
--- repP
+-- Patterns
-- repP deals with patterns. It assumes that we have already
-- walked over the pattern(s) once to collect the binders, and
-- have extended the environment. So every pattern-bound
-- variable should already appear in the environment.
-- Process a list of patterns
-repPs :: [Pat Name] -> DsM (Core [M.Patt])
-repPs ps = do { ps' <- mapM repP ps ;
- coreList pattTyConName ps' }
-
-repP :: Pat Name -> DsM (Core M.Patt)
-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 }
+repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
+repLPs ps = do { ps' <- mapM repLP ps ;
+ coreList patQTyConName ps' }
+
+repLP :: LPat Name -> DsM (Core TH.PatQ)
+repLP (L _ p) = repP p
+
+repP :: Pat Name -> DsM (Core TH.PatQ)
+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 <- 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 <- globalVar dc
+ = do { con_str <- lookupLOcc dc
; case details of
- PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
- RecCon pairs -> error "No records in template haskell yet"
- InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
+ 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 fieldPatQTyConName fps
+ ; repPrec con_str fps' }
+ InfixCon p1 p2 -> do { p1' <- repLP p1;
+ p2' <- repLP p2;
+ repPinfix p1' con_str p2' }
}
+repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
+repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
+repP (SigPatIn p t) = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
repP other = panic "Exotic pattern inside meta brackets"
-repListPat :: [Pat Name] -> DsM (Core M.Patt)
-repListPat [] = do { nil_con <- coreStringLit "[]"
- ; nil_args <- coreList pattTyConName []
- ; repPcon nil_con nil_args }
-repListPat (p:ps) = do { p2 <- repP p
- ; ps2 <- repListPat ps
- ; cons_con <- coreStringLit ":"
- ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
-
-
----------------------------------------------------------
--- Literals
+-- Declaration ordering helpers
-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"
+sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
+sort_by_loc xs = sortBy comp xs
+ where comp x y = compare (fst x) (fst y)
-repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
-repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i]
-repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
+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
+
+mkGenSyms :: [Name] -> DsM [GenSymBind]
+-- We can use the existing name. For example:
+-- [| \x_77 -> x_77 + x_77 |]
+-- desugars to
+-- do { x_77 <- genSym "x"; .... }
+-- We use the same x_77 in the desugared program, but with the type Bndr
+-- instead of Int
+--
+-- 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
-lookupBinder :: Name -> DsM (Core String)
+-- Look up a locally bound name
+--
+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
- 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) }
+ Just (Bound x) -> return (coreVar x)
+ other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
-mkGenSyms :: [Name] -> DsM [GenSymBind]
-mkGenSyms ns = mapM mkGenSym ns
-
-lookupType :: Name -- Name of type constructor (e.g. M.Expr)
+-- Look up a name that is either locally bound or a global name
+--
+-- * If it is a global name, generate the "original name" representation (ie,
+-- the <module>:<name> form) for the associated entity
+--
+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
+ Nothing -> globalVar n
+ Just (Bound x) -> return (coreVar x)
+ Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
+ }
+
+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 mkNameLName [occ,uni] }
+ where
+ name_mod = moduleString (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 []) }
-
--- combine[ x1 <- e1, x2 <- e2 ] y
--- --> bindQ e1 (\ x1 -> bindQ e2 (\ x2 -> y))
-
-combine :: Name -- Name of the type (consructor) for 'a'
- -> [GenSymBind]
- -> Core (M.Q a) -> DsM (Core (M.Q a))
-combine tc_name binds body@(MkC b)
- = do { elt_ty <- lookupType tc_name
- ; go elt_ty binds }
+ return (mkTyConApp 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 binds body@(MkC b)
+ = do { var_ty <- lookupType nameTyConName
+ ; go var_ty binds }
where
- go elt_ty [] = return body
- go elt_ty ((name,id) : binds)
- = do { MkC body' <- go elt_ty binds
- ; lit_str <- localVar name
+ [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 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')) }
-constructor :: Name -> Bool
-constructor x = isDataOcc (nameOccName x)
-
-void = placeHolderType
+-- Just like wrapGenSym, but don't actually do the gensym
+-- 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 <- occNameLit name
+ ; MkC var <- rep2 mkNameName [lit_str]
+ ; return (NonRec id var) }
-string :: String -> HsExpr Id
-string s = HsLit (HsString (mkFastString s))
+occNameLit :: Name -> DsM (Core String)
+occNameLit n = coreStringLit (occNameString (nameOccName n))
-- %*********************************************************************
-- %*********************************************************************
--------------- Patterns -----------------
-repPlit :: Core M.Lit -> DsM (Core M.Patt)
-repPlit (MkC l) = rep2 plitName [l]
+repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
+repPlit (MkC l) = rep2 litPName [l]
+
+repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
+repPvar (MkC s) = rep2 varPName [s]
+
+repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPtup (MkC ps) = rep2 tupPName [ps]
+
+repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
+
+repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
-repPvar :: Core String -> DsM (Core M.Patt)
-repPvar (MkC s) = rep2 pvarName [s]
+repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
-repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
-repPtup (MkC ps) = rep2 ptupName [ps]
+repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPtilde (MkC p) = rep2 tildePName [p]
-repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
-repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
+repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
-repPtilde :: Core M.Patt -> DsM (Core M.Patt)
-repPtilde (MkC p) = rep2 ptildeName [p]
+repPwild :: DsM (Core TH.PatQ)
+repPwild = rep2 wildPName []
-repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
-repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
+repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPlist (MkC ps) = rep2 listPName [ps]
-repPwild :: DsM (Core M.Patt)
-repPwild = rep2 pwildName []
+repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
--------------- Expressions -----------------
-repVar :: Core String -> DsM (Core M.Expr)
-repVar (MkC s) = rep2 varName [s]
+repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
+ | otherwise = repVar str
-repCon :: Core String -> DsM (Core M.Expr)
-repCon (MkC s) = rep2 conName [s]
+repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repVar (MkC s) = rep2 varEName [s]
-repLit :: Core M.Lit -> DsM (Core M.Expr)
-repLit (MkC c) = rep2 litName [c]
+repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
+repCon (MkC s) = rep2 conEName [s]
-repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repApp (MkC x) (MkC y) = rep2 appName [x,y]
+repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
+repLit (MkC c) = rep2 litEName [c]
-repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
-repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
+repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repApp (MkC x) (MkC y) = rep2 appEName [x,y]
-repTup :: Core [M.Expr] -> DsM (Core M.Expr)
-repTup (MkC es) = rep2 tupName [es]
+repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
-repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z]
+repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repTup (MkC es) = rep2 tupEName [es]
-repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
+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 [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
-repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
+repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
-repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
+repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
repDoE (MkC ss) = rep2 doEName [ss]
-repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
-repComp (MkC ss) = rep2 compName [ss]
+repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repComp (MkC ss) = rep2 compEName [ss]
+
+repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repListExp (MkC es) = rep2 listEName [es]
+
+repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
-repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
-repListExp (MkC es) = rep2 listExpName [es]
+repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
-repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
+repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
+
+repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
+
+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.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
+repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
-repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
+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.Expr, M.Expr)] -> DsM (Core M.Rihs)
-repGuarded (MkC pairs) = rep2 guardedName [pairs]
+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
+repGuarded (MkC pairs) = rep2 guardedBName [pairs]
+
+repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
+repNormal (MkC e) = rep2 normalBName [e]
-repNormal :: Core M.Expr -> DsM (Core M.Rihs)
-repNormal (MkC e) = rep2 normalName [e]
+------------ Guards ----
+repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repLNormalGE g e = do g' <- repLE g
+ e' <- repLE e
+ repNormalGE g' e'
-------------- Statements -------------------
-repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
-repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
+repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
-repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
-repLetSt (MkC ds) = rep2 letStName [ds]
+repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
-repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
-repNoBindSt (MkC e) = rep2 noBindStName [e]
+------------- Stmts -------------------
+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
--------------- DotDot (Arithmetic sequences) -----------
-repFrom :: Core M.Expr -> DsM (Core M.Expr)
-repFrom (MkC x) = rep2 fromName [x]
+repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
+repLetSt (MkC ds) = rep2 letSName [ds]
-repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
+repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repNoBindSt (MkC e) = rep2 noBindSName [e]
-repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
+-------------- Range (Arithmetic sequences) -----------
+repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFrom (MkC x) = rep2 fromEName [x]
-repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
+repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
+
+repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
+
+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.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
+repMatch :: Core TH.PatQ -> 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.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
+repClause :: Core [TH.PatQ] -> 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.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
-repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
-
-repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
-repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
-
-repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
-repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
-
-repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl]
-repInst (MkC cxt) (MkC ty) (Core ds) = rep2 instanceDName [cxt, ty, ds]
-
-repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
-repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
-
-repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
-repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
+
+repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
+
+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 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 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 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 TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
+
+repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
+repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
+
+repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
+
+repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
+repCtxt (MkC tys) = rep2 cxtName [tys]
+
+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 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
+ arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
+ rep2 recCName [unC con, unC arg_vtys']
+repConstr con (InfixCon st1 st2)
+ = do arg1 <- repBangTy st1
+ arg2 <- repBangTy st2
+ rep2 infixCName [unC arg1, unC con, unC arg2]
------------ Types -------------------
-repTvar :: Core String -> DsM (Core M.Type)
-repTvar (MkC s) = rep2 tvarName [s]
+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]
-repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
-repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
+repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
+repTvar (MkC s) = rep2 varTName [s]
-repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
+repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
+
+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.Type)
-repNamedTyCon (MkC s) = rep2 namedTyConName [s]
+repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repNamedTyCon (MkC s) = rep2 conTName [s]
-repTupleTyCon :: Core Int -> DsM (Core M.Tag)
-repTupleTyCon (MkC i) = rep2 tupleTyConName [i]
+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.Type)
-repArrowTyCon = rep2 arrowTyConName []
+repArrowTyCon :: DsM (Core TH.TypeQ)
+repArrowTyCon = rep2 arrowTName []
-repListTyCon :: DsM (Core M.Tag)
-repListTyCon = rep2 listTyConName []
+repListTyCon :: DsM (Core TH.TypeQ)
+repListTyCon = rep2 listTName []
---------------- Miscellaneous -------------------
+----------------------------------------------------------
+-- Literals
-repLift :: Core e -> DsM (Core M.Expr)
-repLift (MkC x) = rep2 liftName [x]
+repLiteral :: HsLit -> DsM (Core TH.Lit)
+repLiteral lit
+ = do lit' <- case lit of
+ 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
+ HsInt _ -> integerLName
+ HsIntPrim _ -> intPrimLName
+ HsFloatPrim _ -> floatPrimLName
+ HsDoublePrim _ -> doublePrimLName
+ HsChar _ -> charLName
+ HsString _ -> stringLName
+ HsRat _ _ -> rationalLName
+ other -> uh_oh
+ uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
+ (ppr lit)
+
+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 Name -> 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 'TH.Syntax.rationalL' uses it in its type,
+ -- and rationalL is sucked in when any TH stuff is used
+
+--------------- Miscellaneous -------------------
-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 [TH.Q a] -> DsM (Core (TH.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
coreList :: Name -- Of the TyCon of the element type
-> [Core a] -> DsM (Core [a])
coreList tc_name es
- = do { elt_ty <- lookupType tc_name
- ; let es' = map unC es
- ; return (MkC (mkListExpr elt_ty es')) }
+ = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
+
+coreList' :: Type -- The element type
+ -> [Core a] -> Core [a]
+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
nonEmptyCoreList :: [Core a] -> Core [a]
-- The list must be non-empty so we can get the element type
corePair :: (Core a, Core b) -> Core (a,b)
corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
-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) }
+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
+
+coreIntLit :: Int -> DsM (Core Int)
+coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
-coreVar :: Id -> Core String -- The Id has type String
+coreVar :: Id -> Core TH.Name -- The Id has type Name
coreVar id = MkC (Var id)
+
+
+
+-- %************************************************************************
+-- %* *
+-- The known-key names for Template Haskell
+-- %* *
+-- %************************************************************************
+
+-- To add a name, do three things
+--
+-- 1) Allocate a key
+-- 2) Make a "Name"
+-- 3) Add the name to knownKeyNames
+
+templateHaskellNames :: [Name]
+-- The names that are implicitly mentioned by ``bracket''
+-- Should stay in sync with the import list of DsMeta
+
+templateHaskellNames = [
+ returnQName, bindQName, sequenceQName, newNameName, liftName,
+ mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
+
+ -- Lit
+ charLName, stringLName, integerLName, intPrimLName,
+ floatPrimLName, doublePrimLName, rationalLName,
+ -- Pat
+ litPName, varPName, tupPName, conPName, tildePName, infixPName,
+ asPName, wildPName, recPName, listPName, sigPName,
+ -- FieldPat
+ fieldPatName,
+ -- Match
+ matchName,
+ -- Clause
+ clauseName,
+ -- Exp
+ varEName, conEName, litEName, appEName, infixEName,
+ infixAppName, sectionLName, sectionRName, lamEName, tupEName,
+ condEName, letEName, caseEName, doEName, compEName,
+ fromEName, fromThenEName, fromToEName, fromThenToEName,
+ listEName, sigEName, recConEName, recUpdEName,
+ -- FieldExp
+ fieldExpName,
+ -- Body
+ guardedBName, normalBName,
+ -- Guard
+ normalGEName, patGEName,
+ -- Stmt
+ bindSName, letSName, noBindSName, parSName,
+ -- Dec
+ funDName, valDName, dataDName, newtypeDName, tySynDName,
+ classDName, instanceDName, sigDName, forImpDName,
+ -- Cxt
+ cxtName,
+ -- Strict
+ isStrictName, notStrictName,
+ -- Con
+ normalCName, recCName, infixCName, forallCName,
+ -- StrictType
+ strictTypeName,
+ -- VarStrictType
+ varStrictTypeName,
+ -- Type
+ forallTName, varTName, conTName, appTName,
+ tupleTName, arrowTName, listTName,
+ -- Callconv
+ cCallName, stdCallName,
+ -- Safety
+ unsafeName,
+ safeName,
+ threadsafeName,
+ -- FunDep
+ funDepName,
+
+ -- And the tycons
+ qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
+ clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
+ decQTyConName, conQTyConName, strictTypeQTyConName,
+ varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
+ typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
+ fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
+
+thSyn :: Module
+thSyn = mkModule "Language.Haskell.TH.Syntax"
+thLib = mkModule "Language.Haskell.TH.Lib"
+
+mk_known_key_name mod space str uniq
+ = mkExternalName uniq mod (mkOccNameFS 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
+funDepTyConName = thTc FSLIT("FunDep") funDepTyConKey
+
+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
+mkNameLName = thFun FSLIT("mkNameL") mkNameLIdKey
+
+
+-------------------- TH.Lib -----------------------
+-- data Lit = ...
+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 = libFun FSLIT("litP") litPIdKey
+varPName = libFun FSLIT("varP") varPIdKey
+tupPName = libFun FSLIT("tupP") tupPIdKey
+conPName = libFun FSLIT("conP") conPIdKey
+infixPName = libFun FSLIT("infixP") infixPIdKey
+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
+sigPName = libFun FSLIT("sigP") sigPIdKey
+
+-- type FieldPat = ...
+fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
+
+-- data Match = ...
+matchName = libFun FSLIT("match") matchIdKey
+
+-- data Clause = ...
+clauseName = libFun FSLIT("clause") clauseIdKey
+
+-- data Exp = ...
+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 = libFun FSLIT("fromE") fromEIdKey
+fromThenEName = libFun FSLIT("fromThenE") fromThenEIdKey
+fromToEName = libFun FSLIT("fromToE") fromToEIdKey
+fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
+-- end ArithSeq
+listEName = libFun FSLIT("listE") listEIdKey
+sigEName = libFun FSLIT("sigE") sigEIdKey
+recConEName = libFun FSLIT("recConE") recConEIdKey
+recUpdEName = libFun FSLIT("recUpdE") recUpdEIdKey
+
+-- type FieldExp = ...
+fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
+
+-- data Body = ...
+guardedBName = libFun FSLIT("guardedB") guardedBIdKey
+normalBName = libFun FSLIT("normalB") normalBIdKey
+
+-- data Guard = ...
+normalGEName = libFun FSLIT("normalGE") normalGEIdKey
+patGEName = libFun FSLIT("patGE") patGEIdKey
+
+-- data Stmt = ...
+bindSName = libFun FSLIT("bindS") bindSIdKey
+letSName = libFun FSLIT("letS") letSIdKey
+noBindSName = libFun FSLIT("noBindS") noBindSIdKey
+parSName = libFun FSLIT("parS") parSIdKey
+
+-- data Dec = ...
+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
+forImpDName = libFun FSLIT("forImpD") forImpDIdKey
+
+-- type Ctxt = ...
+cxtName = libFun FSLIT("cxt") cxtIdKey
+
+-- data Strict = ...
+isStrictName = libFun FSLIT("isStrict") isStrictKey
+notStrictName = libFun FSLIT("notStrict") notStrictKey
+
+-- data Con = ...
+normalCName = libFun FSLIT("normalC") normalCIdKey
+recCName = libFun FSLIT("recC") recCIdKey
+infixCName = libFun FSLIT("infixC") infixCIdKey
+forallCName = libFun FSLIT("forallC") forallCIdKey
+
+-- type StrictType = ...
+strictTypeName = libFun FSLIT("strictType") strictTKey
+
+-- type VarStrictType = ...
+varStrictTypeName = libFun FSLIT("varStrictType") varStrictTKey
+
+-- data Type = ...
+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
+
+-- data Callconv = ...
+cCallName = libFun FSLIT("cCall") cCallIdKey
+stdCallName = libFun FSLIT("stdCall") stdCallIdKey
+
+-- data Safety = ...
+unsafeName = libFun FSLIT("unsafe") unsafeIdKey
+safeName = libFun FSLIT("safe") safeIdKey
+threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
+
+-- data FunDep = ...
+funDepName = libFun FSLIT("funDep") funDepIdKey
+
+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
+fieldExpQTyConName = libTc FSLIT("FieldExpQ") fieldExpQTyConKey
+patQTyConName = libTc FSLIT("PatQ") patQTyConKey
+fieldPatQTyConName = libTc FSLIT("FieldPatQ") fieldPatQTyConKey
+
+-- TyConUniques available: 100-129
+-- Check in PrelNames if you want to change this
+
+expTyConKey = mkPreludeTyConUnique 100
+matchTyConKey = mkPreludeTyConUnique 101
+clauseTyConKey = mkPreludeTyConUnique 102
+qTyConKey = mkPreludeTyConUnique 103
+expQTyConKey = mkPreludeTyConUnique 104
+decQTyConKey = mkPreludeTyConUnique 105
+patTyConKey = mkPreludeTyConUnique 106
+matchQTyConKey = mkPreludeTyConUnique 107
+clauseQTyConKey = mkPreludeTyConUnique 108
+stmtQTyConKey = mkPreludeTyConUnique 109
+conQTyConKey = mkPreludeTyConUnique 110
+typeQTyConKey = mkPreludeTyConUnique 111
+typeTyConKey = mkPreludeTyConUnique 112
+decTyConKey = mkPreludeTyConUnique 113
+varStrictTypeQTyConKey = mkPreludeTyConUnique 114
+strictTypeQTyConKey = mkPreludeTyConUnique 115
+fieldExpTyConKey = mkPreludeTyConUnique 116
+fieldPatTyConKey = mkPreludeTyConUnique 117
+nameTyConKey = mkPreludeTyConUnique 118
+patQTyConKey = mkPreludeTyConUnique 119
+fieldPatQTyConKey = mkPreludeTyConUnique 120
+fieldExpQTyConKey = mkPreludeTyConUnique 121
+funDepTyConKey = mkPreludeTyConUnique 122
+
+-- IdUniques available: 200-399
+-- If you want to change this, make sure you check in PrelNames
+
+returnQIdKey = mkPreludeMiscIdUnique 200
+bindQIdKey = mkPreludeMiscIdUnique 201
+sequenceQIdKey = mkPreludeMiscIdUnique 202
+liftIdKey = mkPreludeMiscIdUnique 203
+newNameIdKey = mkPreludeMiscIdUnique 204
+mkNameIdKey = mkPreludeMiscIdUnique 205
+mkNameG_vIdKey = mkPreludeMiscIdUnique 206
+mkNameG_dIdKey = mkPreludeMiscIdUnique 207
+mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
+mkNameLIdKey = mkPreludeMiscIdUnique 209
+
+
+-- data Lit = ...
+charLIdKey = mkPreludeMiscIdUnique 210
+stringLIdKey = mkPreludeMiscIdUnique 211
+integerLIdKey = mkPreludeMiscIdUnique 212
+intPrimLIdKey = mkPreludeMiscIdUnique 213
+floatPrimLIdKey = mkPreludeMiscIdUnique 214
+doublePrimLIdKey = mkPreludeMiscIdUnique 215
+rationalLIdKey = mkPreludeMiscIdUnique 216
+
+-- data Pat = ...
+litPIdKey = mkPreludeMiscIdUnique 220
+varPIdKey = mkPreludeMiscIdUnique 221
+tupPIdKey = mkPreludeMiscIdUnique 222
+conPIdKey = mkPreludeMiscIdUnique 223
+infixPIdKey = mkPreludeMiscIdUnique 312
+tildePIdKey = mkPreludeMiscIdUnique 224
+asPIdKey = mkPreludeMiscIdUnique 225
+wildPIdKey = mkPreludeMiscIdUnique 226
+recPIdKey = mkPreludeMiscIdUnique 227
+listPIdKey = mkPreludeMiscIdUnique 228
+sigPIdKey = mkPreludeMiscIdUnique 229
+
+-- type FieldPat = ...
+fieldPatIdKey = mkPreludeMiscIdUnique 230
+
+-- data Match = ...
+matchIdKey = mkPreludeMiscIdUnique 231
+
+-- data Clause = ...
+clauseIdKey = mkPreludeMiscIdUnique 232
+
+-- data Exp = ...
+varEIdKey = mkPreludeMiscIdUnique 240
+conEIdKey = mkPreludeMiscIdUnique 241
+litEIdKey = mkPreludeMiscIdUnique 242
+appEIdKey = mkPreludeMiscIdUnique 243
+infixEIdKey = mkPreludeMiscIdUnique 244
+infixAppIdKey = mkPreludeMiscIdUnique 245
+sectionLIdKey = mkPreludeMiscIdUnique 246
+sectionRIdKey = mkPreludeMiscIdUnique 247
+lamEIdKey = mkPreludeMiscIdUnique 248
+tupEIdKey = mkPreludeMiscIdUnique 249
+condEIdKey = mkPreludeMiscIdUnique 250
+letEIdKey = mkPreludeMiscIdUnique 251
+caseEIdKey = mkPreludeMiscIdUnique 252
+doEIdKey = mkPreludeMiscIdUnique 253
+compEIdKey = mkPreludeMiscIdUnique 254
+fromEIdKey = mkPreludeMiscIdUnique 255
+fromThenEIdKey = mkPreludeMiscIdUnique 256
+fromToEIdKey = mkPreludeMiscIdUnique 257
+fromThenToEIdKey = mkPreludeMiscIdUnique 258
+listEIdKey = mkPreludeMiscIdUnique 259
+sigEIdKey = mkPreludeMiscIdUnique 260
+recConEIdKey = mkPreludeMiscIdUnique 261
+recUpdEIdKey = mkPreludeMiscIdUnique 262
+
+-- type FieldExp = ...
+fieldExpIdKey = mkPreludeMiscIdUnique 265
+
+-- data Body = ...
+guardedBIdKey = mkPreludeMiscIdUnique 266
+normalBIdKey = mkPreludeMiscIdUnique 267
+
+-- data Guard = ...
+normalGEIdKey = mkPreludeMiscIdUnique 310
+patGEIdKey = mkPreludeMiscIdUnique 311
+
+-- data Stmt = ...
+bindSIdKey = mkPreludeMiscIdUnique 268
+letSIdKey = mkPreludeMiscIdUnique 269
+noBindSIdKey = mkPreludeMiscIdUnique 270
+parSIdKey = mkPreludeMiscIdUnique 271
+
+-- data Dec = ...
+funDIdKey = mkPreludeMiscIdUnique 272
+valDIdKey = mkPreludeMiscIdUnique 273
+dataDIdKey = mkPreludeMiscIdUnique 274
+newtypeDIdKey = mkPreludeMiscIdUnique 275
+tySynDIdKey = mkPreludeMiscIdUnique 276
+classDIdKey = mkPreludeMiscIdUnique 277
+instanceDIdKey = mkPreludeMiscIdUnique 278
+sigDIdKey = mkPreludeMiscIdUnique 279
+forImpDIdKey = mkPreludeMiscIdUnique 297
+
+-- type Cxt = ...
+cxtIdKey = mkPreludeMiscIdUnique 280
+
+-- data Strict = ...
+isStrictKey = mkPreludeMiscIdUnique 281
+notStrictKey = mkPreludeMiscIdUnique 282
+
+-- data Con = ...
+normalCIdKey = mkPreludeMiscIdUnique 283
+recCIdKey = mkPreludeMiscIdUnique 284
+infixCIdKey = mkPreludeMiscIdUnique 285
+forallCIdKey = mkPreludeMiscIdUnique 288
+
+-- type StrictType = ...
+strictTKey = mkPreludeMiscIdUnique 286
+
+-- type VarStrictType = ...
+varStrictTKey = mkPreludeMiscIdUnique 287
+
+-- data Type = ...
+forallTIdKey = mkPreludeMiscIdUnique 290
+varTIdKey = mkPreludeMiscIdUnique 291
+conTIdKey = mkPreludeMiscIdUnique 292
+tupleTIdKey = mkPreludeMiscIdUnique 294
+arrowTIdKey = mkPreludeMiscIdUnique 295
+listTIdKey = mkPreludeMiscIdUnique 296
+appTIdKey = mkPreludeMiscIdUnique 293
+
+-- data Callconv = ...
+cCallIdKey = mkPreludeMiscIdUnique 300
+stdCallIdKey = mkPreludeMiscIdUnique 301
+
+-- data Safety = ...
+unsafeIdKey = mkPreludeMiscIdUnique 305
+safeIdKey = mkPreludeMiscIdUnique 306
+threadsafeIdKey = mkPreludeMiscIdUnique 307
+
+-- data FunDep = ...
+funDepIdKey = mkPreludeMiscIdUnique 320
+
projects / ghc-hetmet.git / blobdiff