Permalink
Browse files

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

typechecker burbles
  • Loading branch information...
sewardj
sewardj committed Oct 17, 2000
1 parent a180ee1 commit a9d4abde339c30eeb7c7baf0a0edb13fa4a2eacd
@@ -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}

0 comments on commit a9d4abd

Please sign in to comment.