From c271b64780a6504e7ccd4cc422dfc90678ea966f Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 20 Nov 2000 14:48:59 +0000 Subject: [PATCH] [project @ 2000-11-20 14:48:52 by simonpj] When renaming, typechecking an expression from the user interface, we may suck in declarations from interface files (e.g. the Prelude). This commit takes account of that. To do so, I did some significant restructuring in TcModule, with consequential changes and tidy ups elsewhere in the type checker. I think there should be fewer lines in total than before. --- ghc/compiler/compMan/CmLink.lhs | 2 + ghc/compiler/compMan/CompManager.lhs | 17 ++- ghc/compiler/coreSyn/CoreFVs.lhs | 2 +- ghc/compiler/coreSyn/CoreUtils.lhs | 6 +- ghc/compiler/coreSyn/PprCore.lhs | 2 +- ghc/compiler/hsSyn/HsDecls.lhs | 1 - ghc/compiler/main/HscMain.lhs | 28 ++-- ghc/compiler/main/HscTypes.lhs | 19 ++- ghc/compiler/main/Interpreter.hs | 15 +- ghc/compiler/prelude/PrelInfo.lhs | 22 +-- ghc/compiler/prelude/TysWiredIn.lhs | 3 +- ghc/compiler/rename/Rename.lhs | 14 +- ghc/compiler/typecheck/TcClassDcl.lhs | 42 +----- ghc/compiler/typecheck/TcEnv.lhs | 30 ++-- ghc/compiler/typecheck/TcHsSyn.lhs | 10 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 12 +- ghc/compiler/typecheck/TcInstDcls.lhs | 3 +- ghc/compiler/typecheck/TcModule.lhs | 235 +++++++++++++++++-------------- ghc/compiler/typecheck/TcRules.lhs | 32 +++-- ghc/compiler/typecheck/TcTyClsDecls.lhs | 66 +++++---- ghc/compiler/typecheck/TcTyDecls.lhs | 122 +++++++--------- ghc/compiler/types/TyCon.lhs | 16 ++- ghc/compiler/types/TypeRep.lhs | 17 +-- ghc/compiler/utils/StringBuffer.lhs | 4 + 24 files changed, 362 insertions(+), 358 deletions(-) diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index cb3956b..247d2f5 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -12,7 +12,9 @@ module CmLink ( Linkable(..), Unlinked(..), link, unload, PersistentLinkerState{-abstractly!-}, emptyPLS, +#ifdef GHCI linkExpr +#endif ) where diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index a853f1f..9e78ee0 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -5,7 +5,9 @@ \begin{code} module CompManager ( cmInit, cmLoadModule, +#ifdef GHCI cmGetExpr, cmRunExpr, +#endif CmState, emptyCmState -- abstract ) where @@ -15,8 +17,6 @@ where import CmLink import CmTypes import HscTypes -import HscMain ( hscExpr ) -import Interpreter ( HValue ) import Module ( ModuleName, moduleName, isModuleInThisPackage, moduleEnvElts, moduleNameUserString ) @@ -26,7 +26,6 @@ import GetImports import HscTypes ( HomeSymbolTable, HomeIfaceTable, PersistentCompilerState, ModDetails(..) ) import Name ( lookupNameEnv ) -import RdrName import Module import PrelNames ( mainName ) import HscMain ( initPersistentCompilerState ) @@ -36,11 +35,18 @@ import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM, import Unique ( Uniquable ) import Digraph ( SCC(..), stronglyConnComp ) import DriverUtil ( BarfKind(..), splitFilename3 ) -import CmdLineOpts ( DynFlags ) import Util import Outputable import Panic ( panic ) +#ifdef GHCI +import CmdLineOpts ( DynFlags ) +import Interpreter ( HValue ) +import HscMain ( hscExpr ) +import RdrName +import PrelGHC ( unsafeCoerce# ) +#endif + -- lang import Exception ( throwDyn ) @@ -50,7 +56,6 @@ import Directory ( getModificationTime, doesFileExist ) import IO import List ( nub ) import Maybe ( catMaybes, fromMaybe, isJust ) -import PrelGHC ( unsafeCoerce# ) \end{code} @@ -59,6 +64,7 @@ cmInit :: PackageConfigInfo -> GhciMode -> IO CmState cmInit raw_package_info gmode = emptyCmState raw_package_info gmode +#ifdef GHCI cmGetExpr :: CmState -> DynFlags -> ModuleName @@ -83,6 +89,7 @@ cmRunExpr :: HValue -> IO () cmRunExpr hval = do unsafeCoerce# hval :: IO () -- putStrLn "done." +#endif -- Persistent state just for CM, excluding link & compile subsystems data PersistentCMState diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index fc0d7bd..f0da707 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -18,7 +18,7 @@ module CoreFVs ( #include "HsVersions.h" import CoreSyn -import Id ( Id, idName, idType, isLocalId, hasNoBinding, idSpecialisation ) +import Id ( Id, idType, isLocalId, hasNoBinding, idSpecialisation ) import VarSet import Var ( Var, isId ) import Type ( tyVarsOfType ) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index b5e7133..6babe48 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -54,10 +54,8 @@ import IdInfo ( LBVarInfo(..), IdFlavour(..), megaSeqIdInfo ) import Demand ( appIsBottom ) -import Type ( Type, mkFunTy, mkForAllTy, - splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes, - applyTys, isUnLiftedType, seqType, - mkUTy +import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, + applyTys, isUnLiftedType, seqType, mkUTy ) import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index e195c53..22de1fc 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -27,7 +27,7 @@ import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo, specInfo, cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, - cprInfo, ppCprInfo, lbvarInfo, + cprInfo, ppCprInfo, workerInfo, ppWorkerInfo, tyGenInfo, ppTyGenInfo ) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index db29d44..7fe9bf4 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -282,7 +282,6 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where (==) _ _ = False -- default case - eq_hsFD env (ns1,ms1) (ns2,ms2) = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 6ebecc8..f256d08 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -9,17 +9,18 @@ module HscMain ( HscResult(..), hscMain, hscExpr, #include "HsVersions.h" -import Maybe ( isJust ) -import IO ( hPutStrLn, stderr ) +#ifdef GHCI +import RdrHsSyn ( RdrNameHsExpr ) +import CoreToStg ( coreToStgExpr ) +import StringBuffer ( stringToStringBuffer, freeStringBuffer ) +#endif + import HsSyn -import StringBuffer ( hGetStringBuffer, - stringToStringBuffer, freeStringBuffer ) +import StringBuffer ( hGetStringBuffer ) import Parser -import RdrHsSyn ( RdrNameHsExpr ) import Lex ( PState(..), ParseResult(..) ) import SrcLoc ( mkSrcLoc ) - import Rename import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) @@ -33,7 +34,7 @@ import SimplCore import OccurAnal ( occurAnalyseBinds ) import CoreUtils ( coreBindsSize ) import CoreTidy ( tidyCorePgm ) -import CoreToStg ( topCoreBindsToStg, coreToStgExpr ) +import CoreToStg ( topCoreBindsToStg ) import StgSyn ( collectFinalStgBinders ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) @@ -47,7 +48,7 @@ import UniqSupply ( mkSplitUniqSupply ) import Bag ( emptyBag ) import Outputable -import Interpreter +import Interpreter ( stgBindsToInterpSyn, UnlinkedIExpr, UnlinkedIBind, ItblEnv ) import CmStaticInfo ( GhciMode(..) ) import HscStats ( ppSourceStats ) import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), @@ -62,6 +63,8 @@ import Name ( emptyNameEnv ) import Module ( Module, lookupModuleEnvByName ) import Monad ( when ) +import Maybe ( isJust ) +import IO ( hPutStrLn, stderr ) \end{code} @@ -131,7 +134,6 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch | otherwise = do { hPutStrLn stderr "COMPILATION NOT REQUIRED"; - let this_mod = mi_module old_iface ; -- CLOSURE (pcs_cl, closure_errs, cl_hs_decls) @@ -391,6 +393,11 @@ hscExpr -> String -- The expression -> IO ( PersistentCompilerState, Maybe UnlinkedIExpr ) +#ifndef GHCI +hscExpr dflags hst hit pcs this_module expr + = panic "hscExpr: non-interactive build" +#else + hscExpr dflags hst hit pcs0 this_module expr = do { -- Parse it maybe_parsed <- hscParseExpr dflags expr; @@ -406,7 +413,7 @@ hscExpr dflags hst hit pcs0 this_module expr Just (print_unqual, rn_expr) -> do { -- Typecheck it - maybe_tc_expr <- typecheckExpr dflags pcs1 hst print_unqual rn_expr; + maybe_tc_expr <- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr; case maybe_tc_expr of Nothing -> return (pcs1, Nothing) Just tc_expr -> do { @@ -460,6 +467,7 @@ hscParseExpr dflags str return (Just rdr_expr) }} +#endif \end{code} %************************************************************************ diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index c630078..c60c575 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -17,7 +17,7 @@ module HscTypes ( VersionInfo(..), initialVersionInfo, - TyThing(..), isTyClThing, + TyThing(..), isTyClThing, implicitTyThingIds, TypeEnv, lookupType, mkTypeEnv, extendTypeEnvList, typeEnvClasses, typeEnvTyCons, @@ -54,8 +54,9 @@ import Module ( Module, ModuleName, ModuleEnv, import InstEnv ( InstEnv, ClsInstEnv, DFunId ) import Rules ( RuleBase ) import Id ( Id ) -import Class ( Class ) -import TyCon ( TyCon ) +import Class ( Class, classSelIds ) +import TyCon ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable ) +import DataCon ( dataConId, dataConWrapId ) import BasicTypes ( Version, initialVersion, Fixity ) @@ -259,6 +260,18 @@ instance NamedThing TyThing where typeEnvClasses env = [cl | AClass cl <- nameEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env] +implicitTyThingIds :: [TyThing] -> [Id] +-- Add the implicit data cons and selectors etc +implicitTyThingIds things + = concat (map go things) + where + go (AnId f) = [] + go (AClass cl) = classSelIds cl + go (ATyCon tc) = tyConGenIds tc ++ + tyConSelIds tc ++ + [ n | dc <- tyConDataConsIfAvailable tc, + n <- [dataConId dc, dataConWrapId dc] ] + -- Synonyms return empty list of constructors and selectors \end{code} diff --git a/ghc/compiler/main/Interpreter.hs b/ghc/compiler/main/Interpreter.hs index 52efc34..af1d952 100644 --- a/ghc/compiler/main/Interpreter.hs +++ b/ghc/compiler/main/Interpreter.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Interpreter.hs,v 1.6 2000/11/20 14:26:27 simonmar Exp $ +-- $Id: Interpreter.hs,v 1.7 2000/11/20 14:48:54 simonpj Exp $ -- -- Interpreter subsystem wrapper -- @@ -16,7 +16,7 @@ module Interpreter ( ClosureEnv, emptyClosureEnv, ItblEnv, emptyItblEnv, linkIModules, - stgToInterpSyn, + stgToInterpSyn, stgBindsToInterpSyn, HValue, UnlinkedIBind, UnlinkedIExpr, loadObjs, resolveObjs, @@ -55,9 +55,10 @@ data UnlinkedIExpr = UnlinkedIExpr instance Outputable UnlinkedIBind where ppr x = text "Can't output UnlinkedIBind" -linkIModules = error "linkIModules" -stgToInterpSyn = error "linkIModules" -loadObjs = error "loadObjs" -resolveObjs = error "loadObjs" -interactiveUI = error "interactiveUI" +linkIModules = error "linkIModules" +stgToInterpSyn = error "stgToInterpSyn" +stgBindsToInterpSyn = error "stgBindsToInterpSyn" +loadObjs = error "loadObjs" +resolveObjs = error "loadObjs" +interactiveUI = error "interactiveUI" #endif diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index f1a64ed..34e049f 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -32,15 +32,14 @@ module PrelInfo ( import PrelNames -- Prelude module names import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName ) -import DataCon ( DataCon, dataConId, dataConWrapId ) +import DataCon ( DataCon ) import MkId ( mkPrimOpId, wiredInIds ) import MkId -- All of it, for re-export import TysPrim ( primTyCons ) import TysWiredIn ( wiredInTyCons ) -import HscTypes ( TyThing(..), TypeEnv, mkTypeEnv ) +import HscTypes ( TyThing(..), implicitTyThingIds, TypeEnv, mkTypeEnv ) -- others: -import TyCon ( tyConDataConsIfAvailable, tyConGenIds, TyCon ) import Class ( Class, classKey ) import Type ( funTyCon ) import Util ( isIn ) @@ -59,8 +58,9 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and wiredInThings :: [TyThing] wiredInThings = concat - [ -- Wired in TyCons - concat (map wiredInTyConThings ([funTyCon] ++ primTyCons ++ wiredInTyCons)) + [ -- Wired in TyCons and their implicit Ids + tycon_things + , map AnId (implicitTyThingIds tycon_things) -- Wired in Ids , map AnId wiredInIds @@ -68,16 +68,8 @@ wiredInThings -- PrimOps , map (AnId . mkPrimOpId) allThePrimOps ] - -wiredInTyConThings :: TyCon -> [TyThing] --- This is a bit of a cheat (c.f. TcTyDecls.mkImplicitDataBinds --- It assumes that wired in tycons have no record selectors -wiredInTyConThings tc - = [ATyCon tc] - ++ [ AnId i | i <- tyConGenIds tc ] - ++ [ AnId n | dc <- tyConDataConsIfAvailable tc, - n <- [dataConId dc, dataConWrapId dc] ] - -- Synonyms return empty list of constructors + where + tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons) wiredInThingEnv :: TypeEnv wiredInThingEnv = mkTypeEnv wiredInThings diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index cd2c6eb..c63d3e1 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -168,7 +168,8 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons [] -- No context argvrcs cons - (length cons) + (length cons) + [] -- No record selectors new_or_data is_rec gen_info diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index afc43b6..fefa9dc 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -101,7 +101,7 @@ renameExpr :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsExpr - -> IO (PersistentCompilerState, Maybe (PrintUnqualified, RenamedHsExpr)) + -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (RenamedHsExpr, [RenamedHsDecl]))) renameExpr dflags hit hst pcs this_module expr | Just iface <- lookupModuleEnv hit this_module @@ -109,13 +109,11 @@ renameExpr dflags hit hst pcs this_module expr ; let print_unqual = unQualInScope rdr_env ; renameSource dflags hit hst pcs this_module $ - initRnMS rdr_env emptyLocalFixityEnv SourceMode $ - ( rnExpr expr `thenRn` \ (e,_) -> - - doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> - ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e)) `thenRn_` - - returnRn (Just (print_unqual, e))) + initRnMS rdr_env emptyLocalFixityEnv SourceMode (rnExpr expr) `thenRn` \ (e,fvs) -> + closeDecls [] fvs `thenRn` \ decls -> + doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> + ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e)) `thenRn_` + returnRn (Just (print_unqual, (e, decls))) } | otherwise diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 5d30b11..dcc4882 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -4,13 +4,13 @@ \section[TcClassDcl]{Typechecking class declarations} \begin{code} -module TcClassDcl ( tcClassDecl1, tcClassDecls2, mkImplicitClassBinds, +module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), +import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsExpr(..), HsLit(..), HsType(..), HsPred(..), mkSimpleMatch, andMonoBinds, andMonoBindList, isClassDecl, isClassOpSig, isPragSig, @@ -19,10 +19,10 @@ import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) import RnHsSyn ( RenamedTyClDecl, RenamedClassOpSig, RenamedMonoBinds, - RenamedContext, RenamedHsDecl, RenamedSig, + RenamedContext, RenamedSig, maybeGenericMatch ) -import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) +import TcHsSyn ( TcMonoBinds ) import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) @@ -37,7 +37,7 @@ import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars ) import TcMonad import Generics ( mkGenericRhs, validGenericMethodType ) import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) -import Class ( classTyVars, classBigSig, classSelIds, classTyCon, +import Class ( classTyVars, classBigSig, classTyCon, Class, ClassOpItem, DefMeth (..) ) import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) import DataCon ( mkDataCon, notMarkedStrict ) @@ -294,34 +294,6 @@ tcClassSig is_rec unf_env clas clas_tyvars dm_info %************************************************************************ %* * -\subsection[ClassDcl-pass2]{Class decls pass 2: default methods} -%* * -%************************************************************************ - -@mkImplicitClassBinds@ produces a binding for the selector function for each method -and superclass dictionary. - -\begin{code} -mkImplicitClassBinds :: Module -> [Class] -> NF_TcM ([Id], TcMonoBinds) -mkImplicitClassBinds this_mod classes - = returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s) - -- The selector binds are already in the selector Id's unfoldings - -- We don't return the data constructor etc from the class, - -- because that's done via the class's TyCon - where - (cls_ids_s, binds_s) = unzip (map mk_implicit classes) - - mk_implicit clas = (sel_ids, binds) - where - sel_ids = classSelIds clas - binds | isFrom this_mod clas = idsToMonoBinds sel_ids - | otherwise = EmptyMonoBinds -\end{code} - - - -%************************************************************************ -%* * \subsection[Default methods]{Default methods} %* * %************************************************************************ @@ -385,12 +357,12 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to each local class decl. \begin{code} -tcClassDecls2 :: Module -> [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds) +tcClassDecls2 :: Module -> [RenamedTyClDecl] -> NF_TcM (LIE, TcMonoBinds) tcClassDecls2 this_mod decls = foldr combine (returnNF_Tc (emptyLIE, EmptyMonoBinds)) - [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, + [tcClassDecl2 cls_decl | cls_decl <- decls, isClassDecl cls_decl, isFrom this_mod (tyClDeclName cls_decl)] where diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index feb9442..ae1f4e6 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -27,7 +27,7 @@ module TcEnv( tcGetGlobalTyVars, tcExtendGlobalTyVars, -- Random useful things - RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcInstId, + RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe, tcInstId, -- New Ids newLocalId, newSpecPragmaId, @@ -165,7 +165,7 @@ getTcGEnv (TcEnv { tcGEnv = genv }) = genv -- This data type is used to help tie the knot -- when type checking type and class declarations data TyThingDetails = SynTyDetails Type - | DataTyDetails ClassContext [DataCon] + | DataTyDetails ClassContext [DataCon] [Id] | ClassDetails ClassContext [Id] [ClassOpItem] DataCon \end{code} @@ -205,16 +205,20 @@ tcAddImportedIdInfo env id = id `lazySetIdInfo` new_info -- The Id must be returned without a data dependency on maybe_id where - new_info = case tcLookupRecId env (idName id) of + new_info = case tcLookupRecId_maybe env (idName id) of Nothing -> constantIdInfo Just imported_id -> idInfo imported_id -- ToDo: could check that types are the same -tcLookupRecId :: RecTcEnv -> Name -> Maybe Id -tcLookupRecId env name = case lookup_global env name of - Just (AnId id) -> Just id - other -> Nothing +tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id +tcLookupRecId_maybe env name = case lookup_global env name of + Just (AnId id) -> Just id + other -> Nothing +tcLookupRecId :: RecTcEnv -> Name -> Id +tcLookupRecId env name = case lookup_global env name of + Just (AnId id) -> id + Nothing -> pprPanic "tcLookupRecId" (ppr name) \end{code} %************************************************************************ @@ -304,17 +308,21 @@ isLocalThing mod thing = case nameModule_maybe (getName thing) of %************************************************************************ \begin{code} -tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r -tcExtendGlobalEnv bindings thing_inside +tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r +tcExtendGlobalEnv things thing_inside = tcGetEnv `thenNF_Tc` \ env -> let - ge' = extendNameEnvList (tcGEnv env) bindings + ge' = extendNameEnvList (tcGEnv env) [(getName thing, thing) | thing <- things] in tcSetEnv (env {tcGEnv = ge'}) thing_inside tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a tcExtendGlobalValEnv ids thing_inside - = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside + = tcGetEnv `thenNF_Tc` \ env -> + let + ge' = extendNameEnvList (tcGEnv env) [(getName id, AnId id) | id <- ids] + in + tcSetEnv (env {tcGEnv = ge'}) thing_inside \end{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 6acef37..db82b24 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -24,7 +24,6 @@ module TcHsSyn ( mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsLet, - idsToMonoBinds, -- re-exported from TcEnv TcId, tcInstId, @@ -39,7 +38,7 @@ module TcHsSyn ( import HsSyn -- oodles of it -- others: -import Id ( idName, idType, isLocalId, idUnfolding, setIdType, isIP, Id ) +import Id ( idName, idType, isLocalId, setIdType, isIP, Id ) import DataCon ( dataConWrapId ) import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId, tcInstId @@ -49,7 +48,6 @@ import TcMonad import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars ) import CoreSyn ( Expr ) -import CoreUnfold( unfoldingTemplate ) import BasicTypes ( RecFlag(..) ) import Bag import Outputable @@ -118,12 +116,6 @@ mkHsLet EmptyMonoBinds expr = expr mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args - -idsToMonoBinds :: [Id] -> TcMonoBinds -idsToMonoBinds ids - = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id)) - | id <- ids - ] \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 58ed069..6a8e32f 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -8,7 +8,7 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), TyClDecl(..), HsTupCon(..) ) +import HsSyn ( TyClDecl(..), HsTupCon(..) ) import TcMonad import TcMonoType ( tcHsType ) -- NB: all the tyars in interface files are kinded, @@ -17,10 +17,10 @@ import TcMonoType ( tcHsType ) import TcEnv ( TcEnv, RecTcEnv, tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetEnv, - tcLookupGlobal_maybe, tcLookupRecId + tcLookupGlobal_maybe, tcLookupRecId_maybe ) -import RnHsSyn ( RenamedHsDecl ) +import RnHsSyn ( RenamedTyClDecl ) import HsCore import Literal ( Literal(..) ) import CoreSyn @@ -52,13 +52,13 @@ signatures. \begin{code} tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings - -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls + -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls -> TcM [Id] tcInterfaceSigs unf_env decls = listTc [ do_one name ty id_infos src_loc - | TyClD (IfaceSig name ty id_infos src_loc) <- decls] + | IfaceSig name ty id_infos src_loc <- decls] where in_scope_vars = [] -- I think this will be OK @@ -108,7 +108,7 @@ tcWorkerInfo unf_env ty info worker_name = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn -> let -- Watch out! We can't pull on unf_env too eagerly! - info' = case tcLookupRecId unf_env worker_name of + info' = case tcLookupRecId_maybe unf_env worker_name of Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) `setWorkerInfo` HasWorker worker_id arity diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index f8ec304..841988d 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -167,11 +167,10 @@ tcInstDecls1 :: PackageInstEnv -> TcEnv -- Contains IdInfo for dfun ids -> (Name -> Maybe Fixity) -- for deriving Show and Read -> Module -- Module for deriving - -> [TyCon] -> [RenamedHsDecl] -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds) -tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls +tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls = let inst_decls = [inst_decl | InstD inst_decl <- decls] tycl_decls = [decl | TyClD decl <- decls] diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 256e5bb..660fe1c 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -11,9 +11,11 @@ module TcModule ( #include "HsVersions.h" import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug ) -import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..) ) +import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), + isIfaceRuleDecl, nullBinds, andMonoBindList + ) import HsTypes ( toHsType ) -import RnHsSyn ( RenamedHsDecl, RenamedHsExpr ) +import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr ) import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, TypecheckedForeignDecl, TypecheckedRuleDecl, zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet @@ -24,22 +26,20 @@ import TcMonad import TcType ( newTyVarTy ) import Inst ( plusLIE ) import TcBinds ( tcTopBinds ) -import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) +import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) import TcExpr ( tcMonoExpr ) import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, - tcEnvTyCons, tcEnvClasses, isLocalThing, - tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv + isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv ) -import TcRules ( tcRules ) +import TcRules ( tcIfaceRules, tcSourceRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) -import TcTyDecls ( mkImplicitDataBinds ) -import CoreUnfold ( unfoldingTemplate ) +import CoreUnfold ( unfoldingTemplate, hasUnfolding ) import Type ( funResultTy, splitForAllTys, openTypeKind ) import Bag ( isEmptyBag ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn, showPass ) @@ -55,8 +55,9 @@ import Outputable import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, PackageTypeEnv, DFunId, ModIface(..), TypeEnv, extendTypeEnvList, - TyThing(..), mkTypeEnv ) -import List ( partition ) + TyThing(..), implicitTyThingIds, + mkTypeEnv + ) \end{code} Outside-world interface: @@ -103,15 +104,25 @@ typecheckExpr :: DynFlags -> PersistentCompilerState -> HomeSymbolTable -> PrintUnqualified -- For error printing - -> RenamedHsExpr - -> IO (Maybe TypecheckedHsExpr) + -> Module + -> (RenamedHsExpr, -- The expression itself + [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files + -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr)) -typecheckExpr dflags pcs hst unqual expr +typecheckExpr dflags pcs hst unqual this_mod (expr, decls) = typecheck dflags pcs hst unqual $ + + tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) -> + ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules ) + + tcSetEnv env $ newTyVarTy openTypeKind `thenTc` \ ty -> tcMonoExpr expr ty `thenTc` \ (expr', lie) -> tcSimplifyTop lie `thenTc` \ binds -> - returnTc (mkHsLet binds expr') + returnTc (new_pcs, mkHsLet binds expr') + where + get_fixity :: Name -> Maybe Fixity + get_fixity n = pprPanic "typecheckExpr" (ppr n) --------------- typecheck :: DynFlags @@ -146,65 +157,9 @@ tcModule :: PersistentCompilerState -> TcM (PersistentCompilerState, TcResults) tcModule pcs hst get_fixity this_mod decls - = -- Type-check the type and class decls - fixTc (\ ~(unf_env, _, _, _, _) -> - -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas - -- which is done lazily [ie failure just drops the pragma - -- without having any global-failure effect]. - -- - -- unf_env is also used to get the pragama info - -- for imported dfuns and default methods - --- traceTc (text "Tc1") `thenNF_Tc_` - tcTyAndClassDecls unf_env decls `thenTc` \ env -> - tcSetEnv env $ - let - classes = tcEnvClasses env - tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes - in - - -- Typecheck the instance decls, includes deriving --- traceTc (text "Tc2") `thenNF_Tc_` - tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) - hst unf_env get_fixity this_mod - tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) -> - tcSetInstEnv inst_env $ - - -- Interface type signatures - -- We tie a knot so that the Ids read out of interfaces are in scope - -- when we read their pragmas. - -- What we rely on is that pragmas are typechecked lazily; if - -- any type errors are found (ie there's an inconsistency) - -- we silently discard the pragma - -- We must do this before mkImplicitDataBinds (which comes next), since - -- the latter looks up unpackCStringId, for example, which is usually - -- imported --- traceTc (text "Tc3") `thenNF_Tc_` - tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> - tcExtendGlobalValEnv sig_ids $ - - -- Create any necessary record selector Ids and their bindings - -- "Necessary" includes data and newtype declarations - -- We don't create bindings for dictionary constructors; - -- they are always fully applied, and the bindings are just there - -- to support partial applications - mkImplicitDataBinds this_mod tycons `thenTc` \ (data_ids, imp_data_binds) -> - mkImplicitClassBinds this_mod classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) -> - - -- Extend the global value environment with - -- (a) constructors - -- (b) record selectors - -- (c) class op selectors - -- (d) default-method ids... where? I can't see where these are - -- put into the envt, and I'm worried that the zonking phase - -- will find they aren't there and complain. - tcExtendGlobalValEnv data_ids $ - tcExtendGlobalValEnv cls_ids $ - tcGetEnv `thenTc` \ unf_env -> - returnTc (unf_env, new_pcs_insts, local_inst_info, deriv_binds, - imp_data_binds `AndMonoBinds` imp_cls_binds) - ) `thenTc` \ (env, new_pcs_insts, local_inst_info, deriv_binds, data_cls_binds) -> - + = -- Type-check the type and class decls, and all imported decls + tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) -> + tcSetEnv env $ -- Foreign import declarations next @@ -218,8 +173,8 @@ tcModule pcs hst get_fixity this_mod decls -- Value declarations next. -- We also typecheck any extra binds that came out of the "deriving" process --- traceTc (text "Tc5") `thenNF_Tc_` - tcTopBinds (get_binds decls `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) -> +-- traceTc (text "Tc5") `thenNF_Tc_` + tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) -> tcSetEnv env $ -- Foreign export declarations next @@ -228,11 +183,9 @@ tcModule pcs hst get_fixity this_mod decls -- Second pass over class and instance declarations, -- to compile the bindings themselves. --- traceTc (text "Tc7") `thenNF_Tc_` tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> --- traceTc (text "Tc8") `thenNF_Tc_` - tcClassDecls2 this_mod decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> - tcRules (pcs_rules pcs) this_mod decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) -> + tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> + tcSourceRules source_rules `thenNF_Tc` \ (lie_rules, more_local_rules) -> -- Deal with constant or ambiguous InstIds. How could -- there be ambiguous ones? They can only arise if a @@ -242,18 +195,17 @@ tcModule pcs hst get_fixity this_mod decls -- during the generalisation step.) let lie_alldecls = lie_valdecls `plusLIE` - lie_instdecls `plusLIE` - lie_clasdecls `plusLIE` - lie_fodecls `plusLIE` - lie_rules + lie_instdecls `plusLIE` + lie_clasdecls `plusLIE` + lie_fodecls `plusLIE` + lie_rules in tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. let - all_binds = data_cls_binds `AndMonoBinds` - val_binds `AndMonoBinds` + all_binds = val_binds `AndMonoBinds` inst_binds `AndMonoBinds` cls_dm_binds `AndMonoBinds` const_inst_binds `AndMonoBinds` @@ -264,38 +216,111 @@ tcModule pcs hst get_fixity this_mod decls tcSetEnv final_env $ -- zonkTopBinds puts all the top-level Ids into the tcGEnv zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' -> - zonkRules local_rules `thenNF_Tc` \ local_rules' -> + zonkRules more_local_rules `thenNF_Tc` \ more_local_rules' -> - let (local_things, imported_things) = partition (isLocalThing this_mod) - (nameEnvElts (getTcGEnv final_env)) - - local_type_env :: TypeEnv - local_type_env = mkTypeEnv local_things - - new_pte :: PackageTypeEnv - new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things - - final_pcs :: PersistentCompilerState - final_pcs = pcs { pcs_PTE = new_pte, - pcs_insts = new_pcs_insts, - pcs_rules = new_pcs_rules - } + let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env)) + + -- Create any necessary "implicit" bindings (data constructors etc) + -- Should we create bindings for dictionary constructors? + -- They are always fully applied, and the bindings are just there + -- to support partial applications. But it's easier to let them through. + implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf) + | id <- implicitTyThingIds local_things + , let unf = idUnfolding id + , hasUnfolding unf + ] + + local_type_env :: TypeEnv + local_type_env = mkTypeEnv local_things + + all_local_rules = local_rules ++ more_local_rules' in -- traceTc (text "Tc10") `thenNF_Tc_` - returnTc (final_pcs, + returnTc (new_pcs, TcResults { tc_env = local_type_env, - tc_binds = all_binds', + tc_binds = implicit_binds `AndMonoBinds` all_binds', tc_insts = map iDFunId local_inst_info, tc_fords = foi_decls ++ foe_decls', - tc_rules = local_rules' + tc_rules = all_local_rules } ) - -get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] + where + tycl_decls = [d | TyClD d <- decls] + val_binds = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] + source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)] \end{code} +\begin{code} +tcImports :: PersistentCompilerState + -> HomeSymbolTable + -> (Name -> Maybe Fixity) + -> Module + -> [RenamedHsDecl] + -> TcM (TcEnv, PersistentCompilerState, + [InstInfo], RenamedHsBinds, [TypecheckedRuleDecl]) + +-- tcImports is a slight mis-nomer. +-- It deals with everythign that could be an import: +-- type and class decls +-- interface signatures +-- instance decls +-- rule decls +-- These can occur in source code too, of course + +tcImports pcs hst get_fixity this_mod decls + = fixTc (\ ~(unf_env, _, _, _, _) -> + -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas + -- which is done lazily [ie failure just drops the pragma + -- without having any global-failure effect]. + -- + -- unf_env is also used to get the pragama info + -- for imported dfuns and default methods + +-- traceTc (text "Tc1") `thenNF_Tc_` + tcTyAndClassDecls unf_env tycl_decls `thenTc` \ env -> + tcSetEnv env $ + + -- Typecheck the instance decls, includes deriving +-- traceTc (text "Tc2") `thenNF_Tc_` + tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) + hst unf_env get_fixity this_mod + decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) -> + tcSetInstEnv inst_env $ + + -- Interface type signatures + -- We tie a knot so that the Ids read out of interfaces are in scope + -- when we read their pragmas. + -- What we rely on is that pragmas are typechecked lazily; if + -- any type errors are found (ie there's an inconsistency) + -- we silently discard the pragma +-- traceTc (text "Tc3") `thenNF_Tc_` + tcInterfaceSigs unf_env tycl_decls `thenTc` \ sig_ids -> + tcExtendGlobalValEnv sig_ids $ + + + tcIfaceRules (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) -> + + tcGetEnv `thenTc` \ unf_env -> + let + imported_things = filter (not . isLocalThing this_mod) (nameEnvElts (getTcGEnv unf_env)) + + new_pte :: PackageTypeEnv + new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things + + new_pcs :: PersistentCompilerState + new_pcs = pcs { pcs_PTE = new_pte, + pcs_insts = new_pcs_insts, + pcs_rules = new_pcs_rules + } + in + returnTc (unf_env, new_pcs, local_inst_info, deriv_binds, local_rules) + ) + where + tycl_decls = [d | TyClD d <- decls] + iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d] +\end{code} %************************************************************************ %* * diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index da8fda7..6a2a0b3 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -4,13 +4,13 @@ \section[TcRules]{Typechecking transformation rules} \begin{code} -module TcRules ( tcRules ) where +module TcRules ( tcIfaceRules, tcSourceRules ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..) ) +import HsSyn ( RuleDecl(..), RuleBndr(..) ) import CoreSyn ( CoreRule(..) ) -import RnHsSyn ( RenamedHsDecl, RenamedRuleDecl ) +import RnHsSyn ( RenamedRuleDecl ) import HscTypes ( PackageRuleBase ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcMonad @@ -21,7 +21,7 @@ import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars ) import TcExpr ( tcExpr ) import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing ) import Rules ( extendRuleBase ) -import Inst ( LIE, emptyLIE, plusLIEs, instToId ) +import Inst ( LIE, plusLIEs, instToId ) import Id ( idType, idName, mkVanillaId ) import Module ( Module ) import VarSet @@ -32,15 +32,15 @@ import Outputable \end{code} \begin{code} -tcRules :: PackageRuleBase -> Module -> [RenamedHsDecl] - -> TcM (PackageRuleBase, LIE, [TypecheckedRuleDecl]) -tcRules pkg_rule_base mod decls - = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, new_rules) -> +tcIfaceRules :: PackageRuleBase -> Module -> [RenamedRuleDecl] + -> TcM (PackageRuleBase, [TypecheckedRuleDecl]) +tcIfaceRules pkg_rule_base mod decls + = mapTc tcIfaceRule decls `thenTc` \ new_rules -> let (local_rules, imported_rules) = partition is_local new_rules new_rule_base = foldl add pkg_rule_base imported_rules in - returnTc (new_rule_base, plusLIEs lies, local_rules) + returnTc (new_rule_base, local_rules) where add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule) @@ -49,18 +49,24 @@ tcRules pkg_rule_base mod decls is_local (IfaceRuleOut n _) = isLocalThing mod n is_local other = True -tcRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl) +tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl -- No zonking necessary! -tcRule (IfaceRule name vars fun args rhs src_loc) +tcIfaceRule (IfaceRule name vars fun args rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ tcVar fun `thenTc` \ fun' -> tcCoreLamBndrs vars $ \ vars' -> mapTc tcCoreExpr args `thenTc` \ args' -> tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs')) + returnTc (IfaceRuleOut fun' (Rule name vars' args' rhs')) -tcRule (HsRule name sig_tvs vars lhs rhs src_loc) + +tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl]) +tcSourceRules decls + = mapAndUnzipTc tcSourceRule decls `thenTc` \ (lies, decls') -> + returnTc (plusLIEs lies, decls') + +tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty -> diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 0698390..8d575da 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -11,19 +11,18 @@ module TcTyClsDecls ( #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) -import HsSyn ( HsDecl(..), TyClDecl(..), - HsTyVarBndr, - ConDecl(..), - Sig(..), HsPred(..), +import HsSyn ( TyClDecl(..), HsTyVarBndr, + ConDecl(..), Sig(..), HsPred(..), tyClDeclName, hsTyVarNames, isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig ) -import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, tyClDeclFVs ) +import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs ) import BasicTypes ( RecFlag(..), NewOrData(..), isRec ) +import HscTypes ( implicitTyThingIds ) import TcMonad import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..), - tcExtendKindEnv, tcLookup, tcExtendGlobalEnv ) + tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv ) import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep ) import TcClassDcl ( tcClassDecl1 ) import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars ) @@ -40,7 +39,7 @@ import DataCon ( isNullaryDataCon ) import Var ( varName ) import FiniteMap import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( Name, NamedThing(..), getSrcLoc, isTyVarName ) +import Name ( Name, getSrcLoc, isTyVarName ) import Name ( NameEnv, mkNameEnv, lookupNameEnv_NF ) import NameSet import Outputable @@ -61,7 +60,7 @@ The main function ~~~~~~~~~~~~~~~~~ \begin{code} tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff - -> [RenamedHsDecl] + -> [RenamedTyClDecl] -> TcM TcEnv tcTyAndClassDecls unf_env decls @@ -114,6 +113,10 @@ Step 6: tcTyClDecl1 again like whether a function argument is an unboxed tuple, looking through type synonyms properly. We can't do that in Step 5. +Step 7: Extend environment + We extend the type environment with bindings not only for the TyCons and Classes, + but also for their "implicit Ids" like data constructors and class selectors + The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. @@ -131,45 +134,50 @@ tcGroup unf_env scc zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds -> -- Tie the knot - fixTc ( \ ~(rec_details_list, _) -> + fixTc ( \ ~(rec_details_list, _, _) -> -- Step 4 let kind_env = mkNameEnv final_kinds rec_details = mkNameEnv rec_details_list - tyclss, all_tyclss :: [(Name, TyThing)] + tyclss, all_tyclss :: [TyThing] tyclss = map (buildTyConOrClass dflags is_rec kind_env rec_vrcs rec_details) decls -- Add the tycons that come from the classes -- We want them in the environment because -- they are mentioned in interface files - all_tyclss = [ (getName tycon, ATyCon tycon) | (_, AClass clas) <- tyclss, - let tycon = classTyCon clas - ] ++ tyclss + all_tyclss = [ ATyCon (classTyCon clas) | AClass clas <- tyclss] + ++ tyclss -- Calculate variances, and (yes!) feed back into buildTyConOrClass. - rec_vrcs = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss] + rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss] in -- Step 5 tcExtendGlobalEnv all_tyclss $ mapTc (tcTyClDecl1 is_rec unf_env) decls `thenTc` \ tycls_details -> -- Return results - tcGetEnv `thenNF_Tc` \ env -> - returnTc (tycls_details, env) - ) `thenTc` \ (_, env) -> + tcGetEnv `thenNF_Tc` \ env -> + returnTc (tycls_details, all_tyclss, env) + ) `thenTc` \ (_, all_tyclss, env) -> + + tcSetEnv env $ -- Step 6 -- For a recursive group, check all the types again, -- this time with the wimp flag off (if isRec is_rec then - tcSetEnv env (mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls) + mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls else returnTc () ) `thenTc_` - returnTc env + -- Step 7 + -- Extend the environment with the final TyCons/Classes + -- and their implicit Ids + tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) tcGetEnv + where is_rec = case scc of AcyclicSCC _ -> NonRecursive @@ -181,7 +189,7 @@ tcGroup unf_env scc tcTyClDecl1 is_rec unf_env decl | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl) - | otherwise = tcAddDeclCtxt decl (tcTyDecl1 is_rec decl) + | otherwise = tcAddDeclCtxt decl (tcTyDecl1 is_rec unf_env decl) \end{code} @@ -292,13 +300,11 @@ buildTyConOrClass :: DynFlags -> RecFlag -> NameEnv Kind -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails - -> RenamedTyClDecl -> (Name, TyThing) - -- Can't fail; the only reason it's in the monad - -- is so it can zonk the kinds + -> RenamedTyClDecl -> TyThing buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details (TySynonym tycon_name tyvar_names rhs src_loc) - = (tycon_name, ATyCon tycon) + = ATyCon tycon where tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs tycon_kind = lookupNameEnv_NF kenv tycon_name @@ -309,16 +315,16 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2) - = (tycon_name, ATyCon tycon) + = ATyCon tycon where tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs - data_cons nconstrs + data_cons nconstrs sel_ids flavour is_rec gen_info gen_info | not (dopt Opt_Generics dflags) = Nothing | otherwise = mkTyConGenInfo tycon name1 name2 - DataTyDetails ctxt data_cons = lookupNameEnv_NF rec_details tycon_name + DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name tycon_kind = lookupNameEnv_NF kenv tycon_name tyvars = mkTyClTyVars tycon_kind tyvar_names @@ -333,7 +339,7 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details (ClassDecl context class_name tyvar_names fundeps class_sigs def_methods name_list src_loc) - = (class_name, AClass clas) + = AClass clas where (tycon_name, _, _, _) = getClassDeclSysNames name_list clas = mkClass class_name tyvars fds @@ -376,7 +382,7 @@ bogusVrcs = panic "Bogus tycon arg variances" Dependency analysis ~~~~~~~~~~~~~~~~~~~ \begin{code} -sortByDependency :: [RenamedHsDecl] -> TcM [SCC RenamedTyClDecl] +sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl] sortByDependency decls = let -- CHECK FOR CLASS CYCLES cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls) @@ -397,7 +403,7 @@ sortByDependency decls in returnTc decl_sccs where - tycl_decls = [d | TyClD d <- decls, not (isIfaceSigDecl d)] + tycl_decls = filter (not . isIfaceSigDecl) decls edges = map mkEdges tycl_decls is_syn_decl (d, _, _) = isSynDecl d diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 7815057..45afd7b 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -5,44 +5,36 @@ \begin{code} module TcTyDecls ( - tcTyDecl1, - kcConDetails, - mkImplicitDataBinds, mkNewTyConRep + tcTyDecl1, kcConDetails, mkNewTyConRep ) where #include "HsVersions.h" -import HsSyn ( MonoBinds(..), - TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..), +import HsSyn ( TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..), getBangType, conDetailsTys ) import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) -import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) -import BasicTypes ( NewOrData(..), RecFlag ) +import BasicTypes ( NewOrData(..), RecFlag, isRec ) import TcMonoType ( tcHsRecType, tcHsTyVars, tcRecClassContext, kcHsContext, kcHsSigType, kcHsBoxedSigType ) import TcEnv ( tcExtendTyVarEnv, - tcLookupTyCon, tcLookupGlobalId, - TyThingDetails(..) + tcLookupTyCon, tcLookupRecId, + TyThingDetails(..), RecTcEnv ) import TcMonad import Class ( ClassContext ) -import DataCon ( DataCon, mkDataCon, - dataConFieldLabels, dataConId, dataConWrapId, - markedStrict, notMarkedStrict, markedUnboxed, dataConRepType +import DataCon ( DataCon, mkDataCon, dataConFieldLabels, markedStrict, + notMarkedStrict, markedUnboxed, dataConRepType ) import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId ) import FieldLabel -import Var ( Id, TyVar ) -import Module ( Module ) -import Name ( Name, NamedThing(..), isFrom ) +import Var ( TyVar ) +import Name ( Name, NamedThing(..) ) import Outputable -import TyCon ( TyCon, isSynTyCon, isNewTyCon, - tyConDataConsIfAvailable, tyConTyVars, tyConGenIds - ) +import TyCon ( TyCon, isNewTyCon, tyConTyVars ) import Type ( tyVarsOfTypes, splitFunTy, applyTys, mkTyConApp, mkTyVarTys, mkForAllTys, splitAlgTyConApp_maybe, Type @@ -60,8 +52,8 @@ import ListSetOps ( equivClasses ) %************************************************************************ \begin{code} -tcTyDecl1 :: RecFlag -> RenamedTyClDecl -> TcM (Name, TyThingDetails) -tcTyDecl1 is_rec (TySynonym tycon_name tyvar_names rhs src_loc) +tcTyDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails) +tcTyDecl1 is_rec unf_env (TySynonym tycon_name tyvar_names rhs src_loc) = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> tcExtendTyVarEnv (tyConTyVars tycon) $ tcHsRecType is_rec rhs `thenTc` \ rhs_ty -> @@ -79,7 +71,7 @@ tcTyDecl1 is_rec (TySynonym tycon_name tyvar_names rhs src_loc) returnTc (tycon_name, SynTyDetails rhs_ty) -tcTyDecl1 is_rec (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc name1 name2) +tcTyDecl1 is_rec unf_env (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc name1 name2) = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> let tyvars = tyConTyVars tycon @@ -89,7 +81,8 @@ tcTyDecl1 is_rec (TyData new_or_data context tycon_name _ con_decls _ derivings -- Typecheck the pieces tcRecClassContext is_rec context `thenTc` \ ctxt -> mapTc (tcConDecl is_rec new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons -> - returnTc (tycon_name, DataTyDetails ctxt data_cons) + tcRecordSelectors is_rec unf_env tycon data_cons `thenTc` \ sel_ids -> + returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids) \end{code} \begin{code} @@ -158,8 +151,8 @@ tcConDecl is_rec new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ let field_labels = concat field_labels_s arg_stricts = [str | (ns, bty) <- fields, - let str = getBangStrictness bty, - n <- ns -- One for each. E.g x,y,z :: !Int + let str = getBangStrictness bty, + n <- ns -- One for each. E.g x,y,z :: !Int ] in mk_data_con ex_tyvars ex_theta arg_stricts @@ -197,73 +190,54 @@ getBangStrictness (Unpacked _) = markedUnboxed \end{code} - %************************************************************************ %* * -\subsection{Generating constructor/selector bindings for data declarations} +\subsection{Record selectors} %* * %************************************************************************ \begin{code} -mkImplicitDataBinds :: Module -> [TyCon] -> TcM ([Id], TcMonoBinds) -mkImplicitDataBinds this_mod [] = returnTc ([], EmptyMonoBinds) -mkImplicitDataBinds this_mod (tycon : tycons) - | isSynTyCon tycon = mkImplicitDataBinds this_mod tycons - | otherwise = mkImplicitDataBinds_one this_mod tycon `thenTc` \ (ids1, b1) -> - mkImplicitDataBinds this_mod tycons `thenTc` \ (ids2, b2) -> - returnTc (ids1++ids2, b1 `AndMonoBinds` b2) - -mkImplicitDataBinds_one this_mod tycon - = mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids -> - let - unf_ids = sel_ids ++ data_con_wrapper_ids ++ gen_ids - all_ids = map dataConId data_cons ++ unf_ids - - -- For the locally-defined things - -- we need to turn the unfoldings inside the selector Ids into bindings, - -- and build bindigns for the constructor wrappers - binds | isFrom this_mod tycon = idsToMonoBinds unf_ids - | otherwise = EmptyMonoBinds - in - returnTc (all_ids, binds) +tcRecordSelectors is_rec unf_env tycon data_cons + = mapTc tc_group groups where - data_cons = tyConDataConsIfAvailable tycon - -- Abstract types mean we don't bring the - -- data cons into scope, which should be fine - gen_ids = tyConGenIds tycon - data_con_wrapper_ids = map dataConWrapId data_cons - fields = [ (con, field) | con <- data_cons, - field <- dataConFieldLabels con - ] + field <- dataConFieldLabels con ] -- groups is list of fields that share a common name groups = equivClasses cmp_name fields cmp_name (_, field1) (_, field2) = fieldLabelName field1 `compare` fieldLabelName field2 -\end{code} -\begin{code} -mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) - -- These fields all have the same name, but are from - -- different constructors in the data type - -- Check that all the fields in the group have the same type - -- This check assumes that all the constructors of a given - -- data type use the same type variables - = checkTc (all (== field_ty) other_tys) - (fieldTypeMisMatch field_name) `thenTc_` - tcLookupGlobalId unpackCStringName `thenTc` \ unpack_id -> - tcLookupGlobalId unpackCStringUtf8Name `thenTc` \ unpackUtf8_id -> - returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_id) - where - field_ty = fieldLabelType first_field_label - field_name = fieldLabelName first_field_label - other_tys = [fieldLabelType fl | (_, fl) <- other_fields] + tc_group fields@((first_con, first_field_label) : other_fields) + -- These fields all have the same name, but are from + -- different constructors in the data type + = -- Check that all the fields in the group have the same type + -- Wimp out (omit check) if the group is recursive; + -- TcTyClsDecls.tcGroup will repeat with NonRecursive once we + -- have tied the knot + -- NB: this check assumes that all the constructors of a given + -- data type use the same type variables + checkTc (not (isRec is_rec) && all (== field_ty) other_tys) + (fieldTypeMisMatch field_name) `thenTc_` + returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_id) + where + field_ty = fieldLabelType first_field_label + field_name = fieldLabelName first_field_label + other_tys = [fieldLabelType fl | (_, fl) <- other_fields] + + unpack_id = tcLookupRecId unf_env unpackCStringName + unpackUtf8_id = tcLookupRecId unf_env unpackCStringUtf8Name \end{code} -Errors and contexts -~~~~~~~~~~~~~~~~~~~ + +%************************************************************************ +%* * +\subsection{Errors and contexts} +%* * +%************************************************************************ + + \begin{code} fieldTypeMisMatch field_name = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)] diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index b5f0908..5592d00 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -29,8 +29,8 @@ module TyCon( tyConUnique, tyConTyVars, tyConArgVrcs_maybe, - tyConDataCons, tyConDataConsIfAvailable, - tyConFamilySize, + tyConDataCons, tyConDataConsIfAvailable, tyConFamilySize, + tyConSelIds, tyConTheta, tyConPrimRep, tyConArity, @@ -102,6 +102,8 @@ data TyCon -- (b) in a quest for fast compilation we don't import -- the constructors + selIds :: [Id], -- Its record selectors (if any) + noOfDataCons :: Int, -- Number of data constructors -- Usually this is the same as the length of the -- dataCons field, but the latter may be empty if @@ -238,7 +240,7 @@ tyConGenIds tycon = case tyConGenInfo tycon of -- This is the making of a TyCon. Just the same as the old mkAlgTyCon, -- but now you also have to pass in the generic information about the type -- constructor - you can get hold of it easily (see Generics module) -mkAlgTyCon name kind tyvars theta argvrcs cons ncons flavour rec +mkAlgTyCon name kind tyvars theta argvrcs cons ncons sels flavour rec gen_info = AlgTyCon { tyConName = name, @@ -249,6 +251,7 @@ mkAlgTyCon name kind tyvars theta argvrcs cons ncons flavour rec tyConArgVrcs = argvrcs, algTyConTheta = theta, dataCons = cons, + selIds = sels, noOfDataCons = ncons, algTyConClass = False, algTyConFlavour = flavour, @@ -266,6 +269,7 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour tyConArgVrcs = argvrcs, algTyConTheta = [], dataCons = [con], + selIds = [], noOfDataCons = 1, algTyConClass = True, algTyConFlavour = flavour, @@ -401,6 +405,12 @@ tyConFamilySize (TupleTyCon {}) = 1 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif +tyConSelIds :: TyCon -> [Id] +tyConSelIds (AlgTyCon {selIds = sels}) = sels +tyConSelIds other_tycon = [] +\end{code} + +\begin{code} tyConPrimRep :: TyCon -> PrimRep tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep tyConPrimRep _ = PtrRep diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 4ea6cba..a533cd5 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -32,14 +32,12 @@ import Var ( TyVar ) import VarEnv import VarSet -import Name ( Name, mkGlobalName, mkKindOccFS, tcName ) -import OccName ( tcName ) +import Name ( Name, tcName ) import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon ) import Class ( Class ) -- others -import SrcLoc ( builtinSrcLoc ) -import PrelNames ( pREL_GHC, superKindName, superBoxityName, boxedConName, +import PrelNames ( superKindName, superBoxityName, boxedConName, unboxedConName, typeConName, openKindConName, funTyConName, usageKindConName, usOnceTyConName, usManyTyConName ) @@ -228,14 +226,6 @@ in two situations: present in an inferred type. -\begin{code} -mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str) builtinSrcLoc - -- mk_kind_name is a bit of a hack - -- The LocalDef means that we print the name without - -- a qualifier, which is what we want for these kinds. - -- It's used for both Kinds and Boxities -\end{code} - ------------------------------------------ Define KX, the type of a kind BX, the type of a boxity @@ -305,8 +295,7 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] Usage tycons @.@ and @!@ The usage tycons are of kind usageTypeKind (`$'). The types contain -no values, and are used purely for usage annotation. mk_kind_name is -used (hackishly) to avoid z-encoding of the names. +no values, and are used purely for usage annotation. \begin{code} usOnceTyCon = mkKindCon usOnceTyConName usageTypeKind diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index eea0af2..d776c5f 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -13,8 +13,10 @@ module StringBuffer -- creation/destruction hGetStringBuffer, -- :: FilePath -> IO StringBuffer +#ifdef GHCI stringToStringBuffer, -- :: String -> IO StringBuffer freeStringBuffer, -- :: StringBuffer -> IO () +#endif -- Lookup currentChar, -- :: StringBuffer -> Char @@ -180,6 +182,7 @@ unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# = -- Turn a String into a StringBuffer \begin{code} +#ifdef GHCI stringToStringBuffer :: String -> IO StringBuffer stringToStringBuffer str = do let sz@(I# sz#) = length str + 1 @@ -195,6 +198,7 @@ stringToStringBuffer str = freeStringBuffer :: StringBuffer -> IO () freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr (A# a#)) +#endif \end{code} ----------------------------------------------------------------------------- -- 1.7.10.4