-- 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,
quoteExpName, quotePatName
) where
+#include "HsVersions.h"
+
import {-# SOURCE #-} DsExpr ( dsExpr )
import MatchLit
import TyCon
import TysWiredIn
import CoreSyn
+import MkCore
import CoreUtils
import SrcLoc
import Unique
import Bag
import FastString
import ForeignCall
+import MonadUtils
import Data.Maybe
import Control.Monad
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]
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 nameTyConName 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 nameTyConName 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 nameTyConName 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 nameTyConName 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 = _kind }))
+ tyVarBinds
+ = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
+ ; dec <- tyVarBinds tvs $ \bndrs ->
+ do { flav <- repFamilyFlavour flavour
+ ; bndrs1 <- coreList nameTyConName bndrs
+ ; repFamily flav tc1 bndrs1
+ }
+ ; return $ Just (loc, dec)
+ }
+repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
+
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
ys_list <- coreList nameTyConName ys'
repFunDep xs_list ys_list
+-- 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 _ _)) -- 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 <- repPred (HsClassP cls tys)
+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)
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 _ = 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.Name] -> 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
m bndrs
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 = map (hsTyVarName.unLoc) tvs
+ bndrs <- mapM lookupBinder names
+ m bndrs
+
-- represent a type context
--
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
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]
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 ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
repTy ty = notHandled "Exotic form of type" (ppr ty)
; 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
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.Name]
+ -> 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.Name]
+ -> 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.Name]
+ -> 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.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]
+
+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]
+
+repFamily :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.Name]
+ -> DsM (Core TH.DecQ)
+repFamily (MkC flav) (MkC nm) (MkC tvs)
+ = rep2 familyDName [flav, nm, tvs]
+
+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]
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]
+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)
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 []
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
mk_string :: FastString -> DsM HsLit
-mk_string s = do return $ HsString s
+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 (HsIsString s _ _) = do { lit <- mk_string s; 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 -------------------
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)
bindSName, letSName, noBindSName, parSName,
-- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName,
- classDName, instanceDName, sigDName, forImpDName,
+ classDName, instanceDName, sigDName, forImpDName,
+ pragInlDName, pragSpecDName, pragSpecInlDName,
+ familyDName, dataInstDName, newtypeInstDName, tySynInstDName,
-- Cxt
cxtName,
+ -- Pred
+ classPName, equalPName,
-- Strict
isStrictName, notStrictName,
-- Con
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,
+ fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, predQTyConName,
-- Quasiquoting
quoteExpName, quotePatName]
-------------------- TH.Syntax -----------------------
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
- matchTyConName, clauseTyConName, funDepTyConName :: Name
+ matchTyConName, clauseTyConName, funDepTyConName, predTyConName :: Name
qTyConName = thTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
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,
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
- instanceDName, sigDName, forImpDName :: 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
+ instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
+ pragSpecInlDName, familyDName, 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
+familyDName = libFun (fsLit "familyD") familyDIdKey
+dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
+newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
+tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
-- type Ctxt = ...
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, notStrictName :: Name
isStrictName = libFun (fsLit "isStrict") isStrictKey
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 :: 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 :: Name
+ patQTyConName, fieldPatQTyConName, predQTyConName :: Name
matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
patQTyConName = libTc (fsLit "PatQ") patQTyConKey
fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
+predQTyConName = libTc (fsLit "PredQ") predQTyConKey
-- quasiquoting
quoteExpName, quotePatName :: Name
stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
- fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey :: Unique
+ fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
+ predQTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 100
matchTyConKey = mkPreludeTyConUnique 101
clauseTyConKey = mkPreludeTyConUnique 102
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
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
-- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
- classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey :: Unique
+ classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
+ pragSpecDIdKey, pragSpecInlDIdKey, familyDIdKey, dataInstDIdKey,
+ newtypeInstDIdKey, tySynInstDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 272
valDIdKey = mkPreludeMiscIdUnique 273
dataDIdKey = mkPreludeMiscIdUnique 274
instanceDIdKey = mkPreludeMiscIdUnique 278
sigDIdKey = mkPreludeMiscIdUnique 279
forImpDIdKey = mkPreludeMiscIdUnique 297
+pragInlDIdKey = mkPreludeMiscIdUnique 348
+pragSpecDIdKey = mkPreludeMiscIdUnique 349
+pragSpecInlDIdKey = mkPreludeMiscIdUnique 352
+familyDIdKey = mkPreludeMiscIdUnique 340
+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
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
-
projects / ghc-hetmet.git / blobdiff