Commit 8e67f550 authored by simonpj's avatar simonpj

[project @ 2005-02-25 13:06:31 by simonpj]

---------------------------------------------
Type signatures are no longer instantiated with skolem constants
	---------------------------------------------

	Merge to STABLE

Consider

  p :: a
  q :: b
  (p,q,r) = (r,r,p)

Here, 'a' and 'b' end up being the same, because they are both bound
to the type for 'r', which is just a meta type variable.  So 'a' and 'b'
can't be skolems.

Sigh.  This commit goes back to an earlier way of doing things, by
arranging that type signatures get instantiated with *meta* type
variables; then at the end we must check that they have not been
unified with types, nor with each other.

This is a real bore.  I had to do quite a bit of related fiddling around
to make error messages come out right.  Improved one or two.

Also a small unrelated fix to make
	:i (:+)
print with parens in ghci.  Sorry this got mixed up in the same commit.
parent d9fd6a66
......@@ -515,6 +515,11 @@ utils/Binary_HC_OPTS += -O
utils/FastMutInt_HC_OPTS += -O
# ---- Profiling ----
#simplCore/Simplify_HC_OPTS = -auto-all
#simplCore/SimplEnv_HC_OPTS = -auto-all
#simplCore/SimplUtils_HC_OPTS = -auto-all
# CSE interacts badly with top-level IORefs (reportedly in DriverState and
# DriverMkDepend), causing some of them to be commoned up. We have a fix for
# this in 5.00+, but earlier versions of the compiler will need CSE turned off.
......
......@@ -103,7 +103,7 @@ import qualified Demand ( Demand )
import DataCon ( isUnboxedTupleCon )
import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig )
import Name ( Name, OccName, nameIsLocalOrFrom,
mkSystemName, mkSystemNameEncoded, mkInternalName,
mkSystemVarName, mkSystemVarNameEncoded, mkInternalName,
getOccName, getSrcLoc
)
import Module ( Module )
......@@ -168,10 +168,10 @@ mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
-- for SysLocal, we assume the base name is already encoded, to avoid
-- re-encoding the same string over and over again.
mkSysLocal fs uniq ty = mkLocalId (mkSystemNameEncoded uniq fs) ty
mkSysLocal fs uniq ty = mkLocalId (mkSystemVarNameEncoded uniq fs) ty
-- version to use when the faststring needs to be encoded
mkSysLocalUnencoded fs uniq ty = mkLocalId (mkSystemName uniq fs) ty
mkSysLocalUnencoded fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty
mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty
mkVanillaGlobal = mkGlobalId VanillaGlobal
......
......@@ -51,7 +51,7 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
tcSplitFunTys, tcSplitForAllTys
)
import CoreUtils ( exprType )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
......@@ -85,7 +85,6 @@ import CoreSyn
import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
import Maybes
import PrelNames
import Maybe ( isJust )
import Util ( dropList, isSingleton )
import Outputable
import FastString
......
......@@ -11,8 +11,8 @@ module Name (
-- The Name type
Name, -- Abstract
BuiltInSyntax(..),
mkInternalName, mkSystemName,
mkSystemNameEncoded, mkSysTvName,
mkInternalName, mkSystemName,
mkSystemVarName, mkSystemVarNameEncoded, mkSysTvName,
mkFCallName, mkIPName,
mkExternalName, mkWiredInName,
......@@ -206,21 +206,20 @@ mkWiredInName mod occ uniq mb_parent thing built_in
n_sort = WiredIn mod mb_parent thing built_in,
n_occ = occ, n_loc = wiredInSrcLoc }
mkSystemName :: Unique -> UserFS -> Name
mkSystemName uniq fs = Name { n_uniq = uniq, n_sort = System,
n_occ = mkVarOcc fs, n_loc = noSrcLoc }
mkSystemName :: Unique -> OccName -> Name
mkSystemName uniq occ = Name { n_uniq = uniq, n_sort = System,
n_occ = occ, n_loc = noSrcLoc }
mkSystemVarName :: Unique -> UserFS -> Name
mkSystemVarName uniq fs = mkSystemName uniq (mkVarOcc fs)
-- Use this version when the string is already encoded. Avoids duplicating
-- the string each time a new name is created.
mkSystemNameEncoded :: Unique -> EncodedFS -> Name
mkSystemNameEncoded uniq fs = Name { n_uniq = uniq, n_sort = System,
n_occ = mkSysOccFS varName fs,
n_loc = noSrcLoc }
mkSystemVarNameEncoded :: Unique -> EncodedFS -> Name
mkSystemVarNameEncoded uniq fs = mkSystemName uniq (mkSysOccFS varName fs)
mkSysTvName :: Unique -> EncodedFS -> Name
mkSysTvName uniq fs = Name { n_uniq = uniq, n_sort = System,
n_occ = mkSysOccFS tvName fs,
n_loc = noSrcLoc }
mkSysTvName uniq fs = mkSystemName uniq (mkSysOccFS tvName fs)
mkFCallName :: Unique -> EncodedString -> Name
-- The encoded string completely describes the ccall
......@@ -299,7 +298,6 @@ instance NamedThing Name where
\begin{code}
instance Outputable Name where
-- When printing interfaces, all Internals have been given nice print-names
ppr name = pprName name
instance OutputableBndr Name where
......
......@@ -35,7 +35,7 @@ module OccName (
mkDataConWrapperOcc, mkDataConWorkerOcc,
isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
reportIfUnused,
parenSymOcc, reportIfUnused,
occNameFS, occNameString, occNameUserString, occNameSpace,
occNameFlavour, briefOccNameFlavour,
......@@ -402,9 +402,15 @@ isDataOcc other = False
-- Any operator (data constructor or variable)
-- Pretty inefficient!
isSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
isSymOcc (OccName VarName s) = isLexSym (decodeFS s)
isSymOcc other = False
isSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
isSymOcc (OccName TcClsName s) = isLexConSym (decodeFS s)
isSymOcc (OccName VarName s) = isLexSym (decodeFS s)
isSymOcc other = False
parenSymOcc :: OccName -> SDoc -> SDoc
-- Wrap parens around an operator
parenSymOcc occ doc | isSymOcc occ = parens doc
| otherwise = doc
\end{code}
......
......@@ -61,8 +61,7 @@ import HscMain ( newHscEnv )
import DriverState ( v_Output_file, v_NoHsMain, v_MainModIs )
import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, isHaskellSrcFilename )
import Finder ( findModule, findLinkable, addHomeModuleToFinder,
flushFinderCache, findPackageModule,
mkHomeModLocation, FindResult(..), cantFindError )
flushFinderCache, mkHomeModLocation, FindResult(..), cantFindError )
import HscTypes ( ModSummary(..), HomeModInfo(..), ModIface(..), msHsFilePath,
HscEnv(..), GhciMode(..),
InteractiveContext(..), emptyInteractiveContext,
......@@ -78,17 +77,17 @@ import ErrUtils ( showPass )
import SysTools ( cleanTempFilesExcept )
import BasicTypes ( SuccessFlag(..), succeeded )
import StringBuffer ( hGetStringBuffer )
import Type ( dropForAlls )
import Util
import Outputable
import Panic
import CmdLineOpts ( DynFlags(..), dopt )
import CmdLineOpts ( DynFlags(..) )
import Maybes ( expectJust, orElse, mapCatMaybes )
import FiniteMap
import DATA_IOREF ( readIORef )
#ifdef GHCI
import Finder ( findPackageModule )
import HscMain ( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType )
import HscTypes ( TyThing(..), icPrintUnqual, showModMsg )
import TcRnDriver ( mkExportEnv, getModuleContents )
......@@ -97,13 +96,13 @@ import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
import Name ( Name )
import NameEnv
import Id ( idType )
import Type ( tidyType )
import Type ( tidyType, dropForAlls )
import VarEnv ( emptyTidyEnv )
import Linker ( HValue, unload, extendLinkEnv )
import GHC.Exts ( unsafeCoerce# )
import Foreign
import Control.Exception as Exception ( Exception, try )
import CmdLineOpts ( DynFlag(..), dopt_unset )
import CmdLineOpts ( DynFlag(..), dopt_unset, dopt )
#endif
import EXCEPTION ( throwDyn )
......
......@@ -15,7 +15,7 @@ import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO,
import ByteCodeLink ( lookupStaticPtr )
import Outputable
import Name ( Name, getName, mkSystemName )
import Name ( Name, getName, mkSystemVarName )
import Id
import FiniteMap
import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
......@@ -102,7 +102,7 @@ coreExprToBCOs dflags expr
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
let invented_name = mkSystemName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
let invented_name = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
invented_id = mkLocalId invented_name (panic "invented_id's type")
(BcM_State final_ctr mallocd, proto_bco)
......
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.190 2005/02/23 15:38:52 simonmar Exp $
-- $Id: InteractiveUI.hs,v 1.191 2005/02/25 13:07:10 simonpj Exp $
--
-- GHC Interactive User Interface
--
......@@ -27,7 +27,7 @@ import DriverUtil ( remove_spaces )
import Linker ( showLinkerState, linkPackages )
import Util
import Name ( Name, NamedThing(..) )
import OccName ( OccName, isSymOcc, occNameUserString )
import OccName ( OccName, parenSymOcc, occNameUserString )
import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
import Outputable
import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt )
......@@ -622,8 +622,7 @@ ppr_trim show xs
ppr_bndr :: OccName -> SDoc
-- Wrap operators in ()
ppr_bndr occ | isSymOcc occ = parens (ppr occ)
| otherwise = ppr occ
ppr_bndr occ = parenSymOcc occ (ppr occ)
-----------------------------------------------------------------------------
......
......@@ -58,7 +58,7 @@ import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMark
dataConTyCon, dataConIsInfix, isVanillaDataCon )
import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
import OccName ( OccName, OccEnv, emptyOccEnv,
lookupOccEnv, extendOccEnv,
lookupOccEnv, extendOccEnv, parenSymOcc,
OccSet, unionOccSets, unitOccSet )
import Name ( Name, NamedThing(..), nameOccName, isExternalName )
import NameSet ( NameSet, elemNameSet )
......@@ -290,7 +290,7 @@ instance Outputable IfaceClassOp where
pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
pprIfaceDeclHead context thing tyvars
= hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars]
= hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
......
......@@ -30,7 +30,7 @@ import TypeRep ( Type(..), TyNote(..), PredType(..), ThetaType )
import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity )
import Var ( isId, tyVarKind, idType )
import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
import OccName ( OccName )
import OccName ( OccName, parenSymOcc )
import Name ( Name, getName, getOccName, nameModule, nameOccName )
import Module ( Module )
import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity )
......@@ -72,6 +72,12 @@ isLocalIfaceExtName other = False
mkIfaceExtName name = ExtPkg (nameModule name) (nameOccName name)
-- Local helper for wired-in names
ifaceExtOcc :: IfaceExtName -> OccName
ifaceExtOcc (ExtPkg _ occ) = occ
ifaceExtOcc (HomePkg _ occ _) = occ
ifaceExtOcc (LocalTop occ) = occ
ifaceExtOcc (LocalTopSub occ _) = occ
interactiveExtNameFun :: PrintUnqualified -> Name-> IfaceExtName
interactiveExtNameFun print_unqual name
| print_unqual mod occ = LocalTop occ
......@@ -272,7 +278,7 @@ pprIfaceForAllPart tvs ctxt doc
| otherwise = ptext SLIT("forall") <+> pprIfaceTvBndrs tvs <> dot
-------------------
ppr_tc_app ctxt_prec tc [] = ppr tc
ppr_tc_app ctxt_prec tc [] = ppr_tc tc
ppr_tc_app ctxt_prec IfaceListTc [ty] = brackets (pprIfaceType ty)
ppr_tc_app ctxt_prec IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
ppr_tc_app ctxt_prec (IfaceTupTc bx arity) tys
......@@ -280,13 +286,19 @@ ppr_tc_app ctxt_prec (IfaceTupTc bx arity) tys
= tupleParens bx (sep (punctuate comma (map pprIfaceType tys)))
ppr_tc_app ctxt_prec tc tys
= maybeParen ctxt_prec tYCON_PREC
(sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
(sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
ppr_tc :: IfaceTyCon -> SDoc
-- Wrap infix type constructors in parens
ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (ifaceExtOcc ext_nm) (ppr tc)
ppr_tc tc = ppr tc
-------------------
instance Outputable IfacePredType where
-- Print without parens
ppr (IfaceIParam ip ty) = hsep [ppr ip, dcolon, ppr ty]
ppr (IfaceClassP cls ts) = ppr cls <+> sep (map pprParendIfaceType ts)
ppr (IfaceClassP cls ts) = parenSymOcc (ifaceExtOcc cls) (ppr cls)
<+> sep (map pprParendIfaceType ts)
instance Outputable IfaceTyCon where
ppr (IfaceTc ext) = ppr ext
......
......@@ -50,11 +50,11 @@ import TcRnMonad
import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
import TcIface ( loadImportedInsts )
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
zonkTcThetaType, tcInstTyVar, tcInstType
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
tcInstTyVar, tcInstType, tcSkolType
)
import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
PredType(..), typeKind, mkSigmaTy,
PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
tcSplitForAllTys, tcSplitForAllTys,
tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
......@@ -71,27 +71,25 @@ import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSub
import Unify ( tcMatchTys )
import Kind ( isSubKind )
import Packages ( isHomeModule )
import HscTypes ( HscEnv( hsc_HPT ), ExternalPackageState(..),
ModDetails( md_insts ), HomeModInfo( hm_details ) )
import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
import PrelInfo ( isStandardClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
isInternalName, setNameUnique, mkSystemNameEncoded )
isInternalName, setNameUnique, mkSystemVarNameEncoded )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
import Var ( TyVar, tyVarKind, setIdType )
import VarEnv ( TidyEnv, emptyTidyEnv )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
import Module ( moduleEnvElts, elemModuleEnv, lookupModuleEnv )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
import CmdLineOpts( DynFlags )
import Maybes ( isJust, fromJust )
import Maybes ( isJust )
import Outputable
\end{code}
......@@ -402,7 +400,7 @@ newLitInst orig lit expected_ty
= getInstLoc orig `thenM` \ loc ->
newUnique `thenM` \ new_uniq ->
let
lit_nm = mkSystemNameEncoded new_uniq FSLIT("lit")
lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
-- The "encoded" bit means that we don't need to z-encode
-- the string every time we call this!
lit_inst = LitInst lit_nm lit expected_ty loc
......@@ -571,7 +569,12 @@ addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
addInst dflags home_ie dfun
= do { -- Instantiate the dfun type so that we extend the instance
-- envt with completely fresh template variables
(tvs', theta', tau') <- tcInstType (idType dfun)
-- This is important because the template variables must
-- not overlap with anything in the things being looked up
-- (since we do unification).
-- We use tcSkolType because we don't want to allocate fresh
-- *meta* type variables.
(tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
......@@ -704,8 +707,13 @@ lookupInst (Dict _ _ _) = returnM NoInstance
instantiate_dfun :: TvSubst -> DFunId -> TcPredType -> InstLoc -> TcM LookupInstResult
instantiate_dfun tenv dfun_id pred loc
= -- tenv is a substitution that instantiates the dfun_id
-- to match the requested result type. However, the dfun
-- might have some tyvars that only appear in arguments
-- to match the requested result type.
--
-- We ASSUME that the dfun is quantified over the very same tyvars
-- that are bound by the tenv.
--
-- However, the dfun
-- might have some tyvars that *only* appear in arguments
-- dfun :: forall a b. C a b, Ord b => D [a]
-- We instantiate b to a flexi type variable -- it'll presumably
-- become fixed later via functional dependencies
......@@ -731,7 +739,7 @@ instantiate_dfun tenv dfun_id pred loc
mappM tcInstTyVar open_tvs `thenM` \ open_tvs' ->
let
tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
-- Since the tyvars are freshly made, they cannot possibly be captured by
-- Since the open_tvs' are freshly made, they cannot possibly be captured by
-- any nested for-alls in rho. So the in-scope set is unchanged
dfun_rho = substTy tenv' rho
(theta, _) = tcSplitPhiTy dfun_rho
......
......@@ -23,8 +23,10 @@ import TcHsSyn ( TcId, TcDictBinds, zonkId, mkHsLet )
import TcRnMonad
import Inst ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2,
newLocalName, tcLookupLocalIds, pprBinders )
import TcUnify ( Expected(..), tcInfer, checkSigTyVars, sigCtxt )
newLocalName, tcLookupLocalIds, pprBinders,
tcGetGlobalTyVars )
import TcUnify ( Expected(..), tcInfer, unifyTheta,
bleatEscapedTvs, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs )
import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
......@@ -32,16 +34,15 @@ import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
)
import TcPat ( tcPat, PatCtxt(..) )
import TcSimplify ( bindInstsOfLocalFuns )
import TcMType ( newTyFlexiVarTy, tcSkolType, zonkQuantifiedTyVar, zonkTcTypes )
import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar,
tcInstSigType, zonkTcTypes, zonkTcTyVar )
import TcType ( TcTyVar, SkolemInfo(SigSkol),
TcTauType, TcSigmaType,
TvSubstEnv, mkOpenTvSubst, substTheta, substTy,
mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
mkForAllTy, isUnLiftedType, tcGetTyVar_maybe,
mkTyVarTys )
import Unify ( tcMatchPreds )
mkTyVarTys, tidyOpenTyVar, tidyOpenType )
import Kind ( argTypeKind )
import VarEnv ( lookupVarEnv )
import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv, emptyTidyEnv )
import TysPrim ( alphaTyVar )
import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma )
import Var ( idType, idName )
......@@ -51,7 +52,6 @@ import VarSet
import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
import Bag
import Util ( isIn )
import Maybes ( orElse )
import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec,
isNotTopLevel, isAlwaysActive )
import FiniteMap ( listToFM, lookupFM )
......@@ -464,6 +464,7 @@ tcMonoBinds binds lookup_sig is_rec
; binds' <- tcExtendTyVarEnv2 rhs_tvs $
tcExtendIdEnv2 rhs_id_env $
traceTc (text "tcMonoBinds" <+> vcat [ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env]) `thenM_`
mapBagM (wrapLocM tcRhs) tc_binds
; return (binds', mono_info) }
where
......@@ -560,6 +561,27 @@ getMonoBindInfo tc_binds
%* *
%************************************************************************
Type signatures are tricky. Consider
x :: [a]
y :: b
(x,y,z) = ([y,z], z, head x)
Here, x and y have type sigs, which go into the environment. We used to
instantiate their types with skolem constants, and push those types into
the RHS, so we'd typecheck the RHS with type
( [a*], b*, c )
where a*, b* are skolem constants, and c is an ordinary meta type varible.
The trouble is that the occurrences of z in the RHS force a* and b* to
be the *same*, so we can't make them into skolem constants that don't unify
with each other. Alas.
Current solution: don't use skolems at all. Instead, instantiate the type
signatures with ordinary meta type variables, and check at the end that
each group has remained distinct.
\begin{code}
tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
-- The trick here is that all the signatures should have the same
......@@ -570,8 +592,21 @@ tcTySigs [] = return []
tcTySigs sigs
= do { (tc_sig1 : tc_sigs) <- mappM tcTySig sigs
; tc_sigs' <- mapM (checkSigCtxt tc_sig1) tc_sigs
; return (tc_sig1 : tc_sigs') }
; mapM (check_ctxt tc_sig1) tc_sigs
; return (tc_sig1 : tc_sigs) }
where
-- Check tha all the signature contexts are the same
-- The type signatures on a mutually-recursive group of definitions
-- must all have the same context (or none).
--
-- We unify them because, with polymorphic recursion, their types
-- might not otherwise be related. This is a rather subtle issue.
check_ctxt :: TcSigInfo -> TcSigInfo -> TcM ()
check_ctxt sig1@(TcSigInfo { sig_theta = theta1 }) sig@(TcSigInfo { sig_theta = theta })
= setSrcSpan (instLocSrcSpan (sig_loc sig)) $
addErrCtxt (sigContextsCtxt sig1 sig) $
unifyTheta theta1 theta
tcTySig :: LSig Name -> TcM TcSigInfo
tcTySig (L span (Sig (L _ name) ty))
......@@ -587,51 +622,11 @@ tcTySig (L span (Sig (L _ name) ty))
L _ (HsForAllTy _ tvs _ _) -> hsLTyVarNames tvs
other -> []
; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty
; (tvs, theta, tau) <- tcInstSigType sigma_ty
; loc <- getInstLoc (SigOrigin rigid_info)
; return (TcSigInfo { sig_id = poly_id, sig_scoped = scoped_names,
sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
sig_loc = loc }) }
checkSigCtxt :: TcSigInfo -> TcSigInfo -> TcM TcSigInfo
checkSigCtxt sig1 sig@(TcSigInfo { sig_tvs = tvs, sig_theta = theta, sig_tau = tau })
= -- Try to match the context of this signature with
-- that of the first signature
case tcMatchPreds (sig_tvs sig) (sig_theta sig) (sig_theta sig1) of {
Nothing -> bale_out ;
Just tenv ->
case check_tvs tenv tvs of {
Nothing -> bale_out ;
Just tvs' ->
let
subst = mkOpenTvSubst tenv
in
return (sig { sig_tvs = tvs',
sig_theta = substTheta subst theta,
sig_tau = substTy subst tau }) }}
where
bale_out = setSrcSpan (instLocSrcSpan (sig_loc sig)) $
failWithTc $
sigContextsErr (sig_id sig1) (sig_id sig)
-- Rather tedious check that the type variables
-- have been matched only with another type variable,
-- and that two type variables have not been matched
-- with the same one
-- A return of Nothing indicates that one of the bad
-- things has happened
check_tvs :: TvSubstEnv -> [TcTyVar] -> Maybe [TcTyVar]
check_tvs tenv [] = Just []
check_tvs tenv (tv:tvs)
= do { let ty = lookupVarEnv tenv tv `orElse` mkTyVarTy tv
; tv' <- tcGetTyVar_maybe ty
; tvs' <- check_tvs tenv tvs
; if tv' `elem` tvs'
then Nothing
else Just (tv':tvs') }
\end{code}
\begin{code}
......@@ -680,34 +675,74 @@ generalise top_lvl is_unrestricted mono_infos sigs lie_req
is_mono_sig sig = null (sig_theta sig)
doc = ptext SLIT("type signature(s) for") <+> pprBinders bndr_names
mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id
= Method mono_id poly_id (mkTyVarTys tvs) theta tau loc
mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id
= Method mono_id poly_id (mkTyVarTys tvs) theta tau loc
checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
checkSigsTyVars qtvs sigs
= mappM check_one sigs `thenM` \ sig_tvs_s ->
let
-- Sigh. Make sure that all the tyvars in the type sigs
-- appear in the returned ty var list, which is what we are
-- going to generalise over. Reason: we occasionally get
-- silly types like
-- type T a = () -> ()
-- f :: T a
-- f () = ()
-- Here, 'a' won't appear in qtvs, so we have to add it
sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
all_tvs = extendVarSetList sig_tvs qtvs
in
returnM (varSetElems all_tvs)
= do { gbl_tvs <- tcGetGlobalTyVars
; sig_tvs_s <- mappM (check_sig gbl_tvs) sigs
; let -- Sigh. Make sure that all the tyvars in the type sigs
-- appear in the returned ty var list, which is what we are
-- going to generalise over. Reason: we occasionally get
-- silly types like
-- type T a = () -> ()
-- f :: T a
-- f () = ()
-- Here, 'a' won't appear in qtvs, so we have to add it
sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
all_tvs = varSetElems (extendVarSetList sig_tvs qtvs)
; returnM all_tvs }
where
check_one (TcSigInfo {sig_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau})
= addErrCtxt (ptext SLIT("In the type signature for")
<+> quotes (ppr id)) $
addErrCtxtM (sigCtxt id tvs theta tau) $
do { checkSigTyVars tvs; return tvs }
\end{code}
check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs,
sig_theta = theta, sig_tau = tau})
= addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id)) $
addErrCtxtM (sigCtxt id tvs theta tau) $
do { tvs' <- checkDistinctTyVars tvs
; ifM (any (`elemVarSet` gbl_tvs) tvs')
(bleatEscapedTvs gbl_tvs tvs tvs')
; return tvs' }
checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar]
-- (checkDistinctTyVars tvs) checks that the tvs from one type signature
-- are still all type variables, and all distinct from each other.
-- It returns a zonked set of type variables.
-- For example, if the type sig is
-- f :: forall a b. a -> b -> b
-- we want to check that 'a' and 'b' haven't
-- (a) been unified with a non-tyvar type
-- (b) been unified with each other (all distinct)
checkDistinctTyVars sig_tvs
= do { zonked_tvs <- mapM zonk_one sig_tvs
; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
; return zonked_tvs }
where
zonk_one sig_tv = do { ty <- zonkTcTyVar sig_tv
; case tcGetTyVar_maybe ty of
Just tv' -> return tv'
Nothing -> bomb_out sig_tv "a type" ty }
check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
-- The TyVarEnv maps each zonked type variable back to its
-- corresponding user-written signature type variable
check_dup acc (sig_tv, zonked_tv)
= case lookupVarEnv acc zonked_tv of
Just sig_tv' -> bomb_out sig_tv "another quantified type variable"
(mkTyVarTy sig_tv')
Nothing -> return (extendVarEnv acc zonked_tv sig_tv)
bomb_out sig_tv doc ty
= failWithTc (ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv)
<+> ptext SLIT("is unified with") <+> text doc <+> ppr tidy_ty)
where
(env1, tidy_tv) = tidyOpenTyVar emptyTidyEnv sig_tv
(_env2, tidy_ty) = tidyOpenType env1 ty
\end{code}
@getTyVarsToGen@ decides what type variables to generalise over.
......@@ -865,11 +900,14 @@ valSpecSigCtxt v ty
nest 4 (ppr v <+> dcolon <+> ppr ty)]
-----------------------------------------------
sigContextsErr id1 id2
= vcat [ptext SLIT("Mis-match between the contexts of the signatures for"),
sigContextsCtxt sig1 sig2
= vcat [ptext SLIT("When matching the contexts of the signatures for"),
nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
ppr id2 <+> dcolon <+> ppr (idType id2)]),
ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
where
id1 = sig_id sig1
id2 = sig_id sig2
-----------------------------------------------
......
......@@ -345,13 +345,13 @@ find_thing ignore_it tidy_env (ATyVar tv ty)
else let
-- The name tv is scoped, so we don't need to tidy it
(tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
msg = sep [ppr tv <+> eq_stuff, nest 2 bound_at]
msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
tv == tyVarName tv' = empty
getOccName tv == getOccName tv' = empty
| otherwise = equals <+> ppr tidy_ty
-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
bound_at = ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
in
returnM (tidy_env1, Just msg)
\end{code}
......