Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
a9d4abde
Commit
a9d4abde
authored
Oct 17, 2000
by
sewardj
Browse files
[project @ 2000-10-17 10:27:58 by sewardj]
typechecker burbles
parent
a180ee15
Changes
5
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/main/ErrUtils.lhs
View file @
a9d4abde
...
...
@@ -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}
ghc/compiler/main/HscTypes.lhs
View file @
a9d4abde
...
...
@@ -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,
...
...
ghc/compiler/typecheck/TcClassDcl.lhs
View file @
a9d4abde
...
...
@@ -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 (
d
opt_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
...
...
ghc/compiler/typecheck/TcEnv.lhs
View file @
a9d4abde
...
...
@@ -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,
...
...
ghc/compiler/typecheck/TcMonad.lhs
View file @
a9d4abde
...
...
@@ -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}
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment