X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=3518aaf87f6bef7d773471daebb01e3fb55c3f71;hp=36b6b4c910343362565c9a428dcd52ccfeb8c294;hb=432b9c9322181a3644083e3c19b7e240d90659e7;hpb=d386e0d20c6953b7cba4d53538a1782c4aa9980d diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 36b6b4c..3518aaf 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -13,11 +13,19 @@ -- a Royal Pain (triggers other recompilation). ----------------------------------------------------------------------------- +{-# OPTIONS -fno-warn-unused-imports #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details +-- The kludge is only needed in this module because of trac #2267. module DsMeta( dsBracket, templateHaskellNames, qTyConName, nameTyConName, - liftName, expQTyConName, decQTyConName, typeQTyConName, - decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName + liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName, + decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, + quoteExpName, quotePatName ) where #include "HsVersions.h" @@ -33,7 +41,6 @@ import qualified Language.Haskell.TH as TH import HsSyn import Class import PrelNames -import OccName -- 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 @@ -42,28 +49,27 @@ import qualified OccName import Module import Id -import OccName import Name import NameEnv -import Type import TcType import TyCon import TysWiredIn import CoreSyn +import MkCore import CoreUtils import SrcLoc -import PackageConfig import Unique import BasicTypes import Outputable import Bag import FastString import ForeignCall +import MonadUtils import Data.Maybe import Control.Monad import Data.List - + ----------------------------------------------------------------------------- dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr -- Returns a CoreExpr of type TH.ExpQ @@ -131,12 +137,15 @@ repTopDs group -- Do *not* gensym top-level binders } +groupBinders :: HsGroup Name -> [Located Name] groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, - hs_fords = foreign_decls }) + hs_instds = inst_decls, hs_fords = foreign_decls }) -- Collect the binders of a Group = collectHsValBinders val_decls ++ - [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++ + [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++ [n | L _ (ForeignImport n _ _) <- foreign_decls] + where + assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls] {- Note [Binders and occurrences] @@ -165,59 +174,103 @@ in repTyClD and repC. repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +repTyClD tydecl@(L _ (TyFamily {})) + = repTyFamily tydecl addTyVarBinds + 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) } + tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, + tcdCons = cons, tcdDerivs = mb_derivs })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyVarBinds tvs $ \bndrs -> + do { cxt1 <- repLContext cxt + ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts + ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 + ; cons1 <- mapM repC cons + ; cons2 <- coreList conQTyConName cons1 + ; derivs1 <- repDerivs mb_derivs + ; bndrs1 <- coreList tyVarBndrTyConName bndrs + ; repData cxt1 tc1 bndrs1 opt_tys2 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)) } + tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, + tcdCons = [con], tcdDerivs = mb_derivs })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyVarBinds tvs $ \bndrs -> + do { cxt1 <- repLContext cxt + ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts + ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 + ; con1 <- repC con + ; derivs1 <- repDerivs mb_derivs + ; bndrs1 <- coreList tyVarBndrTyConName bndrs + ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1 + } + ; return $ Just (loc, dec) + } + +repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, + tcdSynRhs = ty })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyVarBinds tvs $ \bndrs -> + do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts + ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 + ; ty1 <- repLTy ty + ; bndrs1 <- coreList tyVarBndrTyConName bndrs + ; repTySyn tc1 bndrs1 opt_tys2 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) } + tcdTyVars = tvs, tcdFDs = fds, + tcdSigs = sigs, tcdMeths = meth_binds, + tcdATs = ats })) + = 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 + ; ats1 <- repLAssocFamilys ats + ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1) + ; bndrs1 <- coreList tyVarBndrTyConName bndrs + ; repClass cxt1 cls1 bndrs1 fds1 decls1 + } + ; return $ Just (loc, dec) + } -- Un-handled cases repTyClD (L loc d) = putSrcSpanDs loc $ do { warnDs (hang ds_msg 4 (ppr d)) ; return Nothing } +-- The type variables in the head of families are treated differently when the +-- family declaration is associated. In that case, they are usage, not binding +-- occurences. +-- +repTyFamily :: LTyClDecl Name + -> ProcessTyVarBinds TH.Dec + -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +repTyFamily (L loc (TyFamily { tcdFlavour = flavour, + tcdLName = tc, tcdTyVars = tvs, + tcdKind = opt_kind })) + tyVarBinds + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- tyVarBinds tvs $ \bndrs -> + do { flav <- repFamilyFlavour flavour + ; bndrs1 <- coreList tyVarBndrTyConName bndrs + ; case opt_kind of + Nothing -> repFamilyNoKind flav tc1 bndrs1 + Just ki -> do { ki1 <- repKind ki + ; repFamilyKind flav tc1 bndrs1 ki1 + } + } + ; return $ Just (loc, dec) + } +repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error" + -- represent fundeps -- repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep]) @@ -232,27 +285,55 @@ repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder 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) +-- represent family declaration flavours +-- +repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour) +repFamilyFlavour TypeFamily = rep2 typeFamName [] +repFamilyFlavour DataFamily = rep2 dataFamName [] + +-- represent associated family declarations +-- +repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ] +repLAssocFamilys = mapM repLAssocFamily + where + repLAssocFamily tydecl@(L _ (TyFamily {})) + = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds + repLAssocFamily tydecl + = failWithDs msg + where + msg = ptext (sLit "Illegal associated declaration in class:") <+> + ppr tydecl + +-- represent associated family instances +-- +repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ] +repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD + +-- represent instance declarations +-- +repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now + = do { i <- addTyVarBinds tvs $ \_ -> + -- 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 <- repPredTy (HsClassP cls tys) ; ss <- mkGenSyms (collectHsBindBinders binds) ; binds1 <- addBinds ss (rep_binds binds) - ; decls1 <- coreList decQTyConName binds1 + ; ats1 <- repLAssocFamInst ats + ; decls1 <- coreList decQTyConName (ats1 ++ binds1) ; decls2 <- wrapNongenSyms ss decls1 - -- wrapNonGenSyms: do not clone the class op names! + -- wrapNongenSyms: do not clone the class op names! -- They must be called 'op' etc, not 'op34' - ; repInst cxt1 inst_ty1 decls2 } - + ; 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))) +repForD (L loc (ForeignImport name typ (CImport cc s ch cis))) = do MkC name' <- lookupLOcc name MkC typ' <- repLTy typ MkC cc' <- repCCallConv cc @@ -260,7 +341,6 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis))) cis' <- conv_cimportspec cis MkC str <- coreStringLit $ static ++ unpackFS ch ++ " " - ++ unpackFS cn ++ " " ++ cis' dec <- rep2 forImpDName [cc', s', str, name', typ'] return (loc, dec) @@ -277,30 +357,33 @@ repForD decl = notHandled "Foreign declaration" (ppr decl) repCCallConv :: CCallConv -> DsM (Core TH.Callconv) repCCallConv CCallConv = rep2 cCallName [] repCCallConv StdCallConv = rep2 stdCallName [] +repCCallConv callConv = notHandled "repCCallConv" (ppr callConv) 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:") +ds_msg :: SDoc +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 doc)) - = do { addTyVarBinds tvs $ \bndrs -> do { - c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc)); - ctxt' <- repContext ctxt; - bndrs' <- coreList nameTyConName bndrs; - rep2 forallCName [unC bndrs', unC ctxt', unC c'] - } +repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ [] + , con_details = details, con_res = ResTyH98 })) + = do { con1 <- lookupLOcc con -- See note [Binders and occurrences] + ; repConstr con1 details } +repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 })) + = addTyVarBinds tvs $ \bndrs -> + do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] })) + ; ctxt' <- repContext ctxt + ; bndrs' <- coreList tyVarBndrTyConName bndrs + ; rep2 forallCName [unC bndrs', unC ctxt', unC c'] + } repC (L loc con_decl) -- GADTs = putSrcSpanDs loc $ notHandled "GADT declaration" (ppr con_decl) @@ -313,7 +396,7 @@ repBangTy ty= do where (str, ty') = case ty of L _ (HsBangTy _ ty) -> (isStrictName, ty) - other -> (notStrictName, ty) + _ -> (notStrictName, ty) ------------------------------------------------------- -- Deriving clause @@ -347,36 +430,115 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; 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_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc +rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc +rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc +rep_sig _ = 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)] + } -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)] } +rep_inline :: Located Name -> InlineSpec -> SrcSpan + -> DsM [(SrcSpan, Core TH.DecQ)] +rep_inline nm ispec loc + = do { nm1 <- lookupLOcc nm + ; (_, ispec1) <- rep_InlineSpec ispec + ; pragma <- repPragInl nm1 ispec1 + ; return [(loc, pragma)] + } + +rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan + -> DsM [(SrcSpan, Core TH.DecQ)] +rep_specialise nm ty ispec loc + = do { nm1 <- lookupLOcc nm + ; ty1 <- repLTy ty + ; (hasSpec, ispec1) <- rep_InlineSpec ispec + ; pragma <- if hasSpec + then repPragSpecInl nm1 ty1 ispec1 + else repPragSpec nm1 ty1 + ; return [(loc, pragma)] + } + +-- extract all the information needed to build a TH.InlineSpec +-- +rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ) +rep_InlineSpec (Inline (InlinePragma activation match) inline) + | Nothing <- activation1 + = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1 + | Just (flag, phase) <- activation1 + = liftM ((,) True) $ repInlineSpecPhase inline1 match1 flag phase + | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec" + where + match1 = coreBool (rep_RuleMatchInfo match) + activation1 = rep_Activation activation + inline1 = coreBool inline + + rep_RuleMatchInfo FunLike = False + rep_RuleMatchInfo ConLike = True + + rep_Activation NeverActive = Nothing + rep_Activation AlwaysActive = Nothing + rep_Activation (ActiveBefore phase) = Just (coreBool False, + MkC $ mkIntExprInt phase) + rep_Activation (ActiveAfter phase) = Just (coreBool True, + MkC $ mkIntExprInt phase) ------------------------------------------------------- -- Types ------------------------------------------------------- +-- We process type variable bindings in two ways, either by generating fresh +-- names or looking up existing names. The difference is crucial for type +-- families, depending on whether they are associated or not. +-- +type ProcessTyVarBinds a = + [LHsTyVarBndr Name] -- the binders to be added + -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env + -> DsM (Core (TH.Q a)) + -- 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 :: ProcessTyVarBinds a addTyVarBinds tvs m = do - let names = map (hsTyVarName.unLoc) tvs + let names = hsLTyVarNames tvs + mkWithKinds = map repTyVarBndrWithKind tvs freshNames <- mkGenSyms names term <- addBinds freshNames $ do - bndrs <- mapM lookupBinder names - m bndrs + bndrs <- mapM lookupBinder names + kindedBndrs <- zipWithM ($) mkWithKinds bndrs + m kindedBndrs wrapGenSyns freshNames term +-- Look up a list of type variables; the computations passed as the second +-- argument gets the *new* names on Core-level as an argument +-- +lookupTyVarBinds :: ProcessTyVarBinds a +lookupTyVarBinds tvs m = + do + let names = hsLTyVarNames tvs + mkWithKinds = map repTyVarBndrWithKind tvs + bndrs <- mapM lookupBinder names + kindedBndrs <- zipWithM ($) mkWithKinds bndrs + m kindedBndrs + +-- Produce kinded binder constructors from the Haskell tyvar binders +-- +repTyVarBndrWithKind :: LHsTyVarBndr Name + -> Core TH.Name -> DsM (Core TH.TyVarBndr) +repTyVarBndrWithKind (L _ (UserTyVar _)) = repPlainTV +repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) = + \nm -> repKind ki >>= repKindedTV nm + -- represent a type context -- repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) @@ -385,22 +547,36 @@ repLContext (L _ ctxt) = repContext ctxt repContext :: HsContext Name -> DsM (Core TH.CxtQ) repContext ctxt = do preds <- mapM repLPred ctxt - predList <- coreList typeQTyConName preds + predList <- coreList predQTyConName preds repCtxt predList -- represent a type predicate -- -repLPred :: LHsPred Name -> DsM (Core TH.TypeQ) +repLPred :: LHsPred Name -> DsM (Core TH.PredQ) 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 p@(HsEqualP _ _) = notHandled "Equational constraint" (ppr p) +repPred :: HsPred Name -> DsM (Core TH.PredQ) +repPred (HsClassP cls tys) + = do + cls1 <- lookupOcc cls + tys1 <- repLTys tys + tys2 <- coreList typeQTyConName tys1 + repClassP cls1 tys2 +repPred (HsEqualP tyleft tyright) + = do + tyleft1 <- repLTy tyleft + tyright1 <- repLTy tyright + repEqualP tyleft1 tyright1 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p) +repPredTy :: HsPred Name -> DsM (Core TH.TypeQ) +repPredTy (HsClassP cls tys) + = do + tcon <- repTy (HsTyVar cls) + tys1 <- repLTys tys + repTapps tcon tys1 +repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error" + -- yield the representation of a list of types -- repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] @@ -416,12 +592,12 @@ repTy (HsForAllTy _ tvs ctxt ty) = addTyVarBinds tvs $ \bndrs -> do ctxt1 <- repLContext ctxt ty1 <- repLTy ty - bndrs1 <- coreList nameTyConName bndrs + bndrs1 <- coreList tyVarBndrTyConName bndrs repTForall bndrs1 ctxt1 ty1 repTy (HsTyVar n) | isTvOcc (nameOccName n) = do - tv1 <- lookupBinder n + tv1 <- lookupTvOcc n repTvar tv1 | otherwise = do tc1 <- lookupOcc n @@ -443,17 +619,34 @@ repTy (HsPArrTy t) = do t1 <- repLTy t tcon <- repTy (HsTyVar (tyConName parrTyCon)) repTapp tcon t1 -repTy (HsTupleTy tc tys) = do +repTy (HsTupleTy _ 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 (HsPredTy pred) = repPred pred +repTy (HsPredTy pred) = repPredTy pred +repTy (HsKindSig t k) = do + t1 <- repLTy t + k1 <- repKind k + repTSig t1 k1 repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) repTy ty = notHandled "Exotic form of type" (ppr ty) +-- represent a kind +-- +repKind :: Kind -> DsM (Core TH.Kind) +repKind ki + = do { let (kis, ki') = splitKindFunTys ki + ; kis_rep <- mapM repKind kis + ; ki'_rep <- repNonArrowKind ki' + ; foldlM repArrowK ki'_rep kis_rep + } + where + repNonArrowKind k | isLiftedTypeKind k = repStarK + | otherwise = notHandled "Exotic form of kind" + (ppr k) ----------------------------------------------------------------------------- -- Expressions @@ -478,7 +671,7 @@ repE (HsVar x) = Just (Bound y) -> repVarOrCon x (coreVar y) Just (Splice e) -> do { e' <- dsExpr e ; return (MkC e') } } -repE e@(HsIPVar x) = notHandled "Implicit parameters" (ppr e) +repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) -- Remember, we're desugaring renamer output here, so -- HsOverlit can definitely occur @@ -487,12 +680,12 @@ 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) = +repE (OpApp e1 op _ e2) = do { arg1 <- repLE e1; arg2 <- repLE e2; the_op <- repLE op ; repInfixApp arg1 the_op arg2 } -repE (NegApp x nm) = do +repE (NegApp x _) = do a <- repLE x negateVar <- lookupOcc negateName >>= repVar negateVar `repApp` a @@ -512,21 +705,21 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ; z <- repLetE ds e2 ; wrapGenSyns ss z } -- FIXME: I haven't got the types here right yet -repE (HsDo DoExpr sts body ty) +repE (HsDo DoExpr sts body _) = 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) +repE (HsDo ListComp sts body _) = do { (ss,zs) <- repLSts sts; body' <- addBinds ss $ repLE body; ret <- repNoBindSt body'; e <- repComp (nonEmptyCoreList (zs ++ [ret])); wrapGenSyns ss e } repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e) -repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs } -repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e) +repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } +repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple es boxed) | isBoxed boxed = do { xs <- repLEs es; repTup xs } | otherwise = notHandled "Unboxed tuples" (ppr e) @@ -534,7 +727,7 @@ repE (RecordCon c _ flds) = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } -repE (RecordUpd e flds _ _) +repE (RecordUpd e flds _ _ _) = do { x <- repLE e; fs <- repFields flds; repRecUpd x fs } @@ -561,7 +754,7 @@ repE (HsSpliceE (HsSplice n _)) ; case mb_val of Just (Splice e) -> do { e' <- dsExpr e ; return (MkC e') } - other -> pprPanic "HsSplice" (ppr n) } + _ -> pprPanic "HsSplice" (ppr n) } -- Should not happen; statically checked repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) @@ -575,7 +768,7 @@ repE e = notHandled "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))) = +repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -584,10 +777,10 @@ repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) = ; gs <- repGuards guards ; match <- repMatch p1 gs ds ; wrapGenSyns (ss1++ss2) match }}} -repMatchTup other = panic "repMatchTup: case alt with more than one arg" +repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) -repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) = +repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -616,12 +809,12 @@ repGuards other 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 +repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) +repFields (HsRecFields { rec_flds = flds }) + = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds) + ; es <- mapM repLE (map hsRecFieldArg flds) + ; fs <- zipWithM repFieldExp fnames es + ; coreList fieldExpQTyConName fs } ----------------------------------------------------------------------------- @@ -704,8 +897,8 @@ rep_val_binds (ValBindsOut binds sigs) = do { core1 <- rep_binds' (unionManyBags (map snd binds)) ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_val_binds (ValBindsOut binds sigs) - = panic "rep_val_binds: ValBindsOut" +rep_val_binds (ValBindsIn _ _) + = panic "rep_val_binds: ValBindsIn" rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] rep_binds binds = do { binds_w_locs <- rep_binds' binds @@ -721,7 +914,7 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- 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))] _ })) + fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -744,7 +937,7 @@ rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres })) ; ans' <- wrapGenSyns ss ans ; return (loc, ans') } -rep_bind (L loc (VarBind { var_id = v, var_rhs = e})) +rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v ; e2 <- repLE e ; x <- repNormal e2 @@ -753,7 +946,7 @@ rep_bind (L loc (VarBind { var_id = v, var_rhs = e})) ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind other = panic "rep_bind: AbsBinds" +rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" ----------------------------------------------------------------------------- -- Since everything in a Bind is mutually recursive we need rename all @@ -787,7 +980,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyns ss lam } -repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m) +repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) ----------------------------------------------------------------------------- @@ -810,6 +1003,7 @@ 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 (BangPat p) = do { p1 <- repLP p; repPbang 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 } @@ -817,9 +1011,10 @@ 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 hsRecFieldId pairs) - ; ps <- sequence $ map repLP (map hsRecFieldArg pairs) + PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } + RecCon rec -> do { let flds = rec_flds rec + ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds) + ; ps <- sequence $ map repLP (map hsRecFieldArg flds) ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps ; fps' <- coreList fieldPatQTyConName fps ; repPrec con_str fps' } @@ -827,8 +1022,8 @@ repP (ConPatIn dc details) p2' <- repLP p2; repPinfix p1' con_str p2' } } -repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a } -repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p) +repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) -- The problem is to do with scoped type variables. -- To implement them, we have to implement the scoping rules @@ -890,9 +1085,9 @@ lookupBinder n = do { mb_val <- dsLookupMetaEnv n; case mb_val of Just (Bound x) -> return (coreVar x) - other -> failWithDs msg } + _ -> failWithDs msg } where - msg = ptext SLIT("DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n + msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n -- Look up a name that is either locally bound or a global name -- @@ -913,6 +1108,18 @@ lookupOcc n Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) } +lookupTvOcc :: Name -> DsM (Core TH.Name) +-- Type variables can't be staged and are not lexically scoped in TH +lookupTvOcc n + = do { mb_val <- dsLookupMetaEnv n ; + case mb_val of + Just (Bound x) -> return (coreVar x) + _ -> failWithDs msg + } + where + msg = vcat [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n) + , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ] + globalVar :: Name -> DsM (Core TH.Name) -- Not bound by the meta-env -- Could be top-level; or could be local @@ -929,7 +1136,7 @@ globalVar name ; MkC uni <- coreIntLit (getKey (getUnique name)) ; rep2 mkNameLName [occ,uni] } where - mod = nameModule name + mod = ASSERT( isExternalName name) nameModule name name_mod = moduleNameString (moduleName mod) name_pkg = packageIdString (modulePackageId mod) name_occ = nameOccName name @@ -959,7 +1166,7 @@ wrapGenSyns binds body@(MkC b) -- argument type. NB: this relies on Q being a data/newtype, -- not a type synonym - go var_ty [] = return body + go _ [] = return body go var_ty ((name,id) : binds) = do { MkC body' <- go var_ty binds ; lit_str <- occNameLit name @@ -997,6 +1204,7 @@ occNameLit n = coreStringLit (occNameString (nameOccName n)) -- we invent a new datatype which uses phantom types. newtype Core a = MkC CoreExpr +unC :: Core a -> CoreExpr unC (MkC x) = x rep2 :: Name -> [ CoreExpr ] -> DsM (Core a) @@ -1035,6 +1243,9 @@ 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] +repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ) +repPbang (MkC p) = rep2 bangPName [p] + repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] @@ -1162,22 +1373,69 @@ 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] +repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] + -> Maybe (Core [TH.TypeQ]) + -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ) +repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs) + = rep2 dataDName [cxt, nm, tvs, cons, derivs] +repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs) + = rep2 dataInstDName [cxt, nm, tys, cons, derivs] + +repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] + -> Maybe (Core [TH.TypeQ]) + -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ) +repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs) + = rep2 newtypeDName [cxt, nm, tvs, con, derivs] +repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs) + = rep2 newtypeInstDName [cxt, nm, tys, con, derivs] + +repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] + -> Maybe (Core [TH.TypeQ]) + -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs) + = rep2 tySynDName [nm, tvs, rhs] +repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs) + = rep2 tySynInstDName [nm, tys, 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] +repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] + -> 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] + +repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ) +repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec] + +repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty] + +repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ + -> DsM (Core TH.DecQ) +repPragSpecInl (MkC nm) (MkC ty) (MkC ispec) + = rep2 pragSpecInlDName [nm, ty, ispec] + +repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] + -> DsM (Core TH.DecQ) +repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs) + = rep2 familyNoKindDName [flav, nm, tvs] + +repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] + -> Core TH.Kind + -> DsM (Core TH.DecQ) +repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki) + = rep2 familyKindDName [flav, nm, tvs, ki] + +repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ) +repInlineSpecNoPhase (MkC inline) (MkC conlike) + = rep2 inlineSpecNoPhaseName [inline, conlike] + +repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int + -> DsM (Core TH.InlineSpecQ) +repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase) + = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase] repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep) repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] @@ -1185,18 +1443,24 @@ 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 :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] -repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name) +repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ) +repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys] + +repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ) +repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2] + +repConstr :: Core TH.Name -> HsConDeclDetails 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 hsRecFieldId ips) - arg_tys <- mapM repBangTy (map hsRecFieldArg ips) + = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips) + arg_tys <- mapM repBangTy (map cd_fld_type ips) arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y]) arg_vs arg_tys arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys @@ -1208,7 +1472,8 @@ repConstr con (InfixCon st1 st2) ------------ Types ------------------- -repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) +repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ + -> DsM (Core TH.TypeQ) repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 forallTName [tvars, ctxt, ty] @@ -1216,12 +1481,15 @@ 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] +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 } +repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ) +repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] + --------- Type constructors -------------- repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) @@ -1229,7 +1497,7 @@ 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)] +repTupleTyCon i = rep2 tupleTName [mkIntExprInt i] repArrowTyCon :: DsM (Core TH.TypeQ) repArrowTyCon = rep2 arrowTName [] @@ -1237,6 +1505,19 @@ repArrowTyCon = rep2 arrowTName [] repListTyCon :: DsM (Core TH.TypeQ) repListTyCon = rep2 listTName [] +------------ Kinds ------------------- + +repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr) +repPlainTV (MkC nm) = rep2 plainTVName [nm] + +repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr) +repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] + +repStarK :: DsM (Core TH.Kind) +repStarK = rep2 starKName [] + +repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) +repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2] ---------------------------------------------------------- -- Literals @@ -1245,6 +1526,7 @@ repLiteral :: HsLit -> DsM (Core TH.Lit) repLiteral lit = do lit' <- case lit of HsIntPrim i -> mk_integer i + HsWordPrim w -> mk_integer w HsInt i -> mk_integer i HsFloatPrim r -> mk_rational r HsDoublePrim r -> mk_rational r @@ -1258,24 +1540,34 @@ repLiteral lit HsInteger _ _ -> Just integerLName HsInt _ -> Just integerLName HsIntPrim _ -> Just intPrimLName + HsWordPrim _ -> Just wordPrimLName HsFloatPrim _ -> Just floatPrimLName HsDoublePrim _ -> Just doublePrimLName HsChar _ -> Just charLName HsString _ -> Just stringLName HsRat _ _ -> Just rationalLName - other -> Nothing + _ -> Nothing +mk_integer :: Integer -> DsM HsLit mk_integer i = do integer_ty <- lookupType integerTyConName return $ HsInteger i integer_ty +mk_rational :: Rational -> DsM HsLit mk_rational r = do rat_ty <- lookupType rationalTyConName return $ HsRat r rat_ty +mk_string :: FastString -> DsM HsLit +mk_string s = return $ HsString s 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 } +repOverloadedLiteral (OverLit { ol_val = val}) + = do { lit <- mk_lit val; 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 + +mk_lit :: OverLitVal -> DsM HsLit +mk_lit (HsIntegral i) = mk_integer i +mk_lit (HsFractional f) = mk_rational f +mk_lit (HsIsString s) = mk_string s --------------- Miscellaneous ------------------- @@ -1309,14 +1601,17 @@ nonEmptyCoreList :: [Core a] -> Core [a] 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) } +------------ Bool, Literals & Variables ------------------- + +coreBool :: Bool -> Core Bool +coreBool False = MkC $ mkConApp falseDataCon [] +coreBool True = MkC $ mkConApp trueDataCon [] + coreIntLit :: Int -> DsM (Core Int) -coreIntLit i = return (MkC (mkIntExpr (fromIntegral i))) +coreIntLit i = return (MkC (mkIntExprInt i)) coreVar :: Id -> Core TH.Name -- The Id has type Name coreVar id = MkC (Var id) @@ -1325,7 +1620,7 @@ coreVar id = MkC (Var id) notHandled :: String -> SDoc -> DsM a notHandled what doc = failWithDs msg where - msg = hang (text what <+> ptext SLIT("not (yet) handled by Template Haskell")) + msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell")) 2 doc @@ -1350,10 +1645,10 @@ templateHaskellNames = [ mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, -- Lit - charLName, stringLName, integerLName, intPrimLName, + charLName, stringLName, integerLName, intPrimLName, wordPrimLName, floatPrimLName, doublePrimLName, rationalLName, -- Pat - litPName, varPName, tupPName, conPName, tildePName, infixPName, + litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName, asPName, wildPName, recPName, listPName, sigPName, -- FieldPat fieldPatName, @@ -1377,9 +1672,14 @@ templateHaskellNames = [ bindSName, letSName, noBindSName, parSName, -- Dec funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceDName, sigDName, forImpDName, + classDName, instanceDName, sigDName, forImpDName, + pragInlDName, pragSpecDName, pragSpecInlDName, + familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, + tySynInstDName, -- Cxt cxtName, + -- Pred + classPName, equalPName, -- Strict isStrictName, notStrictName, -- Con @@ -1390,203 +1690,312 @@ templateHaskellNames = [ varStrictTypeName, -- Type forallTName, varTName, conTName, appTName, - tupleTName, arrowTName, listTName, + tupleTName, arrowTName, listTName, sigTName, + -- TyVarBndr + plainTVName, kindedTVName, + -- Kind + starKName, arrowKName, -- Callconv cCallName, stdCallName, -- Safety unsafeName, safeName, threadsafeName, + -- InlineSpec + inlineSpecNoPhaseName, inlineSpecPhaseName, -- FunDep funDepName, + -- FamFlavour + typeFamName, dataFamName, -- And the tycons qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, - clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName, - decQTyConName, conQTyConName, strictTypeQTyConName, + clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, + stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, matchTyConName, clauseTyConName, patQTyConName, - fieldPatQTyConName, fieldExpQTyConName, funDepTyConName] + typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, + patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, + predQTyConName, -thSyn :: Module -thSyn = mkTHModule FSLIT("Language.Haskell.TH.Syntax") -thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib") + -- Quasiquoting + quoteExpName, quotePatName] +thSyn, thLib, qqLib :: Module +thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") +thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib") +qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") + +mkTHModule :: FastString -> Module mkTHModule m = mkModule thPackageId (mkModuleNameFS m) +libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name libFun = mk_known_key_name OccName.varName thLib libTc = mk_known_key_name OccName.tcName thLib thFun = mk_known_key_name OccName.varName thSyn thTc = mk_known_key_name OccName.tcName thSyn +qqFun = mk_known_key_name OccName.varName qqLib -------------------- 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 +qTyConName, nameTyConName, fieldExpTyConName, patTyConName, + fieldPatTyConName, expTyConName, decTyConName, typeTyConName, + tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, + predTyConName :: Name +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 +tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey +matchTyConName = thTc (fsLit "Match") matchTyConKey +clauseTyConName = thTc (fsLit "Clause") clauseTyConKey +funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey +predTyConName = thTc (fsLit "Pred") predTyConKey + +returnQName, bindQName, sequenceQName, newNameName, liftName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, + mkNameLName, liftStringName :: Name +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 +liftStringName = thFun (fsLit "liftString") liftStringIdKey +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 +charLName, stringLName, integerLName, intPrimLName, wordPrimLName, + floatPrimLName, doublePrimLName, rationalLName :: Name +charLName = libFun (fsLit "charL") charLIdKey +stringLName = libFun (fsLit "stringL") stringLIdKey +integerLName = libFun (fsLit "integerL") integerLIdKey +intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey +wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey +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 +litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName, + asPName, wildPName, recPName, listPName, sigPName :: Name +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 +bangPName = libFun (fsLit "bangP") bangPIdKey +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 +fieldPatName :: Name +fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey -- data Match = ... -matchName = libFun FSLIT("match") matchIdKey +matchName :: Name +matchName = libFun (fsLit "match") matchIdKey --- data Clause = ... -clauseName = libFun FSLIT("clause") clauseIdKey +-- data Clause = ... +clauseName :: Name +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 +varEName, conEName, litEName, appEName, infixEName, infixAppName, + sectionLName, sectionRName, lamEName, tupEName, condEName, + letEName, caseEName, doEName, compEName :: Name +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 +fromEName, fromThenEName, fromToEName, fromThenToEName :: Name +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 +listEName, sigEName, recConEName, recUpdEName :: Name +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 +fieldExpName :: Name +fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey -- data Body = ... -guardedBName = libFun FSLIT("guardedB") guardedBIdKey -normalBName = libFun FSLIT("normalB") normalBIdKey +guardedBName, normalBName :: Name +guardedBName = libFun (fsLit "guardedB") guardedBIdKey +normalBName = libFun (fsLit "normalB") normalBIdKey -- data Guard = ... -normalGEName = libFun FSLIT("normalGE") normalGEIdKey -patGEName = libFun FSLIT("patGE") patGEIdKey +normalGEName, patGEName :: Name +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 +bindSName, letSName, noBindSName, parSName :: Name +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 +funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, + instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, + pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName, + newtypeInstDName, tySynInstDName :: Name +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 +pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey +pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey +pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey +familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey +familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey +dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey +newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey +tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey -- type Ctxt = ... -cxtName = libFun FSLIT("cxt") cxtIdKey +cxtName :: Name +cxtName = libFun (fsLit "cxt") cxtIdKey + +-- data Pred = ... +classPName, equalPName :: Name +classPName = libFun (fsLit "classP") classPIdKey +equalPName = libFun (fsLit "equalP") equalPIdKey -- 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 - +isStrictName, notStrictName :: Name +isStrictName = libFun (fsLit "isStrict") isStrictKey +notStrictName = libFun (fsLit "notStrict") notStrictKey + +-- data Con = ... +normalCName, recCName, infixCName, forallCName :: Name +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 +strictTypeName :: Name +strictTypeName = libFun (fsLit "strictType") strictTKey -- type VarStrictType = ... -varStrictTypeName = libFun FSLIT("varStrictType") varStrictTKey +varStrictTypeName :: Name +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 - +forallTName, varTName, conTName, tupleTName, arrowTName, + listTName, appTName, sigTName :: Name +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 +sigTName = libFun (fsLit "sigT") sigTIdKey + +-- data TyVarBndr = ... +plainTVName, kindedTVName :: Name +plainTVName = libFun (fsLit "plainTV") plainTVIdKey +kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey + +-- data Kind = ... +starKName, arrowKName :: Name +starKName = libFun (fsLit "starK") starKIdKey +arrowKName = libFun (fsLit "arrowK") arrowKIdKey + -- data Callconv = ... -cCallName = libFun FSLIT("cCall") cCallIdKey -stdCallName = libFun FSLIT("stdCall") stdCallIdKey +cCallName, stdCallName :: Name +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 - +unsafeName, safeName, threadsafeName :: Name +unsafeName = libFun (fsLit "unsafe") unsafeIdKey +safeName = libFun (fsLit "safe") safeIdKey +threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey + +-- data InlineSpec = ... +inlineSpecNoPhaseName, inlineSpecPhaseName :: Name +inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey +inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey + -- 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 +funDepName :: Name +funDepName = libFun (fsLit "funDep") funDepIdKey + +-- data FamFlavour = ... +typeFamName, dataFamName :: Name +typeFamName = libFun (fsLit "typeFam") typeFamIdKey +dataFamName = libFun (fsLit "dataFam") dataFamIdKey +matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, + decQTyConName, conQTyConName, strictTypeQTyConName, + varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName, + patQTyConName, fieldPatQTyConName, predQTyConName :: Name +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 +predQTyConName = libTc (fsLit "PredQ") predQTyConKey + +-- quasiquoting +quoteExpName, quotePatName :: Name +quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey +quotePatName = qqFun (fsLit "quotePat") quotePatKey + +-- TyConUniques available: 100-129 +-- Check in PrelNames if you want to change this + +expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, + decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey, + stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey, + decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey, + fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, + fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, + predQTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 100 matchTyConKey = mkPreludeTyConUnique 101 clauseTyConKey = mkPreludeTyConUnique 102 @@ -1600,6 +2009,7 @@ stmtQTyConKey = mkPreludeTyConUnique 109 conQTyConKey = mkPreludeTyConUnique 110 typeQTyConKey = mkPreludeTyConUnique 111 typeTyConKey = mkPreludeTyConUnique 112 +tyVarBndrTyConKey = mkPreludeTyConUnique 125 decTyConKey = mkPreludeTyConUnique 113 varStrictTypeQTyConKey = mkPreludeTyConUnique 114 strictTypeQTyConKey = mkPreludeTyConUnique 115 @@ -1610,10 +2020,15 @@ patQTyConKey = mkPreludeTyConUnique 119 fieldPatQTyConKey = mkPreludeTyConUnique 120 fieldExpQTyConKey = mkPreludeTyConUnique 121 funDepTyConKey = mkPreludeTyConUnique 122 +predTyConKey = mkPreludeTyConUnique 123 +predQTyConKey = mkPreludeTyConUnique 124 --- IdUniques available: 200-399 --- If you want to change this, make sure you check in PrelNames +-- IdUniques available: 200-399 +-- If you want to change this, make sure you check in PrelNames +returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, + mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, + mkNameLIdKey :: Unique returnQIdKey = mkPreludeMiscIdUnique 200 bindQIdKey = mkPreludeMiscIdUnique 201 sequenceQIdKey = mkPreludeMiscIdUnique 202 @@ -1627,21 +2042,30 @@ mkNameLIdKey = mkPreludeMiscIdUnique 209 -- data Lit = ... +charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, + floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique charLIdKey = mkPreludeMiscIdUnique 210 stringLIdKey = mkPreludeMiscIdUnique 211 integerLIdKey = mkPreludeMiscIdUnique 212 intPrimLIdKey = mkPreludeMiscIdUnique 213 -floatPrimLIdKey = mkPreludeMiscIdUnique 214 -doublePrimLIdKey = mkPreludeMiscIdUnique 215 -rationalLIdKey = mkPreludeMiscIdUnique 216 +wordPrimLIdKey = mkPreludeMiscIdUnique 214 +floatPrimLIdKey = mkPreludeMiscIdUnique 215 +doublePrimLIdKey = mkPreludeMiscIdUnique 216 +rationalLIdKey = mkPreludeMiscIdUnique 217 + +liftStringIdKey :: Unique +liftStringIdKey = mkPreludeMiscIdUnique 218 -- data Pat = ... +litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, + asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique litPIdKey = mkPreludeMiscIdUnique 220 varPIdKey = mkPreludeMiscIdUnique 221 tupPIdKey = mkPreludeMiscIdUnique 222 conPIdKey = mkPreludeMiscIdUnique 223 infixPIdKey = mkPreludeMiscIdUnique 312 tildePIdKey = mkPreludeMiscIdUnique 224 +bangPIdKey = mkPreludeMiscIdUnique 359 asPIdKey = mkPreludeMiscIdUnique 225 wildPIdKey = mkPreludeMiscIdUnique 226 recPIdKey = mkPreludeMiscIdUnique 227 @@ -1649,23 +2073,32 @@ listPIdKey = mkPreludeMiscIdUnique 228 sigPIdKey = mkPreludeMiscIdUnique 229 -- type FieldPat = ... +fieldPatIdKey :: Unique fieldPatIdKey = mkPreludeMiscIdUnique 230 -- data Match = ... +matchIdKey :: Unique matchIdKey = mkPreludeMiscIdUnique 231 -- data Clause = ... +clauseIdKey :: Unique clauseIdKey = mkPreludeMiscIdUnique 232 + -- data Exp = ... +varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, + sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey, + letEIdKey, caseEIdKey, doEIdKey, compEIdKey, + fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, + listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique varEIdKey = mkPreludeMiscIdUnique 240 conEIdKey = mkPreludeMiscIdUnique 241 litEIdKey = mkPreludeMiscIdUnique 242 appEIdKey = mkPreludeMiscIdUnique 243 infixEIdKey = mkPreludeMiscIdUnique 244 -infixAppIdKey = mkPreludeMiscIdUnique 245 -sectionLIdKey = mkPreludeMiscIdUnique 246 -sectionRIdKey = mkPreludeMiscIdUnique 247 +infixAppIdKey = mkPreludeMiscIdUnique 245 +sectionLIdKey = mkPreludeMiscIdUnique 246 +sectionRIdKey = mkPreludeMiscIdUnique 247 lamEIdKey = mkPreludeMiscIdUnique 248 tupEIdKey = mkPreludeMiscIdUnique 249 condEIdKey = mkPreludeMiscIdUnique 250 @@ -1683,23 +2116,31 @@ recConEIdKey = mkPreludeMiscIdUnique 261 recUpdEIdKey = mkPreludeMiscIdUnique 262 -- type FieldExp = ... +fieldExpIdKey :: Unique fieldExpIdKey = mkPreludeMiscIdUnique 265 -- data Body = ... +guardedBIdKey, normalBIdKey :: Unique guardedBIdKey = mkPreludeMiscIdUnique 266 normalBIdKey = mkPreludeMiscIdUnique 267 -- data Guard = ... +normalGEIdKey, patGEIdKey :: Unique normalGEIdKey = mkPreludeMiscIdUnique 310 patGEIdKey = mkPreludeMiscIdUnique 311 -- data Stmt = ... +bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique bindSIdKey = mkPreludeMiscIdUnique 268 letSIdKey = mkPreludeMiscIdUnique 269 noBindSIdKey = mkPreludeMiscIdUnique 270 parSIdKey = mkPreludeMiscIdUnique 271 -- data Dec = ... +funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, + classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, + pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey, + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 272 valDIdKey = mkPreludeMiscIdUnique 273 dataDIdKey = mkPreludeMiscIdUnique 274 @@ -1709,27 +2150,47 @@ classDIdKey = mkPreludeMiscIdUnique 277 instanceDIdKey = mkPreludeMiscIdUnique 278 sigDIdKey = mkPreludeMiscIdUnique 279 forImpDIdKey = mkPreludeMiscIdUnique 297 +pragInlDIdKey = mkPreludeMiscIdUnique 348 +pragSpecDIdKey = mkPreludeMiscIdUnique 349 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 352 +familyNoKindDIdKey= mkPreludeMiscIdUnique 340 +familyKindDIdKey = mkPreludeMiscIdUnique 353 +dataInstDIdKey = mkPreludeMiscIdUnique 341 +newtypeInstDIdKey = mkPreludeMiscIdUnique 342 +tySynInstDIdKey = mkPreludeMiscIdUnique 343 -- type Cxt = ... +cxtIdKey :: Unique cxtIdKey = mkPreludeMiscIdUnique 280 +-- data Pred = ... +classPIdKey, equalPIdKey :: Unique +classPIdKey = mkPreludeMiscIdUnique 346 +equalPIdKey = mkPreludeMiscIdUnique 347 + -- data Strict = ... +isStrictKey, notStrictKey :: Unique isStrictKey = mkPreludeMiscIdUnique 281 notStrictKey = mkPreludeMiscIdUnique 282 -- data Con = ... +normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique normalCIdKey = mkPreludeMiscIdUnique 283 recCIdKey = mkPreludeMiscIdUnique 284 infixCIdKey = mkPreludeMiscIdUnique 285 forallCIdKey = mkPreludeMiscIdUnique 288 -- type StrictType = ... +strictTKey :: Unique strictTKey = mkPreludeMiscIdUnique 286 -- type VarStrictType = ... +varStrictTKey :: Unique varStrictTKey = mkPreludeMiscIdUnique 287 -- data Type = ... +forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey, + listTIdKey, appTIdKey, sigTIdKey :: Unique forallTIdKey = mkPreludeMiscIdUnique 290 varTIdKey = mkPreludeMiscIdUnique 291 conTIdKey = mkPreludeMiscIdUnique 292 @@ -1737,16 +2198,44 @@ tupleTIdKey = mkPreludeMiscIdUnique 294 arrowTIdKey = mkPreludeMiscIdUnique 295 listTIdKey = mkPreludeMiscIdUnique 296 appTIdKey = mkPreludeMiscIdUnique 293 +sigTIdKey = mkPreludeMiscIdUnique 358 + +-- data TyVarBndr = ... +plainTVIdKey, kindedTVIdKey :: Unique +plainTVIdKey = mkPreludeMiscIdUnique 354 +kindedTVIdKey = mkPreludeMiscIdUnique 355 + +-- data Kind = ... +starKIdKey, arrowKIdKey :: Unique +starKIdKey = mkPreludeMiscIdUnique 356 +arrowKIdKey = mkPreludeMiscIdUnique 357 -- data Callconv = ... +cCallIdKey, stdCallIdKey :: Unique cCallIdKey = mkPreludeMiscIdUnique 300 stdCallIdKey = mkPreludeMiscIdUnique 301 -- data Safety = ... +unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique unsafeIdKey = mkPreludeMiscIdUnique 305 safeIdKey = mkPreludeMiscIdUnique 306 threadsafeIdKey = mkPreludeMiscIdUnique 307 +-- data InlineSpec = +inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique +inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350 +inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 351 + -- data FunDep = ... +funDepIdKey :: Unique funDepIdKey = mkPreludeMiscIdUnique 320 +-- data FamFlavour = ... +typeFamIdKey, dataFamIdKey :: Unique +typeFamIdKey = mkPreludeMiscIdUnique 344 +dataFamIdKey = mkPreludeMiscIdUnique 345 + +-- quasiquoting +quoteExpKey, quotePatKey :: Unique +quoteExpKey = mkPreludeMiscIdUnique 321 +quotePatKey = mkPreludeMiscIdUnique 322