Commit a9d4abde authored by sewardj's avatar sewardj
Browse files

[project @ 2000-10-17 10:27:58 by sewardj]

typechecker burbles
parent a180ee15
......@@ -11,7 +11,7 @@ module ErrUtils (
dontAddErrLoc,
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
ghcExit,
doIfSet, dumpIfSet
doIfSet, dumpIfSet, dumpIfSet_dyn
) where
#include "HsVersions.h"
......@@ -99,14 +99,21 @@ doIfSet flag action | flag = action
\end{code}
\begin{code}
dumpIfSet :: DynFlags -> (DynFlags -> Bool) -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
| not flag = return ()
| otherwise = printDump (dump hdr doc)
dumpIfSet_dyn :: DynFlags -> (DynFlags -> Bool) -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| not (flag dflags) = return ()
| otherwise = printDump dump
where
dump = vcat [text "",
line <+> text hdr <+> line,
doc,
text ""]
line = text (take 20 (repeat '='))
| otherwise = printDump (dump hdr doc)
dump hdr doc
= vcat [text "",
line <+> text hdr <+> line,
doc,
text ""]
where
line = text (take 20 (repeat '='))
\end{code}
......@@ -91,12 +91,29 @@ data ModDetails
md_rules :: RuleEnv -- Domain may include Ids from other modules
}
-- ModIFace is nearly the same as RnMonad.ParsedIface.
-- Right now it's identical :)
data ModIFace
= ModIFace {
mi_mod :: Module, -- Complete with package info
mi_vers :: Version, -- Module version number
mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
mi_usages :: [ImportVersion OccName], -- Usages
mi_exports :: [ExportItem], -- Exports
mi_insts :: [RdrNameInstDecl], -- Local instance declarations
mi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions
mi_fixity :: (Version, [RdrNameFixitySig]), -- Local fixity declarations,
-- with their version
mi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version
mi_deprecs :: [RdrNameDeprecation] -- Deprecations
}
\end{code}
\begin{code}
emptyModDetails :: Module -> ModDetails
emptyModDetails mod
= ModDetails { md_id = mod,
= ModDetails { md_module = mod,
md_exports = [],
md_globals = emptyRdrEnv,
md_fixities = emptyNameEnv,
......
......@@ -39,7 +39,7 @@ import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
import Class ( classTyVars, classBigSig, classSelIds, classTyCon, Class, ClassOpItem,
DefMeth (..) )
import Bag ( bagToList )
import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods, opt_PprStyle_Debug )
import CmdLineOpts ( dopt_GlasgowExts, opt_WarnMissingMethods, opt_PprStyle_Debug )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
import Id ( Id, idType, idName )
......@@ -105,7 +105,8 @@ tcClassDecl1 rec_env
tyvar_names fundeps class_sigs def_methods pragmas
sys_names src_loc)
= -- CHECK ARITY 1 FOR HASKELL 1.4
checkTc (opt_GlasgowExts || length tyvar_names == 1)
doptsTc dopt_GlasgowExts `thenTc` \ glaExts ->
checkTc (glaExts || length tyvar_names == 1)
(classArityErr class_name) `thenTc_`
-- LOOK THINGS UP IN THE ENVIRONMENT
......@@ -210,11 +211,12 @@ tcSuperClasses clas context sc_sel_names
-- only the type variable of the class decl.
-- For std Haskell check that the context constrains only tyvars
(if opt_GlasgowExts then
doptsTc dopt_GlasgowExts `thenTc` \ glaExts ->
(if glaExts then
returnTc ()
else
mapTc_ check_constraint context
) `thenTc_`
) `thenTc_`
-- Context is already kind-checked
tcClassContext context `thenTc` \ sc_theta ->
......@@ -576,7 +578,7 @@ mkDefMethRhs is_inst_decl clas inst_tys sel_id loc GenDefMeth
-- (checkTc, so False provokes the error)
checkTc (not is_inst_decl || simple_inst)
(badGenericInstance sel_id clas) `thenTc_`
ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenNF_Tc_`
returnTc rhs
where
......
......@@ -34,46 +34,48 @@ module TcEnv(
#include "HsVersions.h"
import TcMonad
import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
tcInstTyVars, zonkTcTyVars,
)
import Id ( mkUserLocal, isDataConWrapId_maybe )
import IdInfo ( vanillaIdInfo )
import MkId ( mkSpecPragmaId )
import Var ( TyVar, Id, setVarName,
idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
)
import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
tcInstTyVars, zonkTcTyVars,
)
import Id ( mkUserLocal, isDataConWrapId_maybe )
import IdInfo ( vanillaIdInfo )
import MkId ( mkSpecPragmaId )
import Var ( TyVar, Id, setVarName,
idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
)
import VarSet
import VarEnv ( TyVarSubstEnv )
import Type ( Kind, Type, superKind,
tyVarsOfType, tyVarsOfTypes,
splitForAllTys, splitRhoTy, splitFunTys,
splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
)
import DataCon ( DataCon )
import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
import Class ( Class, ClassOpItem, ClassContext, classTyCon )
import Subst ( substTy )
import Name ( Name, OccName, NamedThing(..),
nameOccName, nameModule, getSrcLoc, mkGlobalName,
isLocallyDefined,
NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
extendNameEnv, extendNameEnvList
)
import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
import Module ( Module )
import Unify ( unifyTyListsX, matchTys )
import HscTypes ( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
GlobalSymbolTable, Provenance(..) )
import Unique ( pprUnique10, Unique, Uniquable(..) )
import VarEnv ( TyVarSubstEnv )
import Type ( Kind, Type, superKind,
tyVarsOfType, tyVarsOfTypes,
splitForAllTys, splitRhoTy, splitFunTys,
splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
)
import DataCon ( DataCon )
import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
import Class ( Class, ClassOpItem, ClassContext, classTyCon )
import Subst ( substTy )
import Name ( Name, OccName, NamedThing(..),
nameOccName, nameModule, getSrcLoc, mkGlobalName,
isLocallyDefined,
NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
extendNameEnv, extendNameEnvList
)
import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
import Module ( Module )
import Unify ( unifyTyListsX, matchTys )
import HscTypes ( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
GlobalSymbolTable, Provenance(..) )
import Unique ( pprUnique10, Unique, Uniquable(..) )
import UniqFM
import Unique ( Uniquable(..) )
import Util ( zipEqual, zipWith3Equal, mapAccumL )
import SrcLoc ( SrcLoc )
import Unique ( Uniquable(..) )
import Util ( zipEqual, zipWith3Equal, mapAccumL )
import SrcLoc ( SrcLoc )
import FastString ( FastString )
import Maybes
import Outputable
import IOExts ( newIORef )
import TcInstUtil ( emptyInstEnv )
import IOExts ( newIORef )
\end{code}
%************************************************************************
......@@ -142,7 +144,7 @@ data TcTyThing
-- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
initTcEnv :: GlobalSymbolTable -> IO TcEnv
initTcEnv gst inst_env
initTcEnv gst
= do { gtv_var <- newIORef emptyVarSet ;
return (TcEnv { tcGST = gst,
tcGEnv = emptyNameEnv,
......
......@@ -21,13 +21,14 @@ module TcMonad(
listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
failTc, failWithTc, addErrTc, addErrsTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
failTc, failWithTc, addErrTc, addErrsTc, warnTc,
recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
addErrTcM, addInstErrTcM, failWithTcM,
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
tcGetUnique, tcGetUniques, tcGetDFunUniq,
doptsTc,
doptsTc, getDOptsTc,
tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
tcAddErrCtxtM, tcSetErrCtxtM,
......@@ -112,9 +113,6 @@ type TcKind = TcType
\begin{code}
type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
-- ToDo: nuke the 's' part
-- The difference between the two is
-- now for documentation purposes only
type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
-- Used only in this file for type signatures which
......@@ -641,6 +639,10 @@ addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
doptsTc :: (DynFlags -> Bool) -> TcM Bool
doptsTc dopt (TcDown{tc_dflags=dflags}) env_down
= return (dopt dflags)
getDOptsTc :: TcM DynFlags
getDOptsTc (TcDown{tc_dflags=dflags}) env_down
= return dflags
\end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment