X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=bbdf08bbe5eacecb8ea34e6be915047d9bd08037;hb=6821c8a47c0fc61a2d989d368f926cc0ded776e9;hp=c1f2456830344315e09c9d31ebe5e67becee3474;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index c1f2456..bbdf08b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1,4 +1,7 @@ ----------------------------------------------------------------------------- +-- +-- (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 @@ -10,58 +13,58 @@ -- 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 @@ -135,7 +138,7 @@ groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, -- 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] @@ -214,7 +217,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, -- 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 @@ -231,7 +234,7 @@ 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 +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 @@ -251,25 +254,27 @@ repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now (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 [] @@ -280,28 +285,27 @@ 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 = 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 @@ -326,7 +330,7 @@ repDerivs (Just ctxt) 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) ------------------------------------------------------- @@ -396,8 +400,8 @@ repPred (HsClassP cls tys) = do tcon <- repTy (HsTyVar cls) tys1 <- repLTys tys repTapps tcon tys1 -repPred (HsIParam _ _) = - panic "DsMeta.repTy: Can't represent predicates with implicit parameters" +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 -- @@ -419,7 +423,7 @@ repTy (HsForAllTy _ tvs ctxt ty) = repTy (HsTyVar n) | isTvOcc (nameOccName n) = do - tv1 <- lookupBinder n + tv1 <- lookupTvOcc n repTvar tv1 | otherwise = do tc1 <- lookupOcc n @@ -448,11 +452,9 @@ repTy (HsTupleTy tc tys) = do 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) ----------------------------------------------------------------------------- @@ -467,7 +469,7 @@ repLEs es = do { es' <- mapM repLE es ; -- 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) = @@ -478,7 +480,7 @@ 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 @@ -524,18 +526,17 @@ repE (HsDo ListComp sts body ty) 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 } @@ -557,18 +558,20 @@ repE (ArithSeq _ aseq) = 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, @@ -583,6 +586,7 @@ 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" repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) = @@ -614,12 +618,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 } ----------------------------------------------------------------------------- @@ -669,8 +673,8 @@ repSts (ExprStmt e _ _ : ss) = ; 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) ----------------------------------------------------------- @@ -682,8 +686,7 @@ repBinds EmptyLocalBinds = 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) } @@ -703,6 +706,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 (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 @@ -750,6 +755,8 @@ 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" + ----------------------------------------------------------------------------- -- Since everything in a Bind is mutually recursive we need rename all -- all the variables simultaneously. For example: @@ -782,7 +789,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) 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) ----------------------------------------------------------------------------- @@ -812,9 +819,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 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' } @@ -822,10 +830,17 @@ repP (ConPatIn dc details) 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 @@ -878,7 +893,9 @@ lookupBinder n = do { mb_val <- dsLookupMetaEnv n; case mb_val of Just (Bound x) -> return (coreVar x) - other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) } + 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 -- @@ -899,6 +916,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) + 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 @@ -1030,9 +1059,6 @@ repPwild = rep2 wildPName [] repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ) repPlist (MkC ps) = rep2 listPName [ps] -repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ) -repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] - --------------- Expressions ----------------- repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str @@ -1177,15 +1203,15 @@ repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty] repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] -repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name) +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 @@ -1234,34 +1260,39 @@ 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 _ -> 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 @@ -1298,6 +1329,9 @@ 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) } @@ -1307,6 +1341,12 @@ coreIntLit i = return (MkC (mkIntExpr (fromIntegral i))) 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 -- %************************************************************************ @@ -1330,7 +1370,7 @@ 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, @@ -1386,187 +1426,193 @@ templateHaskellNames = [ 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 @@ -1615,9 +1661,10 @@ 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 -- data Pat = ... litPIdKey = mkPreludeMiscIdUnique 220 @@ -1734,3 +1781,7 @@ threadsafeIdKey = mkPreludeMiscIdUnique 307 -- data FunDep = ... funDepIdKey = mkPreludeMiscIdUnique 320 +-- quasiquoting +quoteExpKey = mkPreludeMiscIdUnique 321 +quotePatKey = mkPreludeMiscIdUnique 322 +