-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2006
+--
-- The purpose of this module is to transform an HsExpr into a CoreExpr which
-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
-- input HsExpr. We do this in the DsM monad, which supplies access to
-- a Royal Pain (triggers other recompilation).
-----------------------------------------------------------------------------
+{-# OPTIONS -w #-}
+-- 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
module DsMeta( dsBracket,
templateHaskellNames, qTyConName, nameTyConName,
- liftName, expQTyConName, decQTyConName, typeQTyConName,
- decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
+ liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
+ decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
+ quoteExpName, quotePatName
) where
-#include "HsVersions.h"
-
import {-# SOURCE #-} DsExpr ( dsExpr )
-import MatchLit ( dsLit )
-import DsUtils ( mkListExpr, mkStringExpr, mkIntExpr )
+import MatchLit
+import DsUtils
import DsMonad
import qualified Language.Haskell.TH as TH
import HsSyn
-import Class (FunDep)
-import PrelNames ( rationalTyConName, integerTyConName, negateName )
-import OccName ( isDataOcc, isTvOcc, occNameString )
--- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
--- we do this by removing varName from the import of OccName above, making
--- a qualified instance of OccName and using OccNameAlias.varName where varName
--- ws previously used in this file.
+import Class
+import PrelNames
+-- To avoid clashes with DsMeta.varName we must make a local alias for
+-- OccName.varName we do this by removing varName from the import of
+-- OccName above, making a qualified instance of OccName and using
+-- OccNameAlias.varName where varName ws previously used in this file.
import qualified OccName
-import Module ( Module, mkModule, moduleNameString, moduleName,
- modulePackageId, mkModuleNameFS )
-import Id ( Id, mkLocalId )
-import OccName ( mkOccNameFS )
-import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
- isExternalName, getSrcLoc )
+import Module
+import Id
+import Name
import NameEnv
-import Type ( Type, mkTyConApp )
-import TcType ( tcTyConAppArgs )
-import TyCon ( tyConName )
-import TysWiredIn ( parrTyCon )
+import TcType
+import TyCon
+import TysWiredIn
import CoreSyn
-import CoreUtils ( exprType )
-import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
-import PackageConfig ( thPackageId, packageIdString )
-import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
-import BasicTypes ( isBoxed )
+import CoreUtils
+import SrcLoc
+import PackageConfig
+import Unique
+import BasicTypes
import Outputable
-import Bag ( bagToList, unionManyBags )
-import FastString ( unpackFS )
-import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
+import Bag
+import FastString
+import ForeignCall
-import Maybe ( catMaybes )
-import Monad ( zipWithM )
-import List ( sortBy )
+import Data.Maybe
+import Control.Monad
+import Data.List
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
-- Collect the binders of a Group
= collectHsValBinders val_decls ++
[n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
- [n | L _ (ForeignImport n _ _ _) <- foreign_decls]
+ [n | L _ (ForeignImport n _ _) <- foreign_decls]
{- Note [Binders and occurrences]
-- Un-handled cases
repTyClD (L loc d) = putSrcSpanDs loc $
- do { dsWarn (hang ds_msg 4 (ppr d))
+ do { warnDs (hang ds_msg 4 (ppr d))
; return Nothing }
-- represent fundeps
ys_list <- coreList nameTyConName ys'
repFunDep xs_list ys_list
-repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now
+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
(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 cn cis)))
= do MkC name' <- lookupLOcc name
MkC typ' <- repLTy typ
MkC cc' <- repCCallConv cc
MkC s' <- repSafety s
+ cis' <- conv_cimportspec cis
MkC str <- coreStringLit $ static
++ unpackFS ch ++ " "
++ unpackFS cn ++ " "
- ++ conv_cimportspec cis
+ ++ cis'
dec <- rep2 forImpDName [cc', s', str, name', typ']
return (loc, dec)
where
- conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
- conv_cimportspec (CFunction DynamicTarget) = "dynamic"
- conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
- conv_cimportspec CWrapper = "wrapper"
+ conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
+ conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
+ conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
+ conv_cimportspec CWrapper = return "wrapper"
static = case cis of
CFunction (StaticTarget _) -> "static "
_ -> ""
+repForD decl = notHandled "Foreign declaration" (ppr decl)
repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repSafety (PlaySafe False) = rep2 safeName []
repSafety (PlaySafe True) = rep2 threadsafeName []
-ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
+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))
+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))
+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));
+ 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 loc con_decl) -- GADTs
- = putSrcSpanDs loc $
- do { dsWarn (hang ds_msg 4 (ppr con_decl))
- ; return (panic "DsMeta:repC") }
+ = putSrcSpanDs loc $
+ notHandled "GADT declaration" (ppr con_decl)
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
repBangTy ty= do
rep_deriv :: LHsType Name -> DsM (Core TH.Name)
-- Deriving clauses must have the simple H98 form
rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
- rep_deriv other = panic "rep_deriv"
+ rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
-------------------------------------------------------
tcon <- repTy (HsTyVar cls)
tys1 <- repLTys tys
repTapps tcon tys1
-repPred (HsIParam _ _) =
- panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
+repPred p@(HsEqualP _ _) = notHandled "Equational constraint" (ppr p)
+repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
-- yield the representation of a list of types
--
repTy (HsTyVar n)
| isTvOcc (nameOccName n) = do
- tv1 <- lookupBinder n
+ tv1 <- lookupTvOcc n
repTvar tv1
| otherwise = do
tc1 <- lookupOcc n
repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
`nlHsAppTy` ty2)
repTy (HsParTy t) = repLTy t
-repTy (HsNumTy i) =
- panic "DsMeta.repTy: Can't represent number types (for generics)"
repTy (HsPredTy pred) = repPred pred
-repTy (HsKindSig ty kind) =
- panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
+repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
+repTy ty = notHandled "Exotic form of type" (ppr ty)
-----------------------------------------------------------------------------
-- unless we can make sure that constructs, which are plainly not
-- supported in TH already lead to error messages at an earlier stage
repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
-repLE (L _ e) = repE e
+repLE (L loc e) = putSrcSpanDs loc (repE e)
repE :: HsExpr Name -> DsM (Core TH.ExpQ)
repE (HsVar x) =
Just (Bound y) -> repVarOrCon x (coreVar y)
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') } }
-repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
+repE e@(HsIPVar x) = notHandled "Implicit parameters" (ppr e)
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
ret <- repNoBindSt body';
e <- repComp (nonEmptyCoreList (zs ++ [ret]));
wrapGenSyns ss e }
-repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
+repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
-repE (ExplicitPArr ty es) =
- panic "DsMeta.repE: No explicit parallel arrays yet"
-repE (ExplicitTuple es boxed)
+repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e)
+repE e@(ExplicitTuple es boxed)
| isBoxed boxed = do { xs <- repLEs es; repTup xs }
- | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
+ | otherwise = notHandled "Unboxed tuples" (ppr e)
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 }
ds2 <- repLE e2
ds3 <- repLE e3
repFromThenTo ds1 ds2 ds3
-repE (PArrSeq _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
-repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
-repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
-repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets"
repE (HsSpliceE (HsSplice n _))
= do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') }
- other -> pprPanic "HsSplice" (ppr n) }
+ other -> pprPanic "HsSplice" (ppr n) }
+ -- Should not happen; statically checked
-repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
+repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
+repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
+repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
+repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
+repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
+repE e = notHandled "Expression form" (ppr e)
-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt,
; gs <- repGuards guards
; match <- repMatch p1 gs ds
; wrapGenSyns (ss1++ss2) match }}}
+repMatchTup other = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
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 }
-----------------------------------------------------------------------------
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
; return (ss2, z : zs) }
-repSts [] = return ([],[])
-repSts other = panic "Exotic Stmt in meta brackets"
+repSts [] = return ([],[])
+repSts other = notHandled "Exotic statement" (ppr other)
-----------------------------------------------------------
= do { core_list <- coreList decQTyConName []
; return ([], core_list) }
-repBinds (HsIPBinds _)
- = panic "DsMeta:repBinds: can't do implicit parameters"
+repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
repBinds (HsValBinds decs)
= do { let { bndrs = map unLoc (collectHsValBinders decs) }
= do { core1 <- rep_binds' (unionManyBags (map snd binds))
; core2 <- rep_sigs' sigs
; return (core1 ++ core2) }
+rep_val_binds (ValBindsIn binds sigs)
+ = panic "rep_val_binds: ValBindsIn"
rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
rep_binds binds = do { binds_w_locs <- rep_binds' binds
; ans <- repVal patcore x empty_decls
; return (srcLocSpan (getSrcLoc v), ans) }
+rep_bind other = panic "rep_bind: AbsBinds"
+
-----------------------------------------------------------------------------
-- Since everything in a Bind is mutually recursive we need rename all
-- all the variables simultaneously. For example:
do { xs <- repLPs ps; body <- repLE e; repLam xs body })
; wrapGenSyns ss lam }
-repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
+repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
-----------------------------------------------------------------------------
repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
- PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
- RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
- ; ps <- sequence $ map repLP (map snd pairs)
+ 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' }
p2' <- repLP p2;
repPinfix p1' con_str p2' }
}
-repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
-repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
-repP (SigPatIn p t) = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
-repP other = panic "Exotic pattern inside meta brackets"
+repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
+repP p@(NPat l (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
+ -- here in DsMeta, and I don't want to do that today!
+ -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
+ -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+ -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
+repP other = notHandled "Exotic pattern" (ppr other)
----------------------------------------------------------
-- Declaration ordering helpers
= do { mb_val <- dsLookupMetaEnv n;
case mb_val of
Just (Bound x) -> return (coreVar x)
- other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
+ other -> failWithDs msg }
+ where
+ 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
--
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)
+ other -> 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
repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPlist (MkC ps) = rep2 listPName [ps]
-repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
-repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
-
--------------- Expressions -----------------
repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
repCtxt (MkC tys) = rep2 cxtName [tys]
-repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name)
+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 fst ips)
- arg_tys <- mapM repBangTy (map snd 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
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
_ -> return lit
lit_expr <- dsLit lit'
- rep2 lit_name [lit_expr]
+ case mb_lit_name of
+ Just lit_name -> rep2 lit_name [lit_expr]
+ Nothing -> notHandled "Exotic literal" (ppr lit)
where
- lit_name = case lit of
- HsInteger _ _ -> integerLName
- HsInt _ -> integerLName
- HsIntPrim _ -> intPrimLName
- HsFloatPrim _ -> floatPrimLName
- HsDoublePrim _ -> doublePrimLName
- HsChar _ -> charLName
- HsString _ -> stringLName
- HsRat _ _ -> rationalLName
- other -> uh_oh
- uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
- (ppr lit)
+ mb_lit_name = case lit of
+ 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
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger i integer_ty
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
+mk_string s = do string_ty <- lookupType stringTyConName
+ 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 (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 }
-- 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
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) }
coreVar :: Id -> Core TH.Name -- The Id has type Name
coreVar id = MkC (Var id)
+----------------- Failure -----------------------
+notHandled :: String -> SDoc -> DsM a
+notHandled what doc = failWithDs msg
+ where
+ msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
+ 2 doc
-- %************************************************************************
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,
decQTyConName, conQTyConName, strictTypeQTyConName,
varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
- fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
+ fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
+
+ -- Quasiquoting
+ quoteExpName, quotePatName]
thSyn :: Module
-thSyn = mkTHModule FSLIT("Language.Haskell.TH.Syntax")
-thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib")
+thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
+thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
+qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
-mk_known_key_name mod space str uniq
- = mkExternalName uniq mod (mkOccNameFS space str)
- Nothing noSrcLoc
-
-libFun = mk_known_key_name thLib OccName.varName
-libTc = mk_known_key_name thLib OccName.tcName
-thFun = mk_known_key_name thSyn OccName.varName
-thTc = mk_known_key_name thSyn OccName.tcName
+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 = thTc (fsLit "Q") qTyConKey
+nameTyConName = thTc (fsLit "Name") nameTyConKey
+fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
+patTyConName = thTc (fsLit "Pat") patTyConKey
+fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
+expTyConName = thTc (fsLit "Exp") expTyConKey
+decTyConName = thTc (fsLit "Dec") decTyConKey
+typeTyConName = thTc (fsLit "Type") typeTyConKey
+matchTyConName = thTc (fsLit "Match") matchTyConKey
+clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
+funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
+
+returnQName = thFun (fsLit "returnQ") returnQIdKey
+bindQName = thFun (fsLit "bindQ") bindQIdKey
+sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
+newNameName = thFun (fsLit "newName") newNameIdKey
+liftName = thFun (fsLit "lift") liftIdKey
+mkNameName = thFun (fsLit "mkName") mkNameIdKey
+mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
+mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
+mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
+mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
-------------------- TH.Lib -----------------------
-- data Lit = ...
-charLName = libFun FSLIT("charL") charLIdKey
-stringLName = libFun FSLIT("stringL") stringLIdKey
-integerLName = libFun FSLIT("integerL") integerLIdKey
-intPrimLName = libFun FSLIT("intPrimL") intPrimLIdKey
-floatPrimLName = libFun FSLIT("floatPrimL") floatPrimLIdKey
-doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
-rationalLName = libFun FSLIT("rationalL") rationalLIdKey
+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 = libFun (fsLit "litP") litPIdKey
+varPName = libFun (fsLit "varP") varPIdKey
+tupPName = libFun (fsLit "tupP") tupPIdKey
+conPName = libFun (fsLit "conP") conPIdKey
+infixPName = libFun (fsLit "infixP") infixPIdKey
+tildePName = libFun (fsLit "tildeP") tildePIdKey
+asPName = libFun (fsLit "asP") asPIdKey
+wildPName = libFun (fsLit "wildP") wildPIdKey
+recPName = libFun (fsLit "recP") recPIdKey
+listPName = libFun (fsLit "listP") listPIdKey
+sigPName = libFun (fsLit "sigP") sigPIdKey
-- type FieldPat = ...
-fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
+fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
-- data Match = ...
-matchName = libFun FSLIT("match") matchIdKey
+matchName = libFun (fsLit "match") matchIdKey
-- data Clause = ...
-clauseName = libFun FSLIT("clause") clauseIdKey
+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 = 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 = 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 = 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 = libFun (fsLit "fieldExp") fieldExpIdKey
-- data Body = ...
-guardedBName = libFun FSLIT("guardedB") guardedBIdKey
-normalBName = libFun FSLIT("normalB") normalBIdKey
+guardedBName = libFun (fsLit "guardedB") guardedBIdKey
+normalBName = libFun (fsLit "normalB") normalBIdKey
-- data Guard = ...
-normalGEName = libFun FSLIT("normalGE") normalGEIdKey
-patGEName = libFun FSLIT("patGE") patGEIdKey
+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 = 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 = libFun (fsLit "funD") funDIdKey
+valDName = libFun (fsLit "valD") valDIdKey
+dataDName = libFun (fsLit "dataD") dataDIdKey
+newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
+tySynDName = libFun (fsLit "tySynD") tySynDIdKey
+classDName = libFun (fsLit "classD") classDIdKey
+instanceDName = libFun (fsLit "instanceD") instanceDIdKey
+sigDName = libFun (fsLit "sigD") sigDIdKey
+forImpDName = libFun (fsLit "forImpD") forImpDIdKey
-- type Ctxt = ...
-cxtName = libFun FSLIT("cxt") cxtIdKey
+cxtName = libFun (fsLit "cxt") cxtIdKey
-- data Strict = ...
-isStrictName = libFun FSLIT("isStrict") isStrictKey
-notStrictName = libFun FSLIT("notStrict") notStrictKey
+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
+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 = libFun (fsLit "strictType") strictTKey
-- type VarStrictType = ...
-varStrictTypeName = libFun FSLIT("varStrictType") varStrictTKey
+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 = libFun (fsLit "forallT") forallTIdKey
+varTName = libFun (fsLit "varT") varTIdKey
+conTName = libFun (fsLit "conT") conTIdKey
+tupleTName = libFun (fsLit "tupleT") tupleTIdKey
+arrowTName = libFun (fsLit "arrowT") arrowTIdKey
+listTName = libFun (fsLit "listT") listTIdKey
+appTName = libFun (fsLit "appT") appTIdKey
-- data Callconv = ...
-cCallName = libFun FSLIT("cCall") cCallIdKey
-stdCallName = libFun FSLIT("stdCall") stdCallIdKey
+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 = libFun (fsLit "unsafe") unsafeIdKey
+safeName = libFun (fsLit "safe") safeIdKey
+threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
-- data FunDep = ...
-funDepName = libFun FSLIT("funDep") funDepIdKey
-
-matchQTyConName = libTc FSLIT("MatchQ") matchQTyConKey
-clauseQTyConName = libTc FSLIT("ClauseQ") clauseQTyConKey
-expQTyConName = libTc FSLIT("ExpQ") expQTyConKey
-stmtQTyConName = libTc FSLIT("StmtQ") stmtQTyConKey
-decQTyConName = libTc FSLIT("DecQ") decQTyConKey
-conQTyConName = libTc FSLIT("ConQ") conQTyConKey
-strictTypeQTyConName = libTc FSLIT("StrictTypeQ") strictTypeQTyConKey
-varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
-typeQTyConName = libTc FSLIT("TypeQ") typeQTyConKey
-fieldExpQTyConName = libTc FSLIT("FieldExpQ") fieldExpQTyConKey
-patQTyConName = libTc FSLIT("PatQ") patQTyConKey
-fieldPatQTyConName = libTc FSLIT("FieldPatQ") fieldPatQTyConKey
+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
+
+-- quasiquoting
+quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
+quotePatName = qqFun (fsLit "quotePat") quotePatKey
-- TyConUniques available: 100-129
-- Check in PrelNames if you want to change this
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
-- data Pat = ...
litPIdKey = mkPreludeMiscIdUnique 220
-- data FunDep = ...
funDepIdKey = mkPreludeMiscIdUnique 320
+-- quasiquoting
+quoteExpKey = mkPreludeMiscIdUnique 321
+quotePatKey = mkPreludeMiscIdUnique 322
+
projects / ghc-hetmet.git / blobdiff