diff options
Diffstat (limited to 'compiler/deSugar/DsMeta.hs')
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 1732 |
1 files changed, 1732 insertions, 0 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs new file mode 100644 index 0000000000..88b0ba9c8e --- /dev/null +++ b/compiler/deSugar/DsMeta.hs @@ -0,0 +1,1732 @@ +----------------------------------------------------------------------------- +-- 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 + |