+++ /dev/null
------------------------------------------------------------------------------
--- The purpose of this module is to transform an HsExpr into a CoreExpr which
--- 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,
- templateHaskellNames, qTyConName, nameTyConName,
- liftName, expQTyConName, decQTyConName, typeQTyConName,
- decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
- ) where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} DsExpr ( dsExpr )
-
-import MatchLit ( dsLit )
-import DsUtils ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
-import DsMonad
-
-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, mkTyConApp )
-import TcType ( tcTyConAppArgs )
-import TyCon ( tyConName )
-import TysWiredIn ( parrTyCon )
-import CoreSyn
-import CoreUtils ( exprType )
-import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
-import Maybe ( catMaybes )
-import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
-import BasicTypes ( isBoxed )
-import Outputable
-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 TH.ExpQ
--- The quoted thing is parameterised over Name, even though it has
--- been type checked. We don't want all those type decorations!
-
-dsBracket brack splices
- = dsExtendMetaEnv new_bit (do_brack brack)
- where
- new_bit = mkNameEnv [(n, Splice (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 --------------------
-
- [| \x -> x |]
-====>
- gensym (unpackString "x"#) `bindQ` \ x1::String ->
- lam (pvar x1) (var x1)
-
-
- [| \x -> $(f [| x |]) |]
-====>
- gensym (unpackString "x"#) `bindQ` \ x1::String ->
- lam (pvar x1) (f (var x1))
--}
-
-
--------------------------------------------------------
--- 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.
-
--}
-
-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) }
-
--- Un-handled cases
-repTyClD (L loc d) = putSrcSpanDs loc $
- do { dsWarn (hang ds_msg 4 (ppr d))
- ; return Nothing }
-
--- 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 e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
-
------------------------------------------------------------------------------
--- Building representations of auxillary structures like Match, Clause, Stmt,
-
-repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
-repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
- do { ss1 <- mkGenSyms (collectPatBinders p)
- ; addBinds ss1 $ do {
- ; p1 <- repLP p
- ; (ss2,ds) <- repBinds wheres
- ; addBinds ss2 $ do {
- ; gs <- repGuards guards
- ; match <- repMatch p1 gs ds
- ; wrapGenSyns (ss1++ss2) match }}}
-
-repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
-repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
- do { ss1 <- mkGenSyms (collectPatsBinders ps)
- ; addBinds ss1 $ do {
- ps1 <- repLPs ps
- ; (ss2,ds) <- repBinds wheres
- ; addBinds ss2 $ do {
- gs <- repGuards guards
- ; clause <- repClause ps1 gs ds
- ; wrapGenSyns (ss1++ss2) clause }}}
-
-repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
-repGuards [L _ (GRHS [] e)]
- = do {a <- repLE e; repNormal a }
-repGuards other
- = do { zs <- mapM process other;
- let {(xs, ys) = unzip zs};
- gd <- repGuarded (nonEmptyCoreList ys);
- wrapGenSyns (concat xs) gd }
- where
- 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
--- 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
--- and we could reuse the original names (x and x).
---
--- do { x'1 <- gensym "x"
--- ; x'2 <- gensym "x"
--- ; doE [ BindSt (pvar x'1) [| f 1 |]
--- , BindSt (pvar x'2) [| f x |]
--- , NoBindSt [| g x |]
--- ]
--- }
-
--- The strategy is to translate a whole list of do-bindings by building a
--- bigger environment, and a bigger set of meta bindings
--- (like: x'1 <- gensym "x" ) and then combining these with the translations
--- of the expressions within the Do
-
------------------------------------------------------------------------------
--- The helper function repSts computes the translation of each sub expression
--- and a bunch of prefix bindings denoting the dynamic renaming.
-
-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 <- repLP p;
- ; (ss2,zs) <- repSts ss
- ; z <- repBindSt p1 e2
- ; return (ss1++ss2, z : zs) }}
-repSts (LetStmt bs : ss) =
- do { (ss1,ds) <- repBinds bs
- ; z <- repLetSt ds
- ; (ss2,zs) <- addBinds ss1 (repSts ss)
- ; return (ss1++ss2, z : zs) }
-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"
-
-
------------------------------------------------------------
--- 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_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)
-
-rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
--- Assumes: all the binders of the binding are alrady in the meta-env
-
--- Note GHC treats declarations of a variable (not a pattern)
--- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
--- with an empty list of patterns
-rep_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' <- lookupLBinder fn
- ; p <- repPvar fn'
- ; ans <- repVal p guardcore wherecore
- ; ans' <- wrapGenSyns ss ans
- ; return (loc, ans') }
-
-rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
- = do { ms1 <- mapM repClauseTup ms
- ; fn' <- lookupLBinder fn
- ; ans <- repFun fn' (nonEmptyCoreList ms1)
- ; return (loc, ans) }
-
-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
- ; ans' <- wrapGenSyns ss ans
- ; return (loc, ans') }
-
-rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
- = do { v' <- lookupBinder v
- ; e2 <- repLE e
- ; x <- repNormal e2
- ; patcore <- repPvar v'
- ; empty_decls <- coreList decQTyConName []
- ; ans <- repVal patcore x empty_decls
- ; return (srcLocSpan (getSrcLoc v), ans) }
-
------------------------------------------------------------------------------
--- 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"
--- ; g'2 <- gensym "g"
--- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
--- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
--- ]}
--- This requires collecting the bindings (f'1 <- gensym "f"), and the
--- environment ( f |-> f'1 ) from each binding, and then unioning them
--- together. As we do this we collect GenSymBinds's which represent the renamed
--- variables bound by the Bindings. In order not to lose track of these
--- representations we build a shadow datatype MB with the same structure as
--- MonoBinds, but which has slots for the representations
-
-
------------------------------------------------------------------------------
--- 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 :: LMatch Name -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
- = do { let bndrs = collectPatsBinders ps ;
- ; ss <- mkGenSyms bndrs
- ; lam <- addBinds ss (
- 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"
-
-
------------------------------------------------------------------------------
--- 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
-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 <- lookupLOcc dc
- ; case details of
- 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"
-
-----------------------------------------------------------
--- Declaration ordering helpers
-
-sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
-sort_by_loc xs = sortBy comp xs
- where comp x y = compare (fst x) (fst y)
-
-de_loc :: [(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
-
--- 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 x) -> return (coreVar x)
- other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
-
--- 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 (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
- [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 var_ty elt_ty
- gensym_app (MkC (Lam id body')) }
-
--- Just like wrapGenSym, but don't actually do the gensym
--- Instead use the existing name:
--- 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) }
-
-occNameLit :: Name -> DsM (Core String)
-occNameLit n = coreStringLit (occNameString (nameOccName n))
-
-
--- %*********************************************************************
--- %* *
--- Constructing code
--- %* *
--- %*********************************************************************
-
------------------------------------------------------------------------------
--- PHANTOM TYPES for consistency. In order to make sure we do this correct
--- we invent a new datatype which uses phantom types.
-
-newtype Core a = MkC CoreExpr
-unC (MkC x) = x
-
-rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
-rep2 n xs = do { id <- dsLookupGlobalId n
- ; return (MkC (foldl App (Var id) xs)) }
-
--- Then we make "repConstructors" which use the phantom types for each of the
--- smart constructors of the Meta.Meta datatypes.
-
-
--- %*********************************************************************
--- %* *
--- The 'smart constructors'
--- %* *
--- %*********************************************************************
-
---------------- Patterns -----------------
-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]
-
-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]
-
-repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
-repPtilde (MkC p) = rep2 tildePName [p]
-
-repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
-repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
-
-repPwild :: DsM (Core TH.PatQ)
-repPwild = rep2 wildPName []
-
-repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
-repPlist (MkC ps) = rep2 listPName [ps]
-
-repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
-repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
-
---------------- Expressions -----------------
-repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
-repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
- | otherwise = repVar str
-
-repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
-repVar (MkC s) = rep2 varEName [s]
-
-repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
-repCon (MkC s) = rep2 conEName [s]
-
-repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
-repLit (MkC c) = rep2 litEName [c]
-
-repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
-repApp (MkC x) (MkC y) = rep2 appEName [x,y]
-
-repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
-repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
-
-repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
-repTup (MkC es) = rep2 tupEName [es]
-
-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 TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
-repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
-
-repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
-repDoE (MkC ss) = rep2 doEName [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]
-
-repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
-repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
-
-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 TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
-repSectionL (MkC x) (MkC y) = rep2 sectionLName [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 [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]
-
------------- 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'
-
-repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
-repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
-
-repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
-repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
-
-------------- Stmts -------------------
-repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
-repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
-
-repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
-repLetSt (MkC ds) = rep2 letSName [ds]
-
-repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
-repNoBindSt (MkC e) = rep2 noBindSName [e]
-
--------------- Range (Arithmetic sequences) -----------
-repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
-repFrom (MkC x) = rep2 fromEName [x]
-
-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 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 [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 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 -------------------
-
-repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
-repTForall (MkC tvars) (MkC ctxt) (MkC ty)
- = rep2 forallTName [tvars, ctxt, ty]
-
-repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
-repTvar (MkC s) = rep2 varTName [s]
-
-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 TH.Name -> DsM (Core TH.TypeQ)
-repNamedTyCon (MkC s) = rep2 conTName [s]
-
-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 TH.TypeQ)
-repArrowTyCon = rep2 arrowTName []
-
-repListTyCon :: DsM (Core TH.TypeQ)
-repListTyCon = rep2 listTName []
-
-
-----------------------------------------------------------
--- Literals
-
-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 (TH.Q TH.Name))
-repGensym (MkC lit_str) = rep2 newNameName [lit_str]
-
-repBindQ :: Type -> Type -- a and 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; 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
- -- Otherwise use coreList
-nonEmptyCoreList [] = panic "coreList: empty argument"
-nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
-
-corePair :: (Core a, Core b) -> Core (a,b)
-corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
-
-coreStringLit :: String -> DsM (Core String)
-coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
-
-coreIntLit :: Int -> DsM (Core Int)
-coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
-
-coreVar :: Id -> Core TH.Name -- The Id has type Name
-coreVar id = MkC (Var id)
-
-
-
--- %************************************************************************
--- %* *
--- 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