then
TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId, loop Generics.mkGenInfo)
then
- TcType( lots of TywWiredIn stuff)
+ TcType( lots of TysWiredIn stuff)
then
PprType( lots of TcType stuff )
then
+* Can a scoped type variable denote a type scheme?
+
+* Relation between separate type sigs and pattern type sigs
+f :: forall a. a->a
+f :: b->b = e -- No: monomorphic
+
+f :: forall a. a->a
+f :: forall a. a->a -- OK
+
+f :: forall a. [a] -> [a]
+f :: forall b. b->b = e ???
+
+
+-------------------------------
NB: all floats are let-binds, but some non-rec lets
may be unlifted (with RHS ok-for-speculation)
deriving( Eq ) -- Needed because Demand derives Eq
\end{code}
+
%************************************************************************
%* *
\subsection[Top-level/local]{Top-level/not-top level flag}
import {-# SOURCE #-} Subst( substTyWith )
import {-# SOURCE #-} PprType( pprType )
-import Type ( Type, TauType, ThetaType,
+import Type ( Type, ThetaType,
mkForAllTys, mkFunTys, mkTyConApp,
mkTyVarTys, splitTyConApp_maybe, repType,
mkPredTys, isStrictType
-> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType
-> [TyVar] -> ThetaType
- -> [TauType] -> TyCon
+ -> [Type] -> TyCon
-> Id -> Id
-> DataCon
-- Can get the tag from the TyCon
dataConSig :: DataCon -> ([TyVar], ThetaType,
[TyVar], ThetaType,
- [TauType], TyCon)
+ [Type], TyCon)
dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
dataConOrigArgTys :: DataCon -> [Type]
dataConOrigArgTys dc = dcOrigArgTys dc
-dataConRepArgTys :: DataCon -> [TauType]
+dataConRepArgTys :: DataCon -> [Type]
dataConRepArgTys dc = dcRepArgTys dc
\end{code}
mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info
-mkSpecPragmaId :: OccName -> Unique -> Type -> SrcLoc -> Id
-mkSpecPragmaId occ uniq ty loc = Var.mkSpecPragmaId (mkLocalName uniq occ loc)
- (addFreeTyVars ty)
- vanillaIdInfo
+mkSpecPragmaId :: Name -> Type -> Id
+mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo
mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info
foreach $f ( @ARGV ) {
if ( $f =~ /\.lhs$/ ) {
- open(INF, "/home/simonpj/builds/slpj/ghc/utils/unlit/unlit $f - |") || die "Couldn't unlit $f!\n";
+ open(INF, "c:/fptools-HEAD/ghc/utils/unlit/unlit $f - |") || die "Couldn't unlit $f!\n";
} else {
open(INF, "< $f") || die "Couldn't open $f!\n";
}
simplify_pat pat@(WildPat gt) = pat
simplify_pat (VarPat id) = WildPat (idType id)
-simplify_pat (LazyPat p) = simplify_pat p
-simplify_pat (AsPat id p) = simplify_pat p
+simplify_pat (LazyPat p) = simplify_pat p
+simplify_pat (AsPat id p) = simplify_pat p
+simplify_pat (SigPat p ty fn) = simplify_pat p -- I'm not sure this is right
simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
-
\end{code}
import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon ( isExistentialDataCon )
import Literal ( Literal(..) )
+import Type ( ipNameName )
import TyCon ( tyConDataCons )
import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon )
import BasicTypes ( RecFlag(..), Boxity(..) )
\begin{code}
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
-dsExpr (HsVar var) = returnDs (Var var)
-dsExpr (HsIPVar var) = returnDs (Var var)
-dsExpr (HsLit lit) = dsLit lit
+dsExpr (HsVar var) = returnDs (Var var)
+dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
+dsExpr (HsLit lit) = dsLit lit
-- HsOverLit has been gotten rid of by the type checker
dsExpr expr@(HsLam a_Match)
where
dsIPBind body (n, e)
= dsExpr e `thenDs` \ e' ->
- returnDs (Let (NonRec n e') body)
+ returnDs (Let (NonRec (ipNameName n) e') body)
dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc)
| maybeToBool maybe_list_comp
| otherwise
- = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
- `thenDs` \ error_expr ->
- matchSimply val_expr PatBindRhs pat local_tuple error_expr
- `thenDs` \ tuple_expr ->
- newSysLocalDs tuple_ty
- `thenDs` \ tuple_var ->
+ = mkErrorAppDs iRREFUT_PAT_ERROR_ID
+ tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
+ matchSimply val_expr PatBindRhs pat local_tuple error_expr `thenDs` \ tuple_expr ->
+ newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
let
- mk_tup_bind binder =
- (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
+ mk_tup_bind binder
+ = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
in
returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
where
#include "HsVersions.h"
+import {-# SOURCE #-} DsExpr( dsExpr )
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType )
\begin{code}
match [] eqns_info
- = complete_matches eqns_info
+ = returnDs (foldr1 combineMatchResults match_results)
where
- complete_matches [eqn]
- = complete_match eqn
-
- complete_matches (eqn:eqns)
- = complete_match eqn `thenDs` \ match_result1 ->
- complete_matches eqns `thenDs` \ match_result2 ->
- returnDs (combineMatchResults match_result1 match_result2)
-
- complete_match (EqnInfo _ _ pats match_result)
- = ASSERT( null pats )
- returnDs match_result
+ match_results = [ ASSERT( null pats) mr
+ | EqnInfo _ _ pats mr <- eqns_info ]
\end{code}
+
%************************************************************************
%* *
%* match: non-empty rule *
match_result' | v == var = match_result
| otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
+tidy1 v (SigPat pat ty fn) match_result
+ = selectMatchVar pat `thenDs` \ v' ->
+ tidy1 v' pat match_result `thenDs` \ (WildPat _, match_result') ->
+ -- The ice is a little thin here
+ -- We only expect a SigPat (with a non-trivial coercion) wrapping
+ -- a variable pattern. If it was a constructor or literal pattern
+ -- there would be no interesting polymorphism, and hence no coercion.
+ dsExpr (HsApp fn (HsVar v)) `thenDs` \ e ->
+ returnDs (WildPat ty, adjustMatchResult (bindNonRec v' e) match_result')
+
tidy1 v (WildPat ty) match_result
= returnDs (WildPat ty, match_result)
where
first_pat = head column_1_pats
- column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
+ column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
\end{code}
import ForeignCall ( Safety )
import Outputable
import PprType ( pprParendType )
-import Type ( Type )
+import Type ( Type, IPName )
import Var ( TyVar )
import DataCon ( DataCon )
import CStrings ( CLabelString, pprCLabelString )
\begin{code}
data HsExpr id pat
= HsVar id -- variable
- | HsIPVar id -- implicit parameter
+ | HsIPVar (IPName id) -- implicit parameter
| HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker
| HsLit HsLit -- Simple (non-overloaded) literals
(HsExpr id pat)
| HsWith (HsExpr id pat) -- implicit parameter binding
- [(id, HsExpr id pat)]
+ [(IPName id, HsExpr id pat)]
| HsDo HsDoContext
[Stmt id pat] -- "do":one or more stmts
| isOperator v = parens (ppr v)
| otherwise = ppr v
-ppr_expr (HsIPVar v) = char '?' <> ppr v
+ppr_expr (HsIPVar v) = ppr v
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
\begin{code}
pp_ipbinds :: (Outputable id, Outputable pat)
- => [(id, HsExpr id pat)] -> SDoc
+ => [(IPName id, HsExpr id pat)] -> SDoc
pp_ipbinds pairs = hsep (punctuate semi (map pp_item pairs))
where
- pp_item (id,rhs) = char '?' <> ppr id <+> equals <+> ppr_expr rhs
+ pp_item (id,rhs) = ppr id <+> equals <+> ppr_expr rhs
\end{code}
OutPat(..),
irrefutablePat, irrefutablePats,
- failureFreePat, isWildPat,
- patsAreAllCons, isConPat,
+ failureFreePat, isWildPat,
+ patsAreAllCons, isConPat,
patsAreAllLits, isLitPat,
collectPatBinders, collectPatsBinders,
collectSigTysFromPat, collectSigTysFromPats
| AsPat id -- as pattern
(OutPat id)
+ | SigPat (OutPat id) -- Pattern p
+ Type -- Type, t, of the whole pattern
+ (HsExpr id (OutPat id))
+ -- Coercion function,
+ -- of type t -> typeof(p)
+
| ListPat -- Syntactic list
Type -- The type of the elements
[OutPat id]
pprOutPat (AsPat name pat)
= parens (hcat [ppr name, char '@', ppr pat])
+pprOutPat (SigPat pat ty _) = ppr pat <+> dcolon <+> ppr ty
+
pprOutPat (ConPat name ty [] [] [])
= ppr name
#include "HsVersions.h"
import Class ( FunDep )
-import TcType ( Type, Kind, ThetaType, SourceType(..),
+import TcType ( Type, Kind, ThetaType, SourceType(..), IPName,
tcSplitSigmaTy, liftedTypeKind, eqKind, tcEqType
)
import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
type HsContext name = [HsPred name]
data HsPred name = HsClassP name [HsType name]
- | HsIParam name (HsType name)
+ | HsIParam (IPName name) (HsType name)
data HsType name
= HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures
instance Outputable name => Outputable (HsPred name) where
ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
- ppr (HsIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty]
+ ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty]
pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name
toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys)
-toHsPred (IParam n ty) = HsIParam (getName n) (toHsType ty)
+toHsPred (IParam n ty) = HsIParam n (toHsType ty)
toHsContext :: ThetaType -> HsContext Name
toHsContext theta = map toHsPred theta
#include "HsVersions.h"
-import RdrName ( RdrNameEnv, addListToRdrEnv, emptyRdrEnv, mkRdrUnqual, rdrEnvToList )
+import RdrName ( RdrName, RdrNameEnv, addListToRdrEnv, emptyRdrEnv,
+ mkRdrUnqual, rdrEnvToList )
import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc )
import NameEnv
import OccName ( OccName )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
import Id ( Id )
+import Type ( IPName )
import Class ( Class, classSelIds )
import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
import DataCon ( dataConId, dataConWrapId )
}
type OrigNameCache = FiniteMap (ModuleName,OccName) Name
-type OrigIParamCache = FiniteMap OccName Name
+type OrigIParamCache = FiniteMap (IPName RdrName) (IPName Name)
\end{code}
@ImportedModuleInfo@ contains info ONLY about modules that have not yet
| ITqvarsym (FAST_STRING,FAST_STRING)
| ITqconsym (FAST_STRING,FAST_STRING)
- | ITipvarid FAST_STRING -- GHC extension: implicit param: ?x
+ | ITdupipvarid FAST_STRING -- GHC extension: implicit param: ?x
+ | ITsplitipvarid FAST_STRING -- GHC extension: implicit param: %x
| ITpragma StringBuffer
cont (ITunknown "\NUL") (stepOn buf)
'?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
- lex_ip cont (incLexeme buf)
+ lex_ip ITdupipvarid cont (incLexeme buf)
+ '%'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
+ lex_ip ITsplitipvarid cont (incLexeme buf)
c | is_digit c -> lex_num cont glaexts 0 buf
| is_symbol c -> lex_sym cont buf
| is_upper c -> lex_con cont glaexts buf
-----------------------------------------------------------------------------
-- identifiers, symbols etc.
-lex_ip cont buf =
+lex_ip ip_constr cont buf =
case expandWhile# is_ident buf of
- buf' -> cont (ITipvarid lexeme) buf'
- where lexeme = lexemeToFastString buf'
+ buf' -> cont (ip_constr (tailFS lexeme)) buf'
+ where lexeme = lexemeToFastString buf'
lex_id cont glaexts buf =
let buf1 = expandWhile# is_ident buf in
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.76 2001/10/31 15:22:54 simonpj Exp $
+$Id: Parser.y,v 1.77 2001/11/26 09:20:26 simonpj Exp $
Haskell grammar.
import HsSyn
import HsTypes ( mkHsTupCon )
+import TypeRep ( IPName(..) )
import RdrHsSyn
import Lex
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
- IPVARID { ITipvarid $$ } -- GHC extension
+ IPDUPVARID { ITdupipvarid $$ } -- GHC extension
+ IPSPLITVARID { ITsplitipvarid $$ } -- GHC extension
CHAR { ITchar $$ }
STRING { ITstring $$ }
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
-dbinding :: { [(RdrName, RdrNameHsExpr)] }
+dbinding :: { [(IPName RdrName, RdrNameHsExpr)] }
: '{' dbinds '}' { $2 }
| layout_on dbinds close { $2 }
-dbinds :: { [(RdrName, RdrNameHsExpr)] }
+dbinds :: { [(IPName RdrName, RdrNameHsExpr)] }
: dbinds ';' dbind { $3 : $1 }
| dbinds ';' { $1 }
| dbind { [$1] }
| {- empty -} { [] }
-dbind :: { (RdrName, RdrNameHsExpr) }
+dbind :: { (IPName RdrName, RdrNameHsExpr) }
dbind : ipvar '=' exp { ($1, $3) }
-----------------------------------------------------------------------------
-- whether it's a qvar or a var can be postponed until
-- *after* we see the close paren.
-ipvar :: { RdrName }
- : IPVARID { (mkUnqual varName (tailFS $1)) }
+ipvar :: { IPName RdrName }
+ : IPDUPVARID { Dupable (mkUnqual varName $1) }
+ | IPSPLITVARID { MustSplit (mkUnqual varName $1) }
qcon :: { RdrName }
: qconid { $1 }
import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys,
mkArrowKinds, liftedTypeKind, unliftedTypeKind,
- TauType, ThetaType )
+ ThetaType )
import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique )
import PrelNames
import Array
name1 = mkWiredInName mod occ_name1 fn1_key
name2 = mkWiredInName mod occ_name2 fn2_key
-pcDataCon :: Name -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> DataCon
+pcDataCon :: Name -> [TyVar] -> ThetaType -> [Type] -> TyCon -> DataCon
-- The unique is the first of two free uniques;
-- the first is used for the datacon itself and the worker;
-- the second is used for the wrapper.
)
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind )
+import TypeRep ( IPName(..) )
import ForeignCall ( ForeignCall(..), CCallConv(..), CCallSpec(..), CCallTarget(..) )
import Lex
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
- IPVARID { ITipvarid $$ } -- GHC extension
+ IPDUPVARID { ITdupipvarid $$ } -- GHC extension
+ IPSPLITVARID { ITsplitipvarid $$ } -- GHC extension
PRAGMA { ITpragma $$ }
qvar_name : var_name { $1 }
| QVARID { mkIfaceOrig varName $1 }
-ipvar_name :: { RdrName }
- : IPVARID { mkRdrUnqual (mkSysOccFS varName (tailFS $1)) }
+ipvar_name :: { IPName RdrName }
+ : IPDUPVARID { Dupable (mkRdrUnqual (mkSysOccFS varName $1)) }
+ | IPSPLITVARID { MustSplit (mkRdrUnqual (mkSysOccFS varName $1)) }
qvar_names1 :: { [RdrName] }
qvar_names1 : qvar_name { [$1] }
Deprecations(..), lookupDeprec,
extendLocalRdrEnv
)
+import Type ( mapIPName )
import RnMonad
import Name ( Name,
getSrcLoc, nameIsLocalOrFrom,
name = mkGlobalName uniq mod occ noSrcLoc
new_cache = addToFM cache key name
-newIPName rdr_name
+newIPName rdr_name_ip
= getNameSupplyRn `thenRn` \ name_supply ->
let
ipcache = nsIPs name_supply
in
case lookupFM ipcache key of
- Just name -> returnRn name
- Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsIPs = new_ipcache}) `thenRn_`
- returnRn name
+ Just name_ip -> returnRn name_ip
+ Nothing -> setNameSupplyRn new_ns `thenRn_`
+ returnRn name_ip
where
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
- name = mkIPName uniq key
- new_ipcache = addToFM ipcache key name
- where key = (rdrNameOcc rdr_name)
+ name_ip = mapIPName mk_name rdr_name_ip
+ mk_name rdr_name = mkIPName uniq (rdrNameOcc rdr_name)
+ new_ipcache = addToFM ipcache key name_ip
+ new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
+ where
+ key = rdr_name_ip -- Ensures that ?x and %x get distinct Names
\end{code}
%*********************************************************
isClassPred, isTyVarClassPred,
getClassPredTys, getClassPredTys_maybe, mkPredName,
tidyType, tidyTypes, tidyFreeTyVars,
- tcCmpType, tcCmpTypes, tcCmpPred
+ tcCmpType, tcCmpTypes, tcCmpPred,
+ IPName, mapIPName, ipNameName
)
import CoreFVs ( idFreeTyVars )
import Class ( Class )
ipNamesOfInsts :: [Inst] -> [Name]
ipNamesOfInst :: Inst -> [Name]
-- Get the implicit parameters mentioned by these Insts
+-- NB: ?x and %x get different Names
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
-ipNamesOfInst (Dict _ (IParam n _) _) = [n]
-ipNamesOfInst (Method _ _ _ theta _ _) = [n | IParam n _ <- theta]
+ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
+ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
ipNamesOfInst other = []
tyVarsOfInst :: Inst -> TcTyVarSet
\begin{code}
instBindingRequired :: Inst -> Bool
instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
-instBindingRequired (Dict _ (IParam _ _) _) = False
instBindingRequired other = True
instCanBeGeneralised :: Inst -> Bool
where
mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
--- For implicit parameters, since there is only one in scope
--- at any time, we use the name of the implicit parameter itself
-newIPDict orig name ty
- = tcGetInstLoc orig `thenNF_Tc` \ inst_loc ->
- returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc)
- where pred = IParam name ty
+-- For vanilla implicit parameters, there is only one in scope
+-- at any time, so we used to use the name of the implicit parameter itself
+-- But with splittable implicit parameters there may be many in
+-- scope, so we make up a new name.
+newIPDict :: InstOrigin -> IPName Name -> Type
+ -> NF_TcM (IPName Id, Inst)
+newIPDict orig ip_name ty
+ = tcGetInstLoc orig `thenNF_Tc` \ inst_loc@(_,loc,_) ->
+ tcGetUnique `thenNF_Tc` \ uniq ->
+ let
+ pred = IParam ip_name ty
+ id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
+ in
+ returnNF_Tc (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
\end{code}
import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
newDicts, instToId
)
-import TcEnv ( tcExtendLocalValEnv,
- newSpecPragmaId, newLocalId
- )
+import TcEnv ( tcExtendLocalValEnv, newLocalName )
+import TcUnify ( unifyTauTyLists, checkSigTyVars, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts )
-import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars,
- TcSigInfo(..), tcTySig, maybeSig, sigCtxt, tcAddScopedTyVars
+import TcMonoType ( tcHsSigType, UserTypeCtxt(..),
+ TcSigInfo(..), tcTySig, maybeSig, tcAddScopedTyVars
)
-import TcPat ( tcPat )
+import TcPat ( tcPat, tcSubPat, tcMonoPatBndr )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcMType ( newTyVarTy, newTyVar,
- zonkTcTyVarToTyVar,
- unifyTauTy, unifyTauTyLists
+import TcMType ( newTyVar, newTyVarTy, newHoleTyVarTy,
+ zonkTcTyVarToTyVar
)
import TcType ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
mkPredTy, mkForAllTy, isUnLiftedType,
)
import CoreFVs ( idFreeTyVars )
-import Id ( mkLocalId, setInlinePragma )
+import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma )
import Var ( idType, idName )
-import Name ( Name, getOccName, getSrcLoc )
+import Name ( Name, getSrcLoc )
import NameSet
import Var ( tyVarKind )
import VarSet
new_poly_id = mkLocalId binder_name poly_ty
poly_ty = mkForAllTys real_tyvars_to_gen
- $ mkFunTys dict_tys
- $ idType zonked_mono_id
+ $ mkFunTys dict_tys
+ $ idType zonked_mono_id
-- It's important to build a fully-zonked poly_ty, because
-- we'll slurp out its free type variables when extending the
-- local environment (tcExtendLocalValEnv); if it's not zonked
checkSigsTyVars sigs = mapTc_ check_one sigs
where
check_one (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau) $
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (ptext SLIT("When checking the type signature for")
+ <+> quotes (ppr id)) $
+ tcAddErrCtxtM (sigCtxt sig_tyvars sig_theta sig_tau) $
checkSigTyVars sig_tyvars (idFreeTyVars id)
-
- sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id)
\end{code}
@getTyVarsToGen@ decides what type variables to generalise over.
returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
where
- -- This function is used when dealing with a LHS binder;
- -- we make a monomorphic version of the Id.
- -- We check for a type signature; if there is one, we use the mono_id
- -- from the signature. This is how we make sure the tau part of the
- -- signature actually maatches the type of the LHS; then tc_mb_pats
- -- ensures the LHS and RHS have the same type
-
- tc_pat_bndr name pat_ty
- = case maybeSig tc_ty_sigs name of
- Nothing
- -> newLocalId (getOccName name) pat_ty (getSrcLoc name)
-
- Just (TySigInfo _ _ _ _ _ mono_id _ _)
- -> tcAddSrcLoc (getSrcLoc name) $
- unifyTauTy (idType mono_id) pat_ty `thenTc_`
- returnTc mono_id
-
mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
Nothing -> (name, mono_id)
Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
lie_avail1 `plusLIE` lie_avail2)
tc_mb_pats (FunMonoBind name inf matches locn)
- = newTyVarTy kind `thenNF_Tc` \ bndr_ty ->
- tc_pat_bndr name bndr_ty `thenTc` \ bndr_id ->
+ = (case maybeSig tc_ty_sigs name of
+ Just (TySigInfo _ _ _ _ _ mono_id _ _)
+ -> returnNF_Tc mono_id
+ Nothing -> newLocalName name `thenNF_Tc` \ bndr_name ->
+ newTyVarTy openTypeKind `thenNF_Tc` \ bndr_ty ->
+ -- NB: not a 'hole' tyvar; since there is no type
+ -- signature, we revert to ordinary H-M typechecking
+ -- which means the variable gets an inferred tau-type
+ returnNF_Tc (mkLocalId bndr_name bndr_ty)
+ ) `thenNF_Tc` \ bndr_id ->
let
+ bndr_ty = idType bndr_id
complete_it xve = tcAddSrcLoc locn $
tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
returnTc (FunMonoBind bndr_id inf matches' locn, lie)
tc_mb_pats bind@(PatMonoBind pat grhss locn)
= tcAddSrcLoc locn $
- newTyVarTy kind `thenNF_Tc` \ pat_ty ->
+ newHoleTyVarTy `thenNF_Tc` \ pat_ty ->
-- Now typecheck the pattern
- -- We don't support binding fresh (not-already-in-scope) scoped
+ -- We do now support binding fresh (not-already-in-scope) scoped
-- type variables in the pattern of a pattern binding.
- -- For example, this is illegal:
+ -- For example, this is now legal:
-- (x::a, y::b) = e
- -- whereas this is ok
- -- (x::Int, y::Bool) = e
- --
- -- We don't check explicitly for this problem. Instead, we simply
- -- type check the pattern with tcPat. If the pattern mentions any
- -- fresh tyvars we simply get an out-of-scope type variable error
+ -- The type variables are brought into scope in tc_binds_and_then,
+ -- so we don't have to do anything here.
+
tcPat tc_pat_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
let
complete_it xve = tcAddSrcLoc locn $
in
returnTc (complete_it, lie_req, tvs, ids, lie_avail)
- -- Figure out the appropriate kind for the pattern,
- -- and generate a suitable type variable
- kind = case is_rec of
- Recursive -> liftedTypeKind -- Recursive, so no unlifted types
- NonRecursive -> openTypeKind -- Non-recursive, so we permit unlifted types
+ -- tc_pat_bndr is used when dealing with a LHS binder in a pattern.
+ -- If there was a type sig for that Id, we want to make it much
+ -- as if that type signature had been on the binder as a SigPatIn.
+ -- We check for a type signature; if there is one, we use the mono_id
+ -- from the signature. This is how we make sure the tau part of the
+ -- signature actually matches the type of the LHS; then tc_mb_pats
+ -- ensures the LHS and RHS have the same type
+
+ tc_pat_bndr name pat_ty
+ = case maybeSig tc_ty_sigs name of
+ Nothing
+ -> newLocalName name `thenNF_Tc` \ bndr_name ->
+ tcMonoPatBndr bndr_name pat_ty
+
+ Just (TySigInfo _ _ _ _ _ mono_id _ _)
+ -> tcAddSrcLoc (getSrcLoc name) $
+ tcSubPat pat_ty (idType mono_id) `thenTc` \ (co_fn, lie) ->
+ returnTc (co_fn, lie, mono_id)
\end{code}
-- Just specialise "f" by building a SpecPragmaId binding
-- It is the thing that makes sure we don't prematurely
-- dead-code-eliminate the binding we are really interested in.
- newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
+ newLocalName name `thenNF_Tc` \ spec_name ->
+ let
+ spec_bind = VarMonoBind (mkSpecPragmaId spec_name sig_ty)
+ (mkHsLet spec_binds spec_expr)
+ in
-- Do the rest and combine
tcSpecSigs sigs `thenTc` \ (binds_rest, lie_rest) ->
- returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id (mkHsLet spec_binds spec_expr),
+ returnTc (binds_rest `andMonoBinds` spec_bind,
lie_rest `plusLIE` mkLIE spec_dicts)
tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs,
instToId, newDicts, newMethod )
-import TcEnv ( RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
+import TcEnv ( RecTcEnv, TyThingDetails(..),
tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
tcExtendLocalValEnv, tcExtendTyVarEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
-import TcMonoType ( tcHsType, tcHsTheta, checkSigTyVars, sigCtxt, mkTcSig )
+import TcMonoType ( tcHsType, tcHsTheta, mkTcSig )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
+import TcUnify ( checkSigTyVars, sigCtxt )
import TcMType ( tcInstSigTyVars, checkValidTheta, checkValidType, SourceTyCtxt(..), UserTypeCtxt(..) )
import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar,
- mkSigmaTy, mkTyVarTys, mkPredTys, mkClassPred,
+ mkTyVarTys, mkPredTys, mkClassPred,
tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitSigmaTy
)
import TcMonad
let
meth_id = instToId meth
meth_name = idName meth_id
- sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_id
meth_prags = find_prags (idName sel_id) meth_name prags
in
mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
-- We do this for each method independently to localise error messages
-- ...and this is why the call to tcExtendGlobalTyVars must be here
-- rather than in the caller
- tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id)) $
+ tcAddErrCtxt (ptext SLIT("When checking the type of class method")
+ <+> quotes (ppr sel_id)) $
+ tcAddErrCtxtM (sigCtxt inst_tyvars inst_theta (idType meth_id)) $
checkSigTyVars inst_tyvars emptyVarSet `thenTc_`
returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe,
-- New Ids
- newLocalId, newSpecPragmaId,
- newDFunName,
+ newLocalName, newDFunName,
-- Misc
isLocalThing, tcSetEnv
import RnHsSyn ( RenamedMonoBinds, RenamedSig )
import TcMonad
import TcMType ( zonkTcTyVarsAndFV )
-import TcType ( Type, ThetaType, TcType, TcKind, TcTyVar, TcTyVarSet,
+import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
tyVarsOfTypes, tcSplitDFunTy,
getDFunTyKey, tcTyConAppTyCon
)
-import Id ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe )
+import Id ( idName, isDataConWrapId_maybe )
import IdInfo ( vanillaIdInfo )
import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
import VarSet
import DataCon ( DataCon )
import TyCon ( TyCon )
import Class ( Class, ClassOpItem )
-import Name ( Name, OccName, NamedThing(..),
- nameOccName, getSrcLoc, mkLocalName, isLocalName,
- nameIsLocalOrFrom
+import Name ( Name, NamedThing(..),
+ getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom
)
import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv,
extendNameEnvList, emptyNameEnv, plusNameEnv )
Constructing new Ids
\begin{code}
-newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
-newLocalId name ty loc
+newLocalName :: Name -> NF_TcM Name
+newLocalName name -- Make a clone
= tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkUserLocal name uniq ty loc)
-
-newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
-newSpecPragmaId name ty
- = tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
+ returnNF_Tc (mkLocalName uniq (getOccName name) (getSrcLoc name))
\end{code}
Make a name for the dict fun for an instance decl.
\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcApp, tcExpr, tcMonoExpr, tcPolyExpr, tcId ) where
+module TcExpr ( tcExpr, tcMonoExpr, tcId ) where
#include "HsVersions.h"
HsMatchContext(..), HsDoContext(..), mkMonoBind
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn ( TcExpr, TcRecordBinds, mkHsLet )
+import TcHsSyn ( TcExpr, TcRecordBinds, simpleHsLitTy )
import TcMonad
+import TcUnify ( tcSub, tcGen, (<$>),
+ unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy
+ )
import BasicTypes ( RecFlag(..), isMarkedStrict )
import Inst ( InstOrigin(..),
LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
)
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
- tcLookupTyCon, tcLookupDataCon, tcLookupId,
- tcExtendGlobalTyVars
+ tcLookupTyCon, tcLookupDataCon, tcLookupId
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
-import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars, sigCtxt )
-import TcPat ( badFieldCon, simpleHsLitTy )
-import TcSimplify ( tcSimplifyCheck, tcSimplifyIPs )
-import TcMType ( tcInstTyVars, tcInstType,
- newTyVarTy, newTyVarTys, zonkTcType,
- unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy
- )
-import TcType ( TcType, TcTauType, tcSplitFunTys, tcSplitTyConApp,
- isQualifiedTy, mkFunTy, mkAppTy, mkTyConTy,
+import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
+import TcPat ( badFieldCon )
+import TcSimplify ( tcSimplifyIPs )
+import TcMType ( tcInstTyVars, newTyVarTy, newTyVarTys, zonkTcType )
+import TcType ( TcType, TcSigmaType, TcPhiType,
+ tcSplitFunTys, tcSplitTyConApp,
+ isSigmaTy, mkFunTy, mkAppTy, mkTyConTy,
mkTyConApp, mkClassPred, tcFunArgTy,
- isTauTy, tyVarsOfType, tyVarsOfTypes,
+ tyVarsOfTypes,
liftedTypeKind, openTypeKind, mkArrowKind,
tcSplitSigmaTy, tcTyConAppTyCon,
tidyOpenType
%************************************************************************
\begin{code}
-tcExpr :: RenamedHsExpr -- Expession to type check
- -> TcType -- Expected type (could be a polytpye)
- -> TcM (TcExpr, LIE)
+tcExpr :: RenamedHsExpr -- Expession to type check
+ -> TcSigmaType -- Expected type (could be a polytpye)
+ -> TcM (TcExpr, LIE) -- Generalised expr with expected type, and LIE
-tcExpr expr ty | isQualifiedTy ty = -- Polymorphic case
- tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
- returnTc (expr', lie)
+tcExpr expr expected_ty
+ | not (isSigmaTy expected_ty) -- Monomorphic case
+ = tcMonoExpr expr expected_ty
- | otherwise = -- Monomorphic case
- tcMonoExpr expr ty
+ | otherwise
+ = tcGen expected_ty (tcMonoExpr expr) `thenTc` \ (gen_fn, expr', lie) ->
+ returnTc (gen_fn <$> expr', lie)
\end{code}
%************************************************************************
%* *
-\subsection{@tcPolyExpr@ typchecks an application}
+\subsection{The TAUT rules for variables}
%* *
%************************************************************************
\begin{code}
--- tcPolyExpr is like tcMonoExpr, except that the expected type
--- can be a polymorphic one.
-tcPolyExpr :: RenamedHsExpr
- -> TcType -- Expected type
- -> TcM (TcExpr, LIE, -- Generalised expr with expected type, and LIE
- TcExpr, TcTauType, LIE) -- Same thing, but instantiated; tau-type returned
-
-tcPolyExpr arg expected_arg_ty
- = -- Ha! The argument type of the function is a for-all type,
- -- An example of rank-2 polymorphism.
-
- -- To ensure that the forall'd type variables don't get unified with each
- -- other or any other types, we make fresh copy of the alleged type
- tcInstType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_theta, sig_tau) ->
- let
- free_tvs = tyVarsOfType expected_arg_ty
- in
- -- Type-check the arg and unify with expected type
- tcMonoExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
-
- -- Check that the sig_tyvars havn't been constrained
- -- The interesting bit here is that we must include the free variables
- -- of the expected arg ty. Here's an example:
- -- runST (newVar True)
- -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
- -- for (newVar True), with s fresh. Then we unify with the runST's arg type
- -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
- -- So now s' isn't unconstrained because it's linked to a.
- -- Conclusion: include the free vars of the expected arg type in the
- -- list of "free vars" for the signature check.
-
- tcExtendGlobalTyVars free_tvs $
- tcAddErrCtxtM (sigCtxt sig_msg sig_tyvars sig_theta sig_tau) $
-
- newDicts SignatureOrigin sig_theta `thenNF_Tc` \ sig_dicts ->
- tcSimplifyCheck
- (text "the type signature of an expression")
- sig_tyvars
- sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
-
- checkSigTyVars sig_tyvars free_tvs `thenTc` \ zonked_sig_tyvars ->
+tcMonoExpr :: RenamedHsExpr -- Expession to type check
+ -> TcPhiType -- Expected type (could be a type variable)
+ -- Definitely no foralls at the top
+ -- Can be a 'hole'.
+ -> TcM (TcExpr, LIE)
- let
- -- This HsLet binds any Insts which came out of the simplification.
- -- It's a bit out of place here, but using AbsBind involves inventing
- -- a couple of new names which seems worse.
- generalised_arg = TyLam zonked_sig_tyvars $
- DictLam (map instToId sig_dicts) $
- mkHsLet inst_binds $
- arg'
- in
- returnTc ( generalised_arg, free_insts,
- arg', sig_tau, lie_arg )
- where
- sig_msg = ptext SLIT("When checking an expression type signature")
+tcMonoExpr (HsVar name) res_ty
+ = tcId name `thenNF_Tc` \ (expr', lie1, id_ty) ->
+ tcSub res_ty id_ty `thenTc` \ (co_fn, lie2) ->
+ returnTc (co_fn <$> expr', lie1 `plusLIE` lie2)
+
+tcMonoExpr (HsIPVar ip) res_ty
+ = -- Implicit parameters must have a *tau-type* not a
+ -- type scheme. We enforce this by creating a fresh
+ -- type variable as its type. (Because res_ty may not
+ -- be a tau-type.)
+ newTyVarTy openTypeKind `thenNF_Tc` \ ip_ty ->
+ newIPDict (IPOcc ip) ip ip_ty `thenNF_Tc` \ (ip', inst) ->
+ tcSub res_ty ip_ty `thenTc` \ (co_fn, lie) ->
+ returnNF_Tc (co_fn <$> HsIPVar ip', lie `plusLIE` unitLIE inst)
\end{code}
+
%************************************************************************
%* *
-\subsection{The TAUT rules for variables}
+\subsection{Expressions type signatures}
%* *
%************************************************************************
\begin{code}
-tcMonoExpr :: RenamedHsExpr -- Expession to type check
- -> TcTauType -- Expected type (could be a type variable)
- -> TcM (TcExpr, LIE)
-
-tcMonoExpr (HsVar name) res_ty
- = tcId name `thenNF_Tc` \ (expr', lie, id_ty) ->
- unifyTauTy res_ty id_ty `thenTc_`
-
- -- Check that the result type doesn't have any nested for-alls.
- -- For example, a "build" on its own is no good; it must be
- -- applied to something.
- checkTc (isTauTy id_ty)
- (lurkingRank2Err name id_ty) `thenTc_`
-
- returnTc (expr', lie)
+tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
+ = tcHsSigType ExprSigCtxt poly_ty `thenTc` \ sig_tc_ty ->
+ tcAddErrCtxt (exprSigCtxt in_expr) $
+ tcExpr expr sig_tc_ty `thenTc` \ (expr', lie1) ->
+ tcSub res_ty sig_tc_ty `thenTc` \ (co_fn, lie2) ->
+ returnTc (co_fn <$> expr', lie1 `plusLIE` lie2)
\end{code}
-\begin{code}
-tcMonoExpr (HsIPVar name) res_ty
- = newIPDict (IPOcc name) name res_ty `thenNF_Tc` \ ip ->
- returnNF_Tc (HsIPVar (instToId ip), unitLIE ip)
-\end{code}
%************************************************************************
%* *
= tcMatchLambda match res_ty `thenTc` \ (match',lie) ->
returnTc (HsLam match', lie)
-tcMonoExpr (HsApp e1 e2) res_ty = accum e1 [e2]
- where
- accum (HsApp e1 e2) args = accum e1 (e2:args)
- accum fun args
- = tcApp fun args res_ty `thenTc` \ (fun', args', lie) ->
- returnTc (foldl HsApp fun' args', lie)
-
--- equivalent to (op e1) e2:
-tcMonoExpr (OpApp arg1 op fix arg2) res_ty
- = tcApp op [arg1,arg2] res_ty `thenTc` \ (op', [arg1', arg2'], lie) ->
- returnTc (OpApp arg1' op' fix arg2', lie)
+tcMonoExpr (HsApp e1 e2) res_ty
+ = tcApp e1 [e2] res_ty
\end{code}
Note that the operators in sections are expected to be binary, and
-- or just
-- op e
-tcMonoExpr in_expr@(SectionL arg op) res_ty
- = tcApp op [arg] res_ty `thenTc` \ (op', [arg'], lie) ->
-
- -- Check that res_ty is a function type
- -- Without this check we barf in the desugarer on
- -- f op = (3 `op`)
- -- because it tries to desugar to
- -- f op = \r -> 3 op r
- -- so (3 `op`) had better be a function!
- tcAddErrCtxt (sectionLAppCtxt in_expr) $
- unifyFunTy res_ty `thenTc_`
-
- returnTc (SectionL arg' op', lie)
+tcMonoExpr in_expr@(SectionL arg1 op) res_ty
+ = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
+ split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ tcArg op (arg1, arg1_ty, 1) `thenTc` \ (arg1',lie2) ->
+ tcAddErrCtxt (exprCtxt in_expr) $
+ tcSub res_ty (mkFunTy arg2_ty op_res_ty) `thenTc` \ (co_fn, lie3) ->
+ returnTc (co_fn <$> SectionL arg1' op', lie1 `plusLIE` lie2 `plusLIE` lie3)
-- Right sections, equivalent to \ x -> x op expr, or
-- \ x -> op x expr
-tcMonoExpr in_expr@(SectionR op expr) res_ty
- = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
- tcAddErrCtxt (sectionRAppCtxt in_expr) $
- split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
- tcMonoExpr expr arg2_ty `thenTc` \ (expr',lie2) ->
- unifyTauTy res_ty (mkFunTy arg1_ty op_res_ty) `thenTc_`
- returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
+tcMonoExpr in_expr@(SectionR op arg2) res_ty
+ = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
+ split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ tcArg op (arg2, arg2_ty, 2) `thenTc` \ (arg2',lie2) ->
+ tcAddErrCtxt (exprCtxt in_expr) $
+ tcSub res_ty (mkFunTy arg1_ty op_res_ty) `thenTc` \ (co_fn, lie3) ->
+ returnTc (co_fn <$> SectionR op' arg2', lie1 `plusLIE` lie2 `plusLIE` lie3)
+
+-- equivalent to (op e1) e2:
+
+tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty
+ = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
+ split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ tcArg op (arg1, arg1_ty, 1) `thenTc` \ (arg1',lie2a) ->
+ tcArg op (arg2, arg2_ty, 2) `thenTc` \ (arg2',lie2b) ->
+ tcAddErrCtxt (exprCtxt in_expr) $
+ tcSub res_ty op_res_ty `thenTc` \ (co_fn, lie3) ->
+ returnTc (OpApp arg1' op' fix arg2',
+ lie1 `plusLIE` lie2a `plusLIE` lie2b `plusLIE` lie3)
\end{code}
The interesting thing about @ccall@ is that it is just a template
%************************************************************************
%* *
-\subsection{Expressions type signatures}
+\subsection{Implicit Parameter bindings}
%* *
%************************************************************************
\begin{code}
-tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
- = tcHsSigType ExprSigCtxt poly_ty `thenTc` \ sig_tc_ty ->
-
- tcAddErrCtxt (exprSigCtxt in_expr) $
- if not (isQualifiedTy sig_tc_ty) then
- -- Easy case
- unifyTauTy sig_tc_ty res_ty `thenTc_`
- tcMonoExpr expr sig_tc_ty
-
- else -- Signature is polymorphic
- tcPolyExpr expr sig_tc_ty `thenTc` \ (_, _, expr, expr_ty, lie) ->
-
- -- Now match the signature type with res_ty.
- -- We must not do this earlier, because res_ty might well
- -- mention variables free in the environment, and we'd get
- -- bogus complaints about not being able to for-all the
- -- sig_tyvars
- unifyTauTy res_ty expr_ty `thenTc_`
-
- -- If everything is ok, return the stuff unchanged, except for
- -- the effect of any substutions etc. We simply discard the
- -- result of the tcSimplifyCheck (inside tcPolyExpr), except for any default
- -- resolution it may have done, which is recorded in the
- -- substitution.
- returnTc (expr, lie)
-\end{code}
-
-Implicit Parameter bindings.
-
-\begin{code}
tcMonoExpr (HsWith expr binds) res_ty
= tcMonoExpr expr res_ty `thenTc` \ (expr', expr_lie) ->
- mapAndUnzipTc tcIPBind binds `thenTc` \ (pairs, bind_lies) ->
+ mapAndUnzip3Tc tcIPBind binds `thenTc` \ (avail_ips, binds', bind_lies) ->
-- If the binding binds ?x = E, we must now
-- discharge any ?x constraints in expr_lie
- tcSimplifyIPs (map fst pairs) expr_lie `thenTc` \ (expr_lie', dict_binds) ->
+ tcSimplifyIPs avail_ips expr_lie `thenTc` \ (expr_lie', dict_binds) ->
let
- binds' = [(instToId ip, rhs) | (ip,rhs) <- pairs]
expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr'
in
returnTc (HsWith expr'' binds', expr_lie' `plusLIE` plusLIEs bind_lies)
-tcIPBind (name, expr)
+tcIPBind (ip, expr)
= newTyVarTy openTypeKind `thenTc` \ ty ->
tcGetSrcLoc `thenTc` \ loc ->
- newIPDict (IPBind name) name ty `thenNF_Tc` \ ip ->
+ newIPDict (IPBind ip) ip ty `thenNF_Tc` \ (ip', ip_inst) ->
tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
- returnTc ((ip, expr'), lie)
+ returnTc (ip_inst, (ip', expr'), lie)
\end{code}
%************************************************************************
tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
-> TcType -- Expected result type of application
- -> TcM (TcExpr, [TcExpr], -- Translated fun and args
- LIE)
+ -> TcM (TcExpr, LIE) -- Translated fun and args
+
+tcApp (HsApp e1 e2) args res_ty
+ = tcApp e1 (e2:args) res_ty -- Accumulate the arguments
tcApp fun args res_ty
= -- First type-check the function
) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
-- Unify with expected result before type-checking the args
+ -- so that the info from res_ty percolates to expected_arg_tys
-- This is when we might detect a too-few args situation
- tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
- unifyTauTy res_ty actual_result_ty
- ) `thenTc_`
+ tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
+ (tcSub res_ty actual_result_ty) `thenTc` \ (co_fn, lie_res) ->
-- Now typecheck the args
mapAndUnzipTc (tcArg fun)
(zip3 args expected_arg_tys [1..]) `thenTc` \ (args', lie_args_s) ->
- -- Check that the result type doesn't have any nested for-alls.
- -- For example, a "build" on its own is no good; it must be applied to something.
- checkTc (isTauTy actual_result_ty)
- (lurkingRank2Err fun actual_result_ty) `thenTc_`
-
- returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
+ returnTc (co_fn <$> foldl HsApp fun' args',
+ lie_res `plusLIE` lie_fun `plusLIE` plusLIEs lie_args_s)
-- If an error happens we try to figure out whether the
split_fun_ty :: TcType -- The type of the function
- -> Int -- Number of arguments
+ -> Int -- Number of arguments
-> TcM ([TcType], -- Function argument types
- TcType) -- Function result types
+ TcType) -- Function result types
split_fun_ty fun_ty 0
= returnTc ([], fun_ty)
\end{code}
\begin{code}
-tcArg :: RenamedHsExpr -- The function (for error messages)
- -> (RenamedHsExpr, TcType, Int) -- Actual argument and expected arg type
- -> TcM (TcExpr, LIE) -- Resulting argument and LIE
+tcArg :: RenamedHsExpr -- The function (for error messages)
+ -> (RenamedHsExpr, TcSigmaType, Int) -- Actual argument and expected arg type
+ -> TcM (TcExpr, LIE) -- Resulting argument and LIE
tcArg the_fun (arg, expected_arg_ty, arg_no)
= tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
-- The caller of tcRecordBinds has already checked
-- that all the fields come from the same type
- tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
+ tcExpr rhs field_ty `thenTc` \ (rhs', lie) ->
returnTc ((sel_id, rhs', pun_flag), lie)
predCtxt expr
= hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
-sectionRAppCtxt expr
- = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
-
-sectionLAppCtxt expr
- = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
+exprCtxt expr
+ = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
funAppCtxt fun arg arg_no
= hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
import TcMonad
-import TcEnv ( newLocalId )
+import TcEnv ( newLocalName )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl )
-import TcExpr ( tcPolyExpr )
+import TcExpr ( tcExpr )
import Inst ( emptyLIE, LIE, plusLIE )
import ErrUtils ( Message )
tcAddErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty ->
- tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) ->
+ tcExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie) ->
tcCheckFEType sig_ty spec `thenTc_`
-- than its declared/inferred type. Hence the need
-- to create a local binding which will call the exported function
-- at a particular type (and, maybe, overloading).
- newLocalId (nameOccName nm) sig_ty src_loc `thenNF_Tc` \ id ->
+ newLocalName nm `thenNF_Tc` \ id_name ->
let
- bind = VarMonoBind id rhs
+ id = mkLocalId id_name sig_ty
+ bind = VarMonoBind id rhs
in
returnTc (lie, bind, ForeignExport id undefined spec src_loc)
\end{code}
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
+ simpleHsLitTy,
- collectTypedPatBinders, outPatType,
+ collectTypedPatBinders, outPatType,
-- re-exported from TcEnv
TcId,
import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
import TcMonad
-import Type ( Type )
+import TypeRep ( IPName(..) ) -- For zonking
+import Type ( Type, ipNameName )
+import TcType ( TcType )
import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
-import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
+import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
+ doublePrimTy, addrPrimTy
+ )
+import TysWiredIn ( charTy, stringTy, intTy, integerTy,
+ mkListTy, mkTupleTy, unitTy )
import CoreSyn ( Expr )
import Var ( isId )
import BasicTypes ( RecFlag(..), Boxity(..) )
\end{code}
+------------------------------------------------------
+\begin{code}
+simpleHsLitTy :: HsLit -> TcType
+simpleHsLitTy (HsCharPrim c) = charPrimTy
+simpleHsLitTy (HsStringPrim s) = addrPrimTy
+simpleHsLitTy (HsInt i) = intTy
+simpleHsLitTy (HsInteger i) = integerTy
+simpleHsLitTy (HsIntPrim i) = intPrimTy
+simpleHsLitTy (HsFloatPrim f) = floatPrimTy
+simpleHsLitTy (HsDoublePrim d) = doublePrimTy
+simpleHsLitTy (HsChar c) = charTy
+simpleHsLitTy (HsString str) = stringTy
+\end{code}
+
+
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
outPatType (ListPat ty _) = mkListTy ty
outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
outPatType (RecPat _ ty _ _ _) = ty
+outPatType (SigPat _ ty _) = ty
outPatType (LitPat lit ty) = ty
outPatType (NPat lit ty _) = ty
outPatType (NPlusKPat _ _ ty _ _) = ty
collectTypedPatBinders (VarPat var) = [var]
collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
+collectTypedPatBinders (SigPat pat _ _) = collectTypedPatBinders pat
collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
returnNF_Tc (HsVar id')
zonkExpr (HsIPVar id)
- = zonkIdOcc id `thenNF_Tc` \ id' ->
+ = mapIPNameTc zonkIdOcc id `thenNF_Tc` \ id' ->
returnNF_Tc (HsIPVar id')
zonkExpr (HsLit (HsRat f ty))
zonkExpr (HsWith expr binds)
= zonkIPBinds binds `thenNF_Tc` \ new_binds ->
- tcExtendGlobalValEnv (map fst new_binds) $
+ tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $
zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsWith new_expr new_binds)
where
zonkIPBinds = mapNF_Tc zonkIPBind
- zonkIPBind (n, e) =
- zonkIdBndr n `thenNF_Tc` \ n' ->
- zonkExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (n', e')
+ zonkIPBind (n, e)
+ = mapIPNameTc zonkIdBndr n `thenNF_Tc` \ n' ->
+ zonkExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (n', e')
zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
= zonkExpr expr `thenNF_Tc` \ new_expr ->
zonkIdOcc field `thenNF_Tc` \ new_field ->
returnNF_Tc (new_field, new_expr, pun)
+
+-------------------------------------------------------------------------
+mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
+mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
+mapIPNameTc f (MustSplit n) = f n `thenNF_Tc` \ r -> returnNF_Tc (MustSplit r)
\end{code}
+
%************************************************************************
%* *
\subsection[BackSubst-Pats]{Patterns}
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (LitPat lit new_ty, emptyBag)
+zonkPat (SigPat pat ty expr)
+ = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (SigPat new_pat new_ty new_expr, ids)
+
zonkPat (NPat lit ty expr)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
zonkExpr expr `thenNF_Tc` \ new_expr ->
)
import InstEnv ( InstEnv, extendInstEnv )
import PprType ( pprClassPred )
-import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType, checkSigTyVars )
+import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType )
+import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck )
import HscTypes ( HomeSymbolTable, DFunId,
ModDetails(..), PackageInstEnv, PersistentRenamerState
import Subst ( substTy, substTheta )
import DataCon ( classDataCon )
-import Class ( Class, DefMeth(..), classBigSig )
+import Class ( Class, classBigSig )
import Var ( idName, idType )
import VarSet ( emptyVarSet )
import Id ( setIdLocalExported )
\begin{code}
module TcMType (
- TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcRhoType, TcTyVarSet,
+ TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,
--------------------------------
-- Creating new mutable type variables
- newTyVar,
+ newTyVar, newHoleTyVarTy,
newTyVarTy, -- Kind -> NF_TcM TcType
newTyVarTys, -- Int -> Kind -> NF_TcM [TcType]
newKindVar, newKindVars, newBoxityVar,
+ putTcTyVar, getTcTyVar,
--------------------------------
-- Instantiation
checkValidInstHead, instTypeErr,
--------------------------------
- -- Unification
- unifyTauTy, unifyTauTyList, unifyTauTyLists,
- unifyFunTy, unifyListTy, unifyTupleTy,
- unifyKind, unifyKinds, unifyOpenTypeKind,
-
- --------------------------------
-- Zonking
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcSigTyVars,
zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
-- friends:
import TypeRep ( Type(..), SourceType(..), TyNote(..), -- Friend; can see representation
- Kind, TauType, ThetaType,
- openKindCon, typeCon
+ Kind, ThetaType
)
-import TcType ( TcType, TcRhoType, TcThetaType, TcTauType, TcPredType,
+import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..),
tcEqType, tcCmpPred,
tcSplitRhoTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
- tcSplitTyConApp_maybe, tcSplitFunTy_maybe, tcSplitForAllTys,
+ tcSplitTyConApp_maybe, tcSplitForAllTys,
tcGetTyVar, tcIsTyVarTy, tcSplitSigmaTy,
- isUnLiftedType, isIPPred, isUserTyVar, isSkolemTyVar,
+ isUnLiftedType, isIPPred,
- mkAppTy, mkTyVarTy, mkTyVarTys, mkFunTy, mkTyConApp,
+ mkAppTy, mkTyVarTy, mkTyVarTys,
tyVarsOfPred, getClassPredTys_maybe,
- liftedTypeKind, unliftedTypeKind, openTypeKind, defaultKind, superKind,
- superBoxity, liftedBoxity, hasMoreBoxityInfo, typeKind,
- tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyOpenTyVar,
+ liftedTypeKind, openTypeKind, defaultKind, superKind,
+ superBoxity, liftedBoxity, typeKind,
+ tyVarsOfType, tyVarsOfTypes,
eqKind, isTypeKind,
isFFIArgumentTy, isFFIImportResultTy
import Subst ( Subst, mkTopTyVarSubst, substTy )
import Class ( classArity, className )
import TyCon ( TyCon, mkPrimTyCon, isSynTyCon, isUnboxedTupleTyCon,
- isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName )
+ tyConArity, tyConName )
import PrimRep ( PrimRep(VoidRep) )
-import Var ( TyVar, varName, tyVarKind, tyVarName, isTyVar, mkTyVar,
- isMutTyVar, mutTyVarDetails )
+import Var ( TyVar, tyVarKind, tyVarName, isTyVar, mkTyVar, isMutTyVar )
-- others:
import TcMonad -- TcType, amongst others
-import TysWiredIn ( voidTy, listTyCon, mkListTy, mkTupleTy )
+import TysWiredIn ( voidTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import ForeignCall ( Safety(..) )
import FunDeps ( grow )
import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred )
import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName,
- mkLocalName, mkDerivedTyConOcc, isSystemName
+ mkLocalName, mkDerivedTyConOcc
)
import VarSet
-import BasicTypes ( Boxity, Arity, isBoxed )
import CmdLineOpts ( dopt, DynFlag(..) )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
= newTyVar kind `thenNF_Tc` \ tc_tyvar ->
returnNF_Tc (TyVarTy tc_tyvar)
+newHoleTyVarTy :: NF_TcM TcType
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ tcNewMutTyVar (mkSysLocalName uniq SLIT("h")) openTypeKind HoleTv `thenNF_Tc` \ tv ->
+ returnNF_Tc (TyVarTy tv)
+
newTyVarTys :: Int -> Kind -> NF_TcM [TcType]
newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind)
zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta
zonkTcPredType :: TcPredType -> NF_TcM TcPredType
-zonkTcPredType (ClassP c ts) =
- zonkTcTypes ts `thenNF_Tc` \ new_ts ->
+zonkTcPredType (ClassP c ts)
+ = zonkTcTypes ts `thenNF_Tc` \ new_ts ->
returnNF_Tc (ClassP c new_ts)
-zonkTcPredType (IParam n t) =
- zonkTcType t `thenNF_Tc` \ new_t ->
+zonkTcPredType (IParam n t)
+ = zonkTcType t `thenNF_Tc` \ new_t ->
returnNF_Tc (IParam n new_t)
\end{code}
returnNF_Tc (ClassP c tys')
go_pred (NType tc tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
returnNF_Tc (NType tc tys')
- go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (IParam n ty')
+ go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (IParam n ty')
zonkTyVar :: (TcTyVar -> NF_TcM Type) -- What to do for an unbound mutable variable
-> TcTyVar -> NF_TcM TcType
checkValidType ctxt ty
= doptsTc Opt_GlasgowExts `thenNF_Tc` \ gla_exts ->
let
- rank = case ctxt of
- GenPatCtxt -> 0
- PatSigCtxt -> 0
- ResSigCtxt -> 0
- ExprSigCtxt -> 1
- FunSigCtxt _ | gla_exts -> 2
- | otherwise -> 1
- ConArgCtxt _ | gla_exts -> 2 -- We are given the type of the entire
- | otherwise -> 1 -- constructor; hence rank 1 is ok
- TySynCtxt _ | gla_exts -> 1
- | otherwise -> 0
- ForSigCtxt _ -> 1
- RuleSigCtxt _ -> 1
+ rank | gla_exts = Arbitrary
+ | otherwise
+ = case ctxt of -- Haskell 98
+ GenPatCtxt -> Rank 0
+ PatSigCtxt -> Rank 0
+ ResSigCtxt -> Rank 0
+ TySynCtxt _ -> Rank 0
+ ExprSigCtxt -> Rank 1
+ FunSigCtxt _ -> Rank 1
+ ConArgCtxt _ -> Rank 1 -- We are given the type of the entire
+ -- constructor, hence rank 1
+ ForSigCtxt _ -> Rank 1
+ RuleSigCtxt _ -> Rank 1
actual_kind = typeKind ty
\begin{code}
-type Rank = Int
+data Rank = Rank Int | Arbitrary
+
+decRank :: Rank -> Rank
+decRank Arbitrary = Arbitrary
+decRank (Rank n) = Rank (n-1)
+
check_poly_type :: Rank -> Type -> TcM ()
+check_poly_type (Rank 0) ty
+ = check_tau_type (Rank 0) False ty
+
check_poly_type rank ty
- | rank == 0
- = check_tau_type 0 False ty
- | otherwise -- rank > 0
= let
(tvs, theta, tau) = tcSplitSigmaTy ty
in
- check_valid_theta SigmaCtxt theta `thenTc_`
- check_tau_type (rank-1) False tau `thenTc_`
+ check_valid_theta SigmaCtxt theta `thenTc_`
+ check_tau_type (decRank rank) False tau `thenTc_`
checkAmbiguity tvs theta tau
----------------------------------------
-- Question: what about nested unboxed tuples?
-- Currently rejected.
check_arg_type ty
- = check_tau_type 0 False ty `thenTc_`
+ = check_tau_type (Rank 0) False ty `thenTc_`
checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty)
----------------------------------------
| isUnboxedTupleTyCon tc
= checkTc ubx_tup_ok ubx_tup_msg `thenTc_`
- mapTc_ (check_tau_type 0 True) tys -- Args are allowed to be unlifted, or
+ mapTc_ (check_tau_type (Rank 0) True) tys -- Args are allowed to be unlifted, or
-- more unboxed tuples, so can't use check_arg_ty
| otherwise
----------------------------------------
check_note (FTVNote _) = returnTc ()
-check_note (SynNote ty) = check_tau_type 0 False ty
+check_note (SynNote ty) = check_tau_type (Rank 0) False ty
\end{code}
Check for ambiguity
(see is_ambig).
\begin{code}
-checkAmbiguity :: [TyVar] -> ThetaType -> TauType -> TcM ()
+checkAmbiguity :: [TyVar] -> ThetaType -> Type -> TcM ()
checkAmbiguity forall_tyvars theta tau
= mapTc_ check_pred theta `thenTc_`
returnTc ()
InstThetaCtxt -> dopt Opt_AllowUndecidableInstances dflags
other -> dopt Opt_GlasgowExts dflags
-check_source_ty dflags SigmaCtxt (IParam name ty) = check_arg_type ty
+check_source_ty dflags SigmaCtxt (IParam _ ty) = check_arg_type ty
-- Implicit parameters only allows in type
-- signatures; not in instance decls, superclasses etc
-- The reason for not allowing implicit params in instances is a bit subtle
\end{code}
-%************************************************************************
-%* *
-\subsection{Kind unification}
-%* *
-%************************************************************************
-
-\begin{code}
-unifyKind :: TcKind -- Expected
- -> TcKind -- Actual
- -> TcM ()
-unifyKind k1 k2
- = tcAddErrCtxtM (unifyCtxt "kind" k1 k2) $
- uTys k1 k1 k2 k2
-
-unifyKinds :: [TcKind] -> [TcKind] -> TcM ()
-unifyKinds [] [] = returnTc ()
-unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenTc_`
- unifyKinds ks1 ks2
-unifyKinds _ _ = panic "unifyKinds: length mis-match"
-\end{code}
-
-\begin{code}
-unifyOpenTypeKind :: TcKind -> TcM ()
--- Ensures that the argument kind is of the form (Type bx)
--- for some boxity bx
-
-unifyOpenTypeKind ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty' -> unifyOpenTypeKind ty'
- other -> unify_open_kind_help ty
-
-unifyOpenTypeKind ty
- | isTypeKind ty = returnTc ()
- | otherwise = unify_open_kind_help ty
-
-unify_open_kind_help ty -- Revert to ordinary unification
- = newBoxityVar `thenNF_Tc` \ boxity ->
- unifyKind ty (mkTyConApp typeCon [boxity])
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Unify-exported]{Exported unification functions}
-%* *
-%************************************************************************
-
-The exported functions are all defined as versions of some
-non-exported generic functions.
-
-Unify two @TauType@s. Dead straightforward.
-
-\begin{code}
-unifyTauTy :: TcTauType -> TcTauType -> TcM ()
-unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred
- = tcAddErrCtxtM (unifyCtxt "type" ty1 ty2) $
- uTys ty1 ty1 ty2 ty2
-\end{code}
-
-@unifyTauTyList@ unifies corresponding elements of two lists of
-@TauType@s. It uses @uTys@ to do the real work. The lists should be
-of equal length. We charge down the list explicitly so that we can
-complain if their lengths differ.
-
-\begin{code}
-unifyTauTyLists :: [TcTauType] -> [TcTauType] -> TcM ()
-unifyTauTyLists [] [] = returnTc ()
-unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenTc_`
- unifyTauTyLists tys1 tys2
-unifyTauTyLists ty1s ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!"
-\end{code}
-
-@unifyTauTyList@ takes a single list of @TauType@s and unifies them
-all together. It is used, for example, when typechecking explicit
-lists, when all the elts should be of the same type.
-
-\begin{code}
-unifyTauTyList :: [TcTauType] -> TcM ()
-unifyTauTyList [] = returnTc ()
-unifyTauTyList [ty] = returnTc ()
-unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenTc_`
- unifyTauTyList tys
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Unify-uTys]{@uTys@: getting down to business}
-%* *
-%************************************************************************
-
-@uTys@ is the heart of the unifier. Each arg happens twice, because
-we want to report errors in terms of synomyms if poss. The first of
-the pair is used in error messages only; it is always the same as the
-second, except that if the first is a synonym then the second may be a
-de-synonym'd version. This way we get better error messages.
-
-We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''.
-
-\begin{code}
-uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1
- -- ty1 is the *expected* type
-
- -> TcTauType -> TcTauType -- Error reporting ty2 and real ty2
- -- ty2 is the *actual* type
- -> TcM ()
-
- -- Always expand synonyms (see notes at end)
- -- (this also throws away FTVs)
-uTys ps_ty1 (NoteTy n1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
-uTys ps_ty1 ty1 ps_ty2 (NoteTy n2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
-
- -- Ignore usage annotations inside typechecker
-uTys ps_ty1 (UsageTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
-uTys ps_ty1 ty1 ps_ty2 (UsageTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
-
- -- Variables; go for uVar
-uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2
-uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1
- -- "True" means args swapped
-
- -- Predicates
-uTys _ (SourceTy (IParam n1 t1)) _ (SourceTy (IParam n2 t2))
- | n1 == n2 = uTys t1 t1 t2 t2
-uTys _ (SourceTy (ClassP c1 tys1)) _ (SourceTy (ClassP c2 tys2))
- | c1 == c2 = unifyTauTyLists tys1 tys2
-uTys _ (SourceTy (NType tc1 tys1)) _ (SourceTy (NType tc2 tys2))
- | tc1 == tc2 = unifyTauTyLists tys1 tys2
-
- -- Functions; just check the two parts
-uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2)
- = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2
-
- -- Type constructors must match
-uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2)
- | con1 == con2 && equalLength tys1 tys2
- = unifyTauTyLists tys1 tys2
-
- | con1 == openKindCon
- -- When we are doing kind checking, we might match a kind '?'
- -- against a kind '*' or '#'. Notably, CCallable :: ? -> *, and
- -- (CCallable Int) and (CCallable Int#) are both OK
- = unifyOpenTypeKind ps_ty2
-
- -- Applications need a bit of care!
- -- They can match FunTy and TyConApp, so use splitAppTy_maybe
- -- NB: we've already dealt with type variables and Notes,
- -- so if one type is an App the other one jolly well better be too
-uTys ps_ty1 (AppTy s1 t1) ps_ty2 ty2
- = case tcSplitAppTy_maybe ty2 of
- Just (s2,t2) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
- Nothing -> unifyMisMatch ps_ty1 ps_ty2
-
- -- Now the same, but the other way round
- -- Don't swap the types, because the error messages get worse
-uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2)
- = case tcSplitAppTy_maybe ty1 of
- Just (s1,t1) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
- Nothing -> unifyMisMatch ps_ty1 ps_ty2
-
- -- Not expecting for-alls in unification
- -- ... but the error message from the unifyMisMatch more informative
- -- than a panic message!
-
- -- Anything else fails
-uTys ps_ty1 ty1 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2
-\end{code}
-
-
-Notes on synonyms
-~~~~~~~~~~~~~~~~~
-If you are tempted to make a short cut on synonyms, as in this
-pseudocode...
-
-\begin{verbatim}
--- NO uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2)
--- NO = if (con1 == con2) then
--- NO -- Good news! Same synonym constructors, so we can shortcut
--- NO -- by unifying their arguments and ignoring their expansions.
--- NO unifyTauTypeLists args1 args2
--- NO else
--- NO -- Never mind. Just expand them and try again
--- NO uTys ty1 ty2
-\end{verbatim}
-
-then THINK AGAIN. Here is the whole story, as detected and reported
-by Chris Okasaki \tr{<Chris_Okasaki@loch.mess.cs.cmu.edu>}:
-\begin{quotation}
-Here's a test program that should detect the problem:
-
-\begin{verbatim}
- type Bogus a = Int
- x = (1 :: Bogus Char) :: Bogus Bool
-\end{verbatim}
-
-The problem with [the attempted shortcut code] is that
-\begin{verbatim}
- con1 == con2
-\end{verbatim}
-is not a sufficient condition to be able to use the shortcut!
-You also need to know that the type synonym actually USES all
-its arguments. For example, consider the following type synonym
-which does not use all its arguments.
-\begin{verbatim}
- type Bogus a = Int
-\end{verbatim}
-
-If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool},
-the unifier would blithely try to unify \tr{Char} with \tr{Bool} and
-would fail, even though the expanded forms (both \tr{Int}) should
-match.
-
-Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would
-unnecessarily bind \tr{t} to \tr{Char}.
-
-... You could explicitly test for the problem synonyms and mark them
-somehow as needing expansion, perhaps also issuing a warning to the
-user.
-\end{quotation}
-
-
-%************************************************************************
-%* *
-\subsection[Unify-uVar]{@uVar@: unifying with a type variable}
-%* *
-%************************************************************************
-
-@uVar@ is called when at least one of the types being unified is a
-variable. It does {\em not} assume that the variable is a fixed point
-of the substitution; rather, notice that @uVar@ (defined below) nips
-back into @uTys@ if it turns out that the variable is already bound.
-
-\begin{code}
-uVar :: Bool -- False => tyvar is the "expected"
- -- True => ty is the "expected" thing
- -> TcTyVar
- -> TcTauType -> TcTauType -- printing and real versions
- -> TcM ()
-
-uVar swapped tv1 ps_ty2 ty2
- = getTcTyVar tv1 `thenNF_Tc` \ maybe_ty1 ->
- case maybe_ty1 of
- Just ty1 | swapped -> uTys ps_ty2 ty2 ty1 ty1 -- Swap back
- | otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order
- other -> uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2
-
- -- Expand synonyms; ignore FTVs
-uUnboundVar swapped tv1 maybe_ty1 ps_ty2 (NoteTy n2 ty2)
- = uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2
-
-
- -- The both-type-variable case
-uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2)
-
- -- Same type variable => no-op
- | tv1 == tv2
- = returnTc ()
-
- -- Distinct type variables
- -- ASSERT maybe_ty1 /= Just
- | otherwise
- = getTcTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
- case maybe_ty2 of
- Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2'
-
- Nothing | update_tv2
-
- -> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) )
- putTcTyVar tv2 (TyVarTy tv1) `thenNF_Tc_`
- returnTc ()
- | otherwise
-
- -> WARN( not (k2 `hasMoreBoxityInfo` k1), (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) )
- (putTcTyVar tv1 ps_ty2 `thenNF_Tc_`
- returnTc ())
- where
- k1 = tyVarKind tv1
- k2 = tyVarKind tv2
- update_tv2 = (k2 `eqKind` openTypeKind) || (not (k1 `eqKind` openTypeKind) && nicer_to_update_tv2)
- -- Try to get rid of open type variables as soon as poss
-
- nicer_to_update_tv2 = isUserTyVar (mutTyVarDetails tv1)
- -- Don't unify a signature type variable if poss
- || isSystemName (varName tv2)
- -- Try to update sys-y type variables in preference to sig-y ones
-
- -- Second one isn't a type variable
-uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2
- = -- Check that the kinds match
- checkKinds swapped tv1 non_var_ty2 `thenTc_`
-
- -- Check that tv1 isn't a type-signature type variable
- checkTcM (not (isSkolemTyVar (mutTyVarDetails tv1)))
- (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenTc_`
-
- -- Check that we aren't losing boxity info (shouldn't happen)
- warnTc (not (typeKind non_var_ty2 `hasMoreBoxityInfo` tyVarKind tv1))
- ((ppr tv1 <+> ppr (tyVarKind tv1)) $$
- (ppr non_var_ty2 <+> ppr (typeKind non_var_ty2))) `thenNF_Tc_`
-
- -- Occurs check
- -- Basically we want to update tv1 := ps_ty2
- -- because ps_ty2 has type-synonym info, which improves later error messages
- --
- -- But consider
- -- type A a = ()
- --
- -- f :: (A a -> a -> ()) -> ()
- -- f = \ _ -> ()
- --
- -- x :: ()
- -- x = f (\ x p -> p x)
- --
- -- In the application (p x), we try to match "t" with "A t". If we go
- -- ahead and bind t to A t (= ps_ty2), we'll lead the type checker into
- -- an infinite loop later.
- -- But we should not reject the program, because A t = ().
- -- Rather, we should bind t to () (= non_var_ty2).
- --
- -- That's why we have this two-state occurs-check
- zonkTcType ps_ty2 `thenNF_Tc` \ ps_ty2' ->
- if not (tv1 `elemVarSet` tyVarsOfType ps_ty2') then
- putTcTyVar tv1 ps_ty2' `thenNF_Tc_`
- returnTc ()
- else
- zonkTcType non_var_ty2 `thenNF_Tc` \ non_var_ty2' ->
- if not (tv1 `elemVarSet` tyVarsOfType non_var_ty2') then
- -- This branch rarely succeeds, except in strange cases
- -- like that in the example above
- putTcTyVar tv1 non_var_ty2' `thenNF_Tc_`
- returnTc ()
- else
- failWithTcM (unifyOccurCheck tv1 ps_ty2')
-
-
-checkKinds swapped tv1 ty2
--- We're about to unify a type variable tv1 with a non-tyvar-type ty2.
--- We need to check that we don't unify a lifted type variable with an
--- unlifted type: e.g. (id 3#) is illegal
- | tk1 `eqKind` liftedTypeKind && tk2 `eqKind` unliftedTypeKind
- = tcAddErrCtxtM (unifyKindCtxt swapped tv1 ty2) $
- unifyMisMatch k1 k2
- | otherwise
- = returnTc ()
- where
- (k1,k2) | swapped = (tk2,tk1)
- | otherwise = (tk1,tk2)
- tk1 = tyVarKind tv1
- tk2 = typeKind ty2
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Unify-fun]{@unifyFunTy@}
-%* *
-%************************************************************************
-
-@unifyFunTy@ is used to avoid the fruitless creation of type variables.
-
-\begin{code}
-unifyFunTy :: TcType -- Fail if ty isn't a function type
- -> TcM (TcType, TcType) -- otherwise return arg and result types
-
-unifyFunTy ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty' -> unifyFunTy ty'
- other -> unify_fun_ty_help ty
-
-unifyFunTy ty
- = case tcSplitFunTy_maybe ty of
- Just arg_and_res -> returnTc arg_and_res
- Nothing -> unify_fun_ty_help ty
-
-unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification
- = newTyVarTy openTypeKind `thenNF_Tc` \ arg ->
- newTyVarTy openTypeKind `thenNF_Tc` \ res ->
- unifyTauTy ty (mkFunTy arg res) `thenTc_`
- returnTc (arg,res)
-\end{code}
-
-\begin{code}
-unifyListTy :: TcType -- expected list type
- -> TcM TcType -- list element type
-
-unifyListTy ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty' -> unifyListTy ty'
- other -> unify_list_ty_help ty
-
-unifyListTy ty
- = case tcSplitTyConApp_maybe ty of
- Just (tycon, [arg_ty]) | tycon == listTyCon -> returnTc arg_ty
- other -> unify_list_ty_help ty
-
-unify_list_ty_help ty -- Revert to ordinary unification
- = newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
- unifyTauTy ty (mkListTy elt_ty) `thenTc_`
- returnTc elt_ty
-\end{code}
-
-\begin{code}
-unifyTupleTy :: Boxity -> Arity -> TcType -> TcM [TcType]
-unifyTupleTy boxity arity ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty' -> unifyTupleTy boxity arity ty'
- other -> unify_tuple_ty_help boxity arity ty
-
-unifyTupleTy boxity arity ty
- = case tcSplitTyConApp_maybe ty of
- Just (tycon, arg_tys)
- | isTupleTyCon tycon
- && tyConArity tycon == arity
- && tupleTyConBoxity tycon == boxity
- -> returnTc arg_tys
- other -> unify_tuple_ty_help boxity arity ty
-
-unify_tuple_ty_help boxity arity ty
- = newTyVarTys arity kind `thenNF_Tc` \ arg_tys ->
- unifyTauTy ty (mkTupleTy boxity arity arg_tys) `thenTc_`
- returnTc arg_tys
- where
- kind | isBoxed boxity = liftedTypeKind
- | otherwise = openTypeKind
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Unify-context]{Errors and contexts}
-%* *
-%************************************************************************
-
-Errors
-~~~~~~
-
-\begin{code}
-unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred
- = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
- zonkTcType ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (err ty1' ty2')
- where
- err ty1 ty2 = (env1,
- nest 4
- (vcat [
- text "Expected" <+> text s <> colon <+> ppr tidy_ty1,
- text "Inferred" <+> text s <> colon <+> ppr tidy_ty2
- ]))
- where
- (env1, [tidy_ty1,tidy_ty2]) = tidyOpenTypes tidy_env [ty1,ty2]
-
-unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 inferred
- -- tv1 is zonked already
- = zonkTcType ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (err ty2')
- where
- err ty2 = (env2, ptext SLIT("When matching types") <+>
- sep [quotes pp_expected, ptext SLIT("and"), quotes pp_actual])
- where
- (pp_expected, pp_actual) | swapped = (pp2, pp1)
- | otherwise = (pp1, pp2)
- (env1, tv1') = tidyOpenTyVar tidy_env tv1
- (env2, ty2') = tidyOpenType env1 ty2
- pp1 = ppr tv1'
- pp2 = ppr ty2'
-
-unifyMisMatch ty1 ty2
- = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
- zonkTcType ty2 `thenNF_Tc` \ ty2' ->
- let
- (env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2']
- msg = hang (ptext SLIT("Couldn't match"))
- 4 (sep [quotes (ppr tidy_ty1),
- ptext SLIT("against"),
- quotes (ppr tidy_ty2)])
- in
- failWithTcM (env, msg)
-
-unifyWithSigErr tyvar ty
- = (env2, hang (ptext SLIT("Cannot unify the type-signature variable") <+> quotes (ppr tidy_tyvar))
- 4 (ptext SLIT("with the type") <+> quotes (ppr tidy_ty)))
- where
- (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar
- (env2, tidy_ty) = tidyOpenType env1 ty
-
-unifyOccurCheck tyvar ty
- = (env2, hang (ptext SLIT("Occurs check: cannot construct the infinite type:"))
- 4 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty]))
- where
- (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar
- (env2, tidy_ty) = tidyOpenType env1 ty
-\end{code}
import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
import TcMonad
-import TcMonoType ( tcAddScopedTyVars, checkSigTyVars, tcHsSigType, UserTypeCtxt(..), sigPatCtxt )
+import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv, tcExtendGlobalTyVars )
import TcPat ( tcPat, tcMonoPatBndr, polyPatSig )
-import TcMType ( newTyVarTy, unifyFunTy, unifyTauTy )
+import TcMType ( newTyVarTy )
import TcType ( TcType, TcTyVar, tyVarsOfType, isTauTy,
mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind )
import TcBinds ( tcBindsAndThen )
+import TcUnify ( subFunTy, unifyTauTy, checkSigTyVars, sigPatCtxt )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import Name ( Name )
import TysWiredIn ( boolTy )
-- because inconsistency between branches
-- may show up as something wrong with the (non-existent) type signature
- -- No need to zonk expected_ty, because unifyFunTy does that on the fly
+ -- No need to zonk expected_ty, because subFunTy does that on the fly
tcMatches xve (FunRhs fun_name) matches expected_ty
\end{code}
= returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
tc_match_pats (pat:pats) expected_ty
- = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
+ = subFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
+ -- This is the unique place we call subFunTy
+ -- The point is that if expected_y is a "hole", we want
+ -- to make arg_ty and rest_ty as "holes" too.
tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
tc_match_pats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
returnTc ( rhs_ty,
import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
- isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch, placeHolderType
+ isIfaceRuleDecl, nullBinds, mkSimpleMatch, placeHolderType
)
import PrelNames ( mAIN_Name, mainName, ioTyConName, printName,
returnIOName, bindIOName, failIOName,
import MkIface ( pprModDetails )
import TcExpr ( tcMonoExpr )
import TcMonad
-import TcMType ( unifyTauTy, newTyVarTy, zonkTcType, tcInstType )
+import TcMType ( newTyVarTy, zonkTcType, tcInstType )
import TcType ( Type, liftedTypeKind, openTypeKind,
tyVarsOfType, tidyType, tcFunResultTy,
mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
+import TcUnify ( unifyTauTy )
import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
import TcTyClsDecls ( tcTyAndClassDecls )
-import CoreUnfold ( unfoldingTemplate, hasUnfolding )
+import CoreUnfold ( unfoldingTemplate )
import TysWiredIn ( mkListTy, unitTy )
import ErrUtils ( printErrorsAndWarnings, errorsFound,
dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
PackageTypeEnv, ModIface(..),
ModDetails(..), DFunId,
TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts,
- TyThing(..),
mkTypeEnv
)
\end{code}
import HsLit ( HsOverLit )
import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
-import TcType ( Type, Kind, TyVarDetails )
+import TcType ( Type, Kind, TyVarDetails, IPName )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
import Bag ( Bag, emptyBag, isEmptyBag,
data InstOrigin
= OccurrenceOf Id -- Occurrence of an overloaded identifier
- | IPOcc Name -- Occurrence of an implicit parameter
- | IPBind Name -- Binding site of an implicit parameter
+ | IPOcc (IPName Name) -- Occurrence of an implicit parameter
+ | IPBind (IPName Name) -- Binding site of an implicit parameter
| RecordUpdOrigin
kcHsLiftedSigType, kcHsContext,
tcAddScopedTyVars, tcHsTyVars, mkImmutTyVars,
- TcSigInfo(..), tcTySig, mkTcSig, maybeSig,
- checkSigTyVars, sigCtxt, sigPatCtxt
+ TcSigInfo(..), tcTySig, mkTcSig, maybeSig
) where
#include "HsVersions.h"
import TcMonad
import TcEnv ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal,
- tcGetGlobalTyVars, tcLEnvElts, tcInLocalScope,
+ tcInLocalScope,
TyThing(..), TcTyThing(..), tcExtendKindEnv
)
-import TcMType ( newKindVar, tcInstSigTyVars,
- zonkKindEnv, zonkTcType, zonkTcTyVars, zonkTcTyVar,
- unifyKind, unifyOpenTypeKind,
+import TcMType ( newKindVar, tcInstSigTyVars, zonkKindEnv,
checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
)
+import TcUnify ( unifyKind, unifyOpenTypeKind )
import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
- TcTyVar, TcTyVarSet, TcKind, TcThetaType, TcTauType,
+ TcTyVar, TcKind, TcThetaType, TcTauType,
mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
tcSplitForAllTys, tcSplitRhoTy,
- hoistForAllTys, allDistinctTyVars, zipFunTys,
- mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys, mkRhoTy,
+ hoistForAllTys, zipFunTys,
+ mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys,
liftedTypeKind, unliftedTypeKind, mkArrowKind,
- mkArrowKinds, tcGetTyVar_maybe, tcGetTyVar, tcSplitFunTy_maybe,
- tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
- tyVarsOfType, mkForAllTys
+ mkArrowKinds, tcSplitFunTy_maybe
)
-import qualified Type ( getTyVar_maybe )
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
-import PprType ( pprType )
import Subst ( mkTopTyVarSubst, substTy )
-import CoreFVs ( idFreeTyVars )
import Id ( mkLocalId, idName, idType )
-import Var ( Var, TyVar, mkTyVar, tyVarKind, isMutTyVar, mutTyVarDetails )
-import VarEnv
-import VarSet
+import Var ( TyVar, mkTyVar, tyVarKind )
import ErrUtils ( Message )
import TyCon ( TyCon, isSynTyCon, tyConKind )
import Class ( classTyCon )
-import Name ( Name, getSrcLoc )
+import Name ( Name )
import NameSet
import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon )
import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc )
-import Util ( isSingleton, lengthIs )
+import Util ( lengthIs )
import Outputable
\end{code}
%************************************************************************
%* *
-\subsection{Checking signature type variables}
-%* *
-%************************************************************************
-
-@checkSigTyVars@ is used after the type in a type signature has been unified with
-the actual type found. It then checks that the type variables of the type signature
-are
- (a) Still all type variables
- eg matching signature [a] against inferred type [(p,q)]
- [then a will be unified to a non-type variable]
-
- (b) Still all distinct
- eg matching signature [(a,b)] against inferred type [(p,p)]
- [then a and b will be unified together]
-
- (c) Not mentioned in the environment
- eg the signature for f in this:
-
- g x = ... where
- f :: a->[a]
- f y = [x,y]
-
- Here, f is forced to be monorphic by the free occurence of x.
-
- (d) Not (unified with another type variable that is) in scope.
- eg f x :: (r->r) = (\y->y) :: forall a. a->r
- when checking the expression type signature, we find that
- even though there is nothing in scope whose type mentions r,
- nevertheless the type signature for the expression isn't right.
-
- Another example is in a class or instance declaration:
- class C a where
- op :: forall b. a -> b
- op x = x
- Here, b gets unified with a
-
-Before doing this, the substitution is applied to the signature type variable.
-
-We used to have the notion of a "DontBind" type variable, which would
-only be bound to itself or nothing. Then points (a) and (b) were
-self-checking. But it gave rise to bogus consequential error messages.
-For example:
-
- f = (*) -- Monomorphic
-
- g :: Num a => a -> a
- g x = f x x
-
-Here, we get a complaint when checking the type signature for g,
-that g isn't polymorphic enough; but then we get another one when
-dealing with the (Num x) context arising from f's definition;
-we try to unify x with Int (to default it), but find that x has already
-been unified with the DontBind variable "a" from g's signature.
-This is really a problem with side-effecting unification; we'd like to
-undo g's effects when its type signature fails, but unification is done
-by side effect, so we can't (easily).
-
-So we revert to ordinary type variables for signatures, and try to
-give a helpful message in checkSigTyVars.
-
-\begin{code}
-checkSigTyVars :: [TcTyVar] -- Universally-quantified type variables in the signature
- -> TcTyVarSet -- Tyvars that are free in the type signature
- -- Not necessarily zonked
- -- These should *already* be in the free-in-env set,
- -- and are used here only to improve the error message
- -> TcM [TcTyVar] -- Zonked signature type variables
-
-checkSigTyVars [] free = returnTc []
-checkSigTyVars sig_tyvars free_tyvars
- = zonkTcTyVars sig_tyvars `thenNF_Tc` \ sig_tys ->
- tcGetGlobalTyVars `thenNF_Tc` \ globals ->
-
- checkTcM (allDistinctTyVars sig_tys globals)
- (complain sig_tys globals) `thenTc_`
-
- returnTc (map (tcGetTyVar "checkSigTyVars") sig_tys)
-
- where
- complain sig_tys globals
- = -- "check" checks each sig tyvar in turn
- foldlNF_Tc check
- (env2, emptyVarEnv, [])
- (tidy_tvs `zip` tidy_tys) `thenNF_Tc` \ (env3, _, msgs) ->
-
- failWithTcM (env3, main_msg $$ vcat msgs)
- where
- (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tyvars
- (env2, tidy_tys) = tidyOpenTypes env1 sig_tys
-
- main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
-
- check (tidy_env, acc, msgs) (sig_tyvar,ty)
- -- sig_tyvar is from the signature;
- -- ty is what you get if you zonk sig_tyvar and then tidy it
- --
- -- acc maps a zonked type variable back to a signature type variable
- = case tcGetTyVar_maybe ty of {
- Nothing -> -- Error (a)!
- returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (quotes (ppr ty)) : msgs) ;
-
- Just tv ->
-
- case lookupVarEnv acc tv of {
- Just sig_tyvar' -> -- Error (b)!
- returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar thing : msgs)
- where
- thing = ptext SLIT("another quantified type variable") <+> quotes (ppr sig_tyvar')
-
- ; Nothing ->
-
- if tv `elemVarSet` globals -- Error (c) or (d)! Type variable escapes
- -- The least comprehensible, so put it last
- -- Game plan:
- -- a) get the local TcIds and TyVars from the environment,
- -- and pass them to find_globals (they might have tv free)
- -- b) similarly, find any free_tyvars that mention tv
- then tcGetEnv `thenNF_Tc` \ ve ->
- find_globals tv tidy_env (tcLEnvElts ve) `thenNF_Tc` \ (tidy_env1, globs) ->
- find_frees tv tidy_env1 [] (varSetElems free_tyvars) `thenNF_Tc` \ (tidy_env2, frees) ->
- returnNF_Tc (tidy_env2, acc, escape_msg sig_tyvar tv globs frees : msgs)
-
- else -- All OK
- returnNF_Tc (tidy_env, extendVarEnv acc tv sig_tyvar, msgs)
- }}
-
------------------------
--- find_globals looks at the value environment and finds values
--- whose types mention the offending type variable. It has to be
--- careful to zonk the Id's type first, so it has to be in the monad.
--- We must be careful to pass it a zonked type variable, too.
-
-find_globals :: Var
- -> TidyEnv
- -> [TcTyThing]
- -> NF_TcM (TidyEnv, [SDoc])
-
-find_globals tv tidy_env things
- = go tidy_env [] things
- where
- go tidy_env acc [] = returnNF_Tc (tidy_env, acc)
- go tidy_env acc (thing : things)
- = find_thing ignore_it tidy_env thing `thenNF_Tc` \ (tidy_env1, maybe_doc) ->
- case maybe_doc of
- Just d -> go tidy_env1 (d:acc) things
- Nothing -> go tidy_env1 acc things
-
- ignore_it ty = not (tv `elemVarSet` tyVarsOfType ty)
-
------------------------
-find_thing ignore_it tidy_env (ATcId id)
- = zonkTcType (idType id) `thenNF_Tc` \ id_ty ->
- if ignore_it id_ty then
- returnNF_Tc (tidy_env, Nothing)
- else let
- (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
- msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
- nest 2 (parens (ptext SLIT("bound at") <+>
- ppr (getSrcLoc id)))]
- in
- returnNF_Tc (tidy_env', Just msg)
-
-find_thing ignore_it tidy_env (ATyVar tv)
- = zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
- if ignore_it tv_ty then
- returnNF_Tc (tidy_env, Nothing)
- else let
- (tidy_env1, tv1) = tidyOpenTyVar tidy_env tv
- (tidy_env2, tidy_ty) = tidyOpenType tidy_env1 tv_ty
- msg = sep [ptext SLIT("Type variable") <+> quotes (ppr tv1) <+> eq_stuff, nest 2 bound_at]
-
- eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, tv == tv' = empty
- | otherwise = equals <+> ppr tv_ty
- -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
-
- bound_at | isMutTyVar tv = mut_info -- The expected case
- | otherwise = empty
-
- mut_info = sep [ptext SLIT("is bound by the") <+> ppr (mutTyVarDetails tv),
- ptext SLIT("at") <+> ppr (getSrcLoc tv)]
- in
- returnNF_Tc (tidy_env2, Just msg)
-
------------------------
-find_frees tv tidy_env acc []
- = returnNF_Tc (tidy_env, acc)
-find_frees tv tidy_env acc (ftv:ftvs)
- = zonkTcTyVar ftv `thenNF_Tc` \ ty ->
- if tv `elemVarSet` tyVarsOfType ty then
- let
- (tidy_env', ftv') = tidyOpenTyVar tidy_env ftv
- in
- find_frees tv tidy_env' (ftv':acc) ftvs
- else
- find_frees tv tidy_env acc ftvs
-
-
-escape_msg sig_tv tv globs frees
- = mk_msg sig_tv <+> ptext SLIT("escapes") $$
- if not (null globs) then
- vcat [pp_it <+> ptext SLIT("is mentioned in the environment:"),
- nest 2 (vcat globs)]
- else if not (null frees) then
- vcat [ptext SLIT("It is reachable from the type variable(s)") <+> pprQuotedList frees,
- nest 2 (ptext SLIT("which") <+> is_are <+> ptext SLIT("free in the signature"))
- ]
- else
- empty -- Sigh. It's really hard to give a good error message
- -- all the time. One bad case is an existential pattern match
- where
- is_are | isSingleton frees = ptext SLIT("is")
- | otherwise = ptext SLIT("are")
- pp_it | sig_tv /= tv = ptext SLIT("It unifies with") <+> quotes (ppr tv) <> comma <+> ptext SLIT("which")
- | otherwise = ptext SLIT("It")
-
- vcat_first :: Int -> [SDoc] -> SDoc
- vcat_first n [] = empty
- vcat_first 0 (x:xs) = text "...others omitted..."
- vcat_first n (x:xs) = x $$ vcat_first (n-1) xs
-
-
-unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> thing
-mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv)
-\end{code}
-
-These two context are used with checkSigTyVars
-
-\begin{code}
-sigCtxt :: Message -> [TcTyVar] -> TcThetaType -> TcTauType
- -> TidyEnv -> NF_TcM (TidyEnv, Message)
-sigCtxt when sig_tyvars sig_theta sig_tau tidy_env
- = zonkTcType sig_tau `thenNF_Tc` \ actual_tau ->
- let
- (env1, tidy_sig_tyvars) = tidyOpenTyVars tidy_env sig_tyvars
- (env2, tidy_sig_rho) = tidyOpenType env1 (mkRhoTy sig_theta sig_tau)
- (env3, tidy_actual_tau) = tidyOpenType env2 actual_tau
- msg = vcat [ptext SLIT("Signature type: ") <+> pprType (mkForAllTys tidy_sig_tyvars tidy_sig_rho),
- ptext SLIT("Type to generalise:") <+> pprType tidy_actual_tau,
- when
- ]
- in
- returnNF_Tc (env3, msg)
-
-sigPatCtxt bound_tvs bound_ids tidy_env
- = returnNF_Tc (env1,
- sep [ptext SLIT("When checking a pattern that binds"),
- nest 4 (vcat (zipWith ppr_id show_ids tidy_tys))])
- where
- show_ids = filter is_interesting bound_ids
- is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
-
- (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
- ppr_id id ty = ppr id <+> dcolon <+> ppr ty
- -- Don't zonk the types so we get the separate, un-unified versions
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Errors and contexts}
%* *
%************************************************************************
\section[TcPat]{Typechecking patterns}
\begin{code}
-module TcPat ( tcPat, tcMonoPatBndr, simpleHsLitTy, badFieldCon, polyPatSig ) where
+module TcPat ( tcPat, tcMonoPatBndr, tcSubPat,
+ badFieldCon, polyPatSig
+ ) where
#include "HsVersions.h"
import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsOverLit(..), HsExpr(..) )
import RnHsSyn ( RenamedPat )
-import TcHsSyn ( TcPat, TcId )
+import TcHsSyn ( TcPat, TcId, simpleHsLitTy )
import TcMonad
import Inst ( InstOrigin(..),
- emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId,
+ emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE,
newMethod, newOverloadedLit, newDicts
)
-import Id ( mkLocalId )
+import Id ( mkLocalId, mkSysLocal )
import Name ( Name )
import FieldLabel ( fieldLabelName )
import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
-import TcMType ( tcInstTyVars, newTyVarTy, unifyTauTy, unifyListTy, unifyTupleTy )
-import TcType ( TcType, TcTyVar, isTauTy, mkTyConApp, mkClassPred, liftedTypeKind )
+import TcMType ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar )
+import TcType ( TcType, TcTyVar, TcSigmaType,
+ mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe,
+ isHoleTyVar, openTypeKind )
+import TcUnify ( tcSub, unifyTauTy, unifyListTy, unifyTupleTy,
+ mkCoercion, idCoercion, isIdCoercion, (<$>), PatCoFn )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
+import TysWiredIn ( stringTy )
import CmdLineOpts ( opt_IrrefutableTuples )
import DataCon ( dataConSig, dataConFieldLabels,
dataConSourceArity
)
import Subst ( substTy, substTheta )
-import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
- doublePrimTy, addrPrimTy
- )
-import TysWiredIn ( charTy, stringTy, intTy, integerTy )
import PrelNames ( eqStringName, eqName, geName, cCallableClassName )
import BasicTypes ( isBoxed )
import Bag
%************************************************************************
\begin{code}
--- This is the right function to pass to tcPat when
--- we're looking at a lambda-bound pattern,
--- so there's no polymorphic guy to worry about
-tcMonoPatBndr binder_name pat_ty = returnTc (mkLocalId binder_name pat_ty)
+type BinderChecker = Name -> TcSigmaType -> TcM (PatCoFn, LIE, TcId)
+ -- How to construct a suitable (monomorphic)
+ -- Id for variables found in the pattern
+ -- The TcSigmaType is the expected type
+ -- from the pattern context
+
+-- The Id may have a sigma type (e.g. f (x::forall a. a->a))
+-- so we want to *create* it during pattern type checking.
+-- We don't want to make Ids first with a type-variable type
+-- and then unify... becuase we can't unify a sigma type with a type variable.
+
+tcMonoPatBndr :: BinderChecker
+ -- This is the right function to pass to tcPat when
+ -- we're looking at a lambda-bound pattern,
+ -- so there's no polymorphic guy to worry about
+
+tcMonoPatBndr binder_name pat_ty
+ | Just tv <- tcGetTyVar_maybe pat_ty,
+ isHoleTyVar tv
+ -- If there are *no constraints* on the pattern type, we
+ -- revert to good old H-M typechecking, making
+ -- the type of the binder into an *ordinary*
+ -- type variable. We find out if there are no constraints
+ -- by seeing if we are given an "open hole" as our info.
+ -- What we are trying to avoid here is giving a binder
+ -- a type that is a 'hole'. The only place holes should
+ -- appear is as an argument to tcPat and tcExpr/tcMonoExpr.
+ = getTcTyVar tv `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ Just ty -> tcMonoPatBndr binder_name ty
+ Nothing -> newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
+ putTcTyVar tv ty `thenNF_Tc_`
+ returnTc (idCoercion, emptyLIE, mkLocalId binder_name ty)
+ | otherwise
+ = returnTc (idCoercion, emptyLIE, mkLocalId binder_name pat_ty)
\end{code}
%************************************************************************
\begin{code}
-tcPat :: (Name -> TcType -> TcM TcId) -- How to construct a suitable (monomorphic)
- -- Id for variables found in the pattern
- -- The TcType is the expected type, see note below
+tcPat :: BinderChecker
-> RenamedPat
- -> TcType -- Expected type derived from the context
+ -> TcSigmaType -- Expected type derived from the context
-- In the case of a function with a rank-2 signature,
-- this type might be a forall type.
- -- INVARIANT: if it is, the foralls will always be visible,
- -- not hidden inside a mutable type variable
-> TcM (TcPat,
LIE, -- Required by n+k and literal pats
= failWithTc (badTypePat pat)
tcPat tc_bndr (VarPatIn name) pat_ty
- = tc_bndr name pat_ty `thenTc` \ bndr_id ->
- returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
+ = tc_bndr name pat_ty `thenTc` \ (co_fn, lie_req, bndr_id) ->
+ returnTc (co_fn <$> VarPat bndr_id, lie_req,
+ emptyBag, unitBag (name, bndr_id), emptyLIE)
tcPat tc_bndr (LazyPatIn pat) pat_ty
= tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail)
tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty
- = tc_bndr name pat_ty `thenTc` \ bndr_id ->
- tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
- tcAddErrCtxt (patCtxt pat_in) $
- returnTc (AsPat bndr_id pat', lie_req,
+ = tc_bndr name pat_ty `thenTc` \ (co_fn, lie_req1, bndr_id) ->
+ tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req2, tvs, ids, lie_avail) ->
+ returnTc (co_fn <$> (AsPat bndr_id pat'), lie_req1 `plusLIE` lie_req1,
tvs, (name, bndr_id) `consBag` ids, lie_avail)
tcPat tc_bndr WildPatIn pat_ty
= tcPat tc_bndr parend_pat pat_ty
tcPat tc_bndr (SigPatIn pat sig) pat_ty
- = tcHsSigType PatSigCtxt sig `thenTc` \ sig_ty ->
-
- -- Check that the signature isn't a polymorphic one, which
- -- we don't permit (at present, anyway)
- checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
-
- unifyTauTy pat_ty sig_ty `thenTc_`
- tcPat tc_bndr pat sig_ty
+ = tcHsSigType PatSigCtxt sig `thenTc` \ sig_ty ->
+ tcSubPat sig_ty pat_ty `thenTc` \ (co_fn, lie_sig) ->
+ tcPat tc_bndr pat sig_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
+ returnTc (co_fn <$> pat', lie_req `plusLIE` lie_sig, tvs, ids, lie_avail)
\end{code}
+
%************************************************************************
%* *
\subsection{Explicit lists and tuples}
arity = length pats
\end{code}
+
%************************************************************************
%* *
\subsection{Other constructors}
\begin{code}
tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
- = tc_bndr name pat_ty `thenTc` \ bndr_id ->
+ = tc_bndr name pat_ty `thenTc` \ (co_fn, lie1, bndr_id) ->
-- The '-' part is re-mappable syntax
tcLookupId minus_name `thenNF_Tc` \ minus_sel_id ->
tcLookupGlobalId geName `thenNF_Tc` \ ge_sel_id ->
- newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
+ newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie2) ->
newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ ge ->
newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ minus ->
returnTc (NPlusKPat bndr_id i pat_ty
(SectionR (HsVar (instToId ge)) over_lit_expr)
(SectionR (HsVar (instToId minus)) over_lit_expr),
- lie1 `plusLIE` mkLIE [ge,minus],
+ lie1 `plusLIE` lie2 `plusLIE` mkLIE [ge,minus],
emptyBag, unitBag (name, bndr_id), emptyLIE)
where
origin = PatOrigin pat
Helper functions
\begin{code}
-tcPats :: (Name -> TcType -> TcM TcId) -- How to deal with variables
+tcPats :: BinderChecker -- How to deal with variables
-> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded
-> TcM ([TcPat],
LIE, -- Required by n+k and literal pats
------------------------------------------------------
\begin{code}
-simpleHsLitTy :: HsLit -> TcType
-simpleHsLitTy (HsCharPrim c) = charPrimTy
-simpleHsLitTy (HsStringPrim s) = addrPrimTy
-simpleHsLitTy (HsInt i) = intTy
-simpleHsLitTy (HsInteger i) = integerTy
-simpleHsLitTy (HsIntPrim i) = intPrimTy
-simpleHsLitTy (HsFloatPrim f) = floatPrimTy
-simpleHsLitTy (HsDoublePrim d) = doublePrimTy
-simpleHsLitTy (HsChar c) = charTy
-simpleHsLitTy (HsString str) = stringTy
-\end{code}
-
-
-------------------------------------------------------
-\begin{code}
tcConstructor pat con_name pat_ty
= -- Check that it's a constructor
tcLookupDataCon con_name `thenNF_Tc` \ data_con ->
%************************************************************************
%* *
+\subsection{Subsumption}
+%* *
+%************************************************************************
+
+Example:
+ f :: (forall a. a->a) -> Int -> Int
+ f (g::Int->Int) y = g y
+This is ok: the type signature allows fewer callers than
+the (more general) signature f :: (Int->Int) -> Int -> Int
+I.e. (forall a. a->a) <= Int -> Int
+We end up translating this to:
+ f = \g' :: (forall a. a->a). let g = g' Int in g' y
+
+tcSubPat does the work
+ sig_ty is the signature on the pattern itself
+ (Int->Int in the example)
+ expected_ty is the type passed inwards from the context
+ (forall a. a->a in the example)
+
+\begin{code}
+tcSubPat :: TcSigmaType -> TcSigmaType -> TcM (PatCoFn, LIE)
+
+tcSubPat sig_ty exp_ty
+ = tcSub exp_ty sig_ty `thenTc` \ (co_fn, lie) ->
+ -- co_fn is a coercion on *expressions*, and we
+ -- need to make a coercion on *patterns*
+ if isIdCoercion co_fn then
+ ASSERT( isEmptyLIE lie )
+ returnNF_Tc (idCoercion, emptyLIE)
+ else
+ tcGetUnique `thenNF_Tc` \ uniq ->
+ let
+ arg_id = mkSysLocal SLIT("sub") uniq exp_ty
+ the_fn = DictLam [arg_id] (co_fn <$> HsVar arg_id)
+ pat_co_fn p = SigPat p exp_ty the_fn
+ in
+ returnNF_Tc (mkCoercion pat_co_fn, lie)
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Errors and contexts}
%* *
%************************************************************************
#include "HsVersions.h"
+import {-# SOURCE #-} TcUnify( unifyTauTy )
+
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
-
-import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, unifyTauTy )
+import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars )
import TcType ( TcTyVar, TcTyVarSet, ThetaType, PredType,
mkClassPred, isOverloadedTy,
mkTyVarTy, tcGetTyVar, isTyVarClassPred,
where
-- For implicit parameters, all occurrences share the same
-- Id, so there is no need for synonym bindings
+ -- ** BUT THIS TEST IS NEEDED FOR DICTS TOO ** (not sure why)
new_binds | new_id == id = binds
| otherwise = addBind binds new_id (HsVar id)
new_id = instToId w
import TcClassDcl ( tcClassDecl1, checkValidClass )
import TcInstDcls ( tcAddDeclCtxt )
import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
-import TcMType ( unifyKind, newKindVar, zonkKindEnv )
+import TcMType ( newKindVar, zonkKindEnv )
+import TcUnify ( unifyKind )
import TcType ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
import Type ( splitTyConApp_maybe )
import Variance ( calcTyConArgVrcs )
module TcType (
--------------------------------
-- Types
- TcType, TcTauType, TcPredType, TcThetaType, TcRhoType,
- TcTyVar, TcTyVarSet, TcKind,
+ TcType, TcSigmaType, TcPhiType, TcTauType, TcPredType, TcThetaType,
+ TcTyVar, TcTyVarSet, TcKind,
--------------------------------
-- TyVarDetails
- TyVarDetails(..), isUserTyVar, isSkolemTyVar,
+ TyVarDetails(..), isUserTyVar, isSkolemTyVar, isHoleTyVar,
+ tyVarBindingInfo,
--------------------------------
-- Builders
-- Predicates.
-- Again, newtypes are opaque
tcEqType, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
- isQualifiedTy, isOverloadedTy,
+ isSigmaTy, isOverloadedTy,
isDoubleTy, isFloatTy, isIntTy,
isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isForeignPtrTy,
isTauTy, tcIsTyVarTy, tcIsForAllTy,
isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
mkDictTy, tcSplitPredTy_maybe, predTyUnique,
isDictTy, tcSplitDFunTy, predTyUnique,
- mkClassPred, inheritablePred, isIPPred, mkPredName,
+ mkClassPred, inheritablePred, isIPPred, mkPredName,
---------------------------------
-- Foreign import and export
superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind,
isTypeKind,
+ IPName, ipNameName, mapIPName,
+
Type, SourceType(..), PredType, ThetaType,
mkForAllTy, mkForAllTys,
mkFunTy, mkFunTys, zipFunTys,
import Type ( -- Re-exports
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- Kind, Type, TauType, SourceType(..), PredType, ThetaType,
+ IPName, Kind, Type, SourceType(..), PredType, ThetaType,
unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
mkForAllTy, mkForAllTys, defaultKind, isTypeKind,
mkFunTy, mkFunTys, zipFunTys,
splitNewType_maybe, splitTyConApp_maybe,
tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, eqKind, eqUsage,
- hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind
+ hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind,
+ ipNameName, mapIPName
)
import TyCon ( TyCon, isUnLiftedTyCon )
import Class ( classHasFDs, Class )
-import Var ( TyVar, tyVarKind )
+import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails )
import ForeignCall ( Safety, playSafe )
import VarEnv
import VarSet
-- others:
import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
-import Name ( Name, NamedThing(..), mkLocalName )
+import Name ( Name, NamedThing(..), mkLocalName, getSrcLoc )
import OccName ( OccName, mkDictOcc )
import NameSet
import PrelNames -- Lots (e.g. in isFFIArgumentTy)
%* *
%************************************************************************
+The type checker divides the generic Type world into the
+following more structured beasts:
+
+sigma ::= forall tyvars. theta => phi
+ -- A sigma type is a qualified type
+ --
+ -- Note that even if 'tyvars' is empty, theta
+ -- may not be: e.g. (?x::Int) => Int
+
+ -- Note that 'sigma' is in prenex form:
+ -- all the foralls are at the front.
+ -- A 'phi' type has no foralls to the right of
+ -- an arrow
+
+phi ::= sigma -> phi
+ | tau
+
+-- A 'tau' type has no quantification anywhere
+-- Note that the args of a type constructor must be taus
+tau ::= tyvar
+ | tycon tau_1 .. tau_n
+ | tau_1 tau_2
+ | tau_1 -> tau_2
+
+-- In all cases, a (saturated) type synonym application is legal,
+-- provided it expands to the required form.
+
+
+\begin{code}
+type SigmaType = Type
+type PhiType = Type
+type TauType = Type
+\end{code}
+
\begin{code}
type TcTyVar = TyVar -- Might be a mutable tyvar
type TcTyVarSet = TyVarSet
type TcPredType = PredType
type TcThetaType = ThetaType
-type TcRhoType = Type
-type TcTauType = TauType
+type TcSigmaType = TcType
+type TcPhiType = TcType
+type TcTauType = TcType
type TcKind = TcType
\end{code}
\begin{code}
data TyVarDetails
- = SigTv -- Introduced when instantiating a type signature,
+ = HoleTv -- Used *only* by the type checker when passing in a type
+ -- variable that should be side-effected to the result type.
+ -- Always has kind openTypeKind.
+ -- Never appears in types
+
+ | SigTv -- Introduced when instantiating a type signature,
-- prior to checking that the defn of a fn does
-- have the expected type. Should not be instantiated.
--
| VanillaTv -- Everything else
-isUserTyVar :: TyVarDetails -> Bool -- Avoid unifying these if possible
-isUserTyVar VanillaTv = False
-isUserTyVar other = True
-
-isSkolemTyVar :: TyVarDetails -> Bool
-isSkolemTyVar SigTv = True
-isSkolemTyVar other = False
-
-instance Outputable TyVarDetails where
- ppr SigTv = ptext SLIT("type signature")
- ppr ClsTv = ptext SLIT("class declaration")
- ppr InstTv = ptext SLIT("instance declaration")
- ppr PatSigTv = ptext SLIT("pattern type signature")
- ppr VanillaTv = ptext SLIT("???")
+isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible
+isUserTyVar tv = case mutTyVarDetails tv of
+ VanillaTv -> False
+ other -> True
+
+isSkolemTyVar :: TcTyVar -> Bool
+isSkolemTyVar tv = case mutTyVarDetails tv of
+ SigTv -> True
+ oteher -> False
+
+isHoleTyVar :: TcTyVar -> Bool
+-- NB: the hole might be filled in by now, and this
+-- function does not check for that
+isHoleTyVar tv = ASSERT( isMutTyVar tv )
+ case mutTyVarDetails tv of
+ HoleTv -> True
+ other -> False
+
+tyVarBindingInfo :: TyVar -> SDoc -- Used in checkSigTyVars
+tyVarBindingInfo tv
+ | isMutTyVar tv
+ = sep [ptext SLIT("is bound by the") <+> details (mutTyVarDetails tv),
+ ptext SLIT("at") <+> ppr (getSrcLoc tv)]
+ | otherwise
+ = empty
+ where
+ details SigTv = ptext SLIT("type signature")
+ details ClsTv = ptext SLIT("class declaration")
+ details InstTv = ptext SLIT("instance declaration")
+ details PatSigTv = ptext SLIT("pattern type signature")
+ details HoleTv = ptext SLIT("//hole//") -- Should not happen
+ details VanillaTv = ptext SLIT("//vanilla//") -- Ditto
\end{code}
isPred :: SourceType -> Bool
isPred (ClassP _ _) = True
isPred (IParam _ _) = True
-isPred (NType _ __) = False
+isPred (NType _ _) = False
isPredTy :: Type -> Bool
isPredTy (NoteTy _ ty) = isPredTy ty
tcSplitPredTy_maybe other = Nothing
predTyUnique :: PredType -> Unique
-predTyUnique (IParam n _) = getUnique n
+predTyUnique (IParam n _) = getUnique (ipNameName n)
predTyUnique (ClassP clas tys) = getUnique clas
predHasFDs :: PredType -> Bool
mkPredName :: Unique -> SrcLoc -> SourceType -> Name
mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
-mkPredName uniq loc (IParam name ty) = name
+mkPredName uniq loc (IParam ip ty) = mkLocalName uniq (getOccName (ipNameName ip)) loc
\end{code}
\begin{code}
cmpSourceTy :: TyVarEnv TyVar -> SourceType -> SourceType -> Ordering
-cmpSourceTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
+cmpSourceTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
-- Compare types as well as names for implicit parameters
-- This comparison is used exclusively (I think) for the
-- finite map built in TcSimplify
%* *
%************************************************************************
-isQualifiedTy returns true of any qualified type. It doesn't *necessarily* have
+isSigmaTy returns true of any qualified type. It doesn't *necessarily* have
any foralls. E.g.
f :: (?x::Int) => Int -> Int
\begin{code}
-isQualifiedTy :: Type -> Bool
-isQualifiedTy (ForAllTy tyvar ty) = True
-isQualifiedTy (FunTy a b) = isPredTy a
-isQualifiedTy (NoteTy n ty) = isQualifiedTy ty
-isQualifiedTy (UsageTy _ ty) = isQualifiedTy ty
-isQualifiedTy _ = False
+isSigmaTy :: Type -> Bool
+isSigmaTy (ForAllTy tyvar ty) = True
+isSigmaTy (FunTy a b) = isPredTy a
+isSigmaTy (NoteTy n ty) = isSigmaTy ty
+isSigmaTy (UsageTy _ ty) = isSigmaTy ty
+isSigmaTy _ = False
isOverloadedTy :: Type -> Bool
isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty)
deNoteSourceType :: SourceType -> SourceType
-deNoteSourceType (ClassP c tys) = ClassP c (map deNoteType tys)
-deNoteSourceType (IParam n ty) = IParam n (deNoteType ty)
-deNoteSourceType (NType tc tys) = NType tc (map deNoteType tys)
+deNoteSourceType (ClassP c tys) = ClassP c (map deNoteType tys)
+deNoteSourceType (IParam n ty) = IParam n (deNoteType ty)
+deNoteSourceType (NType tc tys) = NType tc (map deNoteType tys)
\end{code}
Find the free names of a type, including the type constructors and classes it mentions
-- friends:
-- (PprType can see all the representations it's trying to print)
-import TypeRep ( Type(..), TyNote(..), Kind, liftedTypeKind ) -- friend
+import TypeRep ( Type(..), TyNote(..), IPName(..),
+ Kind, liftedTypeKind ) -- friend
import Type ( SourceType(..), isUTyVar, eqKind )
-import TcType ( ThetaType, PredType,
+import TcType ( ThetaType, PredType, ipNameName,
tcSplitSigmaTy, isPredTy, isDictTy,
tcSplitTyConApp_maybe, tcSplitFunTy_maybe
)
pprSourceType :: SourceType -> SDoc
pprSourceType (ClassP clas tys) = pprClassPred clas tys
-pprSourceType (IParam n ty) = hsep [ptext SLIT("?") <> ppr n,
- ptext SLIT("::"), ppr ty]
+pprSourceType (IParam n ty) = hsep [ppr n, dcolon, ppr ty]
pprSourceType (NType tc tys) = ppr tc <+> hsep (map pprParendType tys)
pprClassPred :: Class -> [Type] -> SDoc
instance Outputable Type where
ppr ty = pprType ty
-instance Outputable PredType where
+instance Outputable SourceType where
ppr = pprPred
+
+instance Outputable name => Outputable (IPName name) where
+ ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters
+ ppr (MustSplit n) = char '%' <> ppr n -- Splittable implicit parameters
\end{code}
getSourceTyDescription (ClassP cl tys) = getOccString cl
getSourceTyDescription (NType tc tys) = getOccString tc
-getSourceTyDescription (IParam id ty) = getOccString id
+getSourceTyDescription (IParam ip ty) = getOccString (ipNameName ip)
\end{code}
\begin{code}
module Type (
-- re-exports from TypeRep:
- Type, PredType, TauType, ThetaType,
- Kind, TyVarSubst,
+ Type, PredType, ThetaType,
+ Kind, TyVarSubst, IPName,
superKind, superBoxity, -- KX and BX respectively
liftedBoxity, unliftedBoxity, -- :: BX
-- Source types
SourceType(..), sourceTypeRep, mkPredTy, mkPredTys,
+ ipNameName, mapIPName,
-- Newtypes
splitNewType_maybe,
sourceTypeRep :: SourceType -> Type
-- Convert a predicate to its "representation type";
-- the type of evidence for that predicate, which is actually passed at runtime
-sourceTypeRep (IParam n ty) = ty
+sourceTypeRep (IParam _ ty) = ty
sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
-- Note the mkTyConApp; the classTyCon might be a newtype!
sourceTypeRep (NType tc tys) = newTypeRep tc tys
(tvs, rep_ty) -> substTyWith tvs tys rep_ty
\end{code}
+\begin{code}
+ipNameName :: IPName name -> name
+ipNameName (Dupable n) = n
+ipNameName (MustSplit n) = n
+
+mapIPName :: (a->b) -> IPName a -> IPName b
+mapIPName f (Dupable n) = Dupable (f n)
+mapIPName f (MustSplit n) = MustSplit (f n)
+\end{code}
+
%************************************************************************
%* *
tyVarsOfPred = tyVarsOfSourceType -- Just a subtype
tyVarsOfSourceType :: SourceType -> TyVarSet
-tyVarsOfSourceType (IParam n ty) = tyVarsOfType ty
-tyVarsOfSourceType (ClassP clas tys) = tyVarsOfTypes tys
-tyVarsOfSourceType (NType tc tys) = tyVarsOfTypes tys
+tyVarsOfSourceType (IParam _ ty) = tyVarsOfType ty
+tyVarsOfSourceType (ClassP _ tys) = tyVarsOfTypes tys
+tyVarsOfSourceType (NType _ tys) = tyVarsOfTypes tys
tyVarsOfTheta :: ThetaType -> TyVarSet
tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet
\begin{code}
module TypeRep (
- Type(..), TyNote(..), SourceType(..), -- Representation visible to friends
+ Type(..), TyNote(..), -- Representation visible
+ SourceType(..), IPName(..), -- to friends
- Kind, TauType, PredType, ThetaType, -- Synonyms
+ Kind, PredType, ThetaType, -- Synonyms
TyVarSubst,
superKind, superBoxity, -- KX and BX respectively
\begin{code}
type SuperKind = Type
type Kind = Type
-type TauType = Type
type TyVarSubst = TyVarEnv Type
Predicates are represented inside GHC by PredType:
\begin{code}
-data SourceType = ClassP Class [Type] -- Class predicate
- | IParam Name Type -- Implicit parameter
- | NType TyCon [Type] -- A *saturated*, *non-recursive* newtype application
- -- [See notes at top about newtypes]
-
+data SourceType
+ = ClassP Class [Type] -- Class predicate
+ | IParam (IPName Name) Type -- Implicit parameter
+ | NType TyCon [Type] -- A *saturated*, *non-recursive* newtype application
+ -- [See notes at top about newtypes]
+
+data IPName name
+ = Dupable name -- ?x: you can freely duplicate this implicit parameter
+ | MustSplit name -- %x: you must use the splitting function to duplicate it
+ deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map
+ -- (used in HscTypes.OrigIParamCache)
+ -- I sometimes thisnk this type should be in BasicTypes
+
type PredType = SourceType -- A subtype for predicates
type ThetaType = [PredType]
\end{code}
type variable, one that may very well later be unified with a type.
For example, suppose f::a, and we see an application (f x). Then a
must be a function type, so we unify a with (b->c). But what kind
- are b and c? They can be lifted or unlifted types, so we give them
- kind '?'.
+ are b and c? They can be lifted or unlifted types, or indeed type schemes,
+ so we give them kind '?'.
When the type checker generalises over a bunch of type variables, it
makes any that still have kind '?' into kind '*'. So kind '?' is never
projects / ghc-hetmet.git / commitdiff