Commit 8c1b6bd7 authored by simonpj's avatar simonpj

[project @ 2002-10-09 15:03:48 by simonpj]

-----------------------------------
	Lots more Template Haskell stuff
	-----------------------------------

At last!  Top-level declaration splices work!
Syntax is

	$(f x)

not "splice (f x)" as in the paper.

Lots jiggling around, particularly with the top-level plumbining.
Note the new data type HsDecls.HsGroup.
parent d04fb5dc
# -----------------------------------------------------------------------------
# $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 = ..
......@@ -137,9 +137,9 @@ endif
# 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
......
......@@ -99,9 +99,11 @@ import Demand hiding( Demand, seqDemand )
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`,
......
......@@ -373,13 +373,21 @@ type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
-- 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))
......
......@@ -54,9 +54,6 @@ dsMonoBinds auto_scc (AndMonoBinds binds_1 binds_2) rest
= 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 ->
......
This diff is collapsed.
......@@ -40,8 +40,7 @@ import CoreSyn
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 )
......
......@@ -16,7 +16,7 @@ import HsSyn as Hs
( 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(..),
......@@ -41,11 +41,12 @@ import Outputable
-------------------------------------------------------------------
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)
......@@ -76,6 +77,8 @@ cvt_top (Instance tys ty decs)
(cvt_context tys)
(HsPredTy (cvt_pred ty))
cvt_top (Proto nm typ) = SigD (Sig (vName nm) (cvtType typ) loc0)
noContext = []
noExistentials = []
noFunDeps = []
......@@ -196,7 +199,7 @@ cvtp Pwild = WildPat void
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
......@@ -205,15 +208,23 @@ cvt_pred ty = case split_ty_app ty of
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 []
......@@ -226,12 +237,6 @@ sigP :: Dec -> Bool
sigP (Proto _ _) = True
sigP other = False
sigOrBindP :: Dec -> Bool
sigOrBindP (Proto _ _) = True
sigOrBindP (Val _ _ _) = True
sigOrBindP (Fun _ _) = True
sigOrBindP other = False
-----------------------------------------------------------
-- some useful things
......
......@@ -125,9 +125,6 @@ data MonoBinds id
| 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
......@@ -212,9 +209,6 @@ ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
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),
......
......@@ -9,13 +9,12 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
\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,
......@@ -68,17 +67,17 @@ import Maybe ( isNothing, fromJust )
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
......@@ -89,42 +88,63 @@ data HsDecl id
-- 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}
......
......@@ -9,7 +9,7 @@ module HsExpr where
#include "HsVersions.h"
-- friends:
import HsDecls ( HsDecl )
import HsDecls ( HsGroup )
import HsBinds ( HsBinds(..), nullBinds )
import HsPat ( Pat )
import HsLit ( HsLit, HsOverLit )
......@@ -670,7 +670,7 @@ pprComp brack stmts = brack $
\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
......@@ -679,7 +679,7 @@ 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)
......
......@@ -9,11 +9,9 @@ therefore, is almost nothing but re-exporting.
\begin{code}
module HsSyn (
-- NB: don't reexport HsCore
-- this module tells about "real Haskell"
module HsSyn,
module HsBinds,
module HsDecls,
module HsExpr,
......@@ -23,10 +21,11 @@ module HsSyn (
module HsTypes,
Fixity, NewOrData,
HsModule(..), hsModule, hsImports,
collectStmtsBinders,
collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders,
collectSigTysFromHsBinds, collectSigTysFromMonoBinds,
hsModule, hsImports
collectSigTysFromHsBinds, collectSigTysFromMonoBinds
) where
#include "HsVersions.h"
......@@ -151,6 +150,13 @@ collectMonoBinders binds
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
--
......@@ -22,7 +22,7 @@ import Finder ( findModuleDep )
import Util ( global )
import Panic
import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
import DATA_IOREF ( IORef, readIORef, writeIORef )
import EXCEPTION
import Directory
......
......@@ -41,9 +41,8 @@ import Lex ( ParseResult(..), ExtFlags(..), mkPState )
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
......
......@@ -34,7 +34,7 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
(" ImpAll ", import_all),
(" ImpPartial ", import_partial),
(" ImpHiding ", import_hiding),
("FixityDecls ", fixity_ds),
("FixityDecls ", fixity_sigs),
("DefaultDecls ", default_ds),
("TypeDecls ", type_ds),
("DataDecls ", data_ds),
......@@ -64,7 +64,8 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
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
......@@ -83,8 +84,8 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
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)
......@@ -95,12 +96,6 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
(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)
......@@ -110,13 +105,14 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
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)
......@@ -134,13 +130,13 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
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
......
This diff is collapsed.
This diff is collapsed.
......@@ -12,6 +12,7 @@ module PrelInfo (
wiredInThingEnv,
ghcPrimExports,
cCallableClassDecl, cReturnableClassDecl,
knownKeyNames,
-- Random other things
maybeCharLikeCon, maybeIntLikeCon,
......@@ -24,14 +25,22 @@ module PrelInfo (
#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 )
......@@ -40,7 +49,7 @@ import TysWiredIn ( wiredInTyCons )
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 )
......@@ -75,6 +84,13 @@ wiredInThings
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
......@@ -153,7 +169,7 @@ isCcallishClass, isCreturnableClass, isNoDictClass,
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}
This diff is collapsed.
......@@ -208,7 +208,7 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds
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
......
......@@ -40,10 +40,10 @@ import PrelNames ( mkUnboundName, intTyConName,
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
......
......@@ -28,6 +28,7 @@ import RdrHsSyn
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 )
......@@ -41,8 +42,10 @@ import PrelNames ( hasKey, assertIdKey,
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 )
......@@ -224,12 +227,14 @@ rnExpr (HsPar e)
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_`
......@@ -458,10 +463,16 @@ rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
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}
%************************************************************************
......
......@@ -38,7 +38,7 @@ import Name ( Name {-instance NamedThing-}, isWiredInName, isInternalName, name
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
......@@ -631,18 +631,16 @@ checkModUsage (mod_name, _, is_boot, whats_imported)
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
......
......@@ -16,7 +16,7 @@ import {-# SOURCE #-} RnHiFiles ( loadInterface )
import CmdLineOpts ( DynFlag(..) )
import HsSyn ( HsDecl(..), IE(..), ieName, ImportDecl(..),
ForeignDecl(..),
ForeignDecl(..), HsGroup(..),
collectLocatedHsBinders, tyClDeclNames
)
import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsDecl )
......@@ -39,7 +39,8 @@ import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
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 )
......@@ -127,13 +128,11 @@ importsFromImportDecl this_mod_name
-- 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
......@@ -205,15 +204,13 @@ created by its bindings.
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]
......@@ -283,35 +280,27 @@ files (@loadDecl@ calls @getTyClDeclBinders@).
*** 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 _)