# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.223 2002/09/16 10:16:14 simonmar Exp $
+# $Id: Makefile,v 1.224 2002/10/09 15:03:48 simonpj Exp $
TOP = ..
# Only include GHCi if we're bootstrapping with at least version 411
ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES"
# Yes, include the interepreter, readline, and Template Haskell extensions
-SRC_HC_OPTS += -DGHCI -package readline -package haskell-src
+SRC_HC_OPTS += -DGHCI -package haskell-src
ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
-SRC_HC_OPTS += -package unix
+SRC_HC_OPTS += -package unix -package readline
endif
ALL_DIRS += ghci
else
import qualified Demand
import NewDemand
import Outputable
-import Util ( listLengthCmp )
import Maybe ( isJust )
+#ifdef OLD_STRICTNESS
+import Util ( listLengthCmp )
import List ( replicate )
+#endif
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setSpecInfo`,
-- it'll never be evaluated
mkTyVarSubst :: [TyVar] -> [Type] -> Subst
mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys))
- (zip_ty_env tyvars tys emptySubstEnv)
+ (zipTyEnv tyvars tys)
-- mkTopTyVarSubst is called when doing top-level substitutions.
-- Here we expect that the free vars of the range of the
-- substitution will be empty.
mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
-mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
+mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zipTyEnv tyvars tys)
+
+zipTyEnv tyvars tys
+#ifdef DEBUG
+ | length tyvars /= length tys
+ = pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv
+ | otherwise
+ = zip_ty_env tyvars tys emptySubstEnv
+#endif
zip_ty_env [] [] env = env
zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
= dsMonoBinds auto_scc binds_2 rest `thenDs` \ rest' ->
dsMonoBinds auto_scc binds_1 rest'
-dsMonoBinds _ (CoreMonoBind var core_expr) rest
- = returnDs ((var, core_expr) : rest)
-
dsMonoBinds _ (VarMonoBind var expr) rest
= dsExpr expr `thenDs` \ core_expr ->
-- 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
-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
+--
+-- It also defines a bunch of knownKeyNames, in the same way as is done
+-- in prelude/PrelNames. It's much more convenient to do it here, becuase
+-- otherwise we have to recompile PrelNames whenever we add a Name, which is
+-- a Royal Pain (triggers other recompilation).
-----------------------------------------------------------------------------
-module DsMeta( dsBracket ) where
+module DsMeta( dsBracket,
+ templateHaskellNames, qTyConName,
+ liftName, exprTyConName, declTyConName ) where
#include "HsVersions.h"
Match(..), GRHSs(..), GRHS(..), HsBracket(..),
HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
HsBinds(..), MonoBinds(..), HsConDetails(..),
- HsDecl(..), TyClDecl(..), ForeignDecl(..),
- PendingSplice,
+ TyClDecl(..), HsGroup(..),
+ HsType(..), HsContext(..), HsPred(..), HsTyOp(..),
+ HsTyVarBndr(..), Sig(..), ForeignDecl(..),
+ InstDecl(..), ConDecl(..), BangType(..),
+ PendingSplice, splitHsInstDeclTy,
placeHolderType, tyClDeclNames,
- collectHsBinders,
- collectPatBinders, collectPatsBinders
+ collectHsBinders, collectPatBinders, collectPatsBinders,
+ hsTyVarName, hsConArgs, getBangType
)
+import PrelNames ( mETA_META_Name, varQual, tcQual )
import Name ( Name, nameOccName, nameModule )
-import OccName ( isDataOcc, occNameUserString )
+import OccName ( isDataOcc, isTvOcc, occNameUserString )
import Module ( moduleUserString )
-import PrelNames ( intLName,charLName,
- plitName, pvarName, ptupName, pconName,
- ptildeName, paspatName, pwildName,
- varName, conName, litName, appName, lamName,
- tupName, doEName, compName,
- listExpName, condName, letEName, caseEName,
- infixAppName, guardedName, normalName,
- bindStName, letStName, noBindStName,
- fromName, fromThenName, fromToName, fromThenToName,
- funName, valName, matchName, clauseName,
- liftName, gensymName, bindQName,
- matTyConName, expTyConName, clsTyConName,
- pattTyConName, exprTyConName, declTyConName
- )
-
import Id ( Id )
import NameEnv
+import NameSet
import Type ( Type, mkGenTyConApp )
+import TyCon ( DataConDetails(..) )
import TysWiredIn ( stringTy )
import CoreSyn
import CoreUtils ( exprType )
+import SrcLoc ( noSrcLoc )
+import Maybe ( catMaybes )
import Panic ( panic )
+import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
+import BasicTypes ( NewOrData(..), StrictnessMark(..) )
import Outputable
import FastString ( mkFastString )
-- The quoted thing is parameterised over Name, even though it has
-- been type checked. We don't want all those type decorations!
-dsBracket (ExpBr e) splices
- = dsExtendMetaEnv new_bit (repE e) `thenDs` \ (MkC new_e) ->
- returnDs new_e
+dsBracket brack splices
+ = dsExtendMetaEnv new_bit (do_brack brack)
where
new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
+ do_brack (ExpBr e) = do { MkC e1 <- repE e ; return e1 }
+ do_brack (PatBr p) = do { MkC p1 <- repP p ; return p1 }
+ do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 }
+ do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
{- -------------- Examples --------------------
-}
------------------------------------------------------------------------------
--- repD
-
-{-
-repDs :: [HsDecl Name] -> DsM (Core [M.Decl])
-repDs decls
- = do { ds' <- mapM repD ds ;
- coreList declTyConName ds' }
-
-repD :: HsDecl Name -> DsM (Core M.Decl)
-repD (TyClD (TyData { tcdND = DataType, tcdCtxt = [],
- tcdName = tc, tcdTyVars = tvs,
- tcdCons = cons, tcdDerivs = mb_derivs }))
- = do { tc1 <- localVar tc ;
- cons1 <- mapM repCon cons ;
+-------------------------------------------------------
+-- Declarations
+-------------------------------------------------------
+
+repTopDs :: HsGroup Name -> DsM (Core [M.Decl])
+repTopDs group
+ = do { let { bndrs = groupBinders group } ;
+ ss <- mkGenSyms bndrs ;
+
+ decls <- addBinds ss (do {
+ val_ds <- rep_binds (hs_valds group) ;
+ tycl_ds <- mapM repTyClD (hs_tyclds group) ;
+ inst_ds <- mapM repInstD (hs_instds group) ;
+ -- more needed
+ return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
+
+ core_list <- coreList declTyConName decls ;
+ wrapNongenSyms ss core_list
+ -- Do *not* gensym top-level binders
+ }
+
+groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
+ hs_fords = foreign_decls })
+ = collectHsBinders val_decls ++
+ [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
+ [n | ForeignImport n _ _ _ _ <- foreign_decls]
+
+
+repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))
+
+repTyClD (TyData { tcdND = DataType, tcdCtxt = [],
+ tcdName = tc, tcdTyVars = tvs,
+ tcdCons = DataCons cons, tcdDerivs = mb_derivs })
+ = do { tc1 <- lookupBinder tc ;
tvs1 <- repTvs tvs ;
+ cons1 <- mapM repC cons ;
cons2 <- coreList consTyConName cons1 ;
derivs1 <- repDerivs mb_derivs ;
- derivs2 <- coreList stringTyConName derivs1 ;
- repData tc1 tvs1 cons2 derivs2 }
+ dec <- repData tc1 tvs1 cons2 derivs1 ;
+ return (Just dec) }
-repD (TyClD (ClassD { tcdCtxt = cxt, tcdName = cls,
+repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls,
tcdTyVars = tvs, tcdFDs = [],
- tcdSigs = sigs, tcdMeths = Just decls
- }))
- = do { cls1 <- localVar cls ;
+ tcdSigs = sigs, tcdMeths = Just binds
+ })
+ = do { cls1 <- lookupBinder cls ;
tvs1 <- repTvs tvs ;
cxt1 <- repCtxt cxt ;
- sigs1 <- repSigs sigs ;
- repClass cxt1 cls1 tvs1 sigs1 }
+ sigs1 <- rep_sigs sigs ;
+ binds1 <- rep_monobind binds ;
+ decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
+ dec <- repClass cxt1 cls1 tvs1 decls1 ;
+ return (Just dec) }
+
+-- Un-handled cases
+repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
+ return Nothing
+ }
+ where
+ msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
-repD (InstD (InstDecl ty binds _ _ loc))
+repInstD (InstDecl ty binds _ _ loc)
-- Ignore user pragmas for now
- = do { cls1 <- localVar cls ;
- cxt1 <- repCtxt cxt ;
- tys1 <- repTys tys ;
- binds1 <- repMonoBind binds ;
- binds2 <- coreList declTyConName binds1 ;
- repInst ... binds2 }
+ = do { cxt1 <- repCtxt cxt ;
+ inst_ty1 <- repPred (HsClassP cls tys) ;
+ binds1 <- rep_monobind binds ;
+ decls1 <- coreList declTyConName binds1 ;
+ repInst cxt1 inst_ty1 decls1 }
where
(tvs, cxt, cls, tys) = splitHsInstDeclTy ty
--- Un-handled cases
-repD d = do { dsWarn (hang (ptext SLIT("Cannot desugar this Template Haskell declaration:"))
- 4 (ppr d)) ;
- return (ValD EmptyBinds) -- A sort of empty decl
- }
+
+-------------------------------------------------------
+-- Constructors
+-------------------------------------------------------
+
+repC :: ConDecl Name -> DsM (Core M.Cons)
+repC (ConDecl con [] [] details loc)
+ = do { con1 <- lookupBinder con ;
+ arg_tys <- mapM (repBangTy con) (hsConArgs details) ;
+ arg_tys1 <- coreList typeTyConName arg_tys ;
+ repConstr con1 arg_tys1 }
+
+repBangTy con (BangType NotMarkedStrict ty) = repTy ty
+repBangTy con bty = do { addDsWarn msg ; repTy (getBangType bty) }
+ where
+ msg = ptext SLIT("Ignoring stricness on argument of constructor")
+ <+> quotes (ppr con)
+
+-------------------------------------------------------
+-- Deriving clause
+-------------------------------------------------------
+
+repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
+repDerivs Nothing = return (coreList' stringTy [])
+repDerivs (Just ctxt)
+ = do { strs <- mapM rep_deriv ctxt ;
+ return (coreList' stringTy strs) }
+ where
+ rep_deriv :: HsPred Name -> DsM (Core String)
+ -- Deriving clauses must have the simple H98 form
+ rep_deriv (HsClassP cls []) = lookupOcc cls
+ rep_deriv other = panic "rep_deriv"
+
+
+-------------------------------------------------------
+-- Signatures in a class decl, or a group of bindings
+-------------------------------------------------------
+
+rep_sigs :: [Sig Name] -> DsM [Core M.Decl]
+ -- We silently ignore ones we don't recognise
+rep_sigs sigs = do { sigs1 <- mapM rep_sig sigs ;
+ return (concat sigs1) }
+
+rep_sig :: Sig Name -> DsM [Core M.Decl]
+ -- Singleton => Ok
+ -- Empty => Too hard, signature ignored
+rep_sig (ClassOpSig nm _ ty _) = rep_proto nm ty
+rep_sig (Sig nm ty _) = rep_proto nm ty
+rep_sig other = return []
+
+rep_proto nm ty = do { nm1 <- lookupBinder nm ;
+ ty1 <- repTy ty ;
+ sig <- repProto nm1 ty1 ;
+ return [sig] }
+
+
+-------------------------------------------------------
+-- Types
+-------------------------------------------------------
repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
- coreList stringTyConName tvs1 }
+ return (coreList' stringTy tvs1) }
+-----------------
repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
-repCtxt ctxt
- = do {
+repCtxt ctxt = do { preds <- mapM repPred ctxt;
+ coreList typeTyConName preds }
-repTy :: HsType Name -> DsM (Core M.Type)
-repTy ty@(HsForAllTy _ cxt ty)
- = pprPanic "repTy" (ppr ty)
+-----------------
+repPred :: HsPred Name -> DsM (Core M.Type)
+repPred (HsClassP cls tys)
+ = do { tc1 <- lookupOcc cls; tcon <- repNamedTyCon tc1;
+ tys1 <- repTys tys; repTapps tcon tys1 }
+repPred (HsIParam _ _) = panic "No implicit parameters yet"
-repTy (HsTyVar tv)
- = do { tv1 <- localVar tv ; repTvar tv1 }
+-----------------
+repTys :: [HsType Name] -> DsM [Core M.Type]
+repTys tys = mapM repTy tys
-repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a2 }
-repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
-repTy (HsListTy t) = do { t1 <- repTy t ; list <- repListTyCon ; repTapp tcon t1 }
+-----------------
+repTy :: HsType Name -> DsM (Core M.Type)
-repTy (HsTupleTy tc tys)
- = do
+repTy (HsTyVar n)
+ | isTvOcc (nameOccName n) = do { tv1 <- localVar n ; repTvar tv1 }
+ | otherwise = do { tc1 <- lookupOcc n; repNamedTyCon tc1 }
+repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a1 }
+repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ;
+ tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
+repTy (HsListTy t) = do { t1 <- repTy t ; tcon <- repListTyCon ; repTapp tcon t1 }
+repTy (HsTupleTy tc tys) = do { tys1 <- repTys tys;
+ tcon <- repTupleTyCon (length tys);
+ repTapps tcon tys1 }
repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2)
-repTy (HsOpTy ty1 (HsTyOp n) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
+repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
repTy (HsParTy t) = repTy t
-repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsApp (HsTyVar c) tys)
+repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsAppTy (HsTyVar c) tys)
- | HsTupleTy HsTupCon
- [HsType name] -- Element types (length gives arity)
-
- | HsKindSig (HsType name) -- (ty :: kind)
- Kind -- A type with a kind signature
--}
+repTy other_ty = pprPanic "repTy" (ppr other_ty) -- HsForAllTy, HsKindSig
-----------------------------------------------------------------------------
--- Using the phantom type constructors "repConstructor" we define repE
--- This ensures we keep the types of the CoreExpr objects we build are
--- consistent with their real types.
+-- Expressions
+-----------------------------------------------------------------------------
repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
repEs es = do { es' <- mapM repE es ;
= do { mb_val <- dsLookupMetaEnv x
; case mb_val of
Nothing -> do { str <- globalVar x
- ; if constructor x then
- repCon str
- else
- repVar str }
- Just (Bound y) -> repVar (coreVar y)
+ ; repVarOrCon x str }
+ Just (Bound y) -> repVarOrCon x (coreVar y)
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') } }
repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
-repE (OpApp e1 (HsVar op) fix e2) =
- do { arg1 <- repE e1;
+repE (OpApp e1 (HsVar op) fix e2)
+ = do { arg1 <- repE e1;
arg2 <- repE e2;
- mb_val <- dsLookupMetaEnv op;
- the_op <- case mb_val of {
- Nothing -> globalVar op ;
- Just (Bound x) -> return (coreVar x) ;
- other -> pprPanic "repE:OpApp" (ppr op) } ;
+ the_op <- lookupOcc op ;
repInfixApp arg1 the_op arg2 }
repE (HsCase e ms loc)
-- I havn't got the types here right yet
repE (HsDo DoExpr sts _ ty loc) = do { (ss,zs) <- repSts sts;
e <- repDoE (nonEmptyCoreList zs);
- combine expTyConName ss e }
+ wrapGenSyns expTyConName ss e }
repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts;
e <- repComp (nonEmptyCoreList zs);
- combine expTyConName ss e }
+ wrapGenSyns expTyConName ss e }
repE (ArithSeqIn (From e)) = do { ds1 <- repE e; repFrom ds1 }
repE (ArithSeqIn (FromThen e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2;
ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 }
-repE (HsIf x y z loc)
- = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c }
-
-repE (HsLet bs e) =
- do { (ss,ds) <- repDecs bs
- ; e2 <- addBinds ss (repE e)
- ; z <- repLetE ds e2
- ; combine expTyConName ss z }
-repE (HsWith _ _ _) = panic "No with for implicit parameters yet"
-repE (ExplicitList ty es) =
- do { xs <- repEs es; repListExp xs }
-repE (ExplicitTuple es boxed) =
- do { xs <- repEs es; repTup xs }
-repE (ExplicitPArr ty es) = panic "No parallel arrays yet"
-repE (RecordConOut _ _ _) = panic "No record construction yet"
+repE (HsIf x y z loc) = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c }
+
+repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
+ ; e2 <- addBinds ss (repE e)
+ ; z <- repLetE ds e2
+ ; wrapGenSyns expTyConName ss z }
+repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
+repE (ExplicitTuple es boxed) = do { xs <- repEs es; repTup xs }
+
+repE (HsWith _ _ _) = panic "No with for implicit parameters yet"
+repE (ExplicitPArr ty es) = panic "No parallel arrays yet"
+repE (RecordConOut _ _ _) = panic "No record construction yet"
repE (RecordUpdOut _ _ _ _) = panic "No record update yet"
-repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet"
+repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet"
-----------------------------------------------------------------------------
do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repP p
- ; (ss2,ds) <- repDecs wheres
+ ; (ss2,ds) <- repBinds wheres
; addBinds ss2 $ do {
; gs <- repGuards guards
; match <- repMatch p1 gs ds
- ; combine matTyConName (ss1++ss2) match }}}
+ ; wrapGenSyns matTyConName (ss1++ss2) match }}}
repClauseTup :: Match Name -> DsM (Core M.Clse)
repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
ps1 <- repPs ps
- ; (ss2,ds) <- repDecs wheres
+ ; (ss2,ds) <- repBinds wheres
; addBinds ss2 $ do {
gs <- repGuards guards
; clause <- repClause ps1 gs ds
- ; combine clsTyConName (ss1++ss2) clause }}}
+ ; wrapGenSyns clsTyConName (ss1++ss2) clause }}}
repGuards :: [GRHS Name] -> DsM (Core M.Rihs)
-repGuards [GRHS[ResultStmt e loc] loc2]
+repGuards [GRHS [ResultStmt e loc] loc2]
= do {a <- repE e; repNormal a }
repGuards other
= do { zs <- mapM process other;
; z <- repBindSt p1 e2
; return (ss1++ss2, z : zs) }}
repSts (LetStmt bs : ss) =
- do { (ss1,ds) <- repDecs bs
+ do { (ss1,ds) <- repBinds bs
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
repSts other = panic "Exotic Stmt in meta brackets"
+-----------------------------------------------------------
+-- Bindings
+-----------------------------------------------------------
-repDecs :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
-repDecs decs
+repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
+repBinds decs
= do { let { bndrs = collectHsBinders decs } ;
- ss <- mkGenSyms bndrs ;
- core <- addBinds ss (rep_decs decs) ;
+ ss <- mkGenSyms bndrs ;
+ core <- addBinds ss (rep_binds decs) ;
core_list <- coreList declTyConName core ;
return (ss, core_list) }
-rep_decs :: HsBinds Name -> DsM [Core M.Decl]
-rep_decs EmptyBinds = return []
-rep_decs (ThenBinds x y)
- = do { core1 <- rep_decs x
- ; core2 <- rep_decs y
+rep_binds :: HsBinds Name -> DsM [Core M.Decl]
+rep_binds EmptyBinds = return []
+rep_binds (ThenBinds x y)
+ = do { core1 <- rep_binds x
+ ; core2 <- rep_binds y
; return (core1 ++ core2) }
-rep_decs (MonoBind bs sigs _)
- = do { core1 <- repMonoBind bs
+rep_binds (MonoBind bs sigs _)
+ = do { core1 <- rep_monobind bs
; core2 <- rep_sigs sigs
; return (core1 ++ core2) }
-rep_sigs sigs = return [] -- Incomplete!
-
-repMonoBind :: MonoBinds Name -> DsM [Core M.Decl]
-repMonoBind EmptyMonoBinds = return []
-repMonoBind (AndMonoBinds x y) = do { x1 <- repMonoBind x;
- y1 <- repMonoBind y;
- return (x1 ++ y1) }
+rep_monobind :: MonoBinds Name -> DsM [Core M.Decl]
+rep_monobind EmptyMonoBinds = return []
+rep_monobind (AndMonoBinds x y) = do { x1 <- rep_monobind x;
+ y1 <- rep_monobind y;
+ return (x1 ++ y1) }
-- Note GHC treats declarations of a variable (not a pattern)
-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
-- with an empty list of patterns
-repMonoBind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
- = do { (ss,wherecore) <- repDecs wheres
+rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
+ = do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupBinder fn
; p <- repPvar fn'
; ans <- repVal p guardcore wherecore
; return [ans] }
-repMonoBind (FunMonoBind fn infx ms loc)
+rep_monobind (FunMonoBind fn infx ms loc)
= do { ms1 <- mapM repClauseTup ms
; fn' <- lookupBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
; return [ans] }
-repMonoBind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
+rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
= do { patcore <- repP pat
- ; (ss,wherecore) <- repDecs wheres
+ ; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; ans <- repVal patcore guardcore wherecore
; return [ans] }
-repMonoBind (VarMonoBind v e)
+rep_monobind (VarMonoBind v e)
= do { v' <- lookupBinder v
; e2 <- repE e
; x <- repNormal e2
-- representations we build a shadow datatype MB with the same structure as
-- MonoBinds, but which has slots for the representations
------------------------------------------------------------------------------
--- Gathering binders
-
-hsDeclsBinders :: [HsDecl Name] -> [Name]
-hsDeclsBinders ds = concat (map hsDeclBinders ds)
-
-hsDeclBinders (ValD b) = collectHsBinders b
-hsDeclBinders (TyClD d) = map fst (tyClDeclNames d)
-hsDeclBinders (ForD d) = forDeclBinders d
-hsDeclBinders other = []
-
-forDeclBinders (ForeignImport n _ _ _ _) = [n]
-forDeclBinders other = []
-
-----------------------------------------------------------------------------
--- GHC seems to allow a more general form of lambda abstraction than specified
+-- GHC allows a more general form of lambda abstraction than specified
-- by Haskell 98. In particular it allows guarded lambda's like :
-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
do { xs <- repPs ps; body <- repE e; repLam xs body })
- ; combine expTyConName ss lam }
+ ; wrapGenSyns expTyConName ss lam }
repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
-----------------------------------------------------------------------------
--- repP
+-- Patterns
-- repP deals with patterns. It assumes that we have already
-- walked over the pattern(s) once to collect the binders, and
-- have extended the environment. So every pattern-bound
repP (ListPat ps _) = repListPat ps
repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
repP (ConPatIn dc details)
- = do { con_str <- globalVar dc
+ = do { con_str <- lookupOcc dc
; case details of
PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
RecCon pairs -> error "No records in template haskell yet"
----------------------------------------------------------
--- Literals
-
-repLiteral :: HsLit -> DsM (Core M.Lit)
-repLiteral (HsInt i) = rep2 intLName [mkIntExpr i]
-repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
-repLiteral x = panic "trying to represent exotic literal"
-
-repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
-repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i]
-repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
-
-
-----------------------------------------------------------
-- The meta-environment
type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
return (mkGenTyConApp tc []) }
--- combine[ x1 <- e1, x2 <- e2 ] y
--- --> bindQ e1 (\ x1 -> bindQ e2 (\ x2 -> y))
+-- wrapGenSyns [(nm1,id1), (nm2,id2)] y
+-- --> bindQ (gensym nm1) (\ id1 ->
+-- bindQ (gensym nm2 (\ id2 ->
+-- y))
-combine :: Name -- Name of the type (consructor) for 'a'
- -> [GenSymBind]
- -> Core (M.Q a) -> DsM (Core (M.Q a))
-combine tc_name binds body@(MkC b)
+wrapGenSyns :: Name -- Name of the type (consructor) for 'a'
+ -> [GenSymBind]
+ -> Core (M.Q a) -> DsM (Core (M.Q a))
+wrapGenSyns tc_name binds body@(MkC b)
= do { elt_ty <- lookupType tc_name
; go elt_ty binds }
where
; repBindQ stringTy elt_ty
gensym_app (MkC (Lam id body')) }
-constructor :: Name -> Bool
-constructor x = isDataOcc (nameOccName x)
+-- Just like wrapGenSym, but don't actually do the gensym
+-- Instead use the existing name
+-- Only used for [Decl]
+wrapNongenSyms :: [GenSymBind]
+ -> Core [M.Decl] -> DsM (Core [M.Decl])
+wrapNongenSyms binds body@(MkC b)
+ = go binds
+ where
+ go [] = return body
+ go ((name,id) : binds)
+ = do { MkC body' <- go binds
+ ; MkC lit_str <- localVar name -- No gensym
+ ; return (MkC (Let (NonRec id lit_str) body'))
+ }
void = placeHolderType
repPwild = rep2 pwildName []
--------------- Expressions -----------------
+repVarOrCon :: Name -> Core String -> DsM (Core M.Expr)
+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
+ | otherwise = repVar str
+
repVar :: Core String -> DsM (Core M.Expr)
repVar (MkC s) = rep2 varName [s]
repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
-{-
repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
-repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl]
-repInst (MkC cxt) (MkC ty) (Core ds) = rep2 instanceDName [cxt, ty, ds]
+repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -> DsM (Core M.Decl)
+repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
+repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
+repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys]
+
------------ Types -------------------
repTvar :: Core String -> DsM (Core M.Type)
repTapps f [] = return f
repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
+--------- Type constructors --------------
repNamedTyCon :: Core String -> DsM (Core M.Type)
repNamedTyCon (MkC s) = rep2 namedTyConName [s]
-repTupleTyCon :: Core Int -> DsM (Core M.Tag)
-repTupleTyCon (MkC i) = rep2 tupleTyConName [i]
+repTupleTyCon :: Int -> DsM (Core M.Type)
+-- Note: not Core Int; it's easier to be direct here
+repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
repArrowTyCon :: DsM (Core M.Type)
repArrowTyCon = rep2 arrowTyConName []
-repListTyCon :: DsM (Core M.Tag)
+repListTyCon :: DsM (Core M.Type)
repListTyCon = rep2 listTyConName []
--}
+----------------------------------------------------------
+-- Literals
+
+repLiteral :: HsLit -> DsM (Core M.Lit)
+repLiteral (HsInt i) = rep2 intLName [mkIntExpr i]
+repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
+repLiteral x = panic "trying to represent exotic literal"
+
+repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
+repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i]
+repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
+
+
--------------- Miscellaneous -------------------
repLift :: Core e -> DsM (Core M.Expr)
coreList :: Name -- Of the TyCon of the element type
-> [Core a] -> DsM (Core [a])
coreList tc_name es
- = do { elt_ty <- lookupType tc_name
- ; let es' = map unC es
- ; return (MkC (mkListExpr elt_ty es')) }
+ = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
+
+coreList' :: Type -- The element type
+ -> [Core a] -> Core [a]
+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
nonEmptyCoreList :: [Core a] -> Core [a]
-- The list must be non-empty so we can get the element type
corePair :: (Core a, Core b) -> Core (a,b)
corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
+lookupOcc :: Name -> DsM (Core String)
+-- Lookup an occurrence; it can't be a splice.
+-- Use the in-scope bindings if they exist
+lookupOcc n
+ = do { mb_val <- dsLookupMetaEnv n ;
+ case mb_val of
+ Nothing -> globalVar n
+ Just (Bound x) -> return (coreVar x)
+ other -> pprPanic "repE:lookupOcc" (ppr n)
+ }
+
globalVar :: Name -> DsM (Core String)
globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
where
coreVar :: Id -> Core String -- The Id has type String
coreVar id = MkC (Var id)
+
+
+
+-- %************************************************************************
+-- %* *
+-- The known-key names for Template Haskell
+-- %* *
+-- %************************************************************************
+
+-- To add a name, do three things
+--
+-- 1) Allocate a key
+-- 2) Make a "Name"
+-- 3) Add the name to knownKeyNames
+
+templateHaskellNames :: NameSet
+-- The names that are implicitly mentioned by ``bracket''
+-- Should stay in sync with the import list of DsMeta
+templateHaskellNames
+ = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName,
+ pconName, ptildeName, paspatName, pwildName,
+ varName, conName, litName, appName, infixEName, lamName,
+ tupName, doEName, compName,
+ listExpName, condName, letEName, caseEName,
+ infixAppName, sectionLName, sectionRName, guardedName, normalName,
+ bindStName, letStName, noBindStName, parStName,
+ fromName, fromThenName, fromToName, fromThenToName,
+ funName, valName, liftName,
+ gensymName, returnQName, bindQName,
+ matchName, clauseName, funName, valName, dataDName, classDName,
+ instName, protoName, tvarName, tconName, tappName,
+ arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
+ constrName,
+ exprTyConName, declTyConName, pattTyConName, mtchTyConName,
+ clseTyConName, stmtTyConName, consTyConName, typeTyConName,
+ qTyConName, expTyConName, matTyConName, clsTyConName ]
+
+
+
+intLName = varQual mETA_META_Name FSLIT("intL") intLIdKey
+charLName = varQual mETA_META_Name FSLIT("charL") charLIdKey
+plitName = varQual mETA_META_Name FSLIT("plit") plitIdKey
+pvarName = varQual mETA_META_Name FSLIT("pvar") pvarIdKey
+ptupName = varQual mETA_META_Name FSLIT("ptup") ptupIdKey
+pconName = varQual mETA_META_Name FSLIT("pcon") pconIdKey
+ptildeName = varQual mETA_META_Name FSLIT("ptilde") ptildeIdKey
+paspatName = varQual mETA_META_Name FSLIT("paspat") paspatIdKey
+pwildName = varQual mETA_META_Name FSLIT("pwild") pwildIdKey
+varName = varQual mETA_META_Name FSLIT("var") varIdKey
+conName = varQual mETA_META_Name FSLIT("con") conIdKey
+litName = varQual mETA_META_Name FSLIT("lit") litIdKey
+appName = varQual mETA_META_Name FSLIT("app") appIdKey
+infixEName = varQual mETA_META_Name FSLIT("infixE") infixEIdKey
+lamName = varQual mETA_META_Name FSLIT("lam") lamIdKey
+tupName = varQual mETA_META_Name FSLIT("tup") tupIdKey
+doEName = varQual mETA_META_Name FSLIT("doE") doEIdKey
+compName = varQual mETA_META_Name FSLIT("comp") compIdKey
+listExpName = varQual mETA_META_Name FSLIT("listExp") listExpIdKey
+condName = varQual mETA_META_Name FSLIT("cond") condIdKey
+letEName = varQual mETA_META_Name FSLIT("letE") letEIdKey
+caseEName = varQual mETA_META_Name FSLIT("caseE") caseEIdKey
+infixAppName = varQual mETA_META_Name FSLIT("infixApp") infixAppIdKey
+sectionLName = varQual mETA_META_Name FSLIT("sectionL") sectionLIdKey
+sectionRName = varQual mETA_META_Name FSLIT("sectionR") sectionRIdKey
+guardedName = varQual mETA_META_Name FSLIT("guarded") guardedIdKey
+normalName = varQual mETA_META_Name FSLIT("normal") normalIdKey
+bindStName = varQual mETA_META_Name FSLIT("bindSt") bindStIdKey
+letStName = varQual mETA_META_Name FSLIT("letSt") letStIdKey
+noBindStName = varQual mETA_META_Name FSLIT("noBindSt") noBindStIdKey
+parStName = varQual mETA_META_Name FSLIT("parSt") parStIdKey
+fromName = varQual mETA_META_Name FSLIT("from") fromIdKey
+fromThenName = varQual mETA_META_Name FSLIT("fromThen") fromThenIdKey
+fromToName = varQual mETA_META_Name FSLIT("fromTo") fromToIdKey
+fromThenToName = varQual mETA_META_Name FSLIT("fromThenTo") fromThenToIdKey
+liftName = varQual mETA_META_Name FSLIT("lift") liftIdKey
+gensymName = varQual mETA_META_Name FSLIT("gensym") gensymIdKey
+returnQName = varQual mETA_META_Name FSLIT("returnQ") returnQIdKey
+bindQName = varQual mETA_META_Name FSLIT("bindQ") bindQIdKey
+
+-- type Mat = ...
+matchName = varQual mETA_META_Name FSLIT("match") matchIdKey
+
+-- type Cls = ...
+clauseName = varQual mETA_META_Name FSLIT("clause") clauseIdKey
+
+-- data Dec = ...
+funName = varQual mETA_META_Name FSLIT("fun") funIdKey
+valName = varQual mETA_META_Name FSLIT("val") valIdKey
+dataDName = varQual mETA_META_Name FSLIT("dataD") dataDIdKey
+classDName = varQual mETA_META_Name FSLIT("classD") classDIdKey
+instName = varQual mETA_META_Name FSLIT("inst") instIdKey
+protoName = varQual mETA_META_Name FSLIT("proto") protoIdKey
+
+-- data Typ = ...
+tvarName = varQual mETA_META_Name FSLIT("tvar") tvarIdKey
+tconName = varQual mETA_META_Name FSLIT("tcon") tconIdKey
+tappName = varQual mETA_META_Name FSLIT("tapp") tappIdKey
+
+-- data Tag = ...
+arrowTyConName = varQual mETA_META_Name FSLIT("arrowTyCon") arrowIdKey
+tupleTyConName = varQual mETA_META_Name FSLIT("tupleTyCon") tupleIdKey
+listTyConName = varQual mETA_META_Name FSLIT("listTyCon") listIdKey
+namedTyConName = varQual mETA_META_Name FSLIT("namedTyCon") namedTyConIdKey
+
+-- data Con = ...
+constrName = varQual mETA_META_Name FSLIT("constr") constrIdKey
+
+exprTyConName = tcQual mETA_META_Name FSLIT("Expr") exprTyConKey
+declTyConName = tcQual mETA_META_Name FSLIT("Decl") declTyConKey
+pattTyConName = tcQual mETA_META_Name FSLIT("Patt") pattTyConKey
+mtchTyConName = tcQual mETA_META_Name FSLIT("Mtch") mtchTyConKey
+clseTyConName = tcQual mETA_META_Name FSLIT("Clse") clseTyConKey
+stmtTyConName = tcQual mETA_META_Name FSLIT("Stmt") stmtTyConKey
+consTyConName = tcQual mETA_META_Name FSLIT("Cons") consTyConKey
+typeTyConName = tcQual mETA_META_Name FSLIT("Type") typeTyConKey
+
+qTyConName = tcQual mETA_META_Name FSLIT("Q") qTyConKey
+expTyConName = tcQual mETA_META_Name FSLIT("Exp") expTyConKey
+matTyConName = tcQual mETA_META_Name FSLIT("Mat") matTyConKey
+clsTyConName = tcQual mETA_META_Name FSLIT("Cls") clsTyConKey
+
+-- TyConUniques available: 100-119
+-- Check in PrelNames if you want to change this
+
+expTyConKey = mkPreludeTyConUnique 100
+matTyConKey = mkPreludeTyConUnique 101
+clsTyConKey = mkPreludeTyConUnique 102
+qTyConKey = mkPreludeTyConUnique 103
+exprTyConKey = mkPreludeTyConUnique 104
+declTyConKey = mkPreludeTyConUnique 105
+pattTyConKey = mkPreludeTyConUnique 106
+mtchTyConKey = mkPreludeTyConUnique 107
+clseTyConKey = mkPreludeTyConUnique 108
+stmtTyConKey = mkPreludeTyConUnique 109
+consTyConKey = mkPreludeTyConUnique 110
+typeTyConKey = mkPreludeTyConUnique 111
+
+
+-- IdUniques available: 200-299
+-- If you want to change this, make sure you check in PrelNames
+fromIdKey = mkPreludeMiscIdUnique 200
+fromThenIdKey = mkPreludeMiscIdUnique 201
+fromToIdKey = mkPreludeMiscIdUnique 202
+fromThenToIdKey = mkPreludeMiscIdUnique 203
+liftIdKey = mkPreludeMiscIdUnique 204
+gensymIdKey = mkPreludeMiscIdUnique 205
+returnQIdKey = mkPreludeMiscIdUnique 206
+bindQIdKey = mkPreludeMiscIdUnique 207
+funIdKey = mkPreludeMiscIdUnique 208
+valIdKey = mkPreludeMiscIdUnique 209
+protoIdKey = mkPreludeMiscIdUnique 210
+matchIdKey = mkPreludeMiscIdUnique 211
+clauseIdKey = mkPreludeMiscIdUnique 212
+intLIdKey = mkPreludeMiscIdUnique 213
+charLIdKey = mkPreludeMiscIdUnique 214
+
+classDIdKey = mkPreludeMiscIdUnique 215
+instIdKey = mkPreludeMiscIdUnique 216
+dataDIdKey = mkPreludeMiscIdUnique 217
+
+
+plitIdKey = mkPreludeMiscIdUnique 220
+pvarIdKey = mkPreludeMiscIdUnique 221
+ptupIdKey = mkPreludeMiscIdUnique 222
+pconIdKey = mkPreludeMiscIdUnique 223
+ptildeIdKey = mkPreludeMiscIdUnique 224
+paspatIdKey = mkPreludeMiscIdUnique 225
+pwildIdKey = mkPreludeMiscIdUnique 226
+varIdKey = mkPreludeMiscIdUnique 227
+conIdKey = mkPreludeMiscIdUnique 228
+litIdKey = mkPreludeMiscIdUnique 229
+appIdKey = mkPreludeMiscIdUnique 230
+infixEIdKey = mkPreludeMiscIdUnique 231
+lamIdKey = mkPreludeMiscIdUnique 232
+tupIdKey = mkPreludeMiscIdUnique 233
+doEIdKey = mkPreludeMiscIdUnique 234
+compIdKey = mkPreludeMiscIdUnique 235
+listExpIdKey = mkPreludeMiscIdUnique 237
+condIdKey = mkPreludeMiscIdUnique 238
+letEIdKey = mkPreludeMiscIdUnique 239
+caseEIdKey = mkPreludeMiscIdUnique 240
+infixAppIdKey = mkPreludeMiscIdUnique 241
+sectionLIdKey = mkPreludeMiscIdUnique 242
+sectionRIdKey = mkPreludeMiscIdUnique 243
+guardedIdKey = mkPreludeMiscIdUnique 244
+normalIdKey = mkPreludeMiscIdUnique 245
+bindStIdKey = mkPreludeMiscIdUnique 246
+letStIdKey = mkPreludeMiscIdUnique 247
+noBindStIdKey = mkPreludeMiscIdUnique 248
+parStIdKey = mkPreludeMiscIdUnique 249
+
+tvarIdKey = mkPreludeMiscIdUnique 250
+tconIdKey = mkPreludeMiscIdUnique 251
+tappIdKey = mkPreludeMiscIdUnique 252
+
+arrowIdKey = mkPreludeMiscIdUnique 253
+tupleIdKey = mkPreludeMiscIdUnique 254
+listIdKey = mkPreludeMiscIdUnique 255
+namedTyConIdKey = mkPreludeMiscIdUnique 256
+
+constrIdKey = mkPreludeMiscIdUnique 257
+
+-- %************************************************************************
+-- %* *
+-- Other utilities
+-- %* *
+-- %************************************************************************
+
+-- It is rather usatisfactory that we don't have a SrcLoc
+addDsWarn :: SDoc -> DsM ()
+addDsWarn msg = dsWarn (noSrcLoc, msg)
\ No newline at end of file
import DsMonad
import CoreUtils ( exprType, mkIfThenElse, mkCoerce )
-import PrelInfo ( iRREFUT_PAT_ERROR_ID )
-import MkId ( mkReboxingAlt, mkNewTypeBody )
+import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
import Id ( idType, Id, mkWildId )
import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
import TyCon ( isNewTyCon, tyConDataCons )
( HsExpr(..), HsLit(..), ArithSeqInfo(..),
HsStmtContext(..),
Match(..), GRHSs(..), GRHS(..), HsPred(..),
- HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
+ HsDecl(..), InstDecl(..), ConDecl(..),
Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
Pat(..), HsConDetails(..), HsOverLit, BangType(..),
placeHolderType, HsType(..), HsTupCon(..),
-------------------------------------------------------------------
convertToHsDecls :: [Meta.Dec] -> [HsDecl RdrName]
-convertToHsDecls ds
- = ValD (cvtdecs binds_and_sigs) : map cvt_top top_decls
- where
- (binds_and_sigs, top_decls) = partition sigOrBindP ds
+convertToHsDecls ds = map cvt_top ds
+
+cvt_top d@(Val _ _ _) = ValD (cvtd d)
+cvt_top d@(Fun _ _) = ValD (cvtd d)
+
cvt_top (Data tc tvs constrs derivs)
= TyClD (mkTyData DataType
(noContext, tconName tc, cvt_tvs tvs)
(cvt_context tys)
(HsPredTy (cvt_pred ty))
+cvt_top (Proto nm typ) = SigD (Sig (vName nm) (cvtType typ) loc0)
+
noContext = []
noExistentials = []
noFunDeps = []
cvt_tvs :: [String] -> [HsTyVarBndr RdrName]
cvt_tvs tvs = map (UserTyVar . tName) tvs
-cvt_context :: Context -> HsContext RdrName
+cvt_context :: Cxt -> HsContext RdrName
cvt_context tys = map cvt_pred tys
cvt_pred :: Typ -> HsPred RdrName
other -> panic "Malformed predicate"
cvtType :: Meta.Typ -> HsType RdrName
-cvtType (Tvar nm) = HsTyVar(tName nm)
-cvtType (Tapp x y) = trans (root x [y])
- where root (Tapp a b) zs = root a (b:zs)
- root t zs = (t,zs)
- trans (Tcon (Tuple n),args) = HsTupleTy (HsTupCon Boxed n) (map cvtType args)
- trans (Tcon Arrow,[x,y]) = HsFunTy (cvtType x) (cvtType y)
- trans (Tcon List,[x]) = HsListTy (cvtType x)
- trans (Tcon (Name nm),args) = HsTyVar(tconName nm)
- trans (t,args) = panic "bad type application"
+cvtType ty = trans (root ty [])
+ where root (Tapp a b) zs = root a (cvtType b : zs)
+ root t zs = (t,zs)
+
+ trans (Tcon (Tuple n),args) | length args == n
+ = HsTupleTy (HsTupCon Boxed n) args
+ trans (Tcon Arrow, [x,y]) = HsFunTy x y
+ trans (Tcon List, [x]) = HsListTy x
+
+ trans (Tvar nm, args) = foldl HsAppTy (HsTyVar (tName nm)) args
+ trans (Tcon tc, args) = foldl HsAppTy (HsTyVar (tc_name tc)) args
+
+ tc_name (TconName nm) = tconName nm
+ tc_name Arrow = tconName "->"
+ tc_name List = tconName "[]"
+ tc_name (Tuple 0) = tconName "()"
+ tc_name (Tuple n) = tconName ("(" ++ replicate (n-1) ',' ++ ")")
split_ty_app :: Typ -> (Typ, [Typ])
split_ty_app ty = go ty []
sigP (Proto _ _) = True
sigP other = False
-sigOrBindP :: Dec -> Bool
-sigOrBindP (Proto _ _) = True
-sigOrBindP (Val _ _ _) = True
-sigOrBindP (Fun _ _) = True
-sigOrBindP other = False
-
-----------------------------------------------------------
-- some useful things
| VarMonoBind id -- TRANSLATION
(HsExpr id)
- | CoreMonoBind id -- TRANSLATION
- CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
-
| AbsBinds -- Binds abstraction; TRANSLATION
[TyVar] -- Type variables
[id] -- Dicts
ppr_monobind (VarMonoBind name expr)
= sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
-ppr_monobind (CoreMonoBind name expr)
- = sep [pprBndr LetBind name <+> equals, nest 4 (ppr expr)]
-
ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
= sep [ptext SLIT("AbsBinds"),
brackets (interpp'SP tyvars),
\begin{code}
module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
- DefaultDecl(..),
+ DefaultDecl(..), HsGroup(..),
ForeignDecl(..), ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), CoreDecl(..),
BangType(..), getBangType, getBangStrictness, unbangedType,
DeprecDecl(..), DeprecTxt,
- hsDeclName, instDeclName,
tyClDeclName, tyClDeclNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl,
isTypeOrClassDecl, countTyClDecls,
data HsDecl id
= TyClD (TyClDecl id)
| InstD (InstDecl id)
+ | ValD (MonoBinds id)
+ | SigD (Sig id)
| DefD (DefaultDecl id)
- | ValD (HsBinds id)
| ForD (ForeignDecl id)
- | FixD (FixitySig id)
| DeprecD (DeprecDecl id)
| RuleD (RuleDecl id)
| CoreD (CoreDecl id)
| SpliceD (HsExpr id) -- Top level splice
-- NB: all top-level fixity decls are contained EITHER
--- EITHER FixDs
+-- EITHER SigDs
-- OR in the ClassDecls in TyClDs
--
-- The former covers
-- d) top level decls
--
-- The latter is for class methods only
-\end{code}
-
-\begin{code}
-#ifdef DEBUG
-hsDeclName :: (NamedThing name, OutputableBndr name)
- => HsDecl name -> name
-#endif
-hsDeclName (TyClD decl) = tyClDeclName decl
-hsDeclName (InstD decl) = instDeclName decl
-hsDeclName (ForD decl) = foreignDeclName decl
-hsDeclName (FixD (FixitySig name _ _)) = name
-hsDeclName (CoreD (CoreDecl name _ _ _)) = name
--- Others don't make sense
-#ifdef DEBUG
-hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
-#endif
-
-
-instDeclName :: InstDecl name -> name
-instDeclName (InstDecl _ _ _ (Just name) _) = name
+-- A [HsDecl] is categorised into a HsGroup before being
+-- fed to the renamer.
+data HsGroup id
+ = HsGroup {
+ hs_valds :: HsBinds id,
+ -- Before the renamer, this is a single big MonoBinds,
+ -- with all the bindings, and all the signatures.
+ -- The renamer does dependency analysis, using ThenBinds
+ -- to give the structure
+
+ hs_tyclds :: [TyClDecl id],
+ hs_instds :: [InstDecl id],
+
+ hs_fixds :: [FixitySig id],
+ -- Snaffled out of both top-level fixity signatures,
+ -- and those in class declarations
+
+ hs_defds :: [DefaultDecl id],
+ hs_fords :: [ForeignDecl id],
+ hs_depds :: [DeprecDecl id],
+ hs_ruleds :: [RuleDecl id],
+ hs_coreds :: [CoreDecl id]
+ }
\end{code}
\begin{code}
instance OutputableBndr name => Outputable (HsDecl name) where
-
ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def
ppr (InstD inst) = ppr inst
ppr (ForD fd) = ppr fd
- ppr (FixD fd) = ppr fd
+ ppr (SigD sd) = ppr sd
ppr (RuleD rd) = ppr rd
ppr (DeprecD dd) = ppr dd
ppr (CoreD dd) = ppr dd
ppr (SpliceD e) = ptext SLIT("splice") <> parens (pprExpr e)
+
+instance OutputableBndr name => Outputable (HsGroup name) where
+ ppr (HsGroup { hs_valds = val_decls,
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_fixds = fix_decls,
+ hs_depds = deprec_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_decls,
+ hs_ruleds = rule_decls,
+ hs_coreds = core_decls })
+ = vcat [ppr_ds fix_decls, ppr_ds default_decls,
+ ppr_ds deprec_decls, ppr_ds rule_decls,
+ ppr val_decls,
+ ppr_ds tycl_decls, ppr_ds inst_decls,
+ ppr_ds foreign_decls, ppr_ds core_decls]
+ where
+ ppr_ds [] = empty
+ ppr_ds ds = text "" $$ vcat (map ppr ds)
\end{code}
#include "HsVersions.h"
-- friends:
-import HsDecls ( HsDecl )
+import HsDecls ( HsGroup )
import HsBinds ( HsBinds(..), nullBinds )
import HsPat ( Pat )
import HsLit ( HsLit, HsOverLit )
\begin{code}
data HsBracket id = ExpBr (HsExpr id)
| PatBr (Pat id)
- | DecBr [HsDecl id]
+ | DecBr (HsGroup id)
| TypBr (HsType id)
instance OutputableBndr id => Outputable (HsBracket id) where
pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
-pprHsBracket (DecBr d) = thBrackets (char 'd') (vcat (map ppr d))
+pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
\begin{code}
module HsSyn (
-
-- NB: don't reexport HsCore
-- this module tells about "real Haskell"
- module HsSyn,
module HsBinds,
module HsDecls,
module HsExpr,
module HsTypes,
Fixity, NewOrData,
+ HsModule(..), hsModule, hsImports,
+ collectStmtsBinders,
collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders,
- collectSigTysFromHsBinds, collectSigTysFromMonoBinds,
- hsModule, hsImports
+ collectSigTysFromHsBinds, collectSigTysFromMonoBinds
) where
#include "HsVersions.h"
go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Getting patterns out of bindings}
+%* *
+%************************************************************************
+
Get all the pattern type signatures out of a bunch of bindings
\begin{code}
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.23 2002/09/18 10:51:01 simonmar Exp $
+-- $Id: DriverMkDepend.hs,v 1.24 2002/10/09 15:03:52 simonpj Exp $
--
-- GHC Driver
--
import Util ( global )
import Panic
-import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
+import DATA_IOREF ( IORef, readIORef, writeIORef )
import EXCEPTION
import Directory
import SrcLoc ( mkSrcLoc )
import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
import Rules ( emptyRuleBase )
-import PrelInfo ( wiredInThingEnv, wiredInThings )
+import PrelInfo ( wiredInThingEnv, wiredInThings, knownKeyNames )
import PrelRules ( builtinRules )
-import PrelNames ( knownKeyNames )
import MkIface ( mkIface )
import InstEnv ( emptyInstEnv )
import Desugar
(" ImpAll ", import_all),
(" ImpPartial ", import_partial),
(" ImpHiding ", import_hiding),
- ("FixityDecls ", fixity_ds),
+ ("FixityDecls ", fixity_sigs),
("DefaultDecls ", default_ds),
("TypeDecls ", type_ds),
("DataDecls ", data_ds),
trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
- fixity_ds = count (\ x -> case x of { FixD{} -> True; _ -> False}) decls
+ (fixity_sigs, bind_tys, _, bind_specs, bind_inlines)
+ = count_sigs [d | SigD d <- decls]
-- NB: this omits fixity decls on local bindings and
-- in class decls. ToDo
export_ds = n_exports - export_ms
export_all = case exports of { Nothing -> 1; other -> 0 }
- (val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
- = count_binds (foldr ThenBinds EmptyBinds val_decls)
+ (val_bind_ds, fn_bind_ds)
+ = foldr add2 (0,0) (map count_monobinds val_decls)
(import_no, import_qual, import_as, import_all, import_partial, import_hiding)
= foldr add6 (0,0,0,0,0,0) (map import_info imports)
(inst_method_ds, method_specs, method_inlines)
= foldr add3 (0,0,0) (map inst_info inst_decls)
-
- count_binds EmptyBinds = (0,0,0,0,0)
- count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
- count_binds (MonoBind b sigs _) = case (count_monobinds b, count_sigs sigs) of
- ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is)
-
count_monobinds EmptyMonoBinds = (0,0)
count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
count_monobinds (PatMonoBind (VarPat n) r _) = (1,0)
count_mb_monobinds (Just mbs) = count_monobinds mbs
count_mb_monobinds Nothing = (0,0)
- count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
+ count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs)
- sig_info (Sig _ _ _) = (1,0,0,0)
- sig_info (ClassOpSig _ _ _ _) = (0,1,0,0)
- sig_info (SpecSig _ _ _) = (0,0,1,0)
- sig_info (InlineSig _ _ _ _) = (0,0,0,1)
- sig_info _ = (0,0,0,0)
+ sig_info (FixSig _) = (1,0,0,0,0)
+ sig_info (Sig _ _ _) = (0,1,0,0,0)
+ sig_info (ClassOpSig _ _ _ _) = (0,0,1,0,0)
+ sig_info (SpecSig _ _ _) = (0,0,0,1,0)
+ sig_info (InlineSig _ _ _ _) = (0,0,0,0,1)
+ sig_info _ = (0,0,0,0,0)
import_info (ImportDecl _ _ qual as spec _)
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
class_info decl@(ClassDecl {})
= case count_sigs (tcdSigs decl) of
- (_,classops,_,_) ->
+ (_,_,classops,_,_) ->
(classops, addpr (count_mb_monobinds (tcdMeths decl)))
class_info other = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs _ _)
= case count_sigs inst_sigs of
- (_,_,ss,is) ->
+ (_,_,_,ss,is) ->
(addpr (count_monobinds inst_meths), ss, is)
addpr :: (Int,Int) -> Int
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.105 2002/09/27 08:20:45 simonpj Exp $
+$Id: Parser.y,v 1.106 2002/10/09 15:03:53 simonpj Exp $
Haskell grammar.
import RdrHsSyn
import HscTypes ( ParsedIface(..), IsBootInterface )
import Lex
-import ParseUtil
import RdrName
import PrelNames ( mAIN_Name, funTyConName, listTyConName,
parrTyConName, consDataConName, nilDataConName )
| cvtopdecls { ([],$1) }
cvtopdecls :: { [RdrNameHsDecl] }
- : topdecls { cvTopDecls (groupBindings $1)}
+ : topdecls { cvTopDecls $1 }
-----------------------------------------------------------------------------
-- Interfaces (.hi-boot files)
| layout_on ifacedecls close { $2 }
ifacedecls :: { [RdrNameTyClDecl] }
- : ifacedecl ';' ifacedecls { $1 : $3 }
- | ';' ifacedecls { $2 }
- | ifacedecl { [$1] }
- | {- empty -} { [] }
+ : ifacedecl ';' ifacedecls { $1 : $3 }
+ | ';' ifacedecls { $2 }
+ | ifacedecl { [$1] }
+ | {- empty -} { [] }
ifacedecl :: { RdrNameTyClDecl }
- : srcloc 'data' tycl_hdr constrs
- { mkTyData DataType $3 (DataCons (reverse $4)) Nothing $1 }
-
- | srcloc 'newtype' tycl_hdr '=' newconstr
- { mkTyData NewType $3 (DataCons [$5]) Nothing $1 }
-
- | srcloc 'class' tycl_hdr fds where
- { let
- (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig
- (groupBindings $5)
- in
- mkClassDecl $3 $4 sigs (Just binds) $1 }
-
- | srcloc 'type' tycon tv_bndrs '=' ctype
- { TySynonym $3 $4 $6 $1 }
-
- | srcloc var '::' sigtype
- { IfaceSig $2 $4 [] $1 }
+ : tycl_decl { $1 }
+ | srcloc var '::' sigtype { IfaceSig $2 $4 [] $1 }
-----------------------------------------------------------------------------
-- The Export List
prec :: { Int }
: {- empty -} { 9 }
- | INTEGER {% checkPrec $1 `thenP_`
- returnP (fromInteger $1) }
+ | INTEGER {% checkPrecP (fromInteger $1) }
infix :: { FixityDirection }
: 'infix' { InfixN }
-----------------------------------------------------------------------------
-- Top-Level Declarations
-topdecls :: { [RdrBinding] }
- : topdecls ';' topdecl { ($3 : $1) }
+topdecls :: { [RdrBinding] } -- Reversed
+ : topdecls ';' topdecl { $3 : $1 }
| topdecls ';' { $1 }
| topdecl { [$1] }
topdecl :: { RdrBinding }
+ : tycl_decl { RdrHsDecl (TyClD $1) }
+ | srcloc 'instance' inst_type where
+ { let (binds,sigs) = cvMonoBindsAndSigs $4
+ in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) }
+ | srcloc 'default' '(' comma_types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
+ | 'foreign' fdecl { RdrHsDecl $2 }
+ | '{-# DEPRECATED' deprecations '#-}' { RdrBindings $2 }
+ | '{-# RULES' rules '#-}' { RdrBindings $2 }
+ | '$(' exp ')' { RdrHsDecl (SpliceD $2) }
+ | decl { $1 }
+
+tycl_decl :: { RdrNameTyClDecl }
: srcloc 'type' syn_hdr '=' ctype
-- Note ctype, not sigtype.
-- We allow an explicit for-all but we don't insert one
-- in type Foo a = (b,b)
-- Instead we just say b is out of scope
- { let (tc,tvs) = $3
- in RdrHsDecl (TyClD (TySynonym tc tvs $5 $1)) }
+ { let (tc,tvs) = $3 in TySynonym tc tvs $5 $1 }
| srcloc 'data' tycl_hdr constrs deriving
- {% returnP (RdrHsDecl (TyClD
- (mkTyData DataType $3 (DataCons (reverse $4)) $5 $1))) }
+ { mkTyData DataType $3 (DataCons (reverse $4)) $5 $1 }
| srcloc 'newtype' tycl_hdr '=' newconstr deriving
- {% returnP (RdrHsDecl (TyClD
- (mkTyData NewType $3 (DataCons [$5]) $6 $1))) }
+ { mkTyData NewType $3 (DataCons [$5]) $6 $1 }
| srcloc 'class' tycl_hdr fds where
- {% let
- (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5)
- in
- returnP (RdrHsDecl (TyClD
- (mkClassDecl $3 $4 sigs (Just binds) $1))) }
-
- | srcloc 'instance' inst_type where
- { let (binds,sigs)
- = cvMonoBindsAndSigs cvInstDeclSig
- (groupBindings $4)
- in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) }
-
- | srcloc 'default' '(' comma_types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
- | 'foreign' fdecl { RdrHsDecl $2 }
- | '{-# DEPRECATED' deprecations '#-}' { $2 }
- | '{-# RULES' rules '#-}' { $2 }
- | '$(' exp ')' { RdrHsDecl (SpliceD $2) }
- | decl { $1 }
+ { let
+ (binds,sigs) = cvMonoBindsAndSigs $5
+ in
+ mkClassDecl $3 $4 (map cvClassOpSig sigs) (Just binds) $1 }
syn_hdr :: { (RdrName, [RdrNameHsTyVar]) } -- We don't retain the syntax of an infix
-- type synonym declaration. Oh well.
| type {% checkTyClHdr $1 `thenP` \ (tc,tvs) ->
returnP ([], tc, tvs) }
-{-
- : '(' comma_types1 ')' '=>' gtycon tv_bndrs
- {% mapP checkPred $2 `thenP` \ cxt ->
- returnP (cxt, $5, $6) }
-
- | '(' ')' '=>' gtycon tv_bndrs
- { ([], $4, $5) }
-
- -- qtycon for the class below name would lead to many s/r conflicts
- -- FIXME: does the renamer pick up all wrong forms and raise an
- -- error
- | gtycon atypes1 '=>' gtycon atypes0
- {% checkTyVars $5 `thenP` \ tvs ->
- returnP ([HsClassP $1 $2], $4, tvs) }
-
- | gtycon atypes0
- {% checkTyVars $2 `thenP` \ tvs ->
- returnP ([], $1, tvs) }
- -- We have to have qtycon in this production to avoid s/r
- -- conflicts with the previous one. The renamer will complain
- -- if we use a qualified tycon.
- --
- -- Using a `gtycon' throughout. This enables special syntax,
- -- such as "[]" for tycons as well as tycon ops in
- -- parentheses. This is beyond H98, but used repeatedly in
- -- the Prelude modules. (So, it would be a good idea to raise
- -- an error in the renamer if some non-H98 form is used and
- -- -fglasgow-exts is not given.) -=chak
-
-atypes0 :: { [RdrNameHsType] }
- : atypes1 { $1 }
- | {- empty -} { [] }
-
-atypes1 :: { [RdrNameHsType] }
- : atype { [$1] }
- | atype atypes1 { $1 : $2 }
--}
+-----------------------------------------------------------------------------
+-- Nested declarations
-decls :: { [RdrBinding] }
+decls :: { [RdrBinding] } -- Reversed
: decls ';' decl { $3 : $1 }
| decls ';' { $1 }
| decl { [$1] }
| {- empty -} { [] }
-decl :: { RdrBinding }
- : fixdecl { $1 }
- | valdef { $1 }
- | '{-# INLINE' srcloc activation qvar '#-}' { RdrSig (InlineSig True $4 $3 $2) }
- | '{-# NOINLINE' srcloc inverse_activation qvar '#-}' { RdrSig (InlineSig False $4 $3 $2) }
- | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}'
- { foldr1 RdrAndBindings
- (map (\t -> RdrSig (SpecSig $3 t $2)) $5) }
- | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}'
- { RdrSig (SpecInstSig $4 $2) }
wherebinds :: { RdrNameHsBinds }
- : where { cvBinds cvValSig (groupBindings $1) }
+ : where { cvBinds $1 }
-where :: { [RdrBinding] }
+where :: { [RdrBinding] } -- Reversed
: 'where' decllist { $2 }
| {- empty -} { [] }
-declbinds :: { RdrNameHsBinds }
- : decllist { cvBinds cvValSig (groupBindings $1) }
-
-decllist :: { [RdrBinding] }
+decllist :: { [RdrBinding] } -- Reversed
: '{' decls '}' { $2 }
| layout_on decls close { $2 }
letbinds :: { RdrNameHsExpr -> RdrNameHsExpr }
- : decllist { HsLet (cvBinds cvValSig (groupBindings $1)) }
+ : decllist { HsLet (cvBinds $1) }
| '{' dbinds '}' { \e -> HsWith e $2 False{-not with-} }
| layout_on dbinds close { \e -> HsWith e $2 False{-not with-} }
-fixdecl :: { RdrBinding }
- : srcloc infix prec ops { foldr1 RdrAndBindings
- [ RdrSig (FixSig (FixitySig n
- (Fixity $3 $2) $1))
- | n <- $4 ] }
+
-----------------------------------------------------------------------------
-- Transformation Rules
-rules :: { RdrBinding }
- : rules ';' rule { $1 `RdrAndBindings` $3 }
- | rules ';' { $1 }
- | rule { $1 }
- | {- empty -} { RdrNullBind }
+rules :: { [RdrBinding] }
+ : rule ';' rules { $1 : $3 }
+ | rule { [$1] }
+ | {- empty -} { [] }
rule :: { RdrBinding }
: STRING activation rule_forall infixexp '=' srcloc exp
-----------------------------------------------------------------------------
-- Deprecations
-deprecations :: { RdrBinding }
- : deprecations ';' deprecation { $1 `RdrAndBindings` $3 }
- | deprecations ';' { $1 }
- | deprecation { $1 }
- | {- empty -} { RdrNullBind }
+deprecations :: { [RdrBinding] }
+ : deprecation ';' deprecations { $1 : $3 }
+ | deprecation { [$1] }
+ | {- empty -} { [] }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { RdrBinding }
: srcloc depreclist STRING
- { foldr RdrAndBindings RdrNullBind
+ { RdrBindings
[ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] }
We can't tell whether to reduce var to qvar until after we've read the signatures.
-}
-valdef :: { RdrBinding }
- : infixexp srcloc opt_sig rhs {% (checkValDef $1 $3 $4 $2) }
- | infixexp srcloc '::' sigtype {% (checkValSig $1 $4 $2) }
- | var ',' sig_vars srcloc '::' sigtype { foldr1 RdrAndBindings
- [ RdrSig (Sig n $6 $4) | n <- $1:$3 ]
- }
+decl :: { RdrBinding }
+ : sigdecl { $1 }
+ | infixexp srcloc opt_sig rhs {% checkValDef $1 $3 $4 $2 }
rhs :: { RdrNameGRHSs }
- : '=' srcloc exp wherebinds { (GRHSs (unguardedRHS $3 $2) $4 placeHolderType)}
- | gdrhs wherebinds { GRHSs (reverse $1) $2 placeHolderType }
+ : '=' srcloc exp wherebinds { GRHSs (unguardedRHS $3 $2) $4 placeHolderType }
+ | gdrhs wherebinds { GRHSs (reverse $1) $2 placeHolderType }
gdrhs :: { [RdrNameGRHS] }
: gdrhs gdrh { $2 : $1 }
gdrh :: { RdrNameGRHS }
: '|' srcloc quals '=' exp { GRHS (reverse (ResultStmt $5 $2 : $3)) $2 }
+sigdecl :: { RdrBinding }
+ : infixexp srcloc '::' sigtype
+ {% checkValSig $1 $4 $2 }
+ -- See the above notes for why we need infixexp here
+ | var ',' sig_vars srcloc '::' sigtype
+ { mkSigDecls [ Sig n $6 $4 | n <- $1:$3 ] }
+ | srcloc infix prec ops { mkSigDecls [ FixSig (FixitySig n (Fixity $3 $2) $1)
+ | n <- $4 ] }
+ | '{-# INLINE' srcloc activation qvar '#-}'
+ { RdrHsDecl (SigD (InlineSig True $4 $3 $2)) }
+ | '{-# NOINLINE' srcloc inverse_activation qvar '#-}'
+ { RdrHsDecl (SigD (InlineSig False $4 $3 $2)) }
+ | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}'
+ { mkSigDecls [ SpecSig $3 t $2 | t <- $5] }
+ | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}'
+ { RdrHsDecl (SigD (SpecInstSig $4 $2)) }
+
-----------------------------------------------------------------------------
-- Expressions
exp :: { RdrNameHsExpr }
- : infixexp '::' sigtype { (ExprWithTySig $1 $3) }
+ : infixexp '::' sigtype { ExprWithTySig $1 $3 }
| infixexp 'with' dbinding { HsWith $1 $3 True{-not a let-} }
| infixexp { $1 }
| '[t|' ctype '|]' { HsBracket (TypBr $2) }
| '[p|' srcloc infixexp '|]' {% checkPattern $2 $3 `thenP` \p ->
returnP (HsBracket (PatBr p)) }
- | '[d|' cvtopdecls '|]' { HsBracket (DecBr $2) }
+ | '[d|' cvtopdecls '|]' { HsBracket (DecBr (mkGroup $2)) }
texps :: { [RdrNameHsExpr] }
: srcloc infixexp '<-' exp {% checkPattern $1 $2 `thenP` \p ->
returnP (BindStmt p $4 $1) }
| srcloc exp { ExprStmt $2 placeHolderType $1 }
- | srcloc 'let' declbinds { LetStmt $3 }
+ | srcloc 'let' decllist { LetStmt (cvBinds $3) }
-----------------------------------------------------------------------------
-- Record Field Update/Construction
RdrBinding(..),
RdrMatch(..),
- SigConverter,
extractHsTyRdrNames, extractHsTyRdrTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl, mkClassOpSigDM,
mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
- mkHsDo, mkHsSplice,
+ mkHsDo, mkHsSplice, mkSigDecls,
+ mkTyData, mkPrefixCon, mkRecCon,
+ mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
+ mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem]
cvBinds,
cvMonoBindsAndSigs,
cvTopDecls,
- cvValSig, cvClassOpSig, cvInstDeclSig,
- mkTyData
+ cvClassOpSig,
+ findSplice, addImpDecls, emptyGroup, mkGroup,
+
+ -- Stuff to do with Foreign declarations
+ , CallConv(..)
+ , mkImport -- CallConv -> Safety
+ -- -> (FastString, RdrName, RdrNameHsType)
+ -- -> SrcLoc
+ -- -> P RdrNameHsDecl
+ , mkExport -- CallConv
+ -- -> (FastString, RdrName, RdrNameHsType)
+ -- -> SrcLoc
+ -- -> P RdrNameHsDecl
+ , mkExtName -- RdrName -> CLabelString
+
+ -- Bunch of functions in the parser monad for
+ -- checking and constructing values
+ , checkPrecP -- Int -> P Int
+ , checkContext -- HsType -> P HsContext
+ , checkPred -- HsType -> P HsPred
+ , checkTyVars -- [HsTyVar] -> P [HsType]
+ , checkTyClHdr -- HsType -> (name,[tyvar])
+ , checkInstType -- HsType -> P HsType
+ , checkPattern -- HsExp -> P HsPat
+ , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
+ , checkDo -- [Stmt] -> P [Stmt]
+ , checkMDo -- [Stmt] -> P [Stmt]
+ , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ , parseError -- String -> Pa
) where
#include "HsVersions.h"
import HsSyn -- Lots of it
-import OccName ( mkDefaultMethodOcc, mkVarOcc )
-import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
-import List ( nub )
-import BasicTypes ( RecFlag(..), FixitySig )
+import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc,
+ isRdrTyVar, isRdrDataCon, isUnqual, getRdrName,
+ setRdrNameSpace )
+import BasicTypes ( RecFlag(..), FixitySig(..), maxPrecedence )
import Class ( DefMeth (..) )
+import Lex ( P, mapP, setSrcLocP, thenP, returnP, getSrcLocP, failMsgP )
+import HscTypes ( RdrAvailInfo, GenAvailInfo(..) )
+import TysWiredIn ( unitTyCon )
+import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
+ DNCallSpec(..))
+import OccName ( dataName, varName, isDataOcc, isTcOcc, occNameUserString,
+ mkDefaultMethodOcc, mkVarOcc )
+import SrcLoc
+import CStrings ( CLabelString )
+import List ( isSuffixOf, nub )
+import Outputable
+import FastString
+import Panic
\end{code}
\begin{code}
data RdrBinding
- = -- On input we use the Empty/And form rather than a list
- RdrNullBind
- | RdrAndBindings RdrBinding RdrBinding
-
- -- Value bindings havn't been united with their
+ = -- Value bindings havn't been united with their
-- signatures yet
- | RdrValBinding RdrNameMonoBinds
+ RdrBindings [RdrBinding] -- Convenience for parsing
- -- Signatures are mysterious; we can't
- -- tell if its a Sig or a ClassOpSig,
- -- so we just save the pieces:
- | RdrSig RdrNameSig
+ | RdrValBinding RdrNameMonoBinds
-- The remainder all fit into the main HsDecl form
| RdrHsDecl RdrNameHsDecl
-
-type SigConverter = RdrNameSig -> RdrNameSig
\end{code}
\begin{code}
these conversion functions:
\begin{code}
-cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
-
-cvValSig sig = sig
-
-cvInstDeclSig sig = sig
-
+cvClassOpSig :: RdrNameSig -> RdrNameSig
cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
cvClassOpSig sig = sig
\end{code}
initially, and non recursive definitions are discovered by the dependency
analyser.
-\begin{code}
-cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
- -- The mysterious SigConverter converts Sigs to ClassOpSigs
- -- in class declarations. Mostly it's just an identity function
-cvBinds sig_cvtr binding
- = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
+\begin{code}
+cvTopDecls :: [RdrBinding] -> [RdrNameHsDecl]
+-- Incoming bindings are in reverse order; result is in ordinary order
+-- (a) flatten RdrBindings
+-- (b) Group together bindings for a single function
+cvTopDecls decls
+ = go [] decls
+ where
+ go :: [RdrNameHsDecl] -> [RdrBinding] -> [RdrNameHsDecl]
+ go acc [] = acc
+ go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2
+ go acc (RdrHsDecl d : ds) = go (d : acc) ds
+ go acc (RdrValBinding b : ds) = go (ValD b' : acc) ds'
+ where
+ (b', ds') = getMonoBind b ds
+
+cvBinds :: [RdrBinding] -> RdrNameHsBinds
+cvBinds binding
+ = case (cvMonoBindsAndSigs binding) of { (mbs, sigs) ->
MonoBind mbs sigs Recursive
}
-\end{code}
-\begin{code}
-cvMonoBindsAndSigs :: SigConverter
- -> RdrBinding
- -> (RdrNameMonoBinds, [RdrNameSig])
+cvMonoBindsAndSigs :: [RdrBinding] -> (RdrNameMonoBinds, [RdrNameSig])
+-- Input bindings are in *reverse* order,
+-- and contain just value bindings and signatuers
-cvMonoBindsAndSigs sig_cvtr fb
- = mangle_bind (EmptyMonoBinds, []) fb
+cvMonoBindsAndSigs fb
+ = go (EmptyMonoBinds, []) fb
where
- mangle_bind acc RdrNullBind
- = acc
-
- mangle_bind acc (RdrAndBindings fb1 fb2)
- = mangle_bind (mangle_bind acc fb1) fb2
-
- mangle_bind (b_acc, s_acc) (RdrSig sig)
- = (b_acc, sig_cvtr sig : s_acc)
-
- mangle_bind (b_acc, s_acc) (RdrValBinding binding)
- = (b_acc `AndMonoBinds` binding, s_acc)
+ go acc [] = acc
+ go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2
+ go (bs, ss) (RdrHsDecl (SigD s) : ds) = go (bs, s : ss) ds
+ go (bs, ss) (RdrValBinding b : ds) = go (b' `AndMonoBinds` bs, ss) ds'
+ where
+ (b',ds') = getMonoBind b ds
+
+-----------------------------------------------------------------------------
+-- Group function bindings into equation groups
+
+getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBinding])
+-- Suppose (b',ds') = getMonoBind b ds
+-- ds is a *reversed* list of parsed bindings
+-- b is a MonoBinds that has just been read off the front
+
+-- Then b' is the result of grouping more equations from ds that
+-- belong with b into a single MonoBinds, and ds' is the depleted
+-- list of parsed bindings.
+--
+-- No AndMonoBinds or EmptyMonoBinds here; just single equations
+
+getMonoBind (FunMonoBind f1 inf1 mtchs1 loc1) binds
+ | has_args mtchs1
+ = go mtchs1 loc1 binds
+ where
+ go mtchs loc (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds)
+ | f1 == f2 = go (mtchs2 ++ mtchs1) loc2 binds
+ -- Remember binds is reversed, so glue mtchs2 on the front
+ -- and use loc2 as the final location
+ go mtchs loc binds = (FunMonoBind f1 inf1 mtchs loc, binds)
+
+has_args ((Match args _ _) : _) = not (null args)
+ -- Don't group together FunMonoBinds if they have
+ -- no arguments. This is necessary now that variable bindings
+ -- with no arguments are now treated as FunMonoBinds rather
+ -- than pattern bindings (tests/rename/should_fail/rnfail002).
\end{code}
+\begin{code}
+emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive,
+ -- The renamer adds structure to the bindings;
+ -- they start life as a single giant MonoBinds
+ hs_tyclds = [], hs_instds = [],
+ hs_fixds = [], hs_defds = [], hs_fords = [],
+ hs_depds = [] ,hs_ruleds = [], hs_coreds = [] }
+
+findSplice :: [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a]))
+findSplice ds = add emptyGroup ds
+
+mkGroup :: [HsDecl a] -> HsGroup a
+mkGroup ds = addImpDecls emptyGroup ds
+
+addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a
+-- The decls are imported, and should not have a splice
+addImpDecls group decls = case add group decls of
+ (group', Nothing) -> group'
+ other -> panic "addImpDecls"
+
+add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a]))
+ -- This stuff reverses the declarations (again) but it doesn't matter
+
+-- Base cases
+add gp [] = (gp, Nothing)
+add gp (SpliceD e : ds) = (gp, Just (e, ds))
+
+-- Class declarations: pull out the fixity signatures to the top
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds)
+ | isClassDecl d = add (gp { hs_tyclds = d : ts,
+ hs_fixds = [f | FixSig f <- tcdSigs d] }) ds
+ | otherwise = add (gp { hs_tyclds = d : ts }) ds
+
+-- Signatures: fixity sigs go a different place than all others
+add gp@(HsGroup {hs_fixds = ts}) (SigD (FixSig f) : ds) = add (gp {hs_fixds = f : ts}) ds
+add gp@(HsGroup {hs_valds = ts}) (SigD d : ds) = add (gp {hs_valds = add_sig d ts}) ds
+
+-- Value declarations: use add_bind
+add gp@(HsGroup {hs_valds = ts}) (ValD d : ds) = add (gp { hs_valds = add_bind d ts }) ds
+
+-- The rest are routine
+add gp@(HsGroup {hs_instds = ts}) (InstD d : ds) = add (gp { hs_instds = d : ts }) ds
+add gp@(HsGroup {hs_defds = ts}) (DefD d : ds) = add (gp { hs_defds = d : ts }) ds
+add gp@(HsGroup {hs_fords = ts}) (ForD d : ds) = add (gp { hs_fords = d : ts }) ds
+add gp@(HsGroup {hs_depds = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds
+add gp@(HsGroup {hs_ruleds = ts})(RuleD d : ds) = add (gp { hs_ruleds = d : ts }) ds
+add gp@(HsGroup {hs_coreds = ts})(CoreD d : ds) = add (gp { hs_coreds = d : ts }) ds
+
+add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r
+add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r
+\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
-Separate declarations into all the various kinds:
\begin{code}
-cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
-cvTopDecls bind
- = let
- (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
- in
- (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
+-----------------------------------------------------------------------------
+-- mkPrefixCon
+
+-- When parsing data declarations, we sometimes inadvertently parse
+-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
+-- This function splits up the type application, adds any pending
+-- arguments, and converts the type constructor back into a data constructor.
+
+mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
+
+mkPrefixCon ty tys
+ = split ty tys
+ where
+ split (HsAppTy t u) ts = split t (unbangedType u : ts)
+ split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
+ returnP (data_con, PrefixCon ts)
+ split _ _ = parseError "Illegal data/newtype declaration"
+
+mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
+mkRecCon con fields
+ = tyConToDataCon con `thenP` \ data_con ->
+ returnP (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
+
+tyConToDataCon :: RdrName -> P RdrName
+tyConToDataCon tc
+ | isTcOcc (rdrNameOcc tc)
+ = returnP (setRdrNameSpace tc dataName)
+ | otherwise
+ = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
+
+----------------------------------------------------------------------------
+-- Various Syntactic Checks
+
+checkInstType :: RdrNameHsType -> P RdrNameHsType
+checkInstType t
+ = case t of
+ HsForAllTy tvs ctxt ty ->
+ checkDictTy ty [] `thenP` \ dict_ty ->
+ returnP (HsForAllTy tvs ctxt dict_ty)
+
+ HsParTy ty -> checkInstType ty
+
+ ty -> checkDictTy ty [] `thenP` \ dict_ty->
+ returnP (HsForAllTy Nothing [] dict_ty)
+
+checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
+checkTyVars tvs = mapP chk tvs
+ where
+ chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k)
+ chk (HsTyVar tv) = returnP (UserTyVar tv)
+ chk other = parseError "Type found where type variable expected"
+
+checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
+-- The header of a type or class decl should look like
+-- (C a, D b) => T a b
+-- or T a b
+-- or a + b
+-- etc
+checkTyClHdr ty
+ = go ty []
+ where
+ go (HsTyVar tc) acc
+ | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs ->
+ returnP (tc, tvs)
+ go (HsOpTy t1 (HsTyOp tc) t2) acc
+ = checkTyVars (t1:t2:acc) `thenP` \ tvs ->
+ returnP (tc, tvs)
+ go (HsParTy ty) acc = go ty acc
+ go (HsAppTy t1 t2) acc = go t1 (t2:acc)
+ go other acc = parseError "Malformed LHS to type of class declaration"
+
+checkContext :: RdrNameHsType -> P RdrNameContext
+checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
+ = mapP checkPred ts
+
+checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way
+ = checkContext ty
+
+checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
+ | t == getRdrName unitTyCon = returnP []
+
+checkContext t
+ = checkPred t `thenP` \p ->
+ returnP [p]
+
+checkPred :: RdrNameHsType -> P (HsPred RdrName)
+-- Watch out.. in ...deriving( Show )... we use checkPred on
+-- the list of partially applied predicates in the deriving,
+-- so there can be zero args.
+checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
+checkPred ty
+ = go ty []
+ where
+ go (HsTyVar t) args | not (isRdrTyVar t)
+ = returnP (HsClassP t args)
+ go (HsAppTy l r) args = go l (r:args)
+ go (HsParTy t) args = go t args
+ go _ _ = parseError "Illegal class assertion"
+
+checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
+checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
+ = returnP (mkHsDictTy t args)
+checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
+checkDictTy (HsParTy t) args = checkDictTy t args
+checkDictTy _ _ = parseError "Malformed context in instance header"
+
+
+---------------------------------------------------------------------------
+-- Checking statements in a do-expression
+-- We parse do { e1 ; e2 ; }
+-- as [ExprStmt e1, ExprStmt e2]
+-- checkDo (a) checks that the last thing is an ExprStmt
+-- (b) transforms it to a ResultStmt
+-- same comments apply for mdo as well
+
+checkDo = checkDoMDo "a " "'do'"
+checkMDo = checkDoMDo "an " "'mdo'"
+
+checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct"
+checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l]
+checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
+checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss `thenP` \ ss' ->
+ returnP (s:ss')
+
+---------------------------------------------------------------------------
+-- Checking Patterns.
+
+-- We parse patterns as expressions and check for valid patterns below,
+-- converting the expression into a pattern at the same time.
+
+checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
+checkPattern loc e = setSrcLocP loc (checkPat e [])
+
+checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
+checkPatterns loc es = mapP (checkPattern loc) es
+
+checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
+checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
+checkPat (HsApp f x) args =
+ checkPat x [] `thenP` \x ->
+ checkPat f (x:args)
+checkPat e [] = case e of
+ EWildPat -> returnP (WildPat placeHolderType)
+ HsVar x -> returnP (VarPat x)
+ HsLit l -> returnP (LitPat l)
+ HsOverLit l -> returnP (NPatIn l Nothing)
+ ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat)
+ EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n)
+ ExprWithTySig e t -> checkPat e [] `thenP` \e ->
+ -- Pattern signatures are parsed as sigtypes,
+ -- but they aren't explicit forall points. Hence
+ -- we have to remove the implicit forall here.
+ let t' = case t of
+ HsForAllTy Nothing [] ty -> ty
+ other -> other
+ in
+ returnP (SigPatIn e t')
+
+ -- Translate out NegApps of literals in patterns. We negate
+ -- the Integer here, and add back the call to 'negate' when
+ -- we typecheck the pattern.
+ -- NB. Negative *primitive* literals are already handled by
+ -- RdrHsSyn.mkHsNegApp
+ NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
+
+ OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
+ | plus == plus_RDR
+ -> returnP (mkNPlusKPat n lit)
+ where
+ plus_RDR = mkUnqual varName FSLIT("+") -- Hack
+
+ OpApp l op fix r -> checkPat l [] `thenP` \l ->
+ checkPat r [] `thenP` \r ->
+ case op of
+ HsVar c | isDataOcc (rdrNameOcc c)
+ -> returnP (ConPatIn c (InfixCon l r))
+ _ -> patFail
+
+ HsPar e -> checkPat e [] `thenP` (returnP . ParPat)
+ ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ returnP (ListPat ps placeHolderType)
+ ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ returnP (PArrPat ps placeHolderType)
+
+ ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ returnP (TuplePat ps b)
+
+ RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
+ returnP (ConPatIn c (RecCon fs))
+-- Generics
+ HsType ty -> returnP (TypePat ty)
+ _ -> patFail
+
+checkPat _ _ = patFail
+
+checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
+checkPatField (n,e) = checkPat e [] `thenP` \p ->
+ returnP (n,p)
+
+patFail = parseError "Parse error in pattern"
+
+
+---------------------------------------------------------------------------
+-- Check Equation Syntax
+
+checkValDef
+ :: RdrNameHsExpr
+ -> Maybe RdrNameHsType
+ -> RdrNameGRHSs
+ -> SrcLoc
+ -> P RdrBinding
+
+checkValDef lhs opt_sig grhss loc
+ = case isFunLhs lhs [] of
+ Just (f,inf,es) ->
+ checkPatterns loc es `thenP` \ps ->
+ returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
+
+ Nothing ->
+ checkPattern loc lhs `thenP` \lhs ->
+ returnP (RdrValBinding (PatMonoBind lhs grhss loc))
+
+checkValSig
+ :: RdrNameHsExpr
+ -> RdrNameHsType
+ -> SrcLoc
+ -> P RdrBinding
+checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc)))
+checkValSig other ty loc = parseError "Type signature given for an expression"
+
+mkSigDecls :: [Sig RdrName] -> RdrBinding
+mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs]
+
+
+-- A variable binding is parsed as an RdrNameFunMonoBind.
+-- See comments with HsBinds.MonoBinds
+
+isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
+isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
+ = Just (op, True, (l:r:es))
+ | otherwise
+ = case isFunLhs l es of
+ Just (op', True, j : k : es') ->
+ Just (op', True, j : OpApp k (HsVar op) fix r : es')
+ _ -> Nothing
+isFunLhs (HsVar f) es | not (isRdrDataCon f)
+ = Just (f,False,es)
+isFunLhs (HsApp f e) es = isFunLhs f (e:es)
+isFunLhs (HsPar e) es@(_:_) = isFunLhs e es
+isFunLhs _ _ = Nothing
+
+---------------------------------------------------------------------------
+-- Miscellaneous utilities
+
+checkPrecP :: Int -> P Int
+checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i
+ | otherwise = parseError "Precedence out of range"
+
+mkRecConstrOrUpdate
+ :: RdrNameHsExpr
+ -> RdrNameHsRecordBinds
+ -> P RdrNameHsExpr
+
+mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
+ = returnP (RecordCon c fs)
+mkRecConstrOrUpdate exp fs@(_:_)
+ = returnP (RecordUpd exp fs)
+mkRecConstrOrUpdate _ _
+ = parseError "Empty record update"
+
+-----------------------------------------------------------------------------
+-- utilities for foreign declarations
+
+-- supported calling conventions
+--
+data CallConv = CCall CCallConv -- ccall or stdcall
+ | DNCall -- .NET
+
+-- construct a foreign import declaration
+--
+mkImport :: CallConv
+ -> Safety
+ -> (FastString, RdrName, RdrNameHsType)
+ -> SrcLoc
+ -> P RdrNameHsDecl
+mkImport (CCall cconv) safety (entity, v, ty) loc =
+ parseCImport entity cconv safety v `thenP` \importSpec ->
+ returnP $ ForD (ForeignImport v ty importSpec False loc)
+mkImport (DNCall ) _ (entity, v, ty) loc =
+ returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
+
+-- parse the entity string of a foreign import declaration for the `ccall' or
+-- `stdcall' calling convention'
+--
+parseCImport :: FastString
+ -> CCallConv
+ -> Safety
+ -> RdrName
+ -> P ForeignImport
+parseCImport entity cconv safety v
+ -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
+ | entity == FSLIT ("dynamic") =
+ returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
+ | entity == FSLIT ("wrapper") =
+ returnP $ CImport cconv safety nilFS nilFS CWrapper
+ | otherwise = parse0 (unpackFS entity)
+ where
+ -- using the static keyword?
+ parse0 (' ': rest) = parse0 rest
+ parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
+ parse0 rest = parse1 rest
+ -- check for header file name
+ parse1 "" = parse4 "" nilFS False nilFS
+ parse1 (' ':rest) = parse1 rest
+ parse1 str@('&':_ ) = parse2 str nilFS
+ parse1 str@('[':_ ) = parse3 str nilFS False
+ parse1 str
+ | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
+ | otherwise = parse4 str nilFS False nilFS
+ where
+ (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
+ -- check for address operator (indicating a label import)
+ parse2 "" header = parse4 "" header False nilFS
+ parse2 (' ':rest) header = parse2 rest header
+ parse2 ('&':rest) header = parse3 rest header True
+ parse2 str@('[':_ ) header = parse3 str header False
+ parse2 str header = parse4 str header False nilFS
+ -- check for library object name
+ parse3 (' ':rest) header isLbl = parse3 rest header isLbl
+ parse3 ('[':rest) header isLbl =
+ case break (== ']') rest of
+ (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
+ _ -> parseError "Missing ']' in entity"
+ parse3 str header isLbl = parse4 str header isLbl nilFS
+ -- check for name of C function
+ parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib
+ parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
+ parse4 str header isLbl lib
+ | all (== ' ') rest = build (mkFastString first) header isLbl lib
+ | otherwise = parseError "Malformed entity string"
+ where
+ (first, rest) = break (== ' ') str
+ --
+ build cid header False lib = returnP $
+ CImport cconv safety header lib (CFunction (StaticTarget cid))
+ build cid header True lib = returnP $
+ CImport cconv safety header lib (CLabel cid )
+
+-- construct a foreign export declaration
+--
+mkExport :: CallConv
+ -> (FastString, RdrName, RdrNameHsType)
+ -> SrcLoc
+ -> P RdrNameHsDecl
+mkExport (CCall cconv) (entity, v, ty) loc = returnP $
+ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
where
- go acc RdrNullBind = acc
- go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
- go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
- go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
- go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
- go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)
+ entity' | nullFastString entity = mkExtName v
+ | otherwise = entity
+mkExport DNCall (entity, v, ty) loc =
+ parseError "Foreign export is not yet supported for .NET"
+
+-- Supplying the ext_name in a foreign decl is optional; if it
+-- isn't there, the Haskell name is assumed. Note that no transformation
+-- of the Haskell name is then performed, so if you foreign export (++),
+-- it's external name will be "++". Too bad; it's important because we don't
+-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
+-- (This is why we use occNameUserString.)
+--
+mkExtName :: RdrName -> CLabelString
+mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
+
+-- ---------------------------------------------------------------------------
+-- Make the export list for an interface
+
+mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
+mkIfaceExports decls = map getExport decls
+ where getExport d = case d of
+ TyData{} -> tc_export
+ ClassDecl{} -> tc_export
+ _other -> var_export
+ where
+ tc_export = AvailTC (rdrNameOcc (tcdName d))
+ (map (rdrNameOcc.fst) (tyClDeclNames d))
+ var_export = Avail (rdrNameOcc (tcdName d))
\end{code}
+
+
+-----------------------------------------------------------------------------
+-- Misc utils
+
+\begin{code}
+parseError :: String -> P a
+parseError s =
+ getSrcLocP `thenP` \ loc ->
+ failMsgP (hcat [ppr loc, text ": ", text s])
+\end{code}
+
wiredInThingEnv,
ghcPrimExports,
cCallableClassDecl, cReturnableClassDecl,
+ knownKeyNames,
-- Random other things
maybeCharLikeCon, maybeIntLikeCon,
#include "HsVersions.h"
-import PrelNames -- Prelude module names
+import PrelNames ( basicKnownKeyNames,
+ cCallableClassName, cReturnableClassName,
+ hasKey, charDataConKey, intDataConKey,
+ numericClassKeys, standardClassKeys, cCallishClassKeys,
+ noDictClassKeys )
+#ifdef GHCI
+import DsMeta ( templateHaskellNames )
+#endif
import PrimOp ( allThePrimOps, primOpOcc )
import DataCon ( DataCon )
import Id ( idName )
import MkId ( mkPrimOpId, wiredInIds )
import MkId -- All of it, for re-export
-import Name ( nameOccName )
+import Name ( Name, nameOccName )
+import NameSet ( nameSetToList )
import RdrName ( mkRdrUnqual, getRdrName )
import HsSyn ( HsTyVarBndr(..) )
import OccName ( mkVarOcc )
import RdrHsSyn ( mkClassDecl )
import HscTypes ( TyThing(..), implicitTyThingIds, TypeEnv, mkTypeEnv,
GenAvailInfo(..), RdrAvailInfo )
-import Class ( Class, classKey )
+import Class ( Class, classKey, className )
import Type ( funTyCon, openTypeKind, liftedTypeKind )
import TyCon ( tyConName )
import SrcLoc ( noSrcLoc )
wiredInThingEnv :: TypeEnv
wiredInThingEnv = mkTypeEnv wiredInThings
+
+knownKeyNames :: [Name]
+knownKeyNames
+ = basicKnownKeyNames
+#ifdef GHCI
+ ++ nameSetToList templateHaskellNames
+#endif
\end{code}
We let a lot of "non-standard" values be visible, so that we can make
isNumericClass clas = classKey clas `is_elem` numericClassKeys
isStandardClass clas = classKey clas `is_elem` standardClassKeys
isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys
-isCreturnableClass clas = classKey clas == cReturnableClassKey
+isCreturnableClass clas = className clas == cReturnableClassName
isNoDictClass clas = classKey clas `is_elem` noDictClassKeys
is_elem = isIn "is_X_Class"
\end{code}
\section[PrelNames]{Definitions of prelude modules and names}
--- MetaHaskell Extension
-to do -- three things
-1) Allocate a key
-2) Make a "Name"
-3) Add the name to knownKeyNames
-
-
The strings identify built-in prelude modules. They are
defined here so as to avod
-- So many that we export them all
-----------------------------------------------------------
- knownKeyNames, templateHaskellNames,
+ basicKnownKeyNames,
mkTupNameStr, isBuiltInSyntaxName,
------------------------------------------------------------
)
import BasicTypes ( Boxity(..) )
import Name ( Name, mkInternalName, mkKnownKeyExternalName, mkWiredInName, nameUnique )
-import NameSet ( NameSet, mkNameSet )
import SrcLoc ( noSrcLoc )
import Util ( nOfThem )
import Panic ( panic )
names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in TysWiredIn etc.
-
-MetaHaskell Extension
-It is here that the names defiend in module Meta must be added
\begin{code}
-knownKeyNames :: [Name]
-knownKeyNames
+basicKnownKeyNames :: [Name]
+basicKnownKeyNames
= [ -- Type constructors (synonyms especially)
ioTyConName, ioDataConName,
runIOName,
filterPName, zipPName, crossPName, indexPName,
toPName, bpermutePName, bpermuteDftPName, indexOfPName,
- -- MetaHaskell Extension, "the smart constructors"
- -- text1 from Meta/work/gen.hs
- intLName,
- charLName,
- plitName,
- pvarName,
- ptupName,
- pconName,
- ptildeName,
- paspatName,
- pwildName,
- varName,
- conName,
- litName,
- appName,
- infixEName,
- lamName,
- tupName,
- doEName,
- compName,
- listExpName,
- condName,
- letEName,
- caseEName,
- infixAppName,
- sectionLName,
- sectionRName,
- guardedName,
- normalName,
- bindStName,
- letStName,
- noBindStName,
- parStName,
- fromName,
- fromThenName,
- fromToName,
- fromThenToName,
- liftName,
- gensymName,
- returnQName,
- bindQName,
- funName,
- valName,
- protoName, matchName, clauseName,
- exprTyConName, declTyConName, pattTyConName, mtchTyConName, clseTyConName,
- qTyConName, expTyConName, matTyConName, clsTyConName,
-
-- FFI primitive types that are not wired-in.
int8TyConName, int16TyConName, int32TyConName, int64TyConName,
word8TyConName, word16TyConName, word32TyConName, word64TyConName,
filterName = varQual pREL_LIST_Name FSLIT("filter") filterIdKey
zipName = varQual pREL_LIST_Name FSLIT("zip") zipIdKey
--- MetaHaskell Extension, "the smart constructors"
--- text3 from Meta/work/gen.hs
-intLName = varQual mETA_META_Name FSLIT("intL") intLIdKey
-charLName = varQual mETA_META_Name FSLIT("charL") charLIdKey
-plitName = varQual mETA_META_Name FSLIT("plit") plitIdKey
-pvarName = varQual mETA_META_Name FSLIT("pvar") pvarIdKey
-ptupName = varQual mETA_META_Name FSLIT("ptup") ptupIdKey
-pconName = varQual mETA_META_Name FSLIT("pcon") pconIdKey
-ptildeName = varQual mETA_META_Name FSLIT("ptilde") ptildeIdKey
-paspatName = varQual mETA_META_Name FSLIT("paspat") paspatIdKey
-pwildName = varQual mETA_META_Name FSLIT("pwild") pwildIdKey
-varName = varQual mETA_META_Name FSLIT("var") varIdKey
-conName = varQual mETA_META_Name FSLIT("con") conIdKey
-litName = varQual mETA_META_Name FSLIT("lit") litIdKey
-appName = varQual mETA_META_Name FSLIT("app") appIdKey
-infixEName = varQual mETA_META_Name FSLIT("infixE") infixEIdKey
-lamName = varQual mETA_META_Name FSLIT("lam") lamIdKey
-tupName = varQual mETA_META_Name FSLIT("tup") tupIdKey
-doEName = varQual mETA_META_Name FSLIT("doE") doEIdKey
-compName = varQual mETA_META_Name FSLIT("comp") compIdKey
-listExpName = varQual mETA_META_Name FSLIT("listExp") listExpIdKey
-condName = varQual mETA_META_Name FSLIT("cond") condIdKey
-letEName = varQual mETA_META_Name FSLIT("letE") letEIdKey
-caseEName = varQual mETA_META_Name FSLIT("caseE") caseEIdKey
-infixAppName = varQual mETA_META_Name FSLIT("infixApp") infixAppIdKey
-sectionLName = varQual mETA_META_Name FSLIT("sectionL") sectionLIdKey
-sectionRName = varQual mETA_META_Name FSLIT("sectionR") sectionRIdKey
-guardedName = varQual mETA_META_Name FSLIT("guarded") guardedIdKey
-normalName = varQual mETA_META_Name FSLIT("normal") normalIdKey
-bindStName = varQual mETA_META_Name FSLIT("bindSt") bindStIdKey
-letStName = varQual mETA_META_Name FSLIT("letSt") letStIdKey
-noBindStName = varQual mETA_META_Name FSLIT("noBindSt") noBindStIdKey
-parStName = varQual mETA_META_Name FSLIT("parSt") parStIdKey
-fromName = varQual mETA_META_Name FSLIT("from") fromIdKey
-fromThenName = varQual mETA_META_Name FSLIT("fromThen") fromThenIdKey
-fromToName = varQual mETA_META_Name FSLIT("fromTo") fromToIdKey
-fromThenToName = varQual mETA_META_Name FSLIT("fromThenTo") fromThenToIdKey
-liftName = varQual mETA_META_Name FSLIT("lift") liftIdKey
-gensymName = varQual mETA_META_Name FSLIT("gensym") gensymIdKey
-returnQName = varQual mETA_META_Name FSLIT("returnQ") returnQIdKey
-bindQName = varQual mETA_META_Name FSLIT("bindQ") bindQIdKey
-funName = varQual mETA_META_Name FSLIT("fun") funIdKey
-valName = varQual mETA_META_Name FSLIT("val") valIdKey
-matchName = varQual mETA_META_Name FSLIT("match") matchIdKey
-clauseName = varQual mETA_META_Name FSLIT("clause") clauseIdKey
-protoName = varQual mETA_META_Name FSLIT("proto") protoIdKey
-exprTyConName = tcQual mETA_META_Name FSLIT("Expr") exprTyConKey
-declTyConName = tcQual mETA_META_Name FSLIT("Decl") declTyConKey
-pattTyConName = tcQual mETA_META_Name FSLIT("Patt") pattTyConKey
-mtchTyConName = tcQual mETA_META_Name FSLIT("Mtch") mtchTyConKey
-clseTyConName = tcQual mETA_META_Name FSLIT("Clse") clseTyConKey
-stmtTyConName = tcQual mETA_META_Name FSLIT("Stmt") stmtTyConKey
-
-qTyConName = tcQual mETA_META_Name FSLIT("Q") qTyConKey
-expTyConName = tcQual mETA_META_Name FSLIT("Exp") expTyConKey
-matTyConName = tcQual mETA_META_Name FSLIT("Mat") matTyConKey
-clsTyConName = tcQual mETA_META_Name FSLIT("Cls") clsTyConKey
-
-- Class Show
showClassName = clsQual pREL_SHOW_Name FSLIT("Show") showClassKey
%************************************************************************
%* *
-\subsection{Standard groups of names}
-%* *
-%************************************************************************
-
-\begin{code}
-templateHaskellNames :: NameSet
--- The names that are implicitly mentioned by ``bracket''
--- Should stay in sync with the import list of DsMeta
-templateHaskellNames
- = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName,
- pconName, ptildeName, paspatName, pwildName,
- varName, conName, litName, appName, lamName,
- tupName, doEName, compName,
- listExpName, condName, letEName, caseEName,
- infixAppName, guardedName, normalName,
- bindStName, letStName, noBindStName, parStName,
- fromName, fromThenName, fromToName, fromThenToName,
- funName, valName, liftName,gensymName, bindQName,
- appendName, matchName, clauseName ]
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Local helpers}
%* *
%************************************************************************
-- Parallel array type constructor
parrTyConKey = mkPreludeTyConUnique 82
--- Template Haskell
-qTyConKey = mkPreludeTyConUnique 83
-exprTyConKey = mkPreludeTyConUnique 84
-declTyConKey = mkPreludeTyConUnique 85
-pattTyConKey = mkPreludeTyConUnique 86
-mtchTyConKey = mkPreludeTyConUnique 87
-clseTyConKey = mkPreludeTyConUnique 88
-stmtTyConKey = mkPreludeTyConUnique 89
-expTyConKey = mkPreludeTyConUnique 90
-matTyConKey = mkPreludeTyConUnique 91
-clsTyConKey = mkPreludeTyConUnique 92
+---------------- Template Haskell -------------------
+-- USES TyConUniques 100-119
+-----------------------------------------------------
unitTyConKey = mkTupleTyConUnique Boxed 0
\end{code}
thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>)
returnMClassOpKey = mkPreludeMiscIdUnique 117
--- MetaHaskell Extension, (text4 118) from Meta/work/gen.hs
-intLIdKey = mkPreludeMiscIdUnique 118
-charLIdKey = mkPreludeMiscIdUnique 119
-plitIdKey = mkPreludeMiscIdUnique 120
-pvarIdKey = mkPreludeMiscIdUnique 121
-ptupIdKey = mkPreludeMiscIdUnique 122
-pconIdKey = mkPreludeMiscIdUnique 123
-ptildeIdKey = mkPreludeMiscIdUnique 124
-paspatIdKey = mkPreludeMiscIdUnique 125
-pwildIdKey = mkPreludeMiscIdUnique 126
-varIdKey = mkPreludeMiscIdUnique 127
-conIdKey = mkPreludeMiscIdUnique 128
-litIdKey = mkPreludeMiscIdUnique 129
-appIdKey = mkPreludeMiscIdUnique 130
-infixEIdKey = mkPreludeMiscIdUnique 131
-lamIdKey = mkPreludeMiscIdUnique 132
-tupIdKey = mkPreludeMiscIdUnique 133
-doEIdKey = mkPreludeMiscIdUnique 134
-compIdKey = mkPreludeMiscIdUnique 135
-listExpIdKey = mkPreludeMiscIdUnique 137
-condIdKey = mkPreludeMiscIdUnique 138
-letEIdKey = mkPreludeMiscIdUnique 139
-caseEIdKey = mkPreludeMiscIdUnique 140
-infixAppIdKey = mkPreludeMiscIdUnique 141
-sectionLIdKey = mkPreludeMiscIdUnique 142
-sectionRIdKey = mkPreludeMiscIdUnique 143
-guardedIdKey = mkPreludeMiscIdUnique 144
-normalIdKey = mkPreludeMiscIdUnique 145
-bindStIdKey = mkPreludeMiscIdUnique 146
-letStIdKey = mkPreludeMiscIdUnique 147
-noBindStIdKey = mkPreludeMiscIdUnique 148
-parStIdKey = mkPreludeMiscIdUnique 149
-fromIdKey = mkPreludeMiscIdUnique 150
-fromThenIdKey = mkPreludeMiscIdUnique 151
-fromToIdKey = mkPreludeMiscIdUnique 152
-fromThenToIdKey = mkPreludeMiscIdUnique 153
-liftIdKey = mkPreludeMiscIdUnique 154
-gensymIdKey = mkPreludeMiscIdUnique 155
-returnQIdKey = mkPreludeMiscIdUnique 156
-bindQIdKey = mkPreludeMiscIdUnique 157
-funIdKey = mkPreludeMiscIdUnique 158
-valIdKey = mkPreludeMiscIdUnique 159
-protoIdKey = mkPreludeMiscIdUnique 160
-matchIdKey = mkPreludeMiscIdUnique 161
-clauseIdKey = mkPreludeMiscIdUnique 162
-
-- Recursive do notation
-mfixIdKey = mkPreludeMiscIdUnique 163
+mfixIdKey = mkPreludeMiscIdUnique 118
+
+---------------- Template Haskell -------------------
+-- USES IdUniques 200-299
+-----------------------------------------------------
\end{code}
rnMonoBinds mbinds sigs `thenM` \ (binds, bind_fvs) ->
-- Now do the "thing inside"
- thing_inside binds `thenM` \ (result,result_fvs) ->
+ thing_inside binds `thenM` \ (result,result_fvs) ->
-- Final error checking
let
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName, printName,
bindIOName, returnIOName, failIOName, thenIOName
+ )
#ifdef GHCI
- , templateHaskellNames, qTyConName
+import DsMeta ( templateHaskellNames, qTyConName )
#endif
- )
import TysWiredIn ( unitTyCon ) -- A little odd
import FiniteMap
import UniqSupply
import RnHsSyn
import TcRnMonad
import RnEnv
+import RnNames ( importsFromLocalDecls )
import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
dupFieldErr, precParseErr, sectionPrecErr, patSigErr )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
replicatePName, mapPName, filterPName,
crossPName, zipPName, toPName,
enumFromToPName, enumFromThenToPName, assertErrorName,
- negateName, qTyConName, monadNames, mfixName )
-import RdrName ( RdrName )
+ negateName, monadNames, mfixName )
+#ifdef GHCI
+import DsMeta ( qTyConName )
+#endif
import Name ( Name, nameOccName )
import NameSet
import UnicodeUtil ( stringToUtf8 )
returnM (HsPar e', fvs_e)
-- Template Haskell extensions
+#ifdef GHCI
rnExpr (HsBracket br_body)
= checkGHCI (thErr "bracket") `thenM_`
rnBracket br_body `thenM` \ (body', fvs_e) ->
returnM (HsBracket body', fvs_e `addOneFV` qTyConName)
-- We use the Q tycon as a proxy to haul in all the smart
-- constructors; see the hack in RnIfaces
+#endif
rnExpr (HsSplice n e)
= checkGHCI (thErr "splice") `thenM_`
returnM (TypBr t', fvs)
where
doc = ptext SLIT("In a Template-Haskell quoted type")
-rnBracket (DecBr ds) = rnSrcDecls ds `thenM` \ (tcg_env, ds', fvs) ->
- -- Discard the tcg_env; it contains the extended global RdrEnv
- -- because there is no scope that these decls cover (yet!)
- returnM (DecBr ds', fvs)
+rnBracket (DecBr group)
+ = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
+ -- Discard avails (not useful here)
+
+ updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
+
+ rnSrcDecls group `thenM` \ (tcg_env, group', fvs) ->
+ -- Discard the tcg_env; it contains only extra info about fixity
+
+ returnM (DecBr group', fvs)
\end{code}
%************************************************************************
import NameEnv ( delFromNameEnv, lookupNameEnv )
import NameSet
import Module ( Module, isHomeModule, extendModuleSet )
-import PrelInfo ( hasKey, fractionalClassKey, numClassKey,
+import PrelNames ( hasKey, fractionalClassKey, numClassKey,
integerTyConName, doubleTyConName )
import FiniteMap
import Outputable
in
traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_`
- recoverM (returnM Nothing)
- (loadInterface doc_str mod_name from `thenM` \ iface ->
- returnM (Just iface)) `thenM` \ mb_iface ->
+ tryM (loadInterface doc_str mod_name from) `thenM` \ mb_iface ->
case mb_iface of {
- Nothing -> (out_of_date (sep [ptext SLIT("Can't find version number for module"),
+ Left exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"),
ppr mod_name]));
-- Couldn't find or parse a module mentioned in the
-- old interface file. Don't complain -- it might just be that
-- the current module doesn't need that import and it's been deleted
- Just iface ->
+ Right iface ->
let
new_vers = mi_version iface
new_mod_vers = vers_module new_vers
import CmdLineOpts ( DynFlag(..) )
import HsSyn ( HsDecl(..), IE(..), ieName, ImportDecl(..),
- ForeignDecl(..),
+ ForeignDecl(..), HsGroup(..),
collectLocatedHsBinders, tyClDeclNames
)
import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsDecl )
Deprecations(..), ModIface(..),
GlobalRdrElt(..), unQualInScope, isLocalGRE
)
-import RdrName ( rdrNameOcc, setRdrNameSpace, emptyRdrEnv, foldRdrEnv, isQual )
+import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace,
+ emptyRdrEnv, foldRdrEnv, isQual )
import Outputable
import Maybes ( maybeToBool, catMaybes )
import ListSetOps ( removeDups )
-- If there's an error in loadInterface, (e.g. interface
-- file not found) we get lots of spurious errors from 'filterImports'
- recoverM (returnM Nothing)
- (loadInterface doc imp_mod_name (ImportByUser is_boot) `thenM` \ iface ->
- returnM (Just iface)) `thenM` \ mb_iface ->
+ tryM (loadInterface doc imp_mod_name (ImportByUser is_boot)) `thenM` \ mb_iface ->
case mb_iface of {
- Nothing -> returnM (emptyRdrEnv, emptyImportAvails ) ;
- Just iface ->
+ Left exn -> returnM (emptyRdrEnv, emptyImportAvails ) ;
+ Right iface ->
let
imp_mod = mi_module iface
Complain about duplicate bindings
\begin{code}
-importsFromLocalDecls :: [RdrNameHsDecl]
+importsFromLocalDecls :: HsGroup RdrName
-> TcRn m (GlobalRdrEnv, ImportAvails)
-importsFromLocalDecls decls
- = getModule `thenM` \ this_mod ->
- mappM (getLocalDeclBinders this_mod) decls `thenM` \ avails_s ->
+importsFromLocalDecls group
+ = getModule `thenM` \ this_mod ->
+ getLocalDeclBinders this_mod group `thenM` \ avails ->
-- The avails that are returned don't include the "system" names
let
- avails = concat avails_s
-
all_names :: [Name] -- All the defns; no dups eliminated
all_names = [name | avail <- avails, name <- availNames avail]
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
-getLocalDeclBinders :: Module -> RdrNameHsDecl -> TcRn m [AvailInfo]
-getLocalDeclBinders mod (TyClD tycl_decl)
+getLocalDeclBinders :: Module -> HsGroup RdrName -> TcRn m [AvailInfo]
+getLocalDeclBinders mod (HsGroup {hs_valds = val_decls,
+ hs_tyclds = tycl_decls,
+ hs_fords = foreign_decls })
= -- For type and class decls, we generate Global names, with
-- no export indicator. They need to be global because they get
-- permanently bound into the TyCons and Classes. They don't need
-- an export indicator because they are all implicitly exported.
- mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) ->
- returnM [AvailTC main_name names]
- where
- new (nm,loc) = newTopBinder mod nm loc
-getLocalDeclBinders mod (ValD binds)
- = mappM new (collectLocatedHsBinders binds) `thenM` \ avails ->
- returnM avails
+ mappM new_tc tycl_decls `thenM` \ tc_avails ->
+ mappM new_bndr (for_hs_bndrs ++ val_hs_bndrs) `thenM` \ simple_bndrs ->
+
+ returnM (tc_avails ++ map Avail simple_bndrs)
where
- new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenM` \ name ->
- returnM (Avail name)
-
-getLocalDeclBinders mod (ForD (ForeignImport nm _ _ _ loc))
- = newTopBinder mod nm loc `thenM` \ name ->
- returnM [Avail name]
-getLocalDeclBinders mod (ForD _)
- = returnM []
-
-getLocalDeclBinders mod (FixD _) = returnM []
-getLocalDeclBinders mod (DeprecD _) = returnM []
-getLocalDeclBinders mod (DefD _) = returnM []
-getLocalDeclBinders mod (InstD _) = returnM []
-getLocalDeclBinders mod (RuleD _) = returnM []
+ new_bndr (rdr_name,loc) = newTopBinder mod rdr_name loc
+
+ val_hs_bndrs = collectLocatedHsBinders val_decls
+ for_hs_bndrs = [(nm,loc) | ForeignImport nm _ _ _ loc <- foreign_decls]
+
+ new_tc tc_decl = mappM new_bndr (tyClDeclNames tc_decl) `thenM` \ names@(main_name:_) ->
+ returnM (AvailTC main_name names)
\end{code}
1 rnBinds :: RdrHsSyn.RdrNameHsBinds
-> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.FreeVars) ;
-1 rnSrcDecls :: [RdrHsSyn.RdrNameHsDecl]
- -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, [RnHsSyn.RenamedHsDecl], NameSet.FreeVars) ;
+1 rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName
+ -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.FreeVars) ;
rnBinds :: RdrHsSyn.RdrNameHsBinds
-> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.FreeVars) ;
-rnSrcDecls :: [RdrHsSyn.RdrNameHsDecl]
- -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, [RnHsSyn.RenamedHsDecl], NameSet.FreeVars)
+rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName
+ -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.FreeVars)
\begin{code}
module RnSource (
- rnSrcDecls, rnExtCoreDecls, checkModDeprec,
+ rnSrcDecls, checkModDeprec,
rnTyClDecl, rnIfaceRuleDecl, rnInstDecl,
rnBinds, rnBindsAndThen, rnStats,
) where
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
-import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, RdrNameHsDecl,
+import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl,
RdrNameDeprecation, RdrNameFixitySig,
RdrNameHsBinds,
extractGenericPatTyVars
)
import RnHsSyn
import HsCore
-
-import RnNames ( importsFromLocalDecls )
import RnExpr ( rnExpr )
import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
checkDupOrQualNames, checkDupNames, mapFvRn,
lookupTopSrcBndr_maybe, lookupTopSrcBndr,
- dataTcOccs, unknownNameErr,
- plusGlobalRdrEnv
+ dataTcOccs, unknownNameErr
)
import TcRnMonad
\begin{code}
-rnSrcDecls :: [RdrNameHsDecl] -> RnM (TcGblEnv, [RenamedHsDecl], FreeVars)
-
-rnSrcDecls decls
- = do { (rdr_env, imports) <- importsFromLocalDecls decls ;
- updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
- tcg_rdr_env gbl,
- tcg_imports = imports `plusImportAvails`
- tcg_imports gbl })
- $ do {
-
- -- Deal with deprecations (returns only the extra deprecations)
- deprecs <- rnSrcDeprecDecls [d | DeprecD d <- decls] ;
+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, FreeVars)
+
+rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _,
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_fixds = fix_decls,
+ hs_depds = deprec_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_decls,
+ hs_ruleds = rule_decls,
+ hs_coreds = core_decls })
+
+ = do { -- Deal with deprecations (returns only the extra deprecations)
+ deprecs <- rnSrcDeprecDecls deprec_decls ;
updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
$ do {
-- Deal with top-level fixity decls
-- (returns the total new fixity env)
- fix_env <- rnSrcFixityDecls decls ;
+ fix_env <- rnSrcFixityDecls fix_decls ;
updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
$ do {
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
- -- Rename remaining declarations
- (rn_src_decls, src_fvs) <- rn_src_decls decls ;
+ -- Rename other declarations
+ (rn_val_decls, src_fvs1) <- rnTopMonoBinds binds sigs ;
+ (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ;
+ (rn_tycl_decls, src_fvs3) <- mapFvRn rnSrcTyClDecl tycl_decls ;
+ (rn_rule_decls, src_fvs4) <- mapFvRn rnHsRuleDecl rule_decls ;
+ (rn_foreign_decls, src_fvs5) <- mapFvRn rnHsForeignDecl foreign_decls ;
+ (rn_default_decls, src_fvs6) <- mapFvRn rnDefaultDecl default_decls ;
+ (rn_core_decls, src_fvs7) <- mapFvRn rnCoreDecl core_decls ;
+
+ let {
+ rn_group = HsGroup { hs_valds = rn_val_decls,
+ hs_tyclds = rn_tycl_decls,
+ hs_instds = rn_inst_decls,
+ hs_fixds = [],
+ hs_depds = [],
+ hs_fords = rn_foreign_decls,
+ hs_defds = rn_default_decls,
+ hs_ruleds = rn_rule_decls,
+ hs_coreds = rn_core_decls } ;
+ src_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+ src_fvs5, src_fvs6, src_fvs7] } ;
tcg_env <- getGblEnv ;
- return (tcg_env, rn_src_decls, src_fvs)
- }}}}
-
-rnExtCoreDecls :: [RdrNameHsDecl] -> RnM ([RenamedHsDecl], FreeVars)
-rnExtCoreDecls decls = rn_src_decls decls
-
-rn_src_decls decls -- Declarartions get reversed, but no matter
- = go emptyFVs [] decls
- where
- -- Fixity and deprecations have been dealt with already; ignore them
- go fvs ds' [] = returnM (ds', fvs)
- go fvs ds' (FixD _:ds) = go fvs ds' ds
- go fvs ds' (DeprecD _:ds) = go fvs ds' ds
- go fvs ds' (d:ds) = rnSrcDecl d `thenM` \(d', fvs') ->
- go (fvs `plusFV` fvs') (d':ds') ds
+ return (tcg_env, rn_group, src_fvs)
+ }}}
\end{code}
%*********************************************************
\begin{code}
-rnSrcFixityDecls :: [RdrNameHsDecl] -> TcRn m FixityEnv
-rnSrcFixityDecls decls
+rnSrcFixityDecls :: [RdrNameFixitySig] -> TcRn m FixityEnv
+rnSrcFixityDecls fix_decls
= getGblEnv `thenM` \ gbl_env ->
foldlM rnFixityDecl (tcg_fix_env gbl_env)
fix_decls `thenM` \ fix_env ->
traceRn (text "fixity env" <+> ppr fix_env) `thenM_`
returnM fix_env
- where
- fix_decls = foldr get_fix_sigs [] decls
-
- -- Get fixities from top level decls, and from class decl sigs too
- get_fix_sigs (FixD fix) acc = fix:acc
- get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc
- = [sig | FixSig sig <- sigs] ++ acc
- get_fix_sigs other_decl acc = acc
rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv
rnFixityDecl fix_env (FixitySig rdr_name fixity loc)
%*********************************************************
\begin{code}
-rnSrcDecl :: RdrNameHsDecl -> RnM (RenamedHsDecl, FreeVars)
-
-rnSrcDecl (ValD binds) = rnTopBinds binds `thenM` \ (new_binds, fvs) ->
- returnM (ValD new_binds, fvs)
-
-rnSrcDecl (TyClD tycl_decl)
+rnSrcTyClDecl tycl_decl
= rnTyClDecl tycl_decl `thenM` \ new_decl ->
finishSourceTyClDecl tycl_decl new_decl `thenM` \ (new_decl', fvs) ->
- returnM (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
+ returnM (new_decl', fvs `plusFV` tyClDeclFVs new_decl')
-rnSrcDecl (InstD inst)
+rnSrcInstDecl inst
= rnInstDecl inst `thenM` \ new_inst ->
finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) ->
- returnM (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
-
-rnSrcDecl (RuleD rule)
- = rnHsRuleDecl rule `thenM` \ (new_rule, fvs) ->
- returnM (RuleD new_rule, fvs)
-
-rnSrcDecl (ForD ford)
- = rnHsForeignDecl ford `thenM` \ (new_ford, fvs) ->
- returnM (ForD new_ford, fvs)
+ returnM (new_inst', fvs `plusFV` instDeclFVs new_inst')
-rnSrcDecl (DefD (DefaultDecl tys src_loc))
+rnDefaultDecl (DefaultDecl tys src_loc)
= addSrcLoc src_loc $
mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
- returnM (DefD (DefaultDecl tys' src_loc), fvs)
+ returnM (DefaultDecl tys' src_loc, fvs)
where
doc_str = text "In a `default' declaration"
-rnSrcDecl (CoreD (CoreDecl name ty rhs loc))
+rnCoreDecl (CoreDecl name ty rhs loc)
= addSrcLoc loc $
lookupTopBndrRn name `thenM` \ name' ->
rnHsTypeFVs doc_str ty `thenM` \ (ty', ty_fvs) ->
rnCoreExpr rhs `thenM` \ rhs' ->
- returnM (CoreD (CoreDecl name' ty' rhs' loc),
+ returnM (CoreDecl name' ty' rhs' loc,
ty_fvs `plusFV` ufExprFVs rhs')
where
doc_str = text "In the Core declaration for" <+> quotes (ppr name)
bindPatSigTyVars, bindLocalsFVRn, warnUnusedMatches )
import TcRnMonad
-import PrelInfo ( cCallishClassKeys, eqStringName, eqClassName, ordClassName,
+import PrelNames( cCallishClassKeys, eqStringName, eqClassName, ordClassName,
negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName,
timesIntegerName, ratioDataConName, fromRationalName, cCallableClassName )
import TysWiredIn ( intTyCon )
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon )
-import RdrName ( RdrName, elemRdrEnv )
+import RdrName ( elemRdrEnv )
import Name ( Name, NamedThing(..) )
import NameSet
import Unique ( Uniquable(..) )
import Util ( equalLength )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
-import Bag
import Outputable
\end{code}
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), DefaultDecl(..) )
-import RnHsSyn ( RenamedHsDecl )
-
+import HsSyn ( DefaultDecl(..) )
+import Name ( Name )
import TcRnMonad
import TcEnv ( tcLookupGlobal_maybe )
import TcMonoType ( tcHsType )
\end{code}
\begin{code}
-tcDefaults :: [RenamedHsDecl]
+tcDefaults :: [DefaultDecl Name]
-> TcM [Type] -- defaulting types to heave
-- into Tc monad for later use
-- in Disambig.
-tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls]
-tc_defaults [] = returnM defaultDefaultTys
+tcDefaults [] = returnM defaultDefaultTys
-tc_defaults [DefaultDecl [] locn]
+tcDefaults [DefaultDecl [] locn]
= returnM [] -- no defaults
-tc_defaults [DefaultDecl mono_tys locn]
+tcDefaults [DefaultDecl mono_tys locn]
= tcLookupGlobal_maybe numClassName `thenM` \ maybe_num ->
case maybe_num of
Just (AClass num_class) -> common_case num_class
#include "HsVersions.h"
#ifdef GHCI /* Only if bootstrapped */
-import {-# SOURCE #-} TcSplice( tcSpliceExpr )
-import TcEnv ( bracketOK, tcMetaTy )
+import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
+import TcEnv ( bracketOK )
import TcSimplify ( tcSimplifyBracket )
-import PrelNames ( exprTyConName )
-import HsSyn ( HsBracket(..) )
+import DsMeta ( liftName )
#endif
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName,
- ioTyConName, liftName
+ ioTyConName
)
+import DsMeta
import ListSetOps ( minusList )
import CmdLineOpts
import HscTypes ( TyThing(..) )
tcMonoExpr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty
-tcMonoExpr (HsBracket (ExpBr expr)) res_ty
+tcMonoExpr (HsBracket brack) res_ty
= getStage `thenM` \ level ->
case bracketOK level of {
Nothing -> failWithTc (illegalBracket level) ;
-- it again when we actually use it.
newMutVar [] `thenM` \ pending_splices ->
getLIEVar `thenM` \ lie_var ->
- newTyVarTy openTypeKind `thenM` \ any_ty ->
setStage (Brack next_level pending_splices lie_var) (
- getLIE (tcMonoExpr expr any_ty)
- ) `thenM` \ (expr', lie) ->
- tcSimplifyBracket lie `thenM_`
+ getLIE (tcBracket brack)
+ ) `thenM` \ (meta_ty, lie) ->
+ tcSimplifyBracket lie `thenM_`
- tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
- unifyTauTy res_ty meta_exp_ty `thenM_`
+ unifyTauTy res_ty meta_ty `thenM_`
-- Return the original expression, not the type-decorated one
readMutVar pending_splices `thenM` \ pendings ->
- returnM (HsBracketOut (ExpBr expr) pendings)
+ returnM (HsBracketOut brack pendings)
}
#endif GHCI
\end{code}
= tcLookupIdLvl name `thenM` \ (id, bind_lvl) ->
-- Check for cross-stage lifting
+#ifdef GHCI
getStage `thenM` \ use_stage ->
case use_stage of
Brack use_lvl ps_var lie_var
in
checkTc (wellStaged bind_lvl use_lvl)
(badStageErr id bind_lvl use_lvl) `thenM_`
-
+#endif
+ -- This is the bit that handles the no-Template-Haskell case
case isDataConWrapId_maybe id of
Nothing -> loop (HsVar id) (idType id)
Just data_con -> inst_data_con id data_con
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
+import HsSyn ( ForeignDecl(..), HsExpr(..),
MonoBinds(..), ForeignImport(..), ForeignExport(..),
CImportSpec(..)
)
-import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
+import RnHsSyn ( RenamedForeignDecl )
import TcRnMonad
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import PrimRep ( getPrimRepSize, isFloatingRep )
import Type ( typePrimRep )
import OccName ( mkForeignExportOcc )
-import Name ( NamedThing(..), mkExternalName )
+import Name ( Name, NamedThing(..), mkExternalName )
import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
tcSplitForAllTys,
isFFIArgumentTy, isFFIImportResultTy,
%************************************************************************
\begin{code}
-tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
-tcForeignImports decls =
- mapAndUnzipM tcFImport
- [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
+tcForeignImports :: [ForeignDecl Name] -> TcM ([Id], [TypecheckedForeignDecl])
+tcForeignImports decls
+ = mapAndUnzipM tcFImport (filter isForeignImport decls)
tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc)
%************************************************************************
\begin{code}
-tcForeignExports :: [RenamedHsDecl]
+tcForeignExports :: [ForeignDecl Name]
-> TcM (TcMonoBinds, [TcForeignDecl])
-tcForeignExports decls =
- foldlM combine (EmptyMonoBinds, [])
- [foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
+tcForeignExports decls
+ = foldlM combine (EmptyMonoBinds, []) (filter isForeignExport decls)
where
combine (binds, fs) fe =
tcFExport fe `thenM ` \ (b, f) ->
HsBinds(..), HsType(..), HsStmtContext(..),
unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
)
+import PrelNames ( )
import RdrName ( RdrName, mkUnqual, nameRdrName, getRdrName )
import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
)
import HscTypes ( FixityEnv, lookupFixity )
-import PrelInfo -- Lots of Names
+import PrelNames -- Lots of Names
import PrimOp -- Lots of Names
import SrcLoc ( generatedSrcLoc, SrcLoc )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
import Util ( zipWithEqual, isSingleton,
zipWith3Equal, nOfThem, zipEqual )
import Panic ( panic, assertPanic )
-import Maybes ( maybeToBool )
import Char ( ord, isAlpha )
import Constants
import List ( partition, intersperse )
zonkExpr env expr `thenM` \ new_expr ->
returnM (VarMonoBind new_var new_expr, unitBag new_var)
-zonkMonoBinds env (CoreMonoBind var core_expr)
- = zonkIdBndr env var `thenM` \ new_var ->
- returnM (CoreMonoBind new_var core_expr, unitBag new_var)
-
zonkMonoBinds env (FunMonoBind var inf ms locn)
= zonkIdBndr env var `thenM` \ new_var ->
mappM (zonkMatch env) ms `thenM` \ new_ms ->
#ifdef GHCI
mkGlobalContext, getModuleContents,
#endif
- tcRnModule, checkOldIface, importSupportingDecls,
+ tcRnModule, checkOldIface,
+ importSupportingDecls, tcTopSrcDecls,
tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing
) where
#include "HsVersions.h"
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice( tcSpliceDecls )
+#endif
+
import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
+ HsGroup(..),
mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
isSrcRule, collectStmtsBinders
)
-import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr )
+import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
+ emptyGroup, mkGroup, findSplice, addImpDecls )
import PrelNames ( iNTERACTIVE, ioTyConName, printName,
returnIOName, bindIOName, failIOName, thenIOName, runIOName,
import RnEnv ( lookupSrcName, lookupOccRn,
ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
import RnExpr ( rnStmts, rnExpr )
-import RnSource ( rnSrcDecls, rnExtCoreDecls, checkModDeprec, rnStats )
+import RnNames ( importsFromLocalDecls )
+import RnSource ( rnSrcDecls, checkModDeprec, rnStats )
import OccName ( varName )
import CoreUnfold ( unfoldingTemplate )
-- Get the supporting decls, and typecheck them all together
-- so that any mutually recursive types are done right
extra_decls <- slurpImpDecls needed ;
- env <- typecheckIfaceDecls (decls ++ extra_decls) ;
+ env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ;
returnM (ModDetails { md_types = tcg_type_env env,
md_insts = tcg_insts env,
rule_decls = dcl_rules iface_decls
inst_decls = dcl_insts iface_decls
tycl_decls = dcl_tycl iface_decls
- decls = map RuleD rule_decls ++
- map InstD inst_decls ++
- map TyClD tycl_decls
+ group = emptyGroup { hs_ruleds = rule_decls,
+ hs_instds = inst_decls,
+ hs_tyclds = tycl_decls }
needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
the_bind = FunMonoBind fresh_it False
[ mkSimpleMatch [] expr placeHolderType loc ] loc
in
- tryTc_ (do { -- Try this if the other fails
+ tryTcLIE_ (do { -- Try this if the other fails
traceTc (text "tcs 1b") ;
tc_stmts [
LetStmt (MonoBind the_bind [] NonRecursive),
-- Simplify the context right here, so that we fail
-- if there aren't enough instances. Notably, when we see
-- e
- -- we use tryTc_ to try it <- e
+ -- we use recoverTc_ to try it <- e
-- and then let it = e
-- It's the simplify step that rejects the first.
traceTc (text "tcs 3") ;
let { rdr_names = dataTcOccs rdr_name } ;
(msgs_s, mb_names) <- initRnInteractive ictxt
- (mapAndUnzipM (tryM . lookupOccRn) rdr_names) ;
+ (mapAndUnzipM (tryTc . lookupOccRn) rdr_names) ;
let { names = catMaybes mb_names } ;
if null names then
-- Rename the source, only in interface mode.
-- rnSrcDecls handles fixity decls etc too, which won't occur
-- but that doesn't matter
- (rn_local_decls, fvs) <- initRn (InterfaceMode this_mod)
- (rnExtCoreDecls local_decls) ;
+ let { local_group = mkGroup local_decls } ;
+ (_, rn_local_decls, fvs) <- initRn (InterfaceMode this_mod)
+ (rnSrcDecls local_group) ;
failIfErrsM ;
-- Get the supporting decls, and typecheck them all together
-- so that any mutually recursive types are done right
extra_decls <- slurpImpDecls fvs ;
- tcg_env <- typecheckIfaceDecls (rn_local_decls ++ extra_decls) ;
+ tcg_env <- typecheckIfaceDecls (rn_local_decls `addImpDecls` extra_decls) ;
setGblEnv tcg_env $ do {
-- Now the core bindings
- core_prs <- tcCoreBinds [d | CoreD d <- rn_local_decls] ;
+ core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ;
tcExtendGlobalValEnv (map fst core_prs) $ do {
-- Wrap up
%* *
%************************************************************************
+\begin{code}
tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
-- Returns the variables free in the decls
-tcRnSrcDecls [] = getGblEnv
+ -- Reason: solely to report unused imports and bindings
+tcRnSrcDecls [] = do { tcg_env <- getGblEnv ; return (tcg_env, emptyFVs) }
tcRnSrcDecls ds
= do { let { (first_group, group_tail) = findSplice ds } ;
- tcg_env <- tcRnGroup first_group ;
+ -- Type check the decls up to, but not including, the first splice
+ (tcg_env, src_fvs1) <- tcRnGroup first_group ;
+ -- If there is no splice, we're done
case group_tail of
- Nothing -> return gbl_env
+ Nothing -> return (tcg_env, src_fvs1)
Just (splice_expr, rest_ds) -> do {
setGblEnv tcg_env $ do {
spliced_decls <- tcSpliceDecls rn_splice_expr ;
-- Glue them on the front of the remaining decls and loop
- tcRnSrcDeclsDecls (splice_decls ++ rest_ds)
- }}}}
+ (tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ;
-findSplice :: [HsDecl a] -> ([HsDecl a], Maybe (HsExpr a, [HsDecl a]))
-findSplice [] = ([], Nothing)
-findSplice (SpliceD e : ds) = ([], Just (e, ds))
-findSplice (d : ds) = (d:gs, rest)
- where
- (gs, rest) = findSplice ds
+ return (tcg_env, src_fvs1 `plusFV` src_fvs2)
+ }}}}
+\end{code}
%************************************************************************
%* *
%************************************************************************
-tcRnSrcDecls takes a bunch of top-level source-code declarations, and
+tcRnGroup takes a bunch of top-level source-code declarations, and
* renames them
* gets supporting declarations from interface files
* typechecks them
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
+tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, FreeVars)
-- Returns the variables free in the decls
-tcRnSrcDecls decls
+tcRnGroup decls
= do { -- Rename the declarations
(tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ;
setGblEnv tcg_env $ do {
}}
------------------------------------------------
-rnTopSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, [RenamedHsDecl], FreeVars)
-rnTopSrcDecls decls
- = do { (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls decls) ;
+rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars)
+rnTopSrcDecls group
+ = do { -- Bring top level binders into scope
+ (rdr_env, imports) <- importsFromLocalDecls group ;
+ updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
+ tcg_rdr_env gbl,
+ tcg_imports = imports `plusImportAvails`
+ tcg_imports gbl })
+ $ do {
+
+ -- Rename the source decls
+ (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls group) ;
setGblEnv tcg_env $ do {
failIfErrsM ;
-- Import consquential imports
rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
- let { rn_decls = rn_src_decls ++ rn_imp_decls } ;
+ let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
-- Dump trace of renaming part
- rnDump (vcat (map ppr rn_decls)) ;
+ rnDump (ppr rn_decls) ;
rnStats rn_imp_decls ;
return (tcg_env, rn_decls, src_fvs)
- }}
+ }}}
------------------------------------------------
-tcTopSrcDecls :: [RenamedHsDecl] -> TcM TcGblEnv
+tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv
tcTopSrcDecls rn_decls
= fixM (\ unf_env -> do {
-- Loop back the final environment, including the fully zonked
return tcg_env'
})
-tc_src_decls unf_env decls
+tc_src_decls unf_env
+ (HsGroup { hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_decls,
+ hs_ruleds = rule_decls,
+ hs_valds = val_binds })
= do { -- Type-check the type and class decls, and all imported decls
traceTc (text "Tc2") ;
tcg_env <- tcTyClDecls unf_env tycl_decls ;
-- Foreign import declarations next. No zonking necessary
-- here; we can tuck them straight into the global environment.
traceTc (text "Tc4") ;
- (fi_ids, fi_decls) <- tcForeignImports decls ;
+ (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $
updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
$ do {
-- Default declarations
traceTc (text "Tc4a") ;
- default_tys <- tcDefaults decls ;
+ default_tys <- tcDefaults default_decls ;
updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
-- Value declarations next
-- Foreign exports
-- They need to be zonked, so we return them
traceTc (text "Tc7") ;
- (foe_binds, foe_decls) <- tcForeignExports decls ;
+ (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
-- Rules
-- Need to partition them because the source rules
return (tcg_env, all_binds, src_rules, foe_decls)
}}}}}}}}}
- where
- tycl_decls = [d | TyClD d <- decls]
- rule_decls = [d | RuleD d <- decls]
- inst_decls = [d | InstD d <- decls]
- val_decls = [d | ValD d <- decls]
- val_binds = foldr ThenBinds EmptyBinds val_decls
\end{code}
\begin{code}
= do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
decls <- slurpImpDecls fvs ;
traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
- typecheckIfaceDecls decls }
+ typecheckIfaceDecls (mkGroup decls) }
-typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv
+typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
-- The decls are all interface-file declarations
-- Usually they are all from other modules, but when we are reading
-- this module's interface from a file, it's possible that some of
-- If all the decls are from other modules, the returned TcGblEnv
-- will have an empty tc_genv, but its tc_inst_env and tc_ist
-- caches may have been augmented.
-typecheckIfaceDecls decls
- = do { let { tycl_decls = [d | TyClD d <- decls] ;
- inst_decls = [d | InstD d <- decls] ;
- rule_decls = [d | RuleD d <- decls] } ;
-
- -- Typecheck the type, class, and interface-sig decls
+typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_ruleds = rule_decls })
+ = do { -- Typecheck the type, class, and interface-sig decls
tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ;
setGblEnv tcg_env $ do {
\begin{code}
-tryM :: TcRn m a -> TcRn m (Messages, Maybe a)
- -- (try m) executes m, and returns
+recoverM :: TcRn m r -- Recovery action; do this if the main one fails
+ -> TcRn m r -- Main action: do this first
+ -> TcRn m r
+recoverM recover thing
+ = do { mb_res <- tryM thing ;
+ case mb_res of
+ Left exn -> recover
+ Right res -> returnM res }
+
+tryTc :: TcRn m a -> TcRn m (Messages, Maybe a)
+ -- (tryTc m) executes m, and returns
-- Just r, if m succeeds (returning r) and caused no errors
-- Nothing, if m fails, or caused errors
-- It also returns all the errors accumulated by m
-- (even in the Just case, there might be warnings)
--
-- It always succeeds (never raises an exception)
-tryM m
+tryTc m
= do { errs_var <- newMutVar emptyMessages ;
- mb_r <- recoverM (return Nothing)
- (do { r <- setErrsVar errs_var m ;
- return (Just r) }) ;
+ mb_r <- tryM (setErrsVar errs_var m) ;
new_errs <- readMutVar errs_var ;
return (new_errs,
case mb_r of
- Nothing -> Nothing
- Just r | errorsFound new_errs -> Nothing
- | otherwise -> Just r)
+ Left exn -> Nothing
+ Right r | errorsFound new_errs -> Nothing
+ | otherwise -> Just r)
}
-tryTc :: TcM a -> TcM (Messages, Maybe a)
--- Just like tryM, except that it ensures that the LIE
+tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
+-- Just like tryTc, except that it ensures that the LIE
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
-tryTc thing_inside
- = do { ((errs, mb_r), lie) <- getLIE (tryM thing_inside) ;
+tryTcLIE thing_inside
+ = do { ((errs, mb_r), lie) <- getLIE (tryTc thing_inside) ;
ifM (isJust mb_r) (extendLIEs lie) ;
return (errs, mb_r) }
-tryTc_ :: TcM r -> TcM r -> TcM r
+tryTcLIE_ :: TcM r -> TcM r -> TcM r
-- (tryM_ r m) tries m; if it succeeds it returns it,
-- otherwise it returns r. Any error messages added by m are discarded,
-- whether or not m succeeds.
-tryTc_ recover main
- = do { (_msgs, mb_res) <- tryTc main ;
+tryTcLIE_ recover main
+ = do { (_msgs, mb_res) <- tryTcLIE main ;
case mb_res of
Just res -> return res
Nothing -> recover }
-- If so, it fails too.
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
- = do { (msgs, mb_res) <- tryTc main ;
+ = do { (msgs, mb_res) <- tryTcLIE main ;
addMessages msgs ;
case mb_res of
Just r -> return r
= do { us <- newUniqueSupply ;
unsafeInterleaveM $
do { us_var <- newMutVar us ;
- (msgs, mb_res) <- tryTc (setUsVar us_var thing_inside) ;
+ (msgs, mb_res) <- tryTcLIE (setUsVar us_var thing_inside) ;
case mb_res of
Just r -> return (Just r)
Nothing -> do {
thenM, thenM_, returnM, failM,
-- Non-standard operations
- runTcRn, fixM, recoverM, ioToTcRn,
+ runTcRn, fixM, tryM, ioToTcRn,
newMutVar, readMutVar, writeMutVar,
getEnv, setEnv, updEnv, unsafeInterleaveM,
import FIX_IO ( fixIO )
import Maybe ( mapMaybe )
import List ( nub )
+import Control.Exception as Exception ( try, Exception )
\end{code}
Error recovery
\begin{code}
-recoverM :: TcRn m r -- Recovery action; do this if the main one fails
- -> TcRn m r -- Main action: do this first
- -> TcRn m r
-recoverM (TcRn recover) (TcRn m)
- = TcRn (\ env -> catch (m env) (\ _ -> recover env))
+tryM :: TcRn m r -> TcRn m (Either Exception.Exception r)
+-- Reflect exception into TcRn monad
+tryM (TcRn thing) = TcRn (\ env -> Exception.try (thing env))
\end{code}
Lazy interleave
import NameSet ( NameSet, mkNameSet, elemNameSet )
import Class ( classBigSig )
import FunDeps ( oclose, grow, improve, pprEquationDoc )
-import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass,
- splitName, fstName, sndName )
+import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
+import PrelNames ( splitName, fstName, sndName )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy, pairTyCon )
= failM
try_default (default_ty : default_tys)
- = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
+ = tryTcLIE_ (try_default default_tys) $ -- If default_ty fails, we try
-- default_tys instead
tcSimplifyDefault theta `thenM` \ _ ->
returnM default_ty
where
theta = [mkClassPred clas [default_ty] | clas <- classes]
in
- -- See if any default works, and if so bind the type variable to it
- -- If not, add an AmbigErr
- recoverM (addAmbigErrs dicts `thenM_`
- returnM EmptyMonoBinds) $
+ -- See if any default works
+ tryM (try_default default_tys) `thenM` \ mb_ty ->
+ case mb_ty of {
+ Left _ -> -- If not, add an AmbigErr
+ addAmbigErrs dicts `thenM_`
+ returnM EmptyMonoBinds ;
- try_default default_tys `thenM` \ chosen_default_ty ->
+ Right chosen_default_ty ->
- -- Bind the type variable and reduce the context, for real this time
+ -- If so, bind the type variable
+ -- and reduce the context, for real this time
unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenM_`
simpleReduceLoop (text "disambig" <+> ppr dicts)
reduceMe dicts `thenM` \ (frees, binds, ambigs) ->
WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs )
warnDefault dicts chosen_default_ty `thenM_`
- returnM binds
+ returnM binds }
| all isCreturnableClass classes
= -- Default CCall stuff to (); we don't even both to check that () is an
-> TcType.TcType
-> TcRnTypes.TcM TcHsSyn.TcExpr
+tcSpliceDecls :: RnHsSyn.RenamedHsExpr
+ -> TcRnTypes.TcM [RdrHsSyn.RdrNameHsDecl]
+
+tcBracket :: HsExpr.HsBracket Name.Name
+ -> TcRnTypes.TcM TcType.TcType
\ No newline at end of file
\section[TcSplice]{Template Haskell splices}
\begin{code}
-module TcSplice( tcSpliceExpr, tcSpliceDecls ) where
+module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where
#include "HsVersions.h"
import HscMain ( compileExpr )
-import TcRnDriver ( importSupportingDecls )
+import TcRnDriver ( importSupportingDecls, tcTopSrcDecls )
-- These imports are the reason that TcSplice
-- is very high up the module hierarchy
-import CompManager ( sandboxIO )
- -- Ditto, but this one could be defined muchlower down
-
import qualified Language.Haskell.THSyntax as Meta
import HscTypes ( HscEnv(..), GhciMode(..), PersistentCompilerState(..), unQualInScope )
+import HsSyn ( HsBracket(..) )
import Convert ( convertToHsExpr, convertToHsDecls )
import RnExpr ( rnExpr )
import RdrHsSyn ( RdrNameHsExpr, RdrNameHsDecl )
import TcExpr ( tcMonoExpr )
import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr )
import TcSimplify ( tcSimplifyTop )
-import TcType ( TcType )
+import TcType ( TcType, openTypeKind )
import TcEnv ( spliceOK, tcMetaTy )
import TcRnTypes ( TopEnv(..) )
+import TcMType ( newTyVarTy )
import Name ( Name )
import TcRnMonad
import TysWiredIn ( mkListTy )
-import PrelNames ( exprTyConName, declTyConName )
+import DsMeta ( exprTyConName, declTyConName )
import Outputable
import GHC.Base ( unsafeCoerce# ) -- Should have a better home in the module hierarchy
\end{code}
%************************************************************************
\begin{code}
+tcBracket :: HsBracket Name -> TcM TcType
+tcBracket (ExpBr expr)
+ = newTyVarTy openTypeKind `thenM` \ any_ty ->
+ tcMonoExpr expr any_ty `thenM_`
+ tcMetaTy exprTyConName
+
+tcBracket (DecBr decls)
+ = tcTopSrcDecls decls `thenM_`
+ tcMetaTy declTyConName `thenM` \ decl_ty ->
+ returnM (mkListTy decl_ty)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Splicing an expression}
+%* *
+%************************************************************************
+
+\begin{code}
tcSpliceExpr name expr res_ty
= getStage `thenM` \ level ->
case spliceOK level of {
decls :: [RdrNameHsDecl]
decls = convertToHsDecls simple_expr
in
+ traceTc (text "Got result" <+> vcat (map ppr decls)) `thenM_`
returnM decls
\end{code}
\begin{code}
runMetaE :: TypecheckedHsExpr -- Of type (Q Exp)
-> TcM Meta.Exp -- Of type Exp
-runMetaE e = runMeta e
+runMetaE e = runMeta tcRunQ e
-runMetaD :: TypecheckedHsExpr -- Of type (Q [Dec]
+runMetaD :: TypecheckedHsExpr -- Of type [Q Dec]
-> TcM [Meta.Dec] -- Of type [Dec]
-runMetaD e = runMeta e
+runMetaD e = runMeta run_decl e
+ where
+ run_decl :: [Meta.Decl] -> TcM [Meta.Dec]
+ run_decl ds = mappM tcRunQ ds
-runMeta :: TypecheckedHsExpr -- Of type (Q t)
+-- Warning: if Q is anything other than IO, we need to change this
+tcRunQ :: Meta.Q a -> TcM a
+tcRunQ thing = ioToTcRn thing
+
+
+runMeta :: (x -> TcM t) -- :: X -> IO t
+ -> TypecheckedHsExpr -- Of type X
-> TcM t -- Of type t
-runMeta expr :: TcM t
+runMeta run_it expr :: TcM t
= getTopEnv `thenM` \ top_env ->
getEps `thenM` \ eps ->
getNameCache `thenM` \ name_cache ->
-- enough information available to link all the things that
-- are needed when you try to run a splice
else
- ioToTcRn (do {
- -- Warning: if Q is anything other than IO, we may need to wrap
- -- the expression 'expr' in a runQ before compiling it
- hval <- HscMain.compileExpr hsc_env pcs this_mod print_unqual expr
- -- hval :: HValue
- -- Need to coerce it to IO t
- ; sandboxIO (unsafeCoerce# hval :: IO t) }) `thenM` \ either_tval ->
+ ioToTcRn (HscMain.compileExpr hsc_env pcs this_mod
+ print_unqual expr) `thenM` \ hval ->
+
+ tryM (run_it (unsafeCoerce# hval)) `thenM` \ either_tval ->
case either_tval of
- Left err -> failWithTc (vcat [text "Exception when running compiled-time code:",
- nest 4 (text (show err))])
- Right v -> returnM v
+ Left exn -> failWithTc (vcat [text "Exception when running compile-time code:",
+ nest 4 (vcat [text "Code:" <+> ppr expr,
+ text ("Exn: " ++ show exn)])])
+ Right v -> returnM v
\end{code}
projects / ghc-hetmet.git / commitdiff