-- 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 HsSyn
import Class
import PrelNames
-import OccName
-- To avoid clashes with DsMeta.varName we must make a local alias for
-- OccName.varName we do this by removing varName from the import of
-- OccName above, making a qualified instance of OccName and using
import Module
import Id
-import OccName
import Name
import NameEnv
-import Type
import TcType
import TyCon
import TysWiredIn
repTy (HsTyVar n)
| isTvOcc (nameOccName n) = do
- tv1 <- lookupBinder n
+ tv1 <- lookupTvOcc n
repTvar tv1
| otherwise = do
tc1 <- lookupOcc n
repE e@(ExplicitTuple es boxed)
| isBoxed boxed = do { xs <- repLEs es; repTup xs }
| otherwise = notHandled "Unboxed tuples" (ppr e)
-repE (RecordCon c _ (HsRecordBinds flds))
+repE (RecordCon c _ flds)
= do { x <- lookupLOcc c;
fs <- repFields flds;
repRecCon x fs }
-repE (RecordUpd e (HsRecordBinds flds) _ _)
+repE (RecordUpd e flds _ _ _)
= do { x <- repLE e;
fs <- repFields flds;
repRecUpd x fs }
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 }
-----------------------------------------------------------------------------
= do { core1 <- rep_binds' (unionManyBags (map snd binds))
; core2 <- rep_sigs' sigs
; return (core1 ++ core2) }
-rep_val_binds (ValBindsOut binds sigs)
- = panic "rep_val_binds: ValBindsOut"
+rep_val_binds (ValBindsIn 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
do { xs <- repLPs ps; body <- repLE e; repLam xs body })
; wrapGenSyns ss lam }
-repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m)
+repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
-----------------------------------------------------------------------------
repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
- PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
- RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs)
- ; ps <- sequence $ map repLP (map hsRecFieldArg pairs)
+ PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
+ RecCon rec -> do { let flds = rec_flds rec
+ ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
+ ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
; fps' <- coreList fieldPatQTyConName fps
; repPrec con_str fps' }
p2' <- repLP p2;
repPinfix p1' con_str p2' }
}
-repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
-repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
+repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
+repP p@(NPat 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
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
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 hsRecFieldId ips)
- arg_tys <- mapM repBangTy (map hsRecFieldArg ips)
+ = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
+ arg_tys <- mapM repBangTy (map cd_fld_type ips)
arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
arg_vs arg_tys
arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
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 (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
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")
+qqLib = mkTHModule FSLIT("Language.Haskell.TH.Quote")
mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
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
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
-- data FunDep = ...
funDepIdKey = mkPreludeMiscIdUnique 320
+-- quasiquoting
+quoteExpKey = mkPreludeMiscIdUnique 321
+quotePatKey = mkPreludeMiscIdUnique 322
+