TupCon(..), tupleParens,
OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc,
- isDeadOcc, isLoopBreaker,
+ isDeadOcc, isLoopBreaker, isNoOcc,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch,
| IAmALoopBreaker -- Used by the occurrence analyser to mark loop-breakers
-- in a group of recursive definitions
+isNoOcc :: OccInfo -> Bool
+isNoOcc NoOccInfo = True
+isNoOcc other = False
+
seqOccInfo :: OccInfo -> ()
seqOccInfo occ = occ `seq` ()
isClassOpId_maybe,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
- isDataConWorkId, isDataConWorkId_maybe, idDataCon,
+ isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
isBottomingId, idIsFrom,
hasNoBinding,
DataConWorkId con -> Just con
other -> Nothing
-isDictId :: Id -> Bool
-isDictId id = isDictTy (idType id)
+isDataConId_maybe :: Id -> Maybe DataCon
+isDataConId_maybe id = case globalIdDetails id of
+ DataConWorkId con -> Just con
+ DataConWrapId con -> Just con
+ other -> Nothing
idDataCon :: Id -> DataCon
-- Get from either the worker or the wrapper to the DataCon
other -> pprPanic "idDataCon" (ppr id)
+isDictId :: Id -> Bool
+isDictId id = isDictTy (idType id)
+
-- hasNoBinding returns True of an Id which may not have a
-- binding, even though it is defined in this module.
-- Data constructor workers used to be things of this kind, but
) where
#include "HsVersions.h"
-import OccName
import Outputable
import Unique ( Uniquable(..) )
import UniqFM
nameUnique, setNameUnique,
nameOccName, nameModule, nameModule_maybe,
- setNameOcc,
+ tidyNameOcc,
hashName, localiseName,
nameSrcLoc, nameParent, nameParent_maybe, isImplicitName,
-- one in the thing it's the name of. If you know what I mean.
setNameUnique name uniq = name {n_uniq = uniq}
-setNameOcc :: Name -> OccName -> Name
-setNameOcc name occ = name {n_occ = occ}
+tidyNameOcc :: Name -> OccName -> Name
+-- We set the OccName of a Name when tidying
+-- In doing so, we change System --> Internal, so that when we print
+-- it we don't get the unique by default. It's tidy now!
+tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal}
+tidyNameOcc name occ = name { n_occ = occ }
localiseName :: Name -> Name
localiseName n = n { n_sort = Internal }
fmap f (L l e) = L l (f e)
instance Outputable e => Outputable (Located e) where
- ppr (L span e) = ppr e
+ ppr (L span e) = ppr e
-- do we want to dump the span in debugSty mode?
\end{code}
module Var (
Var,
varName, varUnique,
- setVarName, setVarUnique, setVarOcc,
+ setVarName, setVarUnique,
-- TyVars
TyVar, mkTyVar, mkTcTyVar,
#include "HsVersions.h"
import {-# SOURCE #-} TypeRep( Type )
-import {-# SOURCE #-} TcType( TcTyVarDetails )
+import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails )
import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, IdInfo, seqIdInfo )
-import Name ( Name, OccName, NamedThing(..),
- setNameUnique, setNameOcc, nameUnique
+import Name ( Name, NamedThing(..),
+ setNameUnique, nameUnique
)
import Kind ( Kind )
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# )
\begin{code}
instance Outputable Var where
- ppr var = ppr (varName var)
+ ppr var = ppr (varName var) <+> ifPprDebug (brackets extra)
+ where
+ extra = case var of
+ GlobalId {} -> ptext SLIT("gid")
+ LocalId {} -> ptext SLIT("lid")
+ TyVar {} -> ptext SLIT("tv")
+ TcTyVar {tcTyVarDetails = details} -> pprTcTyVarDetails details
instance Show Var where
showsPrec p var = showsPrecSDoc p (ppr var)
setVarName var new_name
= var { realUnique = getKey# (getUnique new_name),
varName = new_name }
-
-setVarOcc :: Var -> OccName -> Var
-setVarOcc var new_occ
- = var { varName = setNameOcc (varName var) new_occ }
\end{code}
mapVarEnv, zipVarEnv,
modifyVarEnv, modifyVarEnv_Directly,
isEmptyVarEnv, foldVarEnv,
- lookupVarEnv_Directly,
+ elemVarEnvByKey, lookupVarEnv_Directly,
filterVarEnv_Directly,
-- InScopeSet
lookupVarEnv_NF :: VarEnv a -> Var -> a
lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
elemVarEnv :: Var -> VarEnv a -> Bool
+elemVarEnvByKey :: Unique -> VarEnv a -> Bool
foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b
\end{code}
\begin{code}
elemVarEnv = elemUFM
+elemVarEnvByKey = elemUFM_Directly
extendVarEnv = addToUFM
extendVarEnv_C = addToUFM_C
extendVarEnvList = addListToUFM
import CoreSyn
import CostCentre ( pprCostCentreCore )
import Var ( Var )
-import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
- idInfo, idInlinePragma, idOccInfo,
- globalIdDetails, isGlobalId, isExportedId,
- idNewDemandInfo
+import Id ( Id, idType, isDataConWorkId_maybe, idArity,
+ idInfo, globalIdDetails, isGlobalId, isExportedId
)
import Var ( TyVar, isTyVar, tyVarKind )
import IdInfo ( IdInfo, megaSeqIdInfo,
+ inlinePragInfo, occInfo, newDemandInfo,
+ lbvarInfo, hasNoLBVarInfo,
arityInfo, ppArityInfo,
specInfo, pprNewStrictness,
workerInfo, ppWorkerInfo,
newStrictnessInfo, cafInfo, ppCafInfo, specInfoRules
)
-
+import NewDemand ( isTop )
#ifdef OLD_STRICTNESS
import Id ( idDemandInfo )
import IdInfo ( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo )
import DataCon ( dataConTyCon )
import TyCon ( tupleTyConBoxity, isTupleTyCon )
import Type ( pprParendType, pprType, pprParendKind )
-import BasicTypes ( tupleParens )
+import BasicTypes ( tupleParens, isNoOcc, isAlwaysActive )
import Util ( lengthIs )
import Outputable
import FastString ( mkFastString )
-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
-pprIdBndr id = ppr id <+>
- (megaSeqIdInfo (idInfo id) `seq`
- -- Useful for poking on black holes
- brackets (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
+pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
+
+pprIdBndrInfo info
+ = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes
+ where
+ prag_info = inlinePragInfo info
+ occ_info = occInfo info
+ dmd_info = newDemandInfo info
+ lbv_info = lbvarInfo info
+
+ no_info = isAlwaysActive prag_info && isNoOcc occ_info &&
+ (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
+ hasNoLBVarInfo lbv_info
+
+ doc | no_info = empty
+ | otherwise
+ = brackets $ hcat [ppr prag_info, ppr occ_info,
+ ppr dmd_info, ppr lbv_info
#ifdef OLD_STRICTNESS
- ppr (idDemandInfo id) <+>
+ , ppr (demandInfo id)
#endif
- ppr (idNewDemandInfo id) <+>
- ppr (idLBVarInfo id)))
+ ]
\end{code}
untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty
untidy' _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed
untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
- untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
+ untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2)
lower levels it is preserved with @let@/@letrec@s).
\begin{code}
-module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, AutoScc(..) ) where
+module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs,
+ dsCoercion,
+ AutoScc(..)
+ ) where
#include "HsVersions.h"
addDictScc var core_expr `thenDs` \ core_expr' ->
returnDs ((var, core_expr') : rest)
-dsHsBind auto_scc rest (FunBind (L _ fun) _ matches _)
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })
= matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) ->
- addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
+ dsCoercion co_fn (return (mkLams args body)) `thenDs` \ rhs ->
+ addAutoScc auto_scc (fun, rhs) `thenDs` \ pair ->
returnDs (pair : rest)
-dsHsBind auto_scc rest (PatBind pat grhss ty _)
+dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
= dsGuarded grhss ty `thenDs` \ body_expr ->
mkSelectorBinds pat body_expr `thenDs` \ sel_binds ->
mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds ->
returnDs (Note (SCC (mkAllDictsCC mod grp False)) rhs)
-}
\end{code}
+
+
+%************************************************************************
+%* *
+ Desugaring coercions
+%* *
+%************************************************************************
+
+
+\begin{code}
+dsCoercion :: ExprCoFn -> DsM CoreExpr -> DsM CoreExpr
+dsCoercion CoHole thing_inside = thing_inside
+dsCoercion (CoCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
+dsCoercion (CoLams ids c) thing_inside = do { expr <- dsCoercion c thing_inside
+ ; return (mkLams ids expr) }
+dsCoercion (CoTyLams tvs c) thing_inside = do { expr <- dsCoercion c thing_inside
+ ; return (mkLams tvs expr) }
+dsCoercion (CoApps c ids) thing_inside = do { expr <- dsCoercion c thing_inside
+ ; return (mkVarApps expr ids) }
+dsCoercion (CoTyApps c tys) thing_inside = do { expr <- dsCoercion c thing_inside
+ ; return (mkTyApps expr tys) }
+dsCoercion (CoLet bs c) thing_inside = do { prs <- dsLHsBinds bs
+ ; expr <- dsCoercion c thing_inside
+ ; return (Let (Rec prs) expr) }
+\end{code}
+
+
import Match ( matchWrapper, matchSimply, matchSinglePat )
import MatchLit ( dsLit, dsOverLit )
-import DsBinds ( dsLHsBinds )
+import DsBinds ( dsLHsBinds, dsCoercion )
import DsGRHSs ( dsGuarded )
import DsListComp ( dsListComp, dsPArrComp )
import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
(showSDoc (ppr pat))
in
case bagToList binds of
- [L loc (FunBind (L _ fun) _ matches _)]
+ [L loc (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })]
-> putSrcSpanDs loc $
matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
ASSERT( null args ) -- Functions aren't lifted
+ ASSERT( isIdCoercion co_fn )
returnDs (bindNonRec fun rhs body_w_exports)
- [L loc (PatBind pat grhss ty _)]
+ [L loc (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })]
-> putSrcSpanDs loc $
dsGuarded grhss ty `thenDs` \ rhs ->
mk_error_app pat `thenDs` \ error_expr ->
dsExpr (DictApp expr dicts) -- becomes a curried application
= dsLExpr expr `thenDs` \ core_expr ->
returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
+
+dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e)
\end{code}
Here is where we desugar the Template Haskell brackets and escapes
import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
isExternalName, getSrcLoc )
import NameEnv
-import Type ( Type, mkGenTyConApp )
+import Type ( Type, mkTyConApp )
import TcType ( tcTyConAppArgs )
import TyCon ( tyConName )
import TysWiredIn ( parrTyCon )
-- Note GHC treats declarations of a variable (not a pattern)
-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
-- with an empty list of patterns
-rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _) _))
+rep_bind (L loc (FunBind { fun_id = fn,
+ fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupLBinder fn
; ans' <- wrapGenSyns ss ans
; return (loc, ans') }
-rep_bind (L loc (FunBind fn infx (MatchGroup ms _) _))
+rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
= do { ms1 <- mapM repClauseTup ms
; fn' <- lookupLBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
; return (loc, ans) }
-rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2 _))
+rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
= do { patcore <- repLP pat
; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; ans' <- wrapGenSyns ss ans
; return (loc, ans') }
-rep_bind (L loc (VarBind v e))
+rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
= do { v' <- lookupBinder v
; e2 <- repLE e
; x <- repNormal e2
lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
-> DsM Type -- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
- return (mkGenTyConApp tc []) }
+ return (mkTyConApp tc []) }
wrapGenSyns :: [GenSymBind]
-> Core (TH.Q a) -> DsM (Core (TH.Q a))
module DsUtils (
EquationInfo(..),
firstPat, shiftEqns,
-
+
mkDsLet, mkDsLets,
MatchResult(..), CanItFail(..),
lengthPName, indexPName )
import Outputable
import SrcLoc ( Located(..), unLoc )
-import Util ( isSingleton, notNull, zipEqual, sortWith )
+import Util ( isSingleton, zipEqual, sortWith )
import ListSetOps ( assocDefault )
import FastString
-
import Data.Char ( ord )
+
+#ifdef DEBUG
+import Util ( notNull ) -- Used in an assertion
+#endif
\end{code}
cvtBind (TH.ValD (TH.VarP s) body ds)
= do { s' <- vNameL s
; cl' <- cvtClause (Clause [] body ds)
- ; returnL $ FunBind s' False (mkMatchGroup [cl']) placeHolderNames }
+ ; returnL $ mkFunBind s' [cl'] }
cvtBind (TH.FunD nm cls)
= do { nm' <- vNameL nm
; cls' <- mapM cvtClause cls
- ; returnL $ FunBind nm' False (mkMatchGroup cls') placeHolderNames }
+ ; returnL $ mkFunBind nm' cls' }
cvtBind (TH.ValD p body ds)
= do { p' <- cvtPat p
; g' <- cvtGuard body
; ds' <- cvtDecs ds
- ; returnL $ PatBind p' (GRHSs g' ds') void placeHolderNames }
+ ; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds',
+ pat_rhs_ty = void, bind_fvs = placeHolderNames } }
cvtBind d
= failWith (sep [ptext SLIT("Illegal kind of declaration in where clause"),
nest 2 (text (TH.pprint d))])
-
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
cvtClause (Clause ps body wheres)
= do { ps' <- cvtPats ps
import {-# SOURCE #-} HsPat ( LPat )
import HsTypes ( LHsType, PostTcType )
+import Type ( Type )
import Name ( Name )
import NameSet ( NameSet, elemNameSet )
import BasicTypes ( IPName, RecFlag(..), InlineSpec(..), Fixity )
type LHsBind id = Located (HsBind id)
data HsBind id
- = FunBind (Located id)
- -- Used for both functions f x = e
- -- and variables f = \x -> e
- -- Reason: the Match stuff lets us have an optional
- -- result type sig f :: a->a = ...mentions a...
- --
- -- This also means that instance decls can only have
- -- FunBinds, so if you change this, you'll need to
- -- change e.g. rnMethodBinds
- Bool -- True => infix declaration
- (MatchGroup id)
- NameSet -- After the renamer, this contains a superset of the
+ = FunBind { -- FunBind is used for both functions f x = e
+ -- and variables f = \x -> e
+ -- Reason: the Match stuff lets us have an optional
+ -- result type sig f :: a->a = ...mentions a...
+ --
+ -- This also means that instance decls can only have
+ -- FunBinds, so if you change this, you'll need to
+ -- change e.g. rnMethodBinds
+
+ fun_id :: Located id,
+
+ fun_infix :: Bool, -- True => infix declaration
+
+ fun_matches :: MatchGroup id, -- The payload
+
+ fun_co_fn :: ExprCoFn, -- Coercion from the type of the MatchGroup to the type of
+ -- the Id. Example:
+ -- f :: Int -> forall a. a -> a
+ -- f x y = y
+ -- Then the MatchGroup will have type (Int -> a' -> a')
+ -- (with a free type variable a'). The coercion will take
+ -- a CoreExpr of this type and convert it to a CoreExpr of
+ -- type Int -> forall a'. a' -> a'
+ -- Notice that the coercion captures the free a'. That's
+ -- why coercions are (CoreExpr -> CoreExpr), rather than
+ -- just CoreExpr (with a functional type)
+
+ bind_fvs :: NameSet -- After the renamer, this contains a superset of the
-- Names of the other binders in this binding group that
-- are free in the RHS of the defn
-- Before renaming, and after typechecking,
-- the field is unused; it's just an error thunk
-
- | PatBind (LPat id) -- The pattern is never a simple variable;
- -- That case is done by FunBind
- (GRHSs id)
- PostTcType -- Type of the GRHSs
- NameSet -- Same as for FunBind
-
- | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike
- -- All VarBinds are introduced by the type checker
- -- Located only for consistency
-
- | AbsBinds -- Binds abstraction; TRANSLATION
- [TyVar] -- Type variables
- [DictId] -- Dicts
- [([TyVar], id, id, [Prag])] -- (tvs, poly_id, mono_id, prags)
- (LHsBinds id) -- The dictionary bindings and typechecked user bindings
+ }
+
+ | PatBind { -- The pattern is never a simple variable;
+ -- That case is done by FunBind
+ pat_lhs :: LPat id,
+ pat_rhs :: GRHSs id,
+ pat_rhs_ty :: PostTcType, -- Type of the GRHSs
+ bind_fvs :: NameSet -- Same as for FunBind
+ }
+
+ | VarBind { -- Dictionary binding and suchlike
+ var_id :: id, -- All VarBinds are introduced by the type checker
+ var_rhs :: LHsExpr id -- Located only for consistency
+ }
+
+ | AbsBinds { -- Binds abstraction; TRANSLATION
+ abs_tvs :: [TyVar],
+ abs_dicts :: [DictId],
+ abs_exports :: [([TyVar], id, id, [Prag])], -- (tvs, poly_id, mono_id, prags)
+ abs_binds :: LHsBinds id -- The dictionary bindings and typechecked user bindings
-- mixed up together; you can tell the dict bindings because
-- they are all VarBinds
-
+ }
-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
--
-- Creates bindings for (polymorphic, overloaded) poly_f
ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
-ppr_monobind (PatBind pat grhss _ _) = pprPatBind pat grhss
-ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs)
-ppr_monobind (FunBind fun inf matches _) = pprFunBind (unLoc fun) matches
+ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss
+ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs)
+ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
-- ToDo: print infix if appropriate
-ppr_monobind (AbsBinds tyvars dictvars exports val_binds)
+ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
+ abs_exports = exports, abs_binds = val_binds })
= sep [ptext SLIT("AbsBinds"),
brackets (interpp'SP tyvars),
brackets (interpp'SP dictvars),
%************************************************************************
%* *
+\subsection{Coercion functions}
+%* *
+%************************************************************************
+
+\begin{code}
+-- A Coercion is an expression with a hole in it
+-- We need coercions to have concrete form so that we can zonk them
+
+data ExprCoFn
+ = CoHole -- The identity coercion
+ | CoCompose ExprCoFn ExprCoFn
+ | CoApps ExprCoFn [Id] -- Non-empty list
+ | CoTyApps ExprCoFn [Type] -- in all of these
+ | CoLams [Id] ExprCoFn -- so that the identity coercion
+ | CoTyLams [TyVar] ExprCoFn -- is just Hole
+ | CoLet (LHsBinds Id) ExprCoFn -- Would be nicer to be core bindings
+
+(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
+(<.>) = CoCompose
+
+idCoercion :: ExprCoFn
+idCoercion = CoHole
+
+isIdCoercion :: ExprCoFn -> Bool
+isIdCoercion CoHole = True
+isIdCoercion other = False
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{@Sig@: type signatures and value-modifying user pragmas}
%* *
%************************************************************************
f other = Nothing
isFixityLSig :: LSig name -> Bool
-isFixityLSig (L _ (FixSig _)) = True
-isFixityLSig _ = False
+isFixityLSig (L _ (FixSig {})) = True
+isFixityLSig _ = False
isVanillaLSig :: LSig name -> Bool
-isVanillaLSig (L _(TypeSig name _)) = True
-isVanillaLSig sig = False
+isVanillaLSig (L _(TypeSig {})) = True
+isVanillaLSig sig = False
isSpecLSig :: LSig name -> Bool
-isSpecLSig (L _(SpecSig name _ _)) = True
-isSpecLSig sig = False
+isSpecLSig (L _(SpecSig {})) = True
+isSpecLSig sig = False
-isSpecInstLSig (L _ (SpecInstSig _)) = True
-isSpecInstLSig sig = False
+isSpecInstLSig (L _ (SpecInstSig {})) = True
+isSpecInstLSig sig = False
isPragLSig :: LSig name -> Bool
-- Identifies pragmas
-isPragLSig (L _ (SpecSig _ _ _)) = True
-isPragLSig (L _ (InlineSig _ _)) = True
-isPragLSig other = False
-
-hsSigDoc (TypeSig _ _) = ptext SLIT("type signature")
-hsSigDoc (SpecSig _ _ _) = ptext SLIT("SPECIALISE pragma")
-hsSigDoc (InlineSig _ spec) = ppr spec <+> ptext SLIT("pragma")
-hsSigDoc (SpecInstSig _) = ptext SLIT("SPECIALISE instance pragma")
-hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration")
+isPragLSig (L _ (SpecSig {})) = True
+isPragLSig (L _ (InlineSig {})) = True
+isPragLSig other = False
+
+isInlineLSig :: LSig name -> Bool
+ -- Identifies inline pragmas
+isInlineLSig (L _ (InlineSig {})) = True
+isInlineLSig other = False
+
+hsSigDoc (TypeSig {}) = ptext SLIT("type signature")
+hsSigDoc (SpecSig {}) = ptext SLIT("SPECIALISE pragma")
+hsSigDoc (InlineSig _ spec) = ppr spec <+> ptext SLIT("pragma")
+hsSigDoc (SpecInstSig {}) = ptext SLIT("SPECIALISE instance pragma")
+hsSigDoc (FixSig {}) = ptext SLIT("fixity declaration")
\end{code}
Signature equality is used when checking for duplicate signatures
import HsLit ( HsLit(..), HsOverLit )
import HsTypes ( LHsType, PostTcType )
import HsImpExp ( isOperator, pprHsVar )
-import HsBinds ( HsLocalBinds, DictBinds, isEmptyLocalBinds )
+import HsBinds ( HsLocalBinds, DictBinds, ExprCoFn, isEmptyLocalBinds )
-- others:
import Type ( Type, pprParendType )
import Var ( TyVar, Id )
import Name ( Name )
-import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) )
+import BasicTypes ( IPName, Boxity, tupleParens, Arity, Fixity(..) )
import SrcLoc ( Located(..), unLoc )
import Outputable
import FastString
(LHsExpr id)
[id]
+ | HsCoerce ExprCoFn -- TRANSLATION
+ (HsExpr id)
+
type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
-- pasted back in by the desugarer
\end{code}
= hang (ppr_lexpr expr)
4 (brackets (interpp'SP dnames))
+ppr_expr (HsCoerce co_fn e) = ppr_expr e
+
ppr_expr (HsType id) = ppr id
ppr_expr (HsSpliceE s) = pprSplice s
-- Nothing after typechecking
(GRHSs id)
+matchGroupArity :: MatchGroup id -> Arity
+matchGroupArity (MatchGroup (match:matches) _)
+ = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
+ -- Assertion just checks that all the matches have the same number of pats
+ n_pats
+ where
+ n_pats = length (hsLMatchPats match)
+
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats
-]%
+%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[HsTypes]{Abstract syntax: user-defined types}
%************************************************************************
\begin{code}
+mkFunBind :: Located id -> [LMatch id] -> HsBind id
+-- Not infix, with place holders for coercion and free vars
+mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
+ fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
+
+
mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
-> LHsExpr RdrName -> LHsBind RdrName
mk_easy_FunBind loc fun pats expr
- = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
- where
- matches = mkMatchGroup [mkMatch pats expr emptyLocalBinds]
+ = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
------------
mk_FunBind :: SrcSpan -> RdrName
mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
mk_FunBind loc fun pats_and_exprs
- = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
+ = L loc $ mkFunBind (L loc fun) matches
where
- matches = mkMatchGroup [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
+ matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
------------
mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
collectAcc :: HsBind name -> [Located name] -> [Located name]
-collectAcc (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc
-collectAcc (FunBind f _ _ _) acc = f : acc
-collectAcc (VarBind f _) acc = noLoc f : acc
-collectAcc (AbsBinds _ _ dbinds binds) acc
+collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
+collectAcc (FunBind { fun_id = f }) acc = f : acc
+collectAcc (VarBind { var_id = f }) acc = noLoc f : acc
+collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
= [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
-- ++ foldr collectAcc acc binds
-- I don't think we want the binders from the nested binds
%************************************************************************
%* *
- Getting pattern signatures out of bindings
-%* *
-%************************************************************************
-
-Get all the pattern type signatures out of a bunch of bindings
-
-\begin{code}
-collectSigTysFromHsBinds :: LHsBinds name -> [LHsType name]
-collectSigTysFromHsBinds binds = concatMap collectSigTysFromHsBind (bagToList binds)
-
-collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
-collectSigTysFromHsBind bind
- = go (unLoc bind)
- where
- go (PatBind pat _ _ _)
- = collectSigTysFromPat pat
- go (FunBind f _ (MatchGroup ms _) _)
- = [sig | L _ (Match [] (Just sig) _) <- ms]
- -- A binding like x :: a = f y
- -- is parsed as FunMonoBind, but for this purpose we
- -- want to treat it as a pattern binding
- go out_bind = panic "collectSigTysFromHsBind"
-\end{code}
-
-%************************************************************************
-%* *
Getting binders from statements
%* *
%************************************************************************
import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
- tyConHasGenerics, tyConArgVrcs, getSynTyConDefn,
+ tyConHasGenerics, tyConArgVrcs, synTyConRhs,
tyConArity, tyConTyVars, algTyConRhs, tyConExtName )
import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
dataConTyCon, dataConIsInfix, isVanillaDataCon )
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
- tyvars = tyConTyVars tycon
- (_, syn_ty) = getSynTyConDefn tycon
+ tyvars = tyConTyVars tycon
+ syn_ty = synTyConRhs tycon
ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
#include "HsVersions.h"
import Kind ( Kind(..) )
-import TypeRep ( TyThing(..), Type(..), TyNote(..), PredType(..), ThetaType )
+import TypeRep ( TyThing(..), Type(..), PredType(..), ThetaType )
import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName )
import Var ( isId, tyVarKind, idType )
import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
-import TcType ( hoistForAllTys ) -- TEMPORARY HACK
-import Type ( liftedTypeKind, splitTyConApp, mkSynTy, mkTyConApp,
- mkTyVarTys, ThetaType,
- mkGenTyConApp ) -- Don't remove this... see mkIfTcApp
+import Type ( liftedTypeKind, splitTyConApp, mkTyConApp,
+ mkTyVarTys, ThetaType )
import TypeRep ( Type(..), PredType(..) )
-import TyCon ( TyCon, tyConName, isSynTyCon )
+import TyCon ( TyCon, tyConName )
import HscTypes ( ExternalPackageState(..),
TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), HomeModInfo(..),
tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
-tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkIfTcApp tc' ts') }
+tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') }
tcIfaceTypes tys = mapM tcIfaceType tys
-mkIfTcApp :: TyCon -> [Type] -> Type
--- In interface files we retain type synonyms (for brevity and better error
--- messages), but type synonyms can expand into non-hoisted types (ones with
--- foralls to the right of an arrow), so we must be careful to hoist them here.
--- This hack should go away when we get rid of hoisting.
--- Then we should go back to mkGenTyConApp or something like it
---
--- Nov 05: the type is now hoisted before being put into an interface file
-mkIfTcApp tc tys = mkTyConApp tc tys
--- | isSynTyCon tc = hoistForAllTys (mkSynTy tc tys)
--- | otherwise = mkTyConApp tc tys
-
-----------------------------------------
tcIfacePredType :: IfacePredType -> IfL PredType
tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
- getSynTyConDefn,
+ synTyConDefn, synTyConRhs,
-- ** Type variables
TyVar,
import TysPrim ( alphaTyVars )
import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
isPrimTyCon, isFunTyCon, tyConArity,
- tyConTyVars, tyConDataCons, getSynTyConDefn )
+ tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
import Class ( Class, classSCTheta, classTvsFds, classMethods )
import FunDeps ( pprFundeps )
import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
import ParserCoreUtils
import FastString
import Maybes ( expectJust )
-import Bag ( unitBag, emptyBag )
+import Bag ( unitBag )
import Monad ( when )
import Maybe ( isJust )
import IO
(inst_method_ds, method_specs, method_inlines)
= foldr add3 (0,0,0) (map inst_info inst_decls)
- count_bind (PatBind (L _ (VarPat n)) r _ _) = (1,0)
- count_bind (PatBind p r _ _) = (0,1)
- count_bind (FunBind f _ m _) = (0,1)
+ count_bind (PatBind { pat_lhs = L _ (VarPat n) }) = (1,0)
+ count_bind (PatBind {}) = (0,1)
+ count_bind (FunBind {}) = (0,1)
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
pprTyCon exts tyCon
| GHC.isSynTyCon tyCon
- = let (_,rhs_type) = GHC.getSynTyConDefn tyCon
+ = let rhs_type = GHC.synTyConRhs tyCon
in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type)
| otherwise
= pprAlgTyCon exts tyCon (const True) (const True)
: btype { $1 }
| btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 }
| btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 }
- | btype '->' gentype { LL $ HsFunTy $1 $3 }
+ | btype '->' ctype { LL $ HsFunTy $1 $3 }
btype :: { LHsType RdrName }
: btype atype { LL $ HsAppTy $1 $2 }
: gtycon { L1 (HsTyVar (unLoc $1)) }
| tyvar { L1 (HsTyVar (unLoc $1)) }
| strict_mark atype { LL (HsBangTy (unLoc $1) $2) }
- | '(' type ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) }
+ | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) }
| '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 }
- | '[' type ']' { LL $ HsListTy $2 }
- | '[:' type ':]' { LL $ HsPArrTy $2 }
+ | '[' ctype ']' { LL $ HsListTy $2 }
+ | '[:' ctype ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 }
-- Generics
| {- empty -} { [] }
comma_types1 :: { [LHsType RdrName] }
- : type { [$1] }
- | type ',' comma_types1 { $1 : $3 }
+ : ctype { [$1] }
+ | ctype ',' comma_types1 { $1 : $3 }
tv_bndrs :: { [LHsTyVarBndr RdrName] }
: tv_bndr tv_bndrs { $1 : $2 }
| 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) }
qual :: { LStmt RdrName }
- : infixexp '<-' exp {% checkPattern $1 >>= \p ->
+ : exp '<-' exp {% checkPattern $1 >>= \p ->
return (LL $ mkBindStmt p $3) }
| exp { L1 $ mkExprStmt $1 }
| 'let' binds { LL $ LetStmt (unLoc $2) }
extractGenericPatTyVars binds
= nubBy eqLocated (foldrBag get [] binds)
where
- get (L _ (FunBind _ _ (MatchGroup ms _) _)) acc = foldr (get_m.unLoc) acc ms
- get other acc = acc
+ get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
+ get other acc = acc
get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
get_m other acc = acc
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _) _)) binds
+getMonoBind (L loc bind@(FunBind { fun_id = L _ f, fun_matches = MatchGroup mtchs _ })) binds
| has_args mtchs
= go mtchs loc binds
where
- go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _) _)) : binds)
- | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
+ go mtchs1 loc1 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_matches = MatchGroup mtchs2 _ })) : binds)
+ | f == f2 = go (mtchs2++mtchs1) loc binds
where loc = combineSrcSpans loc1 loc2
go mtchs1 loc binds
- = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1)) placeHolderNames), binds)
+ = (L loc (bind { fun_matches = mkMatchGroup (reverse mtchs1) }), binds)
-- Reverse the final matches, to get it back in the right order
getMonoBind bind binds = (bind, binds)
-> P (HsBind RdrName)
checkValDef lhs opt_sig (L rhs_span grhss)
- | Just (f,inf,es) <- isFunLhs lhs []
+ | Just (f,inf,es) <- isFunLhs lhs
= if isQual (unLoc f)
then parseError (getLoc f) ("Qualified name in function definition: " ++
showRdrName (unLoc f))
else do ps <- checkPatterns es
let match_span = combineSrcSpans (getLoc lhs) rhs_span
matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)]
- return (FunBind f inf matches placeHolderNames)
+ return (FunBind { fun_id = f, fun_infix = inf, fun_matches = matches,
+ fun_co_fn = idCoercion, bind_fvs = placeHolderNames })
-- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now.
| otherwise = do
-- A variable binding is parsed as a FunBind.
-isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
+isFunLhs :: LHsExpr RdrName
-> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
-isFunLhs (L loc e) = isFunLhs' loc e
+isFunLhs e = go e []
where
- isFunLhs' loc (HsVar f) es
+ go (L loc (HsVar f)) es
| not (isRdrDataCon f) = Just (L loc f, False, es)
- isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es)
- isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es
- isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
+ go (L _ (HsApp f e)) es = go f (e:es)
+ go (L _ (HsPar e)) es@(_:_) = go e es
+ go (L loc (OpApp l (L loc' (HsVar op)) fix r)) es
| not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
| otherwise =
- case isFunLhs l es of
+ case go l es of
Just (op', True, j : k : es') ->
Just (op', True,
j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
_ -> Nothing
- isFunLhs' _ _ _ = Nothing
+ go _ _ = Nothing
---------------------------------------------------------------------------
-- Miscellaneous utilities
rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses)
rnTopBindsSrc binds@(ValBindsIn mbinds _)
- = bindPatSigTyVars (collectSigTysFromHsBinds mbinds) $ \ _ ->
- -- Hmm; by analogy with Ids, this doesn't look right
- -- Top-level bound type vars should really scope over
- -- everything, but we only scope them over the other bindings
-
- do { (binds', dus) <- rnValBinds noTrim binds
+ = do { (binds', dus) <- rnValBinds noTrim binds
-- Warn about missing signatures,
; let { ValBindsOut _ sigs' = binds'
-- current scope, inventing new names for the new binders
-- This also checks that the names form a set
bindLocatedLocalsRn doc mbinders_w_srclocs $ \ bndrs ->
- bindPatSigTyVarsFV (collectSigTysFromHsBinds mbinds) $
-- Then install local fixity declarations
-- Notice that they scope over thing_inside too
-> (FreeVars -> FreeVars) -- Trimming function for rhs free vars
-> LHsBind RdrName
-> RnM (LHsBind Name, [Name], Uses)
-rnBind sig_fn trim (L loc (PatBind pat grhss ty _))
+rnBind sig_fn trim (L loc (PatBind { pat_lhs = pat, pat_rhs = grhss }))
= setSrcSpan loc $
do { (pat', pat_fvs) <- rnLPat pat
; (grhss', fvs) <- bindSigTyVarsFV (concatMap sig_fn bndrs) $
rnGRHSs PatBindRhs grhss
- ; return (L loc (PatBind pat' grhss' ty (trim fvs)), bndrs, pat_fvs `plusFV` fvs) }
+ ; return (L loc (PatBind { pat_lhs = pat', pat_rhs = grhss',
+ pat_rhs_ty = placeHolderType, bind_fvs = trim fvs }),
+ bndrs, pat_fvs `plusFV` fvs) }
-rnBind sig_fn trim (L loc (FunBind name inf matches _))
+rnBind sig_fn trim (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = matches }))
= setSrcSpan loc $
do { new_name <- lookupLocatedBndrRn name
; let plain_name = unLoc new_name
; checkPrecMatch inf plain_name matches'
- ; return (L loc (FunBind new_name inf matches' (trim fvs)), [plain_name], fvs)
+ ; return (L loc (FunBind { fun_id = new_name, fun_infix = inf, fun_matches = matches',
+ bind_fvs = trim fvs, fun_co_fn = idCoercion }),
+ [plain_name], fvs)
}
\end{code}
(bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind
return (bind' `unionBags` binds, fvs_bind `plusFV` fvs)
-rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _) _))
+rnMethodBind cls gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf,
+ fun_matches = MatchGroup matches _ }))
= setSrcSpan loc $
lookupLocatedInstDeclBndr cls name `thenM` \ sel_name ->
let plain_name = unLoc sel_name in
new_group = MatchGroup new_matches placeHolderType
in
checkPrecMatch inf plain_name new_group `thenM_`
- returnM (unitBag (L loc (FunBind sel_name inf new_group fvs)), fvs `addOneFV` plain_name)
+ returnM (unitBag (L loc (FunBind { fun_id = sel_name, fun_infix = inf, fun_matches = new_group,
+ bind_fvs = fvs, fun_co_fn = idCoercion })),
+ fvs `addOneFV` plain_name)
-- The 'fvs' field isn't used for method binds
where
-- Truly gruesome; bring into scope the correct members of the generic
tidyInsts, tidyMoreInsts,
newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
- tcOverloadedLit, newIPDict,
+ shortCutFracLit, shortCutIntLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
- tcInstClassOp, tcInstCall, tcInstStupidTheta,
- tcSyntaxName,
+ tcInstClassOp, tcInstStupidTheta,
+ tcSyntaxName, isHsVar,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcCheckSigma, tcSyntaxOp )
-import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
+import {-# SOURCE #-} TcExpr( tcPolyExpr )
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
nlHsLit, nlHsVar )
-import TcHsSyn ( mkHsTyApp, mkHsDictApp, zonkId,
- mkCoercion, ExprCoFn
- )
+import TcHsSyn ( mkHsTyApp, mkHsDictApp, zonkId )
import TcRnMonad
import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
instanceHead, instanceDFunId, setInstanceDFunId )
import FunDeps ( checkFunDeps )
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
- tcInstTyVar, tcInstType, tcSkolType
+ tcInstTyVar, tcInstSkolType
)
-import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
+import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType,
+ BoxyRhoType,
PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
- tcSplitForAllTys, mkFunTy,
+ tcSplitForAllTys, applyTys,
tcSplitPhiTy, tcSplitDFunHead,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
- mkPredTy, mkTyVarTy, mkTyVarTys,
+ mkPredTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
isClassPred, isTyVarClassPred, isLinearPred,
getClassPredTys, mkPredName,
import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
- isInternalName, setNameUnique, mkSystemVarName )
+ isInternalName, setNameUnique )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
import Var ( TyVar, tyVarKind, setIdType )
instName inst = idName (instToId inst)
instToId :: Inst -> TcId
-instToId (LitInst nm _ ty _) = mkLocalId nm ty
-instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
-instToId (Method id _ _ _ _ _) = id
+instToId (LitInst nm _ ty _) = mkLocalId nm ty
+instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
+instToId (Method id _ _ _ _) = id
-instLoc (Dict _ _ loc) = loc
-instLoc (Method _ _ _ _ _ loc) = loc
-instLoc (LitInst _ _ _ loc) = loc
+instLoc (Dict _ _ loc) = loc
+instLoc (Method _ _ _ _ loc) = loc
+instLoc (LitInst _ _ _ loc) = loc
dictPred (Dict _ pred _ ) = pred
dictPred inst = pprPanic "dictPred" (ppr inst)
-- Leaving these in is really important for the call to fdPredsOfInsts
-- in TcSimplify.inferLoop, because the result is fed to 'grow',
-- which is supposed to be conservative
-fdPredsOfInst (Dict _ pred _) = [pred]
-fdPredsOfInst (Method _ _ _ theta _ _) = theta
-fdPredsOfInst other = [] -- LitInsts etc
+fdPredsOfInst (Dict _ pred _) = [pred]
+fdPredsOfInst (Method _ _ _ theta _) = theta
+fdPredsOfInst other = [] -- LitInsts etc
fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts
-isInheritableInst (Dict _ pred _) = isInheritablePred pred
-isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
-isInheritableInst other = True
+isInheritableInst (Dict _ pred _) = isInheritablePred pred
+isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta
+isInheritableInst other = True
ipNamesOfInsts :: [Inst] -> [Name]
-- NB: ?x and %x get different Names
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
-ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
-ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
-ipNamesOfInst other = []
+ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
+ipNamesOfInst (Method _ _ _ theta _) = [ipNameName n | IParam n _ <- theta]
+ipNamesOfInst other = []
tyVarsOfInst :: Inst -> TcTyVarSet
-tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
-tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
-tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
+tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
+tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
+tyVarsOfInst (Method _ id tys _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
-- The id might have free type variables; in the case of
-- locally-overloaded class methods, for example
isIPDict other = False
isMethod :: Inst -> Bool
-isMethod (Method _ _ _ _ _ _) = True
-isMethod other = False
+isMethod (Method {}) = True
+isMethod other = False
isMethodFor :: TcIdSet -> Inst -> Bool
-isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
-isMethodFor ids inst = False
+isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
+isMethodFor ids inst = False
isLinearInst :: Inst -> Bool
isLinearInst (Dict _ pred _) = isLinearPred pred
\begin{code}
-tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
-tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
- = do { (tyvars, theta, tau) <- tcInstType fun_ty
- ; dicts <- newDicts orig theta
- ; extendLIEs dicts
- ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
- (map instToId dicts))
- ; return (mkCoercion inst_fn, tyvars, tau) }
-
tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
-- Instantiate the "stupid theta" of the data con, and throw
-- the constraints into the constraint set
stupid_theta = dataConStupidTheta data_con
tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
-newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
+newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
newMethodFromName origin ty name
= tcLookupId name `thenM` \ id ->
-- Use tcLookupId not tcLookupGlobalId; the method is almost
extendLIE inst `thenM_`
returnM (instToId inst)
-newMethodWithGivenTy orig id tys theta tau
- = getInstLoc orig `thenM` \ loc ->
- newMethod loc id tys theta tau `thenM` \ inst ->
- extendLIE inst `thenM_`
+newMethodWithGivenTy orig id tys
+ = getInstLoc orig `thenM` \ loc ->
+ newMethod loc id tys `thenM` \ inst ->
+ extendLIE inst `thenM_`
returnM (instToId inst)
--------------------------------------------
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
tcInstClassOp inst_loc sel_id tys
= let
- (tyvars,rho) = tcSplitForAllTys (idType sel_id)
- rho_ty = ASSERT( length tyvars == length tys )
- substTyWith tyvars tys rho
- (preds,tau) = tcSplitPhiTy rho_ty
+ (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
in
zipWithM_ checkKind tyvars tys `thenM_`
- newMethod inst_loc sel_id tys preds tau
+ newMethod inst_loc sel_id tys
checkKind :: TyVar -> TcType -> TcM ()
-- Ensure that the type has a sub-kind of the tyvar
checkKind tv ty
- = do { ty1 <- zonkTcType ty
+ = do { let ty1 = ty
+ -- ty1 <- zonkTcType ty
; if typeKind ty1 `isSubKind` tyVarKind tv
then return ()
- else do
- { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
- ; tv1 <- tcInstTyVar tv
- ; unifyTauTy (mkTyVarTy tv1) ty1 }}
+ else
+
+ pprPanic "checkKind: adding kind constraint"
+ (vcat [ppr tv <+> ppr (tyVarKind tv),
+ ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
+ }
+-- do { tv1 <- tcInstTyVar tv
+-- ; unifyType ty1 (mkTyVarTy tv1) } }
---------------------------
-newMethod inst_loc id tys theta tau
+newMethod inst_loc id tys
= newUnique `thenM` \ new_uniq ->
let
- meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
- inst = Method meth_id id tys theta tau inst_loc
- loc = instLocSrcLoc inst_loc
+ (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
+ meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
+ inst = Method meth_id id tys theta inst_loc
+ loc = instLocSrcLoc inst_loc
in
returnM inst
\end{code}
-In tcOverloadedLit we convert directly to an Int or Integer if we
-know that's what we want. This may save some time, by not
-temporarily generating overloaded literals, but it won't catch all
-cases (the rest are caught in lookupInst).
-
\begin{code}
-tcOverloadedLit :: InstOrigin
- -> HsOverLit Name
- -> TcType
- -> TcM (HsOverLit TcId)
-tcOverloadedLit orig lit@(HsIntegral i fi) expected_ty
- | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
- -- Reason: If we do, tcSimplify will call lookupInst, which
- -- will call tcSyntaxName, which does unification,
- -- which tcSimplify doesn't like
- -- ToDo: noLoc sadness
- = do { integer_ty <- tcMetaTy integerTyConName
- ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty expected_ty)
- ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
-
- | Just expr <- shortCutIntLit i expected_ty
- = return (HsIntegral i expr)
-
- | otherwise
- = do { expr <- newLitInst orig lit expected_ty
- ; return (HsIntegral i expr) }
-
-tcOverloadedLit orig lit@(HsFractional r fr) expected_ty
- | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
- = do { rat_ty <- tcMetaTy rationalTyConName
- ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty expected_ty)
- ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
-
- | Just expr <- shortCutFracLit r expected_ty
- = return (HsFractional r expr)
-
- | otherwise
- = do { expr <- newLitInst orig lit expected_ty
- ; return (HsFractional r expr) }
-
-newLitInst :: InstOrigin -> HsOverLit Name -> TcType -> TcM (HsExpr TcId)
-newLitInst orig lit expected_ty -- Make a LitInst
- = do { loc <- getInstLoc orig
- ; new_uniq <- newUnique
- ; let
- lit_nm = mkSystemVarName new_uniq FSLIT("lit")
- lit_inst = LitInst lit_nm lit expected_ty loc
- ; extendLIE lit_inst
- ; return (HsVar (instToId lit_inst)) }
-
shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
shortCutIntLit i ty
| isIntTy ty && inIntRange i -- Short cut for Int
= zonkTcPredType pred `thenM` \ new_pred ->
returnM (Dict name new_pred loc)
-zonkInst (Method m id tys theta tau loc)
+zonkInst (Method m id tys theta loc)
= zonkId id `thenM` \ new_id ->
-- Essential to zonk the id in case it's a local variable
-- Can't use zonkIdOcc because the id might itself be
zonkTcTypes tys `thenM` \ new_tys ->
zonkTcThetaType theta `thenM` \ new_theta ->
- zonkTcType tau `thenM` \ new_tau ->
- returnM (Method m new_id new_tys new_theta new_tau loc)
+ returnM (Method m new_id new_tys new_theta loc)
zonkInst (LitInst nm lit ty loc)
= zonkTcType ty `thenM` \ new_ty ->
pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
-pprInst m@(Method inst_id id tys theta tau loc)
+pprInst m@(Method inst_id id tys theta loc)
= ppr inst_id <+> dcolon <+>
braces (sep [ppr id <+> ptext SLIT("at"),
brackets (sep (map pprParendType tys))])
= sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
tidyInst :: TidyEnv -> Inst -> Inst
-tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
-tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
-tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
+tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
+tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
+tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
-- This function doesn't assume that the tyvars are in scope
-- This is important because the template variables must
-- not overlap with anything in the things being looked up
-- (since we do unification).
- -- We use tcSkolType because we don't want to allocate fresh
+ -- We use tcInstSkolType because we don't want to allocate fresh
-- *meta* type variables.
let dfun = instanceDFunId ispec
- ; (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
+ ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
ispec' = setInstanceDFunId ispec dfun'
-- Methods
-lookupInst inst@(Method _ id tys theta _ loc)
+lookupInst inst@(Method _ id tys theta loc)
= newDictsAtLoc loc theta `thenM` \ dicts ->
returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
where
-- same type as the standard one.
-- Tiresome jiggling because tcCheckSigma takes a located expression
getSrcSpanM `thenM` \ span ->
- tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
+ tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
returnM (std_nm, unLoc expr)
syntaxNameCtxt name orig ty tidy_env
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho )
+import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho )
import HsSyn
import TcHsSyn ( mkHsDictLet )
-import TcMatches ( tcMatchPats, matchCtxt, tcStmts, tcMDoStmt, tcGuardStmt,
+import TcMatches ( matchCtxt, tcStmts, tcMDoStmt, tcGuardStmt,
TcMatchCtxt(..), tcMatchesCase )
-import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
+import TcType ( TcType, TcTauType, BoxyRhoType, mkFunTys, mkTyConApp,
mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType,
SkolemInfo(..) )
-import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVars, zonkTcType )
+import TcMType ( newFlexiTyVarTy, tcInstSkolTyVars, zonkTcType )
import TcBinds ( tcLocalBinds )
import TcSimplify ( tcSimplifyCheck )
-import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
+import TcPat ( tcPat, tcPats, PatCtxt(..) )
+import TcUnify ( checkSigTyVarsWrt, boxySplitAppTy )
import TcRnMonad
import Inst ( tcSyntaxName )
import Name ( Name )
\begin{code}
tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr
- -> Expected TcRhoType -- Expected type of whole proc expression
+ -> BoxyRhoType -- Expected type of whole proc expression
-> TcM (OutPat TcId, LHsCmdTop TcId)
tcProc pat cmd exp_ty
--- gaw 2004 FIX?
- = newArrowScope $ do
- { arr_ty <- newTyFlexiVarTy arrowTyConKind
- ; [arg_ty, res_ty] <- newTyFlexiVarTys 2 liftedTypeKind
- ; zapExpectedTo exp_ty (mkAppTys arr_ty [arg_ty,res_ty])
-
+ = newArrowScope $
+ do { (exp_ty1, res_ty) <- boxySplitAppTy exp_ty
+ ; (arr_ty, arg_ty) <- boxySplitAppTy exp_ty1
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
- ; ([pat'], cmd') <- tcMatchPats [pat] [Check arg_ty] (Check res_ty) $
- tcCmdTop cmd_env cmd ([], res_ty)
- -- The False says don't do GADT type refinement
- -- This is a conservative choice, but I'm not sure of the consequences
- -- of type refinement in the arrow world!
-
+ ; (pat', cmd') <- tcPat LamPat pat arg_ty res_ty $ \ res_ty' ->
+ tcCmdTop cmd_env cmd ([], res_ty')
; return (pat', cmd') }
\end{code}
= addErrCtxt (cmdCtxt in_cmd) $
addErrCtxt (caseScrutCtxt scrut) (
tcInferRho scrut
- ) `thenM` \ (scrut', scrut_ty) ->
- tcMatchesCase match_ctxt scrut_ty matches (Check res_ty) `thenM` \ matches' ->
+ ) `thenM` \ (scrut', scrut_ty) ->
+ tcMatchesCase match_ctxt scrut_ty matches res_ty `thenM` \ matches' ->
returnM (HsCase scrut' matches')
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = mc_body }
- mc_body body (Check res_ty') = tcCmd env body (stk, res_ty')
+ mc_body body res_ty' = tcCmd env body (stk, res_ty')
tc_cmd env (HsIf pred b1 b2) res_ty
- = do { pred' <- tcCheckRho pred boolTy
+ = do { pred' <- tcMonoExpr pred boolTy
; b1' <- tcCmd env b1 res_ty
; b2' <- tcCmd env b2 res_ty
; return (HsIf pred' b1' b2')
tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
- do { arg_ty <- newTyFlexiVarTy openTypeKind
+ do { arg_ty <- newFlexiTyVarTy openTypeKind
; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
- ; fun' <- select_arrow_scope (tcCheckRho fun fun_ty)
+ ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty)
- ; arg' <- tcCheckRho arg arg_ty
+ ; arg' <- tcMonoExpr arg arg_ty
; return (HsArrApp fun' arg' fun_ty ho_app lr) }
where
tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
-- gaw 2004 FIX?
- do { arg_ty <- newTyFlexiVarTy openTypeKind
+ do { arg_ty <- newFlexiTyVarTy openTypeKind
; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty)
- ; arg' <- tcCheckRho arg arg_ty
+ ; arg' <- tcMonoExpr arg arg_ty
; return (HsApp fun' arg') }
(kappaUnderflow cmd)
-- Check the patterns, and the GRHSs inside
- ; (pats', grhss') <- setSrcSpan mtch_loc $
- tcMatchPats pats (map Check cmd_stk) (Check res_ty) $
+ ; (pats', grhss') <- setSrcSpan mtch_loc $
+ tcPats LamPat pats cmd_stk res_ty $
tc_grhss grhss
; let match' = L mtch_loc (Match pats' Nothing grhss')
match_ctxt = LambdaExpr -- Maybe KappaExpr?
pg_ctxt = PatGuard match_ctxt
- tc_grhss (GRHSs grhss binds)
+ tc_grhss (GRHSs grhss binds) res_ty
= do { (binds', grhss') <- tcLocalBinds binds $
- mappM (wrapLocM tc_grhs) grhss
+ mapM (wrapLocM (tc_grhs res_ty)) grhss
; return (GRHSs grhss' binds') }
- tc_grhs (GRHS guards body)
- = do { (guards', rhs') <- tcStmts pg_ctxt
- (tcGuardStmt res_ty)
- guards
- (tcCmd env body (stk', res_ty))
+ tc_grhs res_ty (GRHS guards body)
+ = do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt
+ guards res_ty
+ (\res_ty' -> tcCmd env body (stk', res_ty'))
; return (GRHS guards' rhs') }
-------------------------------------------
tc_cmd env cmd@(HsDo do_or_lc stmts body ty) (cmd_stk, res_ty)
= do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
- ; (stmts', body') <- tcStmts do_or_lc tc_stmt stmts $
- tcCmd env body ([], res_ty)
+ ; (stmts', body') <- tcStmts do_or_lc tc_stmt stmts res_ty $ \ res_ty' ->
+ tcCmd env body ([], res_ty')
; return (HsDo do_or_lc stmts' body' res_ty) }
where
- tc_stmt = tcMDoStmt res_ty tc_rhs
- tc_rhs rhs = do { ty <- newTyFlexiVarTy liftedTypeKind
+ tc_stmt = tcMDoStmt tc_rhs
+ tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcCmd env rhs ([], ty)
; return (rhs', ty) }
= addErrCtxt (cmdCtxt cmd) $
do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
; span <- getSrcSpanM
- ; [w_tv] <- tcSkolTyVars (ArrowSkol span) [alphaTyVar]
+ ; [w_tv] <- tcInstSkolTyVars (ArrowSkol span) [alphaTyVar]
; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point
-- a ((w,t1) .. tn) t
e_res_ty
-- Check expr
- ; (expr', lie) <- escapeArrowScope (getLIE (tcCheckRho expr e_ty))
+ ; (expr', lie) <- escapeArrowScope (getLIE (tcMonoExpr expr e_ty))
; inst_binds <- tcSimplifyCheck sig_msg [w_tv] [] lie
-- Check that the polymorphic variable hasn't been unified with anything
-> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
new_cmd_ty cmd i
-- gaw 2004 FIX?
- = do { b_ty <- newTyFlexiVarTy arrowTyConKind
- ; tup_ty <- newTyFlexiVarTy liftedTypeKind
+ = do { b_ty <- newFlexiTyVarTy arrowTyConKind
+ ; tup_ty <- newFlexiTyVarTy liftedTypeKind
-- We actually make a type variable for the tuple
-- because we don't know how deeply nested it is yet
- ; s_ty <- newTyFlexiVarTy liftedTypeKind
+ ; s_ty <- newFlexiTyVarTy liftedTypeKind
; return (cmd, i, b_ty, tup_ty, s_ty)
}
module TcBinds ( tcLocalBinds, tcTopBinds,
tcHsBootSigs, tcMonoBinds,
TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
+ TcSigInfo(..),
badBootDeclErr ) where
#include "HsVersions.h"
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
-import {-# SOURCE #-} TcExpr ( tcCheckRho )
+import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import DynFlags ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) )
import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
LPat, GRHSs, MatchGroup(..), pprLHsBinds,
collectHsBindBinders, collectPatBinders, pprPatBind
)
-import TcHsSyn ( zonkId, (<$>) )
+import TcHsSyn ( zonkId )
import TcRnMonad
import Inst ( newDictsAtLoc, newIPDict, instToId )
import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2,
- tcLookupLocalIds, pprBinders,
+ pprBinders, tcLookupLocalId_maybe, tcLookupId,
tcGetGlobalTyVars )
-import TcUnify ( Expected(..), tcInfer, unifyTheta, tcSub,
+import TcUnify ( tcInfer, tcSubExp, unifyTheta,
bleatEscapedTvs, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck,
tcSimplifyRestricted, tcSimplifyIPs )
-import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
- TcSigInfo(..), TcSigFun, lookupSig
- )
+import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( tcPat, PatCtxt(..) )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar,
- tcInstSigType, zonkTcType, zonkTcTypes, zonkTcTyVar )
-import TcType ( TcType, TcTyVar, SkolemInfo(SigSkol),
+import TcMType ( newFlexiTyVarTy, zonkQuantifiedTyVar, zonkSigTyVar,
+ tcInstSigTyVars, tcInstSkolTyVars, tcInstType,
+ zonkTcType, zonkTcTypes, zonkTcTyVars )
+import TcType ( TcType, TcTyVar, TcThetaType,
+ SkolemInfo(SigSkol), UserTypeCtxt(FunSigCtxt),
TcTauType, TcSigmaType, isUnboxedTupleType,
- mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
+ mkTyVarTy, mkForAllTys, mkFunTys, exactTyVarsOfType,
mkForAllTy, isUnLiftedType, tcGetTyVar,
mkTyVarTys, tidyOpenTyVar )
import Kind ( argTypeKind )
-import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv, emptyTidyEnv )
+import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv )
+import TysWiredIn ( unitTy )
import TysPrim ( alphaTyVar )
import Id ( Id, mkLocalId, mkVanillaGlobal )
import IdInfo ( vanillaIdInfo )
import Var ( TyVar, idType, idName )
-import Name ( Name )
+import Name ( Name, getSrcLoc )
import NameSet
import NameEnv
import VarSet
import Bag
import ErrUtils ( Message )
import Digraph ( SCC(..), stronglyConnComp )
-import Maybes ( fromJust, isJust, isNothing, orElse, catMaybes )
+import Maybes ( fromJust, isJust, isNothing, orElse )
import Util ( singleton )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec )
-- Consider ?x = 4
-- ?y = ?x + 1
tc_ip_bind (IPBind ip expr)
- = newTyFlexiVarTy argTypeKind `thenM` \ ty ->
+ = newFlexiTyVarTy argTypeKind `thenM` \ ty ->
newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) ->
- tcCheckRho expr ty `thenM` \ expr' ->
+ tcMonoExpr expr ty `thenM` \ expr' ->
returnM (ip_inst, (IPBind ip' expr'))
------------------------
= pprPanic "tcValBinds" (ppr binds)
tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
- = tcAddLetBoundTyVars binds $
- -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
- -- Notice that they scope over
- -- a) the type signatures in the binding group
- -- b) the bindings in the group
- -- c) the scope of the binding group (the "in" part)
-
- do { -- Typecheck the signature
- tc_ty_sigs <- recoverM (returnM []) (tcTySigs sigs)
+ = do { -- Typecheck the signature
; let { prag_fn = mkPragFun sigs
- ; sig_fn = lookupSig tc_ty_sigs
- ; sig_ids = map sig_id tc_ty_sigs }
+ ; ty_sigs = filter isVanillaLSig sigs
+ ; sig_fn = mkSigFun ty_sigs }
+
+ ; poly_ids <- mapM tcTySig ty_sigs
-- Extend the envt right away with all
-- the Ids declared with type signatures
- ; (binds', thing) <- tcExtendIdEnv sig_ids $
+ ; (binds', thing) <- tcExtendIdEnv poly_ids $
tc_val_binds top_lvl sig_fn prag_fn
binds thing_inside
tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
= -- A recursive strongly-connected component
-- To maximise polymorphism (with -fglasgow-exts), we do a new
- -- strongly-connected component analysis, this time omitting
+ -- strongly-connected-component analysis, this time omitting
-- any references to variables with type signatures.
--
-- Then we bring into scope all the variables with type signatures
keyd_binds = bagToList binds `zip` [0::BKey ..]
- bind_fvs (FunBind _ _ _ fvs) = fvs
- bind_fvs (PatBind _ _ _ fvs) = fvs
- bind_fvs bind = pprPanic "mkEdges" (ppr bind)
-
key_map :: NameEnv BKey -- Which binding it comes from
key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
, bndr <- bindersOfHsBind bind ]
bindersOfHsBind :: HsBind Name -> [Name]
-bindersOfHsBind (PatBind pat _ _ _) = collectPatBinders pat
-bindersOfHsBind (FunBind (L _ f) _ _ _) = [f]
+bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat
+bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
------------------------
tcPolyBinds :: TopLevelFlag
in
-- SET UP THE MAIN RECOVERY; take advantage of any type sigs
setSrcSpan loc $
- recoverM (recoveryCode binder_names sig_fn) $ do
+ recoverM (recoveryCode binder_names) $ do
{ traceTc (ptext SLIT("------------------------------------------------"))
; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names)
; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id, [])
- -- ToDo: prags
+ -- ToDo: prags for unlifted bindings
; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'],
[poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
; zonked_poly_ids <- mappM zonkId poly_ids
- ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds),
- map idType zonked_poly_ids))
+ ; traceTc (text "binding:" <+> ppr (zonked_poly_ids `zip` map idType zonked_poly_ids))
; let abs_bind = L loc $ AbsBinds tyvars_to_gen'
dict_ids exports
mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
-> TcM ([TyVar], Id, Id, [Prag])
mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
- = do { prags <- tcPrags poly_id (prag_fn poly_name)
- ; return (tvs, poly_id, mono_id, prags) }
- where
- (tvs, poly_id) = case mb_sig of
- Just sig -> (sig_tvs sig, sig_id sig)
- Nothing -> (inferred_tvs, mkLocalId poly_name poly_ty)
- where
- poly_ty = mkForAllTys inferred_tvs
- $ mkFunTys dict_tys
- $ idType mono_id
+ = case mb_sig of
+ Nothing -> do { prags <- tcPrags poly_id (prag_fn poly_name)
+ ; return (inferred_tvs, poly_id, mono_id, prags) }
+ where
+ poly_id = mkLocalId poly_name poly_ty
+ poly_ty = mkForAllTys inferred_tvs
+ $ mkFunTys dict_tys
+ $ idType mono_id
+
+ Just sig -> do { let poly_id = sig_id sig
+ ; prags <- tcPrags poly_id (prag_fn poly_name)
+ ; sig_tys <- zonkTcTyVars (sig_tvs sig)
+ ; let sig_tvs' = map (tcGetTyVar "mkExport") sig_tys
+ ; return (sig_tvs', poly_id, mono_id, prags) }
+ -- We zonk the sig_tvs here so that the export triple
+ -- always has zonked type variables;
+ -- a convenient invariant
+
------------------------
type TcPragFun = Name -> [LSig Name]
tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
tcSpecPrag poly_id hs_ty inl
= do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty
- ; (co_fn, lie) <- getLIE (tcSub spec_ty (idType poly_id))
+ ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty)
; extendLIEs lie
; let const_dicts = map instToId lie
- ; return (SpecPrag (co_fn <$> (HsVar poly_id)) spec_ty const_dicts inl) }
+ ; return (SpecPrag (HsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
--------------
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise
-- subsequent error messages
-recoveryCode binder_names sig_fn
+recoveryCode binder_names
= do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
+ ; poly_ids <- mapM mk_dummy binder_names
; return ([], poly_ids) }
where
- forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
- poly_ids = map mk_dummy binder_names
- mk_dummy name = case sig_fn name of
- Just sig -> sig_id sig -- Signature
- Nothing -> mkLocalId name forall_a_a -- No signature
+ mk_dummy name = do { mb_id <- tcLookupLocalId_maybe name
+ ; case mb_id of
+ Just id -> return id -- Had signature, was in envt
+ Nothing -> return (mkLocalId name forall_a_a) } -- No signature
+
+forall_a_a :: TcType
+forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
+
-- Check that non-overloaded unlifted bindings are
-- a) non-recursive,
-- we are not resuced by a type signature
-> TcM (LHsBinds TcId, [MonoBindInfo])
-tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)]
+tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
+ fun_matches = matches, bind_fvs = fvs })]
sig_fn -- Single function binding,
NonRecursive -- binder isn't mentioned in RHS,
| Nothing <- sig_fn name -- ...with no type signature
-- e.g. f = \(x::forall a. a->a) -> <body>
-- We want to infer a higher-rank type for f
setSrcSpan b_loc $
- do { (matches', rhs_ty) <- tcInfer (tcMatchesFun name matches)
+ do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches)
-- Check for an unboxed tuple type
-- f = (# True, False #)
; mono_name <- newLocalName name
; let mono_id = mkLocalId mono_name zonked_rhs_ty
- ; return (unitBag (L b_loc (FunBind (L nm_loc mono_id) inf matches' fvs)),
+ ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
+ fun_matches = matches', bind_fvs = fvs,
+ fun_co_fn = co_fn })),
[(name, Nothing, mono_id)]) }
+tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
+ fun_matches = matches, bind_fvs = fvs })]
+ sig_fn -- Single function binding
+ non_rec
+ | Just sig <- sig_fn name -- ...with a type signature
+ = -- When we have a single function binding, with a type signature
+ -- we can (a) use genuine, rigid skolem constants for the type variables
+ -- (b) bring (rigid) scoped type variables into scope
+ setSrcSpan b_loc $
+ do { tc_sig <- tcInstSig True sig
+ ; mono_name <- newLocalName name
+ ; let mono_ty = sig_tau tc_sig
+ mono_id = mkLocalId mono_name mono_ty
+ rhs_tvs = [ (name, mkTyVarTy tv)
+ | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ]
+
+ ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $
+ tcMatchesFun mono_name matches mono_ty
+
+ ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id,
+ fun_infix = inf, fun_matches = matches',
+ bind_fvs = placeHolderNames, fun_co_fn = co_fn }
+ ; return (unitBag (L b_loc fun_bind'),
+ [(name, Just tc_sig, mono_id)]) }
+
tcMonoBinds binds sig_fn non_rec
= do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds
- -- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs
- -- For (a) it's ok to bring them all into scope at once, even
- -- though each type sig should scope only over its own RHS,
- -- because the renamer has sorted all that out.
+ -- Bring the monomorphic Ids, into scope for the RHSs
; let mono_info = getMonoBindInfo tc_binds
- rhs_tvs = [ (name, mkTyVarTy tv)
- | (_, Just sig, _) <- mono_info,
- (name, tv) <- sig_scoped sig `zip` sig_tvs sig ]
- rhs_id_env = map mk mono_info -- A binding for each term variable
+ rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
+ -- A monomorphic binding for each term variable that lacks
+ -- a type sig. (Ones with a sig are already in scope.)
- ; binds' <- tcExtendTyVarEnv2 rhs_tvs $
- tcExtendIdEnv2 rhs_id_env $
+ ; binds' <- tcExtendIdEnv2 rhs_id_env $
traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id)
| (n,id) <- rhs_id_env]) `thenM_`
mapM (wrapLocM tcRhs) tc_binds
; return (listToBag binds', mono_info) }
- where
- mk (name, Just sig, _) = (name, sig_id sig) -- Use the type sig if there is one
- mk (name, Nothing, mono_id) = (name, mono_id) -- otherwise use a monomorphic version
------------------------
-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
getMonoType (_,_,mono_id) = idType mono_id
tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
-tcLhs sig_fn (FunBind (L nm_loc name) inf matches _)
- = do { let mb_sig = sig_fn name
+tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
+ = do { mb_sig <- tcInstSig_maybe (sig_fn name)
; mono_name <- newLocalName name
; mono_ty <- mk_mono_ty mb_sig
; let mono_id = mkLocalId mono_name mono_ty
; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
where
mk_mono_ty (Just sig) = return (sig_tau sig)
- mk_mono_ty Nothing = newTyFlexiVarTy argTypeKind
+ mk_mono_ty Nothing = newFlexiTyVarTy argTypeKind
+
+tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss })
+ = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names
-tcLhs sig_fn bind@(PatBind pat grhss _ _)
- = do { let tc_pat exp_ty = tcPat (LetPat sig_fn) pat exp_ty lookup_infos
- ; ((pat', ex_tvs, infos), pat_ty)
- <- addErrCtxt (patMonoBindsCtxt pat grhss)
- (tcInfer tc_pat)
+ ; let nm_sig_prs = names `zip` mb_sigs
+ tau_sig_env = mkNameEnv [ (name, sig_tau sig) | (name, Just sig) <- nm_sig_prs]
+ sig_tau_fn = lookupNameEnv tau_sig_env
- -- Don't know how to deal with pattern-bound existentials yet
- ; checkTc (null ex_tvs) (existentialExplode bind)
+ tc_pat exp_ty = tcPat (LetPat sig_tau_fn) pat exp_ty unitTy $ \ _ ->
+ mapM lookup_info nm_sig_prs
+ -- The unitTy is a bit bogus; it's the "result type" for lookup_info.
+
+ -- After typechecking the pattern, look up the binder
+ -- names, which the pattern has brought into scope.
+ lookup_info :: (Name, Maybe TcSigInfo) -> TcM MonoBindInfo
+ lookup_info (name, mb_sig) = do { mono_id <- tcLookupId name
+ ; return (name, mb_sig, mono_id) }
+
+ ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
+ tcInfer tc_pat
; return (TcPatBind infos pat' grhss pat_ty) }
where
names = collectPatBinders pat
- -- After typechecking the pattern, look up the binder
- -- names, which the pattern has brought into scope.
- lookup_infos :: TcM [MonoBindInfo]
- lookup_infos = do { mono_ids <- tcLookupLocalIds names
- ; return [ (name, sig_fn name, mono_id)
- | (name, mono_id) <- names `zip` mono_ids] }
tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind)
-- AbsBind, VarBind impossible
-------------------
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
- = do { matches' <- tcMatchesFun (idName mono_id) matches
- (Check (idType mono_id))
- ; return (FunBind fun' inf matches' placeHolderNames) }
+ = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches
+ (idType mono_id)
+ ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
+ bind_fvs = placeHolderNames, fun_co_fn = co_fn }) }
tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
= do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
- tcGRHSsPat grhss (Check pat_ty)
- ; return (PatBind pat' grhss' pat_ty placeHolderNames) }
+ tcGRHSsPat grhss pat_ty
+ ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty,
+ bind_fvs = placeHolderNames }) }
---------------------
where
bndrs = bndrNames mono_infos
sigs = [sig | (_, Just sig, _) <- mono_infos]
- tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos
+ tau_tvs = foldr (unionVarSet . exactTyVarsOfType . getMonoType) emptyVarSet mono_infos
+ -- NB: exactTyVarsOfType; see Note [Silly type synonym]
+ -- near defn of TcType.exactTyVarsOfType
is_mono_sig sig = null (sig_theta sig)
doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs
mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
- sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id
- = Method mono_id poly_id (mkTyVarTys tvs) theta tau loc
+ sig_theta = theta, sig_loc = loc }) mono_id
+ = Method mono_id poly_id (mkTyVarTys tvs) theta loc
+\end{code}
+unifyCtxts checks that all the signature contexts are the same
+The type signatures on a mutually-recursive group of definitions
+must all have the same context (or none).
--- Check that all the signature contexts are the same
--- The type signatures on a mutually-recursive group of definitions
--- must all have the same context (or none).
---
--- The trick here is that all the signatures should have the same
--- context, and we want to share type variables for that context, so that
--- all the right hand sides agree a common vocabulary for their type
--- constraints
---
--- We unify them because, with polymorphic recursion, their types
--- might not otherwise be related. This is a rather subtle issue.
+The trick here is that all the signatures should have the same
+context, and we want to share type variables for that context, so that
+all the right hand sides agree a common vocabulary for their type
+constraints
+
+We unify them because, with polymorphic recursion, their types
+might not otherwise be related. This is a rather subtle issue.
+
+\begin{code}
unifyCtxts :: [TcSigInfo] -> TcM [Inst]
unifyCtxts (sig1 : sigs) -- Argument is always non-empty
= do { mapM unify_ctxt sigs
-- (b) been unified with each other (all distinct)
checkDistinctTyVars sig_tvs
- = do { zonked_tvs <- mapM zonk_one sig_tvs
+ = do { zonked_tvs <- mapM zonkSigTyVar sig_tvs
; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
; return zonked_tvs }
where
- zonk_one sig_tv = do { ty <- zonkTcTyVar sig_tv
- ; return (tcGetTyVar "checkDistinctTyVars" ty) }
- -- 'ty' is bound to be a type variable, because SigSkolTvs
- -- can only be unified with type variables
-
check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
-- The TyVarEnv maps each zonked type variable back to its
-- corresponding user-written signature type variable
Nothing -> return (extendVarEnv acc zonked_tv sig_tv)
bomb_out sig_tv1 sig_tv2
- = failWithTc (ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1)
- <+> ptext SLIT("is unified with another quantified type variable")
- <+> quotes (ppr tidy_tv2))
+ = do { env0 <- tcInitTidyEnv
+ ; let (env1, tidy_tv1) = tidyOpenTyVar env0 sig_tv1
+ (env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2
+ msg = ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1)
+ <+> ptext SLIT("is unified with another quantified type variable")
+ <+> quotes (ppr tidy_tv2)
+ ; failWithTcM (env2, msg) }
where
- (env1, tidy_tv1) = tidyOpenTyVar emptyTidyEnv sig_tv1
- (_env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2
\end{code}
Notice the the stupid construction of (f a d), which is of course
identical to the function we're executing. In this case, the
polymorphic recursion isn't being used (but that's a very common case).
-We'd prefer
-
- f = /\a -> \d::Eq a -> letrec
- fm = \ys:[a] -> ...fm...
- in
- fm
-
This can lead to a massive space leak, from the following top-level defn
(post-typechecking)
in \ys. ...f'...
Etc.
+
+NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
+which would make the space leak go away in this case
+
Solution: when typechecking the RHSs we always have in hand the
*monomorphic* Ids for each binding. So we just need to make sure that
if (Method f a d) shows up in the constraints emerging from (...f...)
to the "givens" when simplifying constraints. That's what the "lies_avail"
is doing.
+Then we get
+
+ f = /\a -> \d::Eq a -> letrec
+ fm = \ys:[a] -> ...fm...
+ in
+ fm
+
+
%************************************************************************
%* *
Type signatures are tricky. See Note [Signature skolems] in TcType
+@tcSigs@ checks the signatures for validity, and returns a list of
+{\em freshly-instantiated} signatures. That is, the types are already
+split up, and have fresh type variables installed. All non-type-signature
+"RenamedSigs" are ignored.
+
+The @TcSigInfo@ contains @TcTypes@ because they are unified with
+the variable's type, and after that checked to see whether they've
+been instantiated.
+
\begin{code}
-tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
-tcTySigs sigs = do { mb_sigs <- mappM tcTySig (filter isVanillaLSig sigs)
- ; return (catMaybes mb_sigs) }
+type TcSigFun = Name -> Maybe (LSig Name)
-tcTySig :: LSig Name -> TcM (Maybe TcSigInfo)
+mkSigFun :: [LSig Name] -> TcSigFun
+-- Search for a particular type signature
+-- Precondition: the sigs are all type sigs
+-- Precondition: no duplicates
+mkSigFun sigs = lookupNameEnv env
+ where
+ env = mkNameEnv [(fromJust (sigName sig), sig) | sig <- sigs]
+
+---------------
+data TcSigInfo
+ = TcSigInfo {
+ sig_id :: TcId, -- *Polymorphic* binder for this value...
+
+ sig_scoped :: [Name], -- Names for any scoped type variables
+ -- Invariant: correspond 1-1 with an initial
+ -- segment of sig_tvs (see Note [Scoped])
+
+ sig_tvs :: [TcTyVar], -- Instantiated type variables
+ -- See Note [Instantiate sig]
+
+ sig_theta :: TcThetaType, -- Instantiated theta
+ sig_tau :: TcTauType, -- Instantiated tau
+ sig_loc :: InstLoc -- The location of the signature
+ }
+
+-- Note [Scoped]
+-- There may be more instantiated type variables than scoped
+-- ones. For example:
+-- type T a = forall b. b -> (a,b)
+-- f :: forall c. T c
+-- Here, the signature for f will have one scoped type variable, c,
+-- but two instantiated type variables, c' and b'.
+--
+-- We assume that the scoped ones are at the *front* of sig_tvs,
+-- and remember the names from the original HsForAllTy in sig_scoped
+
+-- Note [Instantiate sig]
+-- It's vital to instantiate a type signature with fresh variable.
+-- For example:
+-- type S = forall a. a->a
+-- f,g :: S
+-- f = ...
+-- g = ...
+-- Here, we must use distinct type variables when checking f,g's right hand sides.
+-- (Instantiation is only necessary because of type synonyms. Otherwise,
+-- it's all cool; each signature has distinct type variables from the renamer.)
+
+instance Outputable TcSigInfo where
+ ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
+ = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
+\end{code}
+
+\begin{code}
+tcTySig :: LSig Name -> TcM TcId
tcTySig (L span (TypeSig (L _ name) ty))
- = recoverM (return Nothing) $
- setSrcSpan span $
+ = setSrcSpan span $
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
- ; (tvs, theta, tau) <- tcInstSigType name scoped_names sigma_ty
- ; loc <- getInstLoc (SigOrigin (SigSkol name))
- ; return (Just (TcSigInfo { sig_id = mkLocalId name sigma_ty,
- sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
- sig_scoped = scoped_names, sig_loc = loc })) }
+ ; return (mkLocalId name sigma_ty) }
+
+-------------------
+tcInstSig_maybe :: Maybe (LSig Name) -> TcM (Maybe TcSigInfo)
+-- Instantiate with *meta* type variables;
+-- this signature is part of a multi-signature group
+tcInstSig_maybe Nothing = return Nothing
+tcInstSig_maybe (Just sig) = do { tc_sig <- tcInstSig False sig
+ ; return (Just tc_sig) }
+
+tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo
+-- Instantiate the signature, with either skolems or meta-type variables
+-- depending on the use_skols boolean
+--
+-- We always instantiate with freshs uniques,
+-- although we keep the same print-name
+--
+-- type T = forall a. [a] -> [a]
+-- f :: T;
+-- f = g where { g :: T; g = <rhs> }
+--
+-- We must not use the same 'a' from the defn of T at both places!!
+
+tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty))
+ = setSrcSpan loc $
+ do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into
+ -- scope when starting the binding group
+ ; let skol_info = SigSkol (FunSigCtxt name)
+ inst_tyvars | use_skols = tcInstSkolTyVars skol_info
+ | otherwise = tcInstSigTyVars skol_info
+ ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id)
+ ; loc <- getInstLoc (SigOrigin skol_info)
+ ; return (TcSigInfo { sig_id = poly_id,
+ sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
+ sig_scoped = scoped_names, sig_loc = loc }) }
+ -- Note that the scoped_names and the sig_tvs will have
+ -- different Names. That's quite ok; when we bring the
+ -- scoped_names into scope, we just bind them to the sig_tvs
where
-- The scoped names are the ones explicitly mentioned
-- in the HsForAll. (There may be more in sigma_ty, because
-- of nested type synonyms. See Note [Scoped] with TcSigInfo.)
- scoped_names = case ty of
- L _ (HsForAllTy Explicit tvs _ _) -> hsLTyVarNames tvs
- other -> []
+ -- We also only have scoped type variables when we are instantiating
+ -- with true skolems
+ scoped_names = case (use_skols, hs_ty) of
+ (True, L _ (HsForAllTy Explicit tvs _ _)) -> hsLTyVarNames tvs
+ other -> []
+-------------------
isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool
isUnRestrictedGroup binds sig_fn
= do { mono_restriction <- doptM Opt_MonomorphismRestriction
all_unrestricted = all (unrestricted . unLoc) binds
has_sig n = isJust (sig_fn n)
- unrestricted (PatBind other _ _ _) = False
- unrestricted (VarBind v _) = has_sig v
- unrestricted (FunBind v _ matches _) = unrestricted_match matches
- || has_sig (unLoc v)
+ unrestricted (PatBind {}) = False
+ unrestricted (VarBind { var_id = v }) = has_sig v
+ unrestricted (FunBind { fun_id = v, fun_matches = matches }) = unrestricted_match matches
+ || has_sig (unLoc v)
unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
-- No args => like a pattern binding
4 (ppr name <+> dcolon <+> ppr ty)
-----------------------------------------------
-existentialExplode mbinds
- = hang (vcat [text "My brain just exploded.",
- text "I can't handle pattern bindings for existentially-quantified constructors.",
- text "In the binding group"])
- 4 (ppr mbinds)
-
------------------------------------------------
restrictedBindCtxtErr binder_names
= hang (ptext SLIT("Illegal overloaded type signature(s)"))
4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
import Inst ( instToId, newDicts, newDictsAtLoc, newMethod, getOverlapFlag )
import InstEnv ( mkLocalInstance )
import TcEnv ( tcLookupLocatedClass,
- tcExtendTyVarEnv,
+ tcExtendTyVarEnv, tcExtendIdEnv,
InstInfo(..), pprInstInfoDetails,
simpleInstInfoTyCon, simpleInstInfoTy,
InstBindings(..), newDFunName
)
-import TcBinds ( TcPragFun, tcMonoBinds, tcPrags, mkPragFun )
-import TcHsType ( TcSigInfo(..), tcHsKindedType, tcHsSigType )
+import TcBinds ( TcPragFun, tcMonoBinds, tcPrags, mkPragFun, TcSigInfo(..) )
+import TcHsType ( tcHsKindedType, tcHsSigType )
import TcSimplify ( tcSimplifyCheck )
import TcUnify ( checkSigTyVars, sigCtxt )
-import TcMType ( tcSkolSigTyVars, UserTypeCtxt( GenPatCtxt ), tcSkolType )
-import TcType ( Type, SkolemInfo(ClsSkol, InstSkol, SigSkol),
+import TcMType ( tcSkolSigTyVars )
+import TcType ( Type, SkolemInfo(ClsSkol, InstSkol), UserTypeCtxt( GenPatCtxt ),
TcType, TcThetaType, TcTyVar, mkTyVarTys,
mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
import SrcLoc ( Located(..), srcSpanStart, unLoc, noLoc )
import Maybes ( seqMaybe, isJust, mapCatMaybes )
import List ( partition )
-import BasicTypes ( RecFlag(..) )
+import BasicTypes ( RecFlag(..), Boxity(..) )
import Bag
import FastString
\end{code}
= do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
return (mkNameEnv dm_infos)
-checkDefaultBind clas ops (FunBind (L _ op) _ (MatchGroup matches _) _)
+checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
= do { -- Check that the op is from this class
checkTc (op `elem` ops) (badMethodErr clas op)
-- Simplification can do unification
; checkSigTyVars clas_tyvars
- ; let
- (_,dm_inst_id,_) = meth_info
- full_bind = AbsBinds
- clas_tyvars
+ -- Inline pragmas
+ -- We'll have an inline pragma on the local binding, made by tcMethodBind
+ -- but that's not enough; we want one on the global default method too
+ -- Specialisations, on the other hand, belong on the thing inside only, I think
+ ; let (_,dm_inst_id,_) = meth_info
+ sel_name = idName sel_id
+ inline_prags = filter isInlineLSig (prag_fn sel_name)
+ ; prags <- tcPrags dm_inst_id inline_prags
+
+ ; let full_bind = AbsBinds clas_tyvars
[instToId this_dict]
- [(clas_tyvars, local_dm_id, dm_inst_id, [])]
- -- No inlines (yet)
+ [(clas_tyvars, local_dm_id, dm_inst_id, prags)]
(dict_binds `unionBags` defm_bind)
; returnM (noLoc full_bind, [local_dm_id]) }}
-- so that we don't quantify over them in nested places
- let -- Fake up a TcSigInfo to pass to tcMonoBinds
- rigid_info = SigSkol (idName meth_id)
- in
- tcSkolType rigid_info (idType meth_id) `thenM` \ (tyvars', theta', tau') ->
- getInstLoc (SigOrigin rigid_info) `thenM` \ loc ->
- let meth_sig = TcSigInfo { sig_id = meth_id, sig_tvs = tyvars', sig_scoped = [],
- sig_theta = theta', sig_tau = tau', sig_loc = loc }
+ let meth_sig = noLoc (TypeSig (noLoc (idName meth_id)) (noLoc bogus_ty))
+ bogus_ty = HsTupleTy Boxed [] -- *Only* used to extract scoped type
+ -- variables... and there aren't any
lookup_sig name = ASSERT( name == idName meth_id )
Just meth_sig
in
tcExtendTyVarEnv inst_tyvars (
- addErrCtxt (methodCtxt sel_id) $
- getLIE $
+ tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig
+ addErrCtxt (methodCtxt sel_id) $
+ getLIE $
tcMonoBinds [meth_bind] lookup_sig Recursive
) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
--
-- We do this for each method independently to localise error messages
+ let
+ [(_, Just sig, local_meth_id)] = mono_bind_infos
+ in
+
addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
- newDictsAtLoc (sig_loc meth_sig) (sig_theta meth_sig) `thenM` \ meth_dicts ->
+ newDictsAtLoc (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
let
- meth_tvs = sig_tvs meth_sig
+ meth_tvs = sig_tvs sig
all_tyvars = meth_tvs ++ inst_tyvars
all_insts = avail_insts ++ meth_dicts
sel_name = idName sel_id
tcPrags meth_id (prag_fn sel_name) `thenM` \ prags ->
let
- [(_,_,local_meth_id)] = mono_bind_infos
poly_meth_bind = noLoc $ AbsBinds meth_tvs
(map instToId meth_dicts)
[(meth_tvs, meth_id, local_meth_id, prags)]
Nothing ->
mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
-- Not infix decl
- returnM (noLoc $ FunBind (noLoc meth_name) False
- (mkMatchGroup [mkSimpleMatch [] rhs])
- placeHolderNames)
+ returnM (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rhs])
) `thenM` \ meth_bind ->
returnM (mb_inst, (sel_id, meth_id, meth_bind))
)
if isSingleton preds then
-- If it's the only one, make a 'method'
- getInstLoc origin `thenM` \ inst_loc ->
- newMethod inst_loc sel_id inst_tys preds tau `thenM` \ meth_inst ->
+ getInstLoc origin `thenM` \ inst_loc ->
+ newMethod inst_loc sel_id inst_tys `thenM` \ meth_inst ->
returnM (Just meth_inst, instToId meth_inst)
else
-- If it's not the only one we need to be careful
find_bind sel_name meth_name binds
= foldlBag seqMaybe Nothing (mapBag f binds)
where
- f (L loc1 (FunBind (L loc2 op_name) fix matches fvs)) | op_name == sel_name
- = Just (L loc1 (FunBind (L loc2 meth_name) fix matches fvs))
+ f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
+ = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
f _other = Nothing
\end{code}
-- them in finite map indexed by the type parameter in the definition.
getGenericBinds binds = concat (map getGenericBind (bagToList binds))
-getGenericBind (L loc (FunBind id infixop (MatchGroup matches ty) fvs))
+getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
= groupWith wrap (mapCatMaybes maybeGenericMatch matches)
where
- wrap ms = L loc (FunBind id infixop (MatchGroup ms ty) fvs)
+ wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
getGenericBind _
= []
tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
- tcLookup, tcLookupLocated, tcLookupLocalIds,
- tcLookupId, tcLookupTyVar,
+ tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupLocalId_maybe,
+ tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
lclEnvElts, getInLocalScope, findGlobals,
wrongThingErr, pprBinders,
+ refineEnvironment,
tcExtendRecEnv, -- For knot-tying
import IfaceEnv ( newGlobalBinder )
import TcRnMonad
import TcMType ( zonkTcType, zonkTcTyVarsAndFV )
-import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType,
- tyVarsOfType, tyVarsOfTypes, mkGenTyConApp,
+import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst,
+ substTy, substTyVar, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp,
getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
- tidyOpenType
+ tidyOpenType, isRefineableTy
)
import qualified Type ( getTyVar_maybe )
-import Id ( idName, isLocalId )
+import Id ( idName, isLocalId, setIdType )
import Var ( TyVar, Id, idType, tyVarName )
import VarSet
import VarEnv
tcLookupTyVar name
= tcLookup name `thenM` \ thing ->
case thing of
- ATyVar _ ty -> returnM (tcGetTyVar "tcLookupTyVar" ty)
+ ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
other -> pprPanic "tcLookupTyVar" (ppr name)
tcLookupId :: Name -> TcM Id
tcLookupId name
= tcLookup name `thenM` \ thing ->
case thing of
- ATcId tc_id _ -> returnM tc_id
+ ATcId tc_id _ _ -> returnM tc_id
AGlobal (AnId id) -> returnM id
other -> pprPanic "tcLookupId" (ppr name)
+tcLookupLocalId_maybe :: Name -> TcM (Maybe Id)
+tcLookupLocalId_maybe name
+ = getLclEnv `thenM` \ local_env ->
+ case lookupNameEnv (tcl_env local_env) name of
+ Just (ATcId tc_id _ _) -> return (Just tc_id)
+ other -> return Nothing
+
tcLookupLocalIds :: [Name] -> TcM [TcId]
-- We expect the variables to all be bound, and all at
-- the same level as the lookup. Only used in one place...
where
lookup lenv lvl name
= case lookupNameEnv lenv name of
- Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
- other -> pprPanic "tcLookupLocalIds" (ppr name)
+ Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id
+ other -> pprPanic "tcLookupLocalIds" (ppr name)
lclEnvElts :: TcLclEnv -> [TcTyThing]
lclEnvElts env = nameEnvElts (tcl_env env)
tcl_rdr = rdr_env}) ->
let
rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
- new_tv_set = tyVarsOfTypes (map snd binds)
+ new_tv_set = tcTyVarsOfTypes (map snd binds)
le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
in
-- It's important to add the in-scope tyvars to the global tyvar set
-- when typechecking the methods.
tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
+
+getScopedTyVarBinds :: TcM [(Name, TcType)]
+getScopedTyVarBinds
+ = do { lcl_env <- getLclEnv
+ ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
\end{code}
tcExtendIdEnv2 names_w_ids thing_inside
= getLclEnv `thenM` \ env ->
let
- extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
- th_lvl = thLevel (tcl_th_ctxt env)
- extra_env = [(name, ATcId id th_lvl) | (name,id) <- names_w_ids]
+ extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
+ th_lvl = thLevel (tcl_th_ctxt env)
+ extra_env = [ (name, ATcId id th_lvl (isRefineableTy (idType id)))
+ | (name,id) <- names_w_ids]
le' = extendNameEnvList (tcl_env env) extra_env
- rdr_env' = extendLocalRdrEnv (tcl_rdr env) (map fst names_w_ids)
+ rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
in
+ traceTc (text "env2") `thenM_`
+ traceTc (text "env3" <+> ppr extra_env) `thenM_`
tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
- setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
+ (traceTc (text "env4") `thenM_`
+ setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
\end{code}
ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
-----------------------
-find_thing ignore_it tidy_env (ATcId id _)
+find_thing ignore_it tidy_env (ATcId id _ _)
= zonkTcType (idType id) `thenM` \ id_ty ->
if ignore_it id_ty then
returnM (tidy_env, Nothing)
returnM (tidy_env1, Just msg)
\end{code}
+\begin{code}
+refineEnvironment :: TvSubst -> TcM a -> TcM a
+refineEnvironment reft thing_inside
+ = do { env <- getLclEnv
+ ; let le' = mapNameEnv refine (tcl_env env)
+ ; gtvs' <- refineGlobalTyVars reft (tcl_tyvars env)
+ ; setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside }
+ where
+ refine (ATcId id lvl True) = ATcId (setIdType id (substTy reft (idType id))) lvl True
+ refine (ATyVar tv ty) = ATyVar tv (substTy reft ty)
+ refine elt = elt
+\end{code}
%************************************************************************
%* *
tc_extend_gtvs gtvs extra_global_tvs
= readMutVar gtvs `thenM` \ global_tvs ->
newMutVar (global_tvs `unionVarSet` extra_global_tvs)
+
+refineGlobalTyVars :: GadtRefinement -> TcRef TcTyVarSet -> TcM (TcRef TcTyVarSet)
+refineGlobalTyVars reft gtv_var
+ = readMutVar gtv_var `thenM` \ gbl_tvs ->
+ newMutVar (tcTyVarsOfTypes (map (substTyVar reft) (varSetElems gbl_tvs)))
\end{code}
@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
-- E.g. given the name "Expr" return the type "Expr"
tcMetaTy tc_name
= tcLookupTyCon tc_name `thenM` \ t ->
- returnM (mkGenTyConApp t [])
- -- Use mkGenTyConApp because it might be a synonym
+ returnM (mkTyConApp t [])
\end{code}
\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho,
- tcMonoExpr, tcExpr, tcSyntaxOp
- ) where
+module TcExpr ( tcPolyExpr, tcPolyExprNC,
+ tcMonoExpr, tcInferRho, tcSyntaxOp ) where
#include "HsVersions.h"
import qualified DsMeta
#endif
-import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields,
- HsMatchContext(..), HsRecordBinds, mkHsApp )
-import TcHsSyn ( hsLitType, (<$>) )
+import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
+ HsMatchContext(..), HsRecordBinds, mkHsApp, mkHsDictApp, mkHsTyApp )
+import TcHsSyn ( hsLitType )
import TcRnMonad
-import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo,
- tcSubExp, tcGen, tcSub,
- unifyFunTys, zapToListTy, zapToTyConApp )
-import BasicTypes ( isMarkedStrict )
-import Inst ( tcOverloadedLit, newMethodFromName, newIPDict,
- newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall )
+import TcUnify ( tcInfer, tcSubExp, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
+ boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType, unBox )
+import BasicTypes ( Arity, isMarkedStrict )
+import Inst ( newMethodFromName, newIPDict, instToId,
+ newDicts, newMethodWithGivenTy, tcInstStupidTheta )
import TcBinds ( tcLocalBinds )
import TcEnv ( tcLookup, tcLookupId,
tcLookupDataCon, tcLookupGlobalId
)
import TcArrows ( tcProc )
-import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) )
+import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, TcMatchCtxt(..) )
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
-import TcPat ( badFieldCon, refineTyVars )
-import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType )
-import TcType ( TcTyVar, TcType, TcSigmaType, TcRhoType,
- tcSplitFunTys, mkTyVarTys,
- isSigmaTy, mkFunTy, mkTyConApp, tyVarsOfTypes, isLinearPred,
- tcSplitSigmaTy, tidyOpenType
+import TcPat ( tcOverloadedLit, badFieldCon )
+import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox,
+ tcInstBoxyTyVar, tcInstTyVar, zonkTcType )
+import TcType ( TcType, TcSigmaType, TcRhoType,
+ BoxySigmaType, BoxyRhoType, ThetaType,
+ tcSplitFunTys, mkTyVarTys, mkFunTys,
+ tcMultiSplitSigmaTy, tcSplitFunTysN,
+ isSigmaTy, mkFunTy, mkTyConApp, isLinearPred,
+ exactTyVarsOfType, exactTyVarsOfTypes, mkTyVarTy,
+ tidyOpenType,
+ zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar, lookupTyVar
)
-import Kind ( openTypeKind, liftedTypeKind, argTypeKind )
+import Kind ( argTypeKind )
-import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isNaughtyRecordSelector )
-import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks,
+import Id ( idType, idName, recordSelectorFieldLabel, isRecordSelector,
+ isNaughtyRecordSelector, isDataConId_maybe )
+import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConSourceArity,
dataConWrapId, isVanillaDataCon, dataConTyVars, dataConOrigArgTys )
import Name ( Name )
import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons )
import Type ( substTheta, substTy )
-import Var ( tyVarKind )
-import VarSet ( emptyVarSet, elemVarSet )
+import Var ( TyVar, tyVarKind )
+import VarSet ( emptyVarSet, elemVarSet, unionVarSet )
import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
import PrelNames ( enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
import DynFlags
import StaticFlags ( opt_NoMethodSharing )
import HscTypes ( TyThing(..) )
-import SrcLoc ( Located(..), unLoc, getLoc )
+import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
import Util
import ListSetOps ( assocMaybe )
import Maybes ( catMaybes )
%************************************************************************
\begin{code}
--- tcCheckSigma does type *checking*; it's passed the expected type of the result
-tcCheckSigma :: LHsExpr Name -- Expession to type check
- -> TcSigmaType -- Expected type (could be a polytpye)
- -> TcM (LHsExpr TcId) -- Generalised expr with expected type
-
-tcCheckSigma expr expected_ty
- = -- traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_`
- tc_expr' expr expected_ty
-
-tc_expr' expr sigma_ty
- | isSigmaTy sigma_ty
- = tcGen sigma_ty emptyVarSet (
- \ rho_ty -> tcCheckRho expr rho_ty
- ) `thenM` \ (gen_fn, expr') ->
- returnM (L (getLoc expr') (gen_fn <$> unLoc expr'))
-
-tc_expr' expr rho_ty -- Monomorphic case
- = tcCheckRho expr rho_ty
-\end{code}
-
-Typecheck expression which in most cases will be an Id.
-The expression can return a higher-ranked type, such as
- (forall a. a->a) -> Int
-so we must create a hole to pass in as the expected tyvar.
+tcPolyExpr, tcPolyExprNC
+ :: LHsExpr Name -- Expession to type check
+ -> BoxySigmaType -- Expected type (could be a polytpye)
+ -> TcM (LHsExpr TcId) -- Generalised expr with expected type
+
+-- tcPolyExpr is a convenient place (frequent but not too frequent) place
+-- to add context information.
+-- The NC version does not do so, usually because the caller wants
+-- to do so himself.
+
+tcPolyExpr expr res_ty
+ = addErrCtxt (exprCtxt (unLoc expr)) $
+ tcPolyExprNC expr res_ty
+
+tcPolyExprNC expr res_ty
+ | isSigmaTy res_ty
+ = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr)
+ -- Note the recursive call to tcPolyExpr, because the
+ -- type may have multiple layers of for-alls
+ ; return (L (getLoc expr') (HsCoerce gen_fn (unLoc expr'))) }
+
+ | otherwise
+ = tcMonoExpr expr res_ty
+
+---------------
+tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
+tcPolyExprs [] [] = returnM []
+tcPolyExprs (expr:exprs) (ty:tys)
+ = do { expr' <- tcPolyExpr expr ty
+ ; exprs' <- tcPolyExprs exprs tys
+ ; returnM (expr':exprs') }
+tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
+
+---------------
+tcMonoExpr :: LHsExpr Name -- Expression to type check
+ -> BoxyRhoType -- Expected type (could be a type variable)
+ -- Definitely no foralls at the top
+ -- Can contain boxes, which will be filled in
+ -> TcM (LHsExpr TcId)
-\begin{code}
-tcCheckRho :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
-tcCheckRho expr rho_ty = tcMonoExpr expr (Check rho_ty)
+tcMonoExpr (L loc expr) res_ty
+ = ASSERT( not (isSigmaTy res_ty) )
+ setSrcSpan loc $
+ do { expr' <- tcExpr expr res_ty
+ ; return (L loc expr') }
+---------------
tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
-tcInferRho (L loc (HsVar name)) = setSrcSpan loc $ do
- { (e,_,ty) <- tcId (OccurrenceOf name) name
- ; return (L loc e, ty) }
-tcInferRho expr = tcInfer (tcMonoExpr expr)
-
-tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
--- Typecheck a syntax operator, checking that it has the specified type
--- The operator is always a variable at this stage (i.e. renamer output)
-tcSyntaxOp orig (HsVar op) ty = do { (expr', _, id_ty) <- tcId orig op
- ; co_fn <- tcSub ty id_ty
- ; returnM (co_fn <$> expr') }
-tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
+tcInferRho expr = tcInfer (tcMonoExpr expr)
\end{code}
%************************************************************************
%* *
-\subsection{The TAUT rules for variables}TcExpr
+ tcExpr: the main expression typechecker
%* *
%************************************************************************
\begin{code}
-tcMonoExpr :: LHsExpr Name -- Expession to type check
- -> Expected TcRhoType -- Expected type (could be a type variable)
- -- Definitely no foralls at the top
- -- Can be a 'hole'.
- -> TcM (LHsExpr TcId)
+tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
+tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty
-tcMonoExpr (L loc expr) res_ty
- = setSrcSpan loc (do { expr' <- tcExpr expr res_ty
- ; return (L loc expr') })
+tcExpr (HsLit lit) res_ty = do { boxyUnify (hsLitType lit) res_ty
+ ; return (HsLit lit) }
+
+tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
+ ; return (HsPar expr') }
-tcExpr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId)
-tcExpr (HsVar name) res_ty
- = do { (expr', _, id_ty) <- tcId (OccurrenceOf name) name
- ; co_fn <- tcSubExp res_ty id_ty
- ; returnM (co_fn <$> expr') }
+tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
+ ; returnM (HsSCC lbl expr') }
+
+tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
+ = do { expr' <- tcMonoExpr expr res_ty
+ ; return (HsCoreAnn lbl expr') }
+
+tcExpr (HsOverLit lit) res_ty
+ = do { lit' <- tcOverloadedLit (LiteralOrigin lit) lit res_ty
+ ; return (HsOverLit lit') }
+
+tcExpr (NegApp expr neg_expr) res_ty
+ = do { neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr
+ (mkFunTy res_ty res_ty)
+ ; expr' <- tcMonoExpr expr res_ty
+ ; return (NegApp expr' neg_expr') }
tcExpr (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.)
- newTyFlexiVarTy argTypeKind `thenM` \ ip_ty ->
- -- argTypeKind: it can't be an unboxed tuple
- newIPDict (IPOccOrigin ip) ip ip_ty `thenM` \ (ip', inst) ->
- extendLIE inst `thenM_`
- tcSubExp res_ty ip_ty `thenM` \ co_fn ->
- returnM (co_fn <$> HsIPVar ip')
-\end{code}
+ = do { -- 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.)
+ ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
+ ; co_fn <- tcSubExp ip_ty res_ty
+ ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
+ ; extendLIE inst
+ ; return (HsCoerce co_fn (HsIPVar ip')) }
+tcExpr (HsApp e1 e2) res_ty
+ = go e1 [e2]
+ where
+ go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
+ go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
+ go lfun@(L loc fun) args
+ = do { (fun', args') <- addErrCtxt (callCtxt lfun args) $
+ tcApp fun (length args) (tcArgs lfun args) res_ty
+ ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
-%************************************************************************
-%* *
-\subsection{Expressions type signatures}
-%* *
-%************************************************************************
+tcExpr (HsLam match) res_ty
+ = do { (co_fn, match') <- tcMatchLambda match res_ty
+ ; return (HsCoerce co_fn (HsLam match')) }
-\begin{code}
-tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
- = addErrCtxt (exprCtxt in_expr) $
- tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty ->
- tcThingWithSig sig_tc_ty (tcCheckRho expr) res_ty `thenM` \ (co_fn, expr') ->
- returnM (co_fn <$> ExprWithTySigOut expr' poly_ty)
+tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
+ = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
+ ; expr' <- tcPolyExpr expr sig_tc_ty
+ ; co_fn <- tcSubExp sig_tc_ty res_ty
+ ; return (HsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) }
tcExpr (HsType ty) res_ty
= failWithTc (text "Can't handle type argument:" <+> ppr ty)
%************************************************************************
%* *
-\subsection{Other expression forms}
+ Infix operators and sections
%* *
%************************************************************************
\begin{code}
-tcExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->
- returnM (HsPar expr')
-tcExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->
- returnM (HsSCC lbl expr')
-tcExpr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> -- hdaume: core annotation
- returnM (HsCoreAnn lbl expr')
-
-tcExpr (HsLit lit) res_ty = tcLit lit res_ty
+tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
+ = do { (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty
+ ; return (OpApp arg1' (L loc op') fix arg2') }
-tcExpr (HsOverLit lit) res_ty
- = zapExpectedType res_ty liftedTypeKind `thenM` \ res_ty' ->
- -- Overloaded literals must have liftedTypeKind, because
- -- we're instantiating an overloaded function here,
- -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
- tcOverloadedLit (LiteralOrigin lit) lit res_ty' `thenM` \ lit' ->
- returnM (HsOverLit lit')
-
-tcExpr (NegApp expr neg_expr) res_ty
- = do { res_ty' <- zapExpectedType res_ty liftedTypeKind
- ; neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr
- (mkFunTy res_ty' res_ty')
- ; expr' <- tcCheckRho expr res_ty'
- ; return (NegApp expr' neg_expr') }
-
-tcExpr (HsLam match) res_ty
- = tcMatchLambda match res_ty `thenM` \ match' ->
- returnM (HsLam match')
-
-tcExpr (HsApp e1 e2) res_ty
- = tcApp e1 [e2] res_ty
-\end{code}
-
-Note that the operators in sections are expected to be binary, and
-a type error will occur if they aren't.
-
-\begin{code}
-- Left sections, equivalent to
-- \ x -> e op x,
-- or
-- \ x -> op e x,
-- or just
-- op e
+--
+-- We treat it as similar to the latter, so we don't
+-- actually require the function to take two arguments
+-- at all. For example, (x `not`) means (not x);
+-- you get postfix operators! Not really Haskell 98
+-- I suppose, but it's less work and kind of useful.
-tcExpr in_expr@(SectionL arg1 op) res_ty
- = tcInferRho op `thenM` \ (op', op_ty) ->
- unifyInfixTy op in_expr op_ty `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
- tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' ->
- addErrCtxt (exprCtxt in_expr) $
- tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenM` \ co_fn ->
- returnM (co_fn <$> SectionL arg1' op')
+tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
+ = do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
+ ; return (SectionL arg1' (L loc op')) }
--- Right sections, equivalent to \ x -> x op expr, or
+-- Right sections, equivalent to \ x -> x `op` expr, or
-- \ x -> op x expr
-
-tcExpr in_expr@(SectionR op arg2) res_ty
- = tcInferRho op `thenM` \ (op', op_ty) ->
- unifyInfixTy op in_expr op_ty `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
- tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' ->
- addErrCtxt (exprCtxt in_expr) $
- tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenM` \ co_fn ->
- returnM (co_fn <$> SectionR op' arg2')
-
--- equivalent to (op e1) e2:
-
-tcExpr in_expr@(OpApp arg1 op fix arg2) res_ty
- = tcInferRho op `thenM` \ (op', op_ty) ->
- unifyInfixTy op in_expr op_ty `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
- tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' ->
- tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' ->
- addErrCtxt (exprCtxt in_expr) $
- tcSubExp res_ty op_res_ty `thenM` \ co_fn ->
- returnM (co_fn <$> OpApp arg1' op' fix arg2')
+
+tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
+ = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
+ tcApp op 2 (tc_args arg1_ty') res_ty'
+ ; return (HsCoerce co_fn (SectionR (L loc op') arg2')) }
+ where
+ doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
+ <+> ptext SLIT("takes one argument")
+ tc_args arg1_ty' [arg1_ty, arg2_ty]
+ = do { boxyUnify arg1_ty' arg1_ty
+ ; tcArg lop (arg2, arg2_ty, 2) }
\end{code}
\begin{code}
tcMonoExpr expr res_ty
; return (HsLet binds' expr') }
-tcExpr in_expr@(HsCase scrut matches) exp_ty
- = -- We used to typecheck the case alternatives first.
- -- The case patterns tend to give good type info to use
- -- when typechecking the scrutinee. For example
- -- case (map f) of
- -- (x:xs) -> ...
- -- will report that map is applied to too few arguments
- --
- -- But now, in the GADT world, we need to typecheck the scrutinee
- -- first, to get type info that may be refined in the case alternatives
- addErrCtxt (caseScrutCtxt scrut)
- (tcInferRho scrut) `thenM` \ (scrut', scrut_ty) ->
-
- addErrCtxt (caseCtxt in_expr) $
- tcMatchesCase match_ctxt scrut_ty matches exp_ty `thenM` \ matches' ->
- returnM (HsCase scrut' matches')
+tcExpr (HsCase scrut matches) exp_ty
+ = do { -- We used to typecheck the case alternatives first.
+ -- The case patterns tend to give good type info to use
+ -- when typechecking the scrutinee. For example
+ -- case (map f) of
+ -- (x:xs) -> ...
+ -- will report that map is applied to too few arguments
+ --
+ -- But now, in the GADT world, we need to typecheck the scrutinee
+ -- first, to get type info that may be refined in the case alternatives
+ (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut)
+ (tcInferRho scrut)
+
+ ; traceTc (text "HsCase" <+> ppr scrut_ty)
+ ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
+ ; return (HsCase scrut' matches') }
where
match_ctxt = MC { mc_what = CaseAlt,
- mc_body = tcMonoExpr }
+ mc_body = tcPolyExpr }
tcExpr (HsIf pred b1 b2) res_ty
- = addErrCtxt (predCtxt pred)
- (tcCheckRho pred boolTy) `thenM` \ pred' ->
-
- zapExpectedType res_ty openTypeKind `thenM` \ res_ty' ->
- -- C.f. the call to zapToType in TcMatches.tcMatches
-
- tcCheckRho b1 res_ty' `thenM` \ b1' ->
- tcCheckRho b2 res_ty' `thenM` \ b2' ->
- returnM (HsIf pred' b1' b2')
+ = do { pred' <- addErrCtxt (predCtxt pred) $
+ tcMonoExpr pred boolTy
+ ; b1' <- tcMonoExpr b1 res_ty
+ ; b2' <- tcMonoExpr b2 res_ty
+ ; return (HsIf pred' b1' b2') }
tcExpr (HsDo do_or_lc stmts body _) res_ty
= tcDoStmts do_or_lc stmts body res_ty
tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
- = zapToListTy res_ty `thenM` \ elt_ty ->
- mappM (tc_elt elt_ty) exprs `thenM` \ exprs' ->
- returnM (ExplicitList elt_ty exprs')
+ = do { elt_ty <- boxySplitListTy res_ty
+ ; exprs' <- mappM (tc_elt elt_ty) exprs
+ ; return (ExplicitList elt_ty exprs') }
where
- tc_elt elt_ty expr
- = addErrCtxt (listCtxt expr) $
- tcCheckRho expr elt_ty
+ tc_elt elt_ty expr = tcPolyExpr expr elt_ty
tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
- = do { [elt_ty] <- zapToTyConApp parrTyCon res_ty
- ; exprs' <- mappM (tc_elt elt_ty) exprs
+ = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
+ ; exprs' <- mappM (tc_elt elt_ty) exprs
+ ; ifM (null exprs) (zapToMonotype elt_ty)
+ -- If there are no expressions in the comprehension
+ -- we must still fill in the box
+ -- (Not needed for [] and () becuase they happen
+ -- to parse as data constructors.)
; return (ExplicitPArr elt_ty exprs') }
where
- tc_elt elt_ty expr
- = addErrCtxt (parrCtxt expr) (tcCheckRho expr elt_ty)
+ tc_elt elt_ty expr = tcPolyExpr expr elt_ty
tcExpr (ExplicitTuple exprs boxity) res_ty
- = do { arg_tys <- zapToTyConApp (tupleTyCon boxity (length exprs)) res_ty
- ; exprs' <- tcCheckRhos exprs arg_tys
+ = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty
+ ; exprs' <- tcPolyExprs exprs arg_tys
; return (ExplicitTuple exprs' boxity) }
tcExpr (HsProc pat cmd) res_ty
- = tcProc pat cmd res_ty `thenM` \ (pat', cmd') ->
- returnM (HsProc pat' cmd')
+ = do { (pat', cmd') <- tcProc pat cmd res_ty
+ ; return (HsProc pat' cmd') }
tcExpr e@(HsArrApp _ _ _ _ _) _
= failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
\begin{code}
tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
- = addErrCtxt (recordConCtxt expr) $
- do { (con_expr, _, con_tau) <- setSrcSpan loc $
- tcId (OccurrenceOf con_name) con_name
- ; data_con <- tcLookupDataCon con_name
+ = do { data_con <- tcLookupDataCon con_name
- ; let (arg_tys, record_ty) = tcSplitFunTys con_tau
- flds_w_tys = zipEqual "tcExpr RecordCon" (dataConFieldLabels data_con) arg_tys
-
- -- Make the result type line up
- ; zapExpectedTo res_ty record_ty
-
- -- Typecheck the record bindings
- ; rbinds' <- tcRecordBinds data_con flds_w_tys rbinds
-
-- Check for missing fields
; checkMissingFields data_con rbinds
+ ; let arity = dataConSourceArity data_con
+ check_fields arg_tys
+ = do { rbinds' <- tcRecordBinds data_con arg_tys rbinds
+ ; mapM unBox arg_tys
+ ; return rbinds' }
+ -- The unBox ensures that all the boxes in arg_tys are indeed
+ -- filled, which is the invariant expected by tcIdApp
+
+ ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
+
; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
-- The main complication with RecordUpd is that we need to explicitly
tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
- = addErrCtxt (recordUpdCtxt expr) $
-
- -- STEP 0
+ = -- STEP 0
-- Check that the field names are really field names
ASSERT( notNull rbinds )
let
-- it contains *all* the fields that are being updated
con1 = head relevant_cons -- A representative constructor
con1_tyvars = dataConTyVars con1
- con1_fld_tys = dataConFieldLabels con1 `zip` dataConOrigArgTys con1
- common_tyvars = tyVarsOfTypes [ty | (fld,ty) <- con1_fld_tys
- , not (fld `elem` upd_field_lbls) ]
+ con1_flds = dataConFieldLabels con1
+ con1_arg_tys = dataConOrigArgTys con1
+ common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
+ , not (fld `elem` upd_field_lbls) ]
is_common_tv tv = tv `elemVarSet` common_tyvars
mk_inst_ty tv result_inst_ty
| is_common_tv tv = returnM result_inst_ty -- Same as result type
- | otherwise = newTyFlexiVarTy (tyVarKind tv) -- Fresh type, of correct kind
+ | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
in
tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ inst_tys ->
-- doesn't match the constructor.)
let
result_record_ty = mkTyConApp tycon result_inst_tys
- inst_fld_tys = [(fld, substTy inst_env ty) | (fld, ty) <- con1_fld_tys]
+ con1_arg_tys' = map (substTy inst_env) con1_arg_tys
in
- zapExpectedTo res_ty result_record_ty `thenM_`
- tcRecordBinds con1 inst_fld_tys rbinds `thenM` \ rbinds' ->
+ tcSubExp result_record_ty res_ty `thenM` \ co_fn ->
+ tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' ->
-- STEP 5
-- Typecheck the expression to be updated
-- This is one place where the isVanilla check is important
-- So that inst_tys matches the tycon
in
- tcCheckRho record_expr record_ty `thenM` \ record_expr' ->
+ tcMonoExpr record_expr record_ty `thenM` \ record_expr' ->
-- STEP 6
-- Figure out the LIE we need. We have to generate some
extendLIEs dicts `thenM_`
-- Phew!
- returnM (RecordUpd record_expr' rbinds' record_ty result_record_ty)
+ returnM (HsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
\end{code}
\begin{code}
tcExpr (ArithSeq _ seq@(From expr)) res_ty
- = zapToListTy res_ty `thenM` \ elt_ty ->
- tcCheckRho expr elt_ty `thenM` \ expr' ->
-
- newMethodFromName (ArithSeqOrigin seq)
- elt_ty enumFromName `thenM` \ enum_from ->
-
- returnM (ArithSeq (HsVar enum_from) (From expr'))
+ = do { elt_ty <- boxySplitListTy res_ty
+ ; expr' <- tcPolyExpr expr elt_ty
+ ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromName
+ ; return (ArithSeq (HsVar enum_from) (From expr')) }
tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
- = addErrCtxt (arithSeqCtxt in_expr) $
- zapToListTy res_ty `thenM` \ elt_ty ->
- tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
- tcCheckRho expr2 elt_ty `thenM` \ expr2' ->
- newMethodFromName (ArithSeqOrigin seq)
- elt_ty enumFromThenName `thenM` \ enum_from_then ->
-
- returnM (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2'))
+ = do { elt_ty <- boxySplitListTy res_ty
+ ; expr1' <- tcPolyExpr expr1 elt_ty
+ ; expr2' <- tcPolyExpr expr2 elt_ty
+ ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromThenName
+ ; return (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
- = addErrCtxt (arithSeqCtxt in_expr) $
- zapToListTy res_ty `thenM` \ elt_ty ->
- tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
- tcCheckRho expr2 elt_ty `thenM` \ expr2' ->
- newMethodFromName (ArithSeqOrigin seq)
- elt_ty enumFromToName `thenM` \ enum_from_to ->
-
- returnM (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2'))
+ = do { elt_ty <- boxySplitListTy res_ty
+ ; expr1' <- tcPolyExpr expr1 elt_ty
+ ; expr2' <- tcPolyExpr expr2 elt_ty
+ ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromToName
+ ; return (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
- = addErrCtxt (arithSeqCtxt in_expr) $
- zapToListTy res_ty `thenM` \ elt_ty ->
- tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
- tcCheckRho expr2 elt_ty `thenM` \ expr2' ->
- tcCheckRho expr3 elt_ty `thenM` \ expr3' ->
- newMethodFromName (ArithSeqOrigin seq)
- elt_ty enumFromThenToName `thenM` \ eft ->
-
- returnM (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3'))
+ = do { elt_ty <- boxySplitListTy res_ty
+ ; expr1' <- tcPolyExpr expr1 elt_ty
+ ; expr2' <- tcPolyExpr expr2 elt_ty
+ ; expr3' <- tcPolyExpr expr3 elt_ty
+ ; eft <- newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromThenToName
+ ; return (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
- = addErrCtxt (parrSeqCtxt in_expr) $
- zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] ->
- tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
- tcCheckRho expr2 elt_ty `thenM` \ expr2' ->
- newMethodFromName (PArrSeqOrigin seq)
- elt_ty enumFromToPName `thenM` \ enum_from_to ->
-
- returnM (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2'))
+ = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
+ ; expr1' <- tcPolyExpr expr1 elt_ty
+ ; expr2' <- tcPolyExpr expr2 elt_ty
+ ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
+ elt_ty enumFromToPName
+ ; return (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
- = addErrCtxt (parrSeqCtxt in_expr) $
- zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] ->
- tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
- tcCheckRho expr2 elt_ty `thenM` \ expr2' ->
- tcCheckRho expr3 elt_ty `thenM` \ expr3' ->
- newMethodFromName (PArrSeqOrigin seq)
- elt_ty enumFromThenToPName `thenM` \ eft ->
-
- returnM (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3'))
+ = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
+ ; expr1' <- tcPolyExpr expr1 elt_ty
+ ; expr2' <- tcPolyExpr expr2 elt_ty
+ ; expr3' <- tcPolyExpr expr3 elt_ty
+ ; eft <- newMethodFromName (PArrSeqOrigin seq)
+ elt_ty enumFromThenToPName
+ ; return (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
tcExpr (PArrSeq _ _) _
= panic "TcExpr.tcMonoExpr: Infinite parallel array!"
%************************************************************************
%* *
-\subsection{@tcApp@ typchecks an application}
+ Applications
%* *
%************************************************************************
\begin{code}
+---------------------------
+tcApp :: HsExpr Name -- Function
+ -> Arity -- Number of args reqd
+ -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
+ -> BoxyRhoType -- Result type
+ -> TcM (HsExpr TcId, arg_results)
+
+-- (tcFun fun n_args arg_checker res_ty)
+-- The argument type checker, arg_checker, will be passed exactly n_args types
+
+tcApp (HsVar fun_name) n_args arg_checker res_ty
+ = tcIdApp fun_name n_args arg_checker res_ty
+
+tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP)
+ = do { arg_boxes <- newBoxyTyVars n_args
+ ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
+ ; arg_tys' <- mapM readFilledBox arg_boxes
+ ; args' <- arg_checker arg_tys'
+ ; return (fun', args') }
+
+---------------------------
+tcIdApp :: Name -- Function
+ -> Arity -- Number of args reqd
+ -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
+ -- The arg-checker guarantees to fill all boxes in the arg types
+ -> BoxyRhoType -- Result type
+ -> TcM (HsExpr TcId, arg_results)
+
+-- Call (f e1 ... en) :: res_ty
+-- Type f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
+-- (where k <= n; fres has the rest)
+-- NB: if k < n then the function doesn't have enough args, and
+-- presumably fres is a type variable that we are going to
+-- instantiate with a function type
+--
+-- Then fres <= bx_(k+1) -> ... -> bx_n -> res_ty
+
+tcIdApp fun_name n_args arg_checker res_ty
+ = do { fun_id <- lookupFun (OccurrenceOf fun_name) fun_name
+
+ -- Split up the function type
+ ; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy (idType fun_id)
+ (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
+
+ qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
+ arg_qtvs = exactTyVarsOfTypes fun_arg_tys
+ res_qtvs = exactTyVarsOfType fun_res_ty
+ -- NB: exactTyVarsOfType. See Note [Silly type synonyms in smart-app]
+ tau_qtvs = arg_qtvs `unionVarSet` res_qtvs
+ k = length fun_arg_tys -- k <= n_args
+ n_missing_args = n_args - k -- Always >= 0
+
+ -- Match the result type of the function with the
+ -- result type of the context, to get an inital substitution
+ ; extra_arg_boxes <- newBoxyTyVars n_missing_args
+ ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
+ res_ty' = mkFunTys extra_arg_tys' res_ty
+ subst = boxySubMatchType arg_qtvs fun_res_ty res_ty'
+ -- Only bind arg_qtvs, since only they will be
+ -- *definitely* be filled in by arg_checker
+ -- E.g. error :: forall a. String -> a
+ -- (error "foo") :: bx5
+ -- Don't make subst [a |-> bx5]
+ -- because then the result subsumption becomes
+ -- bx5 ~ bx5
+ -- and the unifer doesn't expect the
+ -- same box on both sides
+ inst_qtv tv | Just boxy_ty <- lookupTyVar subst tv = return boxy_ty
+ | tv `elemVarSet` tau_qtvs = do { tv' <- tcInstBoxyTyVar tv
+ ; return (mkTyVarTy tv') }
+ | otherwise = do { tv' <- tcInstTyVar tv
+ ; return (mkTyVarTy tv') }
+ -- The 'otherwise' case handles type variables that are
+ -- mentioned only in the constraints, not in argument or
+ -- result types. We'll make them tau-types
+
+ ; qtys' <- mapM inst_qtv qtvs
+ ; let arg_subst = zipOpenTvSubst qtvs qtys'
+ fun_arg_tys' = substTys arg_subst fun_arg_tys
+
+ -- Typecheck the arguments!
+ -- Doing so will fill arg_qtvs and extra_arg_tys'
+ ; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys')
+
+ ; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty'
+ | otherwise = return qty'
+ ; qtys'' <- zipWithM strip qtvs qtys'
+ ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
+
+ -- Result subsumption
+ ; let res_subst = zipOpenTvSubst qtvs qtys''
+ fun_res_ty'' = substTy res_subst fun_res_ty
+ res_ty'' = mkFunTys extra_arg_tys'' res_ty
+ ; co_fn <- addErrCtxtM (checkFunResCtxt fun_name res_ty fun_res_ty'') $
+ tcSubExp fun_res_ty'' res_ty''
+
+ -- And pack up the results
+ -- By applying the coercion just to the *function* we can make
+ -- tcFun work nicely for OpApp and Sections too
+ ; fun' <- instFun fun_id qtvs qtys'' tv_theta_prs
+ ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
+ ; return (HsCoerce co_fn' fun', args') }
+\end{code}
-tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
- -> Expected TcRhoType -- Expected result type of application
- -> TcM (HsExpr TcId) -- Translated fun and args
-
-tcApp (L _ (HsApp e1 e2)) args res_ty
- = tcApp e1 (e2:args) res_ty -- Accumulate the arguments
-
-tcApp fun args res_ty
- = do { let n_args = length args
- ; (fun', fun_tvs, fun_tau) <- tcFun fun -- Type-check the function
-
- -- Extract its argument types
- ; (expected_arg_tys, actual_res_ty)
- <- do { traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_tau))
- ; let msg = sep [ptext SLIT("The function") <+> quotes (ppr fun),
- ptext SLIT("is applied to")
- <+> speakN n_args <+> ptext SLIT("arguments")]
- ; unifyFunTys msg n_args fun_tau }
-
- ; case res_ty of
- Check _ -> do -- Connect to result type first
- -- See Note [Push result type in]
- { co_fn <- tcResult fun args res_ty actual_res_ty
- ; the_app' <- tcArgs fun fun' args expected_arg_tys
- ; traceTc (text "tcApp: check" <+> vcat [ppr fun <+> ppr args,
- ppr the_app', ppr actual_res_ty])
- ; returnM (co_fn <$> the_app') }
-
- Infer _ -> do -- Type check args first, then
- -- refine result type, then do tcResult
- { the_app' <- tcArgs fun fun' args expected_arg_tys
- ; subst <- refineTyVars fun_tvs
- ; let actual_res_ty' = substTy subst actual_res_ty
- ; co_fn <- tcResult fun args res_ty actual_res_ty'
- ; traceTc (text "tcApp: infer" <+> vcat [ppr fun <+> ppr args, ppr the_app',
- ppr actual_res_ty, ppr actual_res_ty'])
- ; returnM (co_fn <$> the_app') }
- }
+Note [Silly type synonyms in smart-app]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we call sripBoxyType, all of the boxes should be filled
+in. But we need to be careful about type synonyms:
+ type T a = Int
+ f :: T a -> Int
+ ...(f x)...
+In the call (f x) we'll typecheck x, expecting it to have type
+(T box). Usually that would fill in the box, but in this case not;
+because 'a' is discarded by the silly type synonym T. So we must
+use exactTyVarsOfType to figure out which type variables are free
+in the argument type.
+
+\begin{code}
+-- tcId is a specialisation of tcIdApp when there are no arguments
+-- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty
+-- ; return res }
+
+tcId :: InstOrigin
+ -> Name -- Function
+ -> BoxyRhoType -- Result type
+ -> TcM (HsExpr TcId)
+tcId orig fun_name res_ty
+ = do { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
+ ; fun_id <- lookupFun orig fun_name
+
+ -- Split up the function type
+ ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy (idType fun_id)
+ qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
+ tau_qtvs = exactTyVarsOfType fun_tau -- Mentiond in the tau part
+ inst_qtv tv | tv `elemVarSet` tau_qtvs = do { tv' <- tcInstBoxyTyVar tv
+ ; return (mkTyVarTy tv') }
+ | otherwise = do { tv' <- tcInstTyVar tv
+ ; return (mkTyVarTy tv') }
+
+ -- Do the subsumption check wrt the result type
+ ; qtv_tys <- mapM inst_qtv qtvs
+ ; let res_subst = zipTopTvSubst qtvs qtv_tys
+ fun_tau' = substTy res_subst fun_tau
+
+ ; co_fn <- addErrCtxtM (checkFunResCtxt fun_name res_ty fun_tau') $
+ tcSubExp fun_tau' res_ty
+
+ -- And pack up the results
+ ; fun' <- instFun fun_id qtvs qtv_tys tv_theta_prs
+ ; return (HsCoerce co_fn fun') }
-- Note [Push result type in]
--
-- the signature is propagated into MkQ's argument. With the check
-- in the other order, the extra signature in f2 is reqd.]
-----------------
-tcFun :: LHsExpr Name -> TcM (LHsExpr TcId, [TcTyVar], TcRhoType)
--- Instantiate the function, returning the type variables used
--- If the function isn't simple, infer its type, and return no
--- type variables
-tcFun (L loc (HsVar f)) = setSrcSpan loc $ do
- { (fun', tvs, fun_tau) <- tcId (OccurrenceOf f) f
- ; return (L loc fun', tvs, fun_tau) }
-tcFun fun = do { (fun', fun_tau) <- tcInfer (tcMonoExpr fun)
- ; return (fun', [], fun_tau) }
+---------------------------
+tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
+-- Typecheck a syntax operator, checking that it has the specified type
+-- The operator is always a variable at this stage (i.e. renamer output)
+tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
+tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
-----------------
+---------------------------
+instFun :: TcId
+ -> [TyVar] -> [TcType] -- Quantified type variables and
+ -- their instantiating types
+ -> [([TyVar], ThetaType)] -- Stuff to instantiate
+ -> TcM (HsExpr TcId)
+instFun fun_id qtvs qtv_tys []
+ = return (HsVar fun_id) -- Common short cut
+
+instFun fun_id qtvs qtv_tys tv_theta_prs
+ = do { let subst = zipOpenTvSubst qtvs qtv_tys
+ ty_theta_prs' = map subst_pr tv_theta_prs
+ subst_pr (tvs, theta) = (map (substTyVar subst) tvs,
+ substTheta subst theta)
+
+ -- The ty_theta_prs' is always non-empty
+ ((tys1',theta1') : further_prs') = ty_theta_prs'
+
+ -- First, chuck in the constraints from
+ -- the "stupid theta" of a data constructor (sigh)
+ ; case isDataConId_maybe fun_id of
+ Just con -> tcInstStupidTheta con tys1'
+ Nothing -> return ()
+
+ ; if want_method_inst theta1'
+ then do { meth_id <- newMethodWithGivenTy orig fun_id tys1'
+ -- See Note [Multiple instantiation]
+ ; go (HsVar meth_id) further_prs' }
+ else go (HsVar fun_id) ty_theta_prs'
+ }
+ where
+ orig = OccurrenceOf (idName fun_id)
+
+ go fun [] = return fun
+
+ go fun ((tys, theta) : prs)
+ = do { dicts <- newDicts orig theta
+ ; extendLIEs dicts
+ ; let the_app = unLoc $ mkHsDictApp (mkHsTyApp (noLoc fun) tys)
+ (map instToId dicts)
+ ; go the_app prs }
+
+ -- Hack Alert (want_method_inst)!
+ -- See Note [No method sharing]
+ -- If f :: (%x :: T) => Int -> Int
+ -- Then if we have two separate calls, (f 3, f 4), we cannot
+ -- make a method constraint that then gets shared, thus:
+ -- let m = f %x in (m 3, m 4)
+ -- because that loses the linearity of the constraint.
+ -- The simplest thing to do is never to construct a method constraint
+ -- in the first place that has a linear implicit parameter in it.
+ want_method_inst theta = not (null theta) -- Overloaded
+ && not (any isLinearPred theta) -- Not linear
+ && not opt_NoMethodSharing
+ -- See Note [No method sharing] below
+\end{code}
+
+Note [Multiple instantiation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
+For example, consider
+ f :: forall a. Eq a => forall b. Ord b => a -> b
+At a call to f, at say [Int, Bool], it's tempting to translate the call to
+
+ f_m1
+ where
+ f_m1 :: forall b. Ord b => Int -> b
+ f_m1 = f Int dEqInt
+
+ f_m2 :: Int -> Bool
+ f_m2 = f_m1 Bool dOrdBool
+
+But notice that f_m2 has f_m1 as its meth_id. Now the danger is that if we do
+a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
+ f_m1 = f_mx
+But it's entirely possible that f_m2 will continue to float out, because it
+mentions no type variables. Result, f_m1 isn't in scope.
+
+Here's a concrete example that does this (test tc200):
+
+ class C a where
+ f :: Eq b => b -> a -> Int
+ baz :: Eq a => Int -> a -> Int
+
+ instance C Int where
+ baz = f
+
+Current solution: only do the "method sharing" thing for the first type/dict
+application, not for the iterated ones. A horribly subtle point.
+
+Note [No method sharing]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The -fno-method-sharing flag controls what happens so far as the LIE
+is concerned. The default case is that for an overloaded function we
+generate a "method" Id, and add the Method Inst to the LIE. So you get
+something like
+ f :: Num a => a -> a
+ f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
+If you specify -fno-method-sharing, the dictionary application
+isn't shared, so we get
+ f :: Num a => a -> a
+ f = /\a (d:Num a) (x:a) -> (+) a d x x
+This gets a bit less sharing, but
+ a) it's better for RULEs involving overloaded functions
+ b) perhaps fewer separated lambdas
+
+\begin{code}
tcArgs :: LHsExpr Name -- The function (for error messages)
- -> LHsExpr TcId -- The function (to build into result)
-> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
- -> TcM (HsExpr TcId) -- Resulting application
+ -> TcM [LHsExpr TcId] -- Resulting args
-tcArgs fun fun' args expected_arg_tys
- = do { args' <- mappM (tcArg fun) (zip3 args expected_arg_tys [1..])
- ; return (unLoc (foldl mkHsApp fun' args')) }
+tcArgs fun args expected_arg_tys
+ = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
tcArg :: LHsExpr Name -- The function (for error messages)
- -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type
+ -> (LHsExpr Name, BoxySigmaType, Int) -- Actual argument and expected arg type
-> TcM (LHsExpr TcId) -- Resulting argument
-tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
- (tcCheckSigma arg ty)
+tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
+ tcPolyExprNC arg ty
-----------------
-tcResult fun args res_ty actual_res_ty
- = addErrCtxtM (checkArgsCtxt fun args res_ty actual_res_ty)
- (tcSubExp res_ty actual_res_ty)
----------------
-- If an error happens we try to figure out whether the
-- function has been given too many or too few arguments,
-- and say so.
--- The ~(Check...) is because in the Infer case the tcSubExp
--- definitely won't fail, so we can be certain we're in the Check branch
-checkArgsCtxt fun args (Infer _) actual_res_ty tidy_env
- = return (tidy_env, ptext SLIT("Urk infer"))
-
-checkArgsCtxt fun args (Check expected_res_ty) actual_res_ty tidy_env
+checkFunResCtxt fun expected_res_ty actual_res_ty tidy_env
= zonkTcType expected_res_ty `thenM` \ exp_ty' ->
zonkTcType actual_res_ty `thenM` \ act_ty' ->
let
len_act_args = length act_args
len_exp_args = length exp_args
- message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
- | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
- | otherwise = appCtxt fun args
+ message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun
+ | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun
+ | otherwise = empty
in
returnM (env2, message)
-
-----------------
-unifyInfixTy :: LHsExpr Name -> HsExpr Name -> TcType
- -> TcM ([TcType], TcType)
--- This wrapper just prepares the error message for unifyFunTys
-unifyInfixTy op expr op_ty
- = unifyFunTys msg 2 op_ty
- where
- msg = sep [herald <+> quotes (ppr expr),
- ptext SLIT("requires") <+> quotes (ppr op)
- <+> ptext SLIT("to take two arguments")]
- herald = case expr of
- OpApp _ _ _ _ -> ptext SLIT("The infix expression")
- other -> ptext SLIT("The operator section")
\end{code}
%* *
%************************************************************************
-tcId instantiates an occurrence of an Id.
-The instantiate_it loop runs round instantiating the Id.
-It has to be a loop because we are now prepared to entertain
-types like
- f:: forall a. Eq a => forall b. Baz b => tau
-We want to instantiate this to
- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
+\begin{code}
+lookupFun :: InstOrigin -> Name -> TcM TcId
+lookupFun orig id_name
+ = do { thing <- tcLookup id_name
+ ; case thing of
+ AGlobal (ADataCon con) -> return (dataConWrapId con)
+
+ AGlobal (AnId id)
+ | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
+ | otherwise -> return id
+ -- A global cannot possibly be ill-staged
+ -- nor does it need the 'lifting' treatment
-The -fno-method-sharing flag controls what happens so far as the LIE
-is concerned. The default case is that for an overloaded function we
-generate a "method" Id, and add the Method Inst to the LIE. So you get
-something like
- f :: Num a => a -> a
- f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
-If you specify -fno-method-sharing, the dictionary application
-isn't shared, so we get
- f :: Num a => a -> a
- f = /\a (d:Num a) (x:a) -> (+) a d x x
-This gets a bit less sharing, but
- a) it's better for RULEs involving overloaded functions
- b) perhaps fewer separated lambdas
+#ifndef GHCI
+ ATcId id th_level _ -> return id -- Non-TH case
+#else
+ ATcId id th_level _ -> do { use_stage <- getStage -- TH case
+ ; thLocalId orig id_name id th_level use_stage }
+#endif
-\begin{code}
-tcId :: InstOrigin -> Name -> TcM (HsExpr TcId, [TcTyVar], TcRhoType)
- -- Return the type variables at which the function
- -- is instantiated, as well as the translated variable and its type
-
-tcId orig id_name -- Look up the Id and instantiate its type
- = tcLookup id_name `thenM` \ thing ->
- case thing of {
- AGlobal (ADataCon con) -- Similar, but instantiate the stupid theta too
- -> do { (expr, tvs, tau) <- instantiate (dataConWrapId con)
- ; tcInstStupidTheta con (mkTyVarTys tvs)
- -- Remember to chuck in the constraints from the "silly context"
- ; return (expr, tvs, tau) }
-
- ; AGlobal (AnId id) | isNaughtyRecordSelector id
- -> failWithTc (naughtyRecordSel id)
- ; AGlobal (AnId id) -> instantiate id
- -- A global cannot possibly be ill-staged
- -- nor does it need the 'lifting' treatment
-
- ; ATcId id th_level -> tc_local_id id th_level
-
- ; other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
+ other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
}
- where
-#ifndef GHCI
- tc_local_id id th_bind_lvl -- Non-TH case
- = instantiate id
-
-#else /* GHCI and TH is on */
- tc_local_id id th_bind_lvl -- TH case
- = -- Check for cross-stage lifting
- getStage `thenM` \ use_stage ->
- case use_stage of
- Brack use_lvl ps_var lie_var
- | use_lvl > th_bind_lvl
- -> if isExternalName id_name then
- -- Top-level identifiers in this module,
- -- (which have External Names)
- -- are just like the imported case:
- -- no need for the 'lifting' treatment
- -- E.g. this is fine:
- -- f x = x
- -- g y = [| f 3 |]
- -- But we do need to put f into the keep-alive
- -- set, because after desugaring the code will
- -- only mention f's *name*, not f itself.
- keepAliveTc id_name `thenM_`
- instantiate id
-
- else -- Nested identifiers, such as 'x' in
- -- E.g. \x -> [| h x |]
- -- We must behave as if the reference to x was
- -- h $(lift x)
- -- We use 'x' itself as the splice proxy, used by
- -- the desugarer to stitch it all back together.
- -- If 'x' occurs many times we may get many identical
- -- bindings of the same splice proxy, but that doesn't
- -- matter, although it's a mite untidy.
- let
- id_ty = idType id
- in
- checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_`
- -- If x is polymorphic, its occurrence sites might
- -- have different instantiations, so we can't use plain
- -- 'x' as the splice proxy name. I don't know how to
- -- solve this, and it's probably unimportant, so I'm
- -- just going to flag an error for now
+#ifdef GHCI /* GHCI and TH is on */
+--------------------------------------
+-- thLocalId : Check for cross-stage lifting
+thLocalId orig id_name id th_bind_lvl (Brack use_lvl ps_var lie_var)
+ | use_lvl > th_bind_lvl
+ = thBrackId orig id_name id ps_var lie_var
+thLocalId orig id_name id th_bind_lvl use_stage
+ = do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
+ ; return id }
+
+--------------------------------------
+thBrackId orig id_name id ps_var lie_var
+ | isExternalName id_name
+ = -- Top-level identifiers in this module,
+ -- (which have External Names)
+ -- are just like the imported case:
+ -- no need for the 'lifting' treatment
+ -- E.g. this is fine:
+ -- f x = x
+ -- g y = [| f 3 |]
+ -- But we do need to put f into the keep-alive
+ -- set, because after desugaring the code will
+ -- only mention f's *name*, not f itself.
+ do { keepAliveTc id_name; return id }
+
+ | otherwise
+ = -- Nested identifiers, such as 'x' in
+ -- E.g. \x -> [| h x |]
+ -- We must behave as if the reference to x was
+ -- h $(lift x)
+ -- We use 'x' itself as the splice proxy, used by
+ -- the desugarer to stitch it all back together.
+ -- If 'x' occurs many times we may get many identical
+ -- bindings of the same splice proxy, but that doesn't
+ -- matter, although it's a mite untidy.
+ do { let id_ty = idType id
+ ; checkTc (isTauTy id_ty) (polySpliceErr id)
+ -- If x is polymorphic, its occurrence sites might
+ -- have different instantiations, so we can't use plain
+ -- 'x' as the splice proxy name. I don't know how to
+ -- solve this, and it's probably unimportant, so I'm
+ -- just going to flag an error for now
- setLIEVar lie_var (
- newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
- -- Put the 'lift' constraint into the right LIE
+ ; setLIEVar lie_var $ do
+ { lift <- newMethodFromName orig id_ty DsMeta.liftName
+ -- Put the 'lift' constraint into the right LIE
-- Update the pending splices
- readMutVar ps_var `thenM` \ ps ->
- writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) `thenM_`
-
- returnM (HsVar id, [], id_ty))
+ ; ps <- readMutVar ps_var
+ ; writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
- other ->
- checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_`
- instantiate id
+ ; return id } }
#endif /* GHCI */
-
- instantiate :: TcId -> TcM (HsExpr TcId, [TcTyVar], TcRhoType)
- instantiate fun_id
- | not (want_method_inst fun_ty)
- = loop (HsVar fun_id) [] fun_ty
- | otherwise -- Make a MethodInst
- = tcInstType fun_ty `thenM` \ (tyvars, theta, tau) ->
- newMethodWithGivenTy orig fun_id
- (mkTyVarTys tyvars) theta tau `thenM` \ meth_id ->
- loop (HsVar meth_id) tyvars tau
- where
- fun_ty = idType fun_id
-
- -- See Note [Multiple instantiation]
- loop fun tvs fun_ty
- | isSigmaTy fun_ty
- = tcInstCall orig fun_ty `thenM` \ (inst_fn, new_tvs, tau) ->
- loop (inst_fn <$> fun) (tvs ++ new_tvs) tau
-
- | otherwise
- = returnM (fun, tvs, fun_ty)
-
- -- Hack Alert (want_method_inst)!
- -- If f :: (%x :: T) => Int -> Int
- -- Then if we have two separate calls, (f 3, f 4), we cannot
- -- make a method constraint that then gets shared, thus:
- -- let m = f %x in (m 3, m 4)
- -- because that loses the linearity of the constraint.
- -- The simplest thing to do is never to construct a method constraint
- -- in the first place that has a linear implicit parameter in it.
- want_method_inst fun_ty
- | opt_NoMethodSharing = False
- | otherwise = case tcSplitSigmaTy fun_ty of
- (_,[],_) -> False -- Not overloaded
- (_,theta,_) -> not (any isLinearPred theta)
\end{code}
Note [Multiple instantiation]
\begin{code}
tcRecordBinds
:: DataCon
- -> [(FieldLabel,TcType)] -- Expected type for each field
+ -> [TcType] -- Expected type for each field
-> HsRecordBinds Name
-> TcM (HsRecordBinds TcId)
-tcRecordBinds data_con flds_w_tys rbinds
+tcRecordBinds data_con arg_tys rbinds
= do { mb_binds <- mappM do_bind rbinds
; return (catMaybes mb_binds) }
where
+ flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
do_bind (L loc field_lbl, rhs)
| Just field_ty <- assocMaybe flds_w_tys field_lbl
= addErrCtxt (fieldCtxt field_lbl) $
- do { rhs' <- tcCheckSigma rhs field_ty
+ do { rhs' <- tcPolyExprNC rhs field_ty
; sel_id <- tcLookupId field_lbl
; ASSERT( isRecordSelector sel_id )
return (Just (L loc sel_id, rhs')) }
%************************************************************************
%* *
-\subsection{@tcCheckRhos@ typechecks a {\em list} of expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-tcCheckRhos :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
-
-tcCheckRhos [] [] = returnM []
-tcCheckRhos (expr:exprs) (ty:tys)
- = tcCheckRho expr ty `thenM` \ expr' ->
- tcCheckRhos exprs tys `thenM` \ exprs' ->
- returnM (expr':exprs')
-tcCheckRhos exprs tys = pprPanic "tcCheckRhos" (ppr exprs $$ ppr tys)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Literals}
-%* *
-%************************************************************************
-
-Overloaded literals.
-
-\begin{code}
-tcLit :: HsLit -> Expected TcRhoType -> TcM (HsExpr TcId)
-tcLit lit res_ty
- = zapExpectedTo res_ty (hsLitType lit) `thenM_`
- returnM (HsLit lit)
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Errors and contexts}
%* *
%************************************************************************
Boring and alphabetical:
\begin{code}
-arithSeqCtxt expr
- = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
-
-parrSeqCtxt expr
- = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
-
-caseCtxt expr
- = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
-
caseScrutCtxt expr
= hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
quotes (ppr fun) <> text ", namely"])
4 (quotes (ppr arg))
-listCtxt expr
- = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
-
-parrCtxt expr
- = hang (ptext SLIT("In the parallel array element:")) 4 (ppr expr)
-
predCtxt expr
= hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
-appCtxt fun args
- = ptext SLIT("In the application") <+> quotes (ppr the_app)
- where
- the_app = foldl mkHsApp fun args -- Used in error messages
-
nonVanillaUpd tycon
= vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
<+> ptext SLIT("is not (yet) supported"),
= hang (ptext SLIT("No constructor has all these fields:"))
4 (pprQuotedList (recBindFields rbinds))
-recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
-recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
-
naughtyRecordSel sel_id
= ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+>
ptext SLIT("as a function due to escaped type variables") $$
= ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
<+> pprWithCommas ppr fields
-wrongArgsCtxt too_many_or_few fun args
- = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
- <+> ptext SLIT("is applied to") <+> text too_many_or_few
- <+> ptext SLIT("arguments in the call"))
- 4 (parens (ppr the_app))
- where
- the_app = foldl mkHsApp fun args -- Used in error messages
+callCtxt fun args
+ = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
+
+wrongArgsCtxt too_many_or_few fun
+ = ptext SLIT("Probable cause:") <+> quotes (ppr fun)
+ <+> ptext SLIT("is applied to") <+> text too_many_or_few
+ <+> ptext SLIT("arguments")
#ifdef GHCI
polySpliceErr :: Id -> SDoc
import HsSyn ( HsExpr, LHsExpr )
import Name ( Name )
import Var ( Id )
-import TcType ( TcType, Expected )
+import TcType ( TcType, BoxySigmaType, BoxyRhoType )
import TcRnTypes( TcM, InstOrigin )
-tcCheckSigma ::
+tcPolyExpr ::
LHsExpr Name
- -> TcType
+ -> BoxySigmaType
-> TcM (LHsExpr Id)
-tcCheckRho ::
+tcMonoExpr ::
LHsExpr Name
- -> TcType
+ -> BoxyRhoType
-> TcM (LHsExpr Id)
tcInferRho ::
LHsExpr Name
-> TcM (LHsExpr Id, TcType)
-tcMonoExpr ::
- LHsExpr Name
- -> Expected TcType
- -> TcM (LHsExpr Id)
-
tcSyntaxOp ::
InstOrigin
-> HsExpr Name
import TcRnMonad
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
-import TcExpr ( tcCheckSigma )
+import TcExpr ( tcPolyExpr )
import ForeignCall ( CCallConv(..) )
import ErrUtils ( Message )
addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
- tcCheckSigma (nlHsVar nm) sig_ty `thenM` \ rhs ->
+ tcPolyExpr (nlHsVar nm) sig_ty `thenM` \ rhs ->
tcCheckFEType sig_ty spec `thenM_`
tycon_loc = getSrcSpan tycon
--------------------------------------------------------------------
- compare = L tycon_loc (FunBind (L tycon_loc compare_RDR) False compare_matches placeHolderNames)
- compare_matches = mkMatchGroup [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
+ compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
+ compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
compare_rhs
nlHsIntLit,
- -- Coercions
- Coercion, ExprCoFn, PatCoFn,
- (<$>), (<.>), mkCoercion,
- idCoercion, isIdCoercion,
-
-- re-exported from TcMonad
TcId, TcIdSet, TcDictBinds,
import TcRnMonad
import Type ( Type )
-import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar, tcGetTyVar )
+import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar )
import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
import qualified Type
-import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, zonkTcTyVars, putMetaTyVar )
+import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, writeMetaTyVar )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
import VarEnv
import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName )
import Maybes ( orElse )
-import Maybe ( isNothing )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc )
import Util ( mapSnd )
hsLitType (HsDoublePrim d) = doublePrimTy
\end{code}
-%************************************************************************
-%* *
-\subsection{Coercion functions}
-%* *
-%************************************************************************
-
-\begin{code}
-type Coercion a = Maybe (a -> a)
- -- Nothing => identity fn
-
-type ExprCoFn = Coercion (HsExpr TcId)
-type PatCoFn = Coercion (Pat TcId)
-
-(<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition
-Nothing <.> Nothing = Nothing
-Nothing <.> Just f = Just f
-Just f <.> Nothing = Just f
-Just f1 <.> Just f2 = Just (f1 . f2)
-
-(<$>) :: Coercion a -> a -> a
-Just f <$> e = f e
-Nothing <$> e = e
-
-mkCoercion :: (a -> a) -> Coercion a
-mkCoercion f = Just f
-
-idCoercion :: Coercion a
-idCoercion = Nothing
-
-isIdCoercion :: Coercion a -> Bool
-isIdCoercion = isNothing
-\end{code}
-
%************************************************************************
%* *
zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
-zonk_bind env (PatBind pat grhss ty fvs)
+zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
= do { (_env, new_pat) <- zonkPat env pat -- Env already extended
; new_grhss <- zonkGRHSs env grhss
; new_ty <- zonkTcTypeToType env ty
- ; return (PatBind new_pat new_grhss new_ty fvs) }
+ ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
-zonk_bind env (VarBind var expr)
+zonk_bind env (VarBind { var_id = var, var_rhs = expr })
= zonkIdBndr env var `thenM` \ new_var ->
zonkLExpr env expr `thenM` \ new_expr ->
- returnM (VarBind new_var new_expr)
+ returnM (VarBind { var_id = new_var, var_rhs = new_expr })
-zonk_bind env (FunBind var inf ms fvs)
+zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
= wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
- zonkMatchGroup env ms `thenM` \ new_ms ->
- returnM (FunBind new_var inf new_ms fvs)
+ zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
+ zonkMatchGroup env1 ms `thenM` \ new_ms ->
+ returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn })
-zonk_bind env (AbsBinds tyvars dicts exports val_binds)
+zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
+ abs_exports = exports, abs_binds = val_binds })
= ASSERT( all isImmutableTyVar tyvars )
zonkIdBndrs env dicts `thenM` \ new_dicts ->
fixM (\ ~(new_val_binds, _) ->
mappM (zonkExport env2) exports `thenM` \ new_exports ->
returnM (new_val_binds, new_exports)
) `thenM` \ (new_val_bind, new_exports) ->
- returnM (AbsBinds tyvars new_dicts new_exports new_val_bind)
+ returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts,
+ abs_exports = new_exports, abs_binds = new_val_bind })
where
zonkExport env (tyvars, global, local, prags)
- = zonkTcTyVars tyvars `thenM` \ tys ->
- let
- new_tyvars = map (tcGetTyVar "zonkExport") tys
- -- This isn't the binding occurrence of these tyvars
- -- but they should *be* tyvars. Hence tcGetTyVar.
- in
- zonkIdBndr env global `thenM` \ new_global ->
- mapM zonk_prag prags `thenM` \ new_prags ->
- returnM (new_tyvars, new_global, zonkIdOcc env local, new_prags)
+ = zonkIdBndr env global `thenM` \ new_global ->
+ mapM zonk_prag prags `thenM` \ new_prags ->
+ returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
zonk_prag prag@(InlinePrag {}) = return prag
zonk_prag (SpecPrag expr ty ds inl) = do { expr' <- zonkExpr env expr
; ty' <- zonkTcTypeToType env ty
mappM (zonkCmdTop env) args `thenM` \ new_args ->
returnM (HsArrForm new_op fixity new_args)
+zonkExpr env (HsCoerce co_fn expr)
+ = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
+ zonkExpr env1 expr `thenM` \ new_expr ->
+ return (HsCoerce new_co_fn new_expr)
+
zonkExpr env other = pprPanic "zonkExpr" (ppr other)
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
-------------------------------------------------------------------------
+zonkCoFn :: ZonkEnv -> ExprCoFn -> TcM (ZonkEnv, ExprCoFn)
+zonkCoFn env CoHole = return (env, CoHole)
+zonkCoFn env (CoCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
+ ; (env2, c2') <- zonkCoFn env1 c2
+ ; return (env2, CoCompose c1' c2') }
+zonkCoFn env (CoLams ids c) = do { ids' <- zonkIdBndrs env ids
+ ; let env1 = extendZonkEnv env ids'
+ ; (env2, c') <- zonkCoFn env1 c
+ ; return (env2, CoLams ids' c') }
+zonkCoFn env (CoTyLams tvs c) = ASSERT( all isImmutableTyVar tvs )
+ do { (env1, c') <- zonkCoFn env c
+ ; return (env1, CoTyLams tvs c') }
+zonkCoFn env (CoApps c ids) = do { (env1, c') <- zonkCoFn env c
+ ; return (env1, CoApps c' (zonkIdOccs env ids)) }
+zonkCoFn env (CoTyApps c tys) = do { tys' <- zonkTcTypeToTypes env tys
+ ; (env1, c') <- zonkCoFn env c
+ ; return (env1, CoTyApps c' tys') }
+zonkCoFn env (CoLet bs c) = do { (env1, bs') <- zonkRecMonoBinds env bs
+ ; (env2, c') <- zonkCoFn env1 c
+ ; return (env2, CoLet bs' c') }
+
+
+-------------------------------------------------------------------------
zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
-- Only used for 'do', so the only Ids are in a MDoExpr table
zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
-- This variant collects unbound type variables in a mutable variable
zonkTypeCollecting unbound_tv_set
- = zonkType zonk_unbound_tyvar True
+ = zonkType zonk_unbound_tyvar
where
zonk_unbound_tyvar tv
= zonkQuantifiedTyVar tv `thenM` \ tv' ->
-- This variant is used for everything except the LHS of rules
-- It zaps unbound type variables to (), or some other arbitrary type
zonkTypeZapping ty
- = zonkType zonk_unbound_tyvar True ty
+ = zonkType zonk_unbound_tyvar ty
where
-- Zonk a mutable but unbound type variable to an arbitrary type
-- We know it's unbound even though we don't carry an environment,
-- mutable tyvar to a fresh immutable one. So the mutable store
-- plays the role of an environment. If we come across a mutable
-- type variable that isn't so bound, it must be completely free.
- zonk_unbound_tyvar tv = do { putMetaTyVar tv ty; return ty }
+ zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty }
where
ty = mkArbitraryType tv
tcTyVarBndrs, dsHsType, tcLHsConResTy,
tcDataKindSig,
- tcHsPatSigType, tcAddLetBoundTyVars,
-
- TcSigInfo(..), TcSigFun, lookupSig
+ -- Pattern type signatures
+ tcHsPatSigType, tcPatSig
) where
#include "HsVersions.h"
import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr,
- LHsContext, HsPred(..), LHsPred, LHsBinds, HsExplicitForAll(..),
- collectSigTysFromHsBinds )
+ LHsContext, HsPred(..), LHsPred, HsExplicitForAll(..) )
import RnHsSyn ( extractHsTyVars )
import TcRnMonad
import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnvTvs,
tcLookup, tcLookupClass, tcLookupTyCon,
- TyThing(..), getInLocalScope, wrongThingErr
+ TyThing(..), getInLocalScope, getScopedTyVarBinds,
+ wrongThingErr
)
-import TcMType ( newKindVar, newMetaTyVar, zonkTcKindToKind,
- checkValidType, UserTypeCtxt(..), pprHsSigCtxt
+import TcMType ( newKindVar,
+ zonkTcKindToKind,
+ tcInstBoxyTyVar, readFilledBox,
+ checkValidType
)
-import TcUnify ( unifyFunKind, checkExpectedKind )
+import TcUnify ( boxyUnify, unifyFunKind, checkExpectedKind )
import TcIface ( checkWiredInTyCon )
-import TcType ( Type, PredType(..), ThetaType,
- MetaDetails(Flexi), hoistForAllTys,
- TcType, TcTyVar, TcKind, TcThetaType, TcTauType,
- mkFunTy, mkSigmaTy, mkPredTy, mkGenTyConApp,
+import TcType ( Type, PredType(..), ThetaType, BoxySigmaType,
+ TcType, TcKind, isRigidTy,
+ UserTypeCtxt(..), pprUserTypeCtxt,
+ substTyWith, mkTyVarTys, tcEqType,
+ tcIsTyVarTy, mkFunTy, mkSigmaTy, mkPredTy,
mkTyConApp, mkAppTys, typeKind )
import Kind ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind,
openTypeKind, argTypeKind, splitKindFunTys )
-import Id ( idName )
-import Var ( TyVar, mkTyVar )
+import Var ( TyVar, mkTyVar, tyVarName )
import TyCon ( TyCon, tyConKind )
import Class ( Class, classTyCon )
import Name ( Name, mkInternalName )
import OccName ( mkOccName, tvName )
import NameSet
-import NameEnv
import PrelNames ( genUnitTyConName )
import TysWiredIn ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon )
-import BasicTypes ( Boxity(..), RecFlag )
-import SrcLoc ( Located(..), unLoc, noLoc, srcSpanStart )
+import BasicTypes ( Boxity(..) )
+import SrcLoc ( Located(..), unLoc, noLoc, getLoc, srcSpanStart )
import UniqSupply ( uniqsFromSupply )
import Outputable
\end{code}
-- This is used in type and class decls, where kinding is
-- done in advance, and validity checking is done later
-- [Validity checking done later because of knot-tying issues.]
-tcHsKindedType hs_ty
- = do { ty <- dsHsType hs_ty
- ; return (hoistForAllTys ty) }
+tcHsKindedType hs_ty = dsHsType hs_ty
tcHsBangType :: LHsType Name -> TcM Type
-- Permit a bang, but discard it
= tcLookup name `thenM` \ thing ->
case thing of
ATyVar _ ty -> returnM (mkAppTys ty arg_tys)
- AGlobal (ATyCon tc) -> returnM (mkGenTyConApp tc arg_tys)
+ AGlobal (ATyCon tc) -> returnM (mkTyConApp tc arg_tys)
other -> wrongThingErr "type" thing name
\end{code}
= mapM (zonk . unLoc) bndrs `thenM` \ tyvars ->
tcExtendTyVarEnv tyvars (thing_inside tyvars)
where
- zonk (KindedTyVar name kind) = zonkTcKindToKind kind `thenM` \ kind' ->
- returnM (mkTyVar name kind')
+ zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind
+ ; return (mkTyVar name kind') }
zonk (UserTyVar name) = pprTrace "Un-kinded tyvar" (ppr name) $
- returnM (mkTyVar name liftedTypeKind)
+ return (mkTyVar name liftedTypeKind)
-----------------------------------
tcDataKindSig :: Maybe Kind -> TcM [TyVar]
it with expected_ty afterwards
\begin{code}
-tcPatSigBndrs :: LHsType Name
- -> TcM ([TcTyVar], -- Brought into scope
- LHsType Name) -- Kinded, but not yet desugared
+tcHsPatSigType :: UserTypeCtxt
+ -> LHsType Name -- The type signature
+ -> TcM ([TyVar], -- Newly in-scope type variables
+ Type) -- The signature
+-- Used for type-checking type signatures in
+-- (a) patterns e.g f (x::Int) = e
+-- (b) result signatures e.g. g x :: Int = e
+-- (c) RULE forall bndrs e.g. forall (x::Int). f x = x
-tcPatSigBndrs hs_ty
- = do { in_scope <- getInLocalScope
- ; span <- getSrcSpanM
- ; let sig_tvs = [ L span (UserTyVar n)
+tcHsPatSigType ctxt hs_ty
+ = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
+ do { -- Find the type variables that are mentioned in the type
+ -- but not already in scope. These are the ones that
+ -- should be bound by the pattern signature
+ in_scope <- getInLocalScope
+ ; let span = getLoc hs_ty
+ sig_tvs = [ L span (UserTyVar n)
| n <- nameSetToList (extractHsTyVars hs_ty),
not (in_scope n) ]
- -- The tyvars we want are the free type variables of
- -- the type that are not already in scope
- -- Behave like kcHsType on a ForAll type
- -- i.e. make kinded tyvars with mutable kinds,
- -- and kind-check the enclosed types
+ -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
+ -- except that we want to keep the tvs separate
; (kinded_tvs, kinded_ty) <- kcHsTyVars sig_tvs $ \ kinded_tvs -> do
{ kinded_ty <- kcTypeType hs_ty
; return (kinded_tvs, kinded_ty) }
-
- -- Zonk the mutable kinds and bring the tyvars into scope
- -- Just like the call to tcTyVarBndrs in ds_type (HsForAllTy case),
- -- except that it brings *meta* tyvars into scope, not regular ones
- --
- -- [Out of date, but perhaps should be resurrected]
- -- Furthermore, the tyvars are PatSigTvs, which means that we get better
- -- error messages when type variables escape:
- -- Inferred type is less polymorphic than expected
- -- Quantified type variable `t' escapes
- -- It is mentioned in the environment:
- -- t is bound by the pattern type signature at tcfail103.hs:6
- ; tyvars <- mapM (zonk . unLoc) kinded_tvs
- ; return (tyvars, kinded_ty) }
+ ; tcTyVarBndrs kinded_tvs $ \ tyvars -> do
+ { sig_ty <- dsHsType kinded_ty
+ ; checkValidType ctxt sig_ty
+ ; return (tyvars, sig_ty)
+ } }
+
+tcPatSig :: UserTypeCtxt
+ -> LHsType Name
+ -> BoxySigmaType
+ -> TcM (TcType, -- The type to use for "inside" the signature
+ [(Name,TcType)]) -- The new bit of type environment, binding
+ -- the scoped type variables
+tcPatSig ctxt sig res_ty
+ = do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig
+
+ ; if null sig_tvs then do {
+ -- The type signature binds no type variables,
+ -- and hence is rigid, so use it to zap the res_ty
+ boxyUnify sig_ty res_ty
+ ; return (sig_ty, [])
+
+ } else do {
+ -- Type signature binds at least one scoped type variable
+
+ -- A pattern binding cannot bind scoped type variables
+ -- The renamer fails with a name-out-of-scope error
+ -- if a pattern binding tries to bind a type variable,
+ -- So we just have an ASSERT here
+ ; let in_pat_bind = case ctxt of
+ BindPatSigCtxt -> True
+ other -> False
+ ; ASSERT( not in_pat_bind || null sig_tvs ) return ()
+
+ -- Check that pat_ty is rigid
+ ; checkTc (isRigidTy res_ty) (wobblyPatSig sig_tvs)
+
+ -- Now match the pattern signature against res_ty
+ -- For convenience, and uniform-looking error messages
+ -- we do the matching by allocating meta type variables,
+ -- unifying, and reading out the results.
+ -- This is a strictly local operation.
+ ; box_tvs <- mapM tcInstBoxyTyVar sig_tvs
+ ; boxyUnify (substTyWith sig_tvs (mkTyVarTys box_tvs) sig_ty) res_ty
+ ; sig_tv_tys <- mapM readFilledBox box_tvs
+
+ -- Check that each is bound to a distinct type variable,
+ -- and one that is not already in scope
+ ; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys
+ ; binds_in_scope <- getScopedTyVarBinds
+ ; check binds_in_scope tv_binds
+
+ -- Phew!
+ ; return (res_ty, tv_binds)
+ } }
where
- zonk (KindedTyVar name kind) = zonkTcKindToKind kind `thenM` \ kind' ->
- newMetaTyVar name kind' Flexi
- -- Scoped type variables are bound to a *type*, hence Flexi
- zonk (UserTyVar name) = pprTrace "Un-kinded tyvar" (ppr name) $
- returnM (mkTyVar name liftedTypeKind)
-
-tcHsPatSigType :: UserTypeCtxt
- -> LHsType Name -- The type signature
- -> TcM ([TcTyVar], -- Newly in-scope type variables
- TcType) -- The signature
-
-tcHsPatSigType ctxt hs_ty
- = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
- do { (tyvars, kinded_ty) <- tcPatSigBndrs hs_ty
+ check in_scope [] = return ()
+ check in_scope ((n,ty):rest) = do { check_one in_scope n ty
+ ; check ((n,ty):in_scope) rest }
- -- Complete processing of the type, and check its validity
- ; tcExtendTyVarEnv tyvars $ do
- { sig_ty <- tcHsKindedType kinded_ty
- ; checkValidType ctxt sig_ty
- ; return (tyvars, sig_ty) }
- }
+ check_one in_scope n ty
+ = do { checkTc (tcIsTyVarTy ty) (scopedNonVar n ty)
+ -- Must bind to a type variable
-tcAddLetBoundTyVars :: [(RecFlag,LHsBinds Name)] -> TcM a -> TcM a
--- Turgid funciton, used for type variables bound by the patterns of a let binding
+ ; checkTc (null dups) (dupInScope n (head dups) ty)
+ -- Must not bind to the same type variable
+ -- as some other in-scope type variable
-tcAddLetBoundTyVars binds thing_inside
- = go (concatMap (collectSigTysFromHsBinds . snd) binds) thing_inside
- where
- go [] thing_inside = thing_inside
- go (hs_ty:hs_tys) thing_inside
- = do { (tyvars, _kinded_ty) <- tcPatSigBndrs hs_ty
- ; tcExtendTyVarEnv tyvars (go hs_tys thing_inside) }
+ ; return () }
+ where
+ dups = [n' | (n',ty') <- in_scope, tcEqType ty' ty]
\end{code}
%************************************************************************
%* *
-\subsection{Signatures}
+ Scoped type variables
%* *
%************************************************************************
-@tcSigs@ checks the signatures for validity, and returns a list of
-{\em freshly-instantiated} signatures. That is, the types are already
-split up, and have fresh type variables installed. All non-type-signature
-"RenamedSigs" are ignored.
-
-The @TcSigInfo@ contains @TcTypes@ because they are unified with
-the variable's type, and after that checked to see whether they've
-been instantiated.
-
\begin{code}
-data TcSigInfo
- = TcSigInfo {
- sig_id :: TcId, -- *Polymorphic* binder for this value...
-
- sig_scoped :: [Name], -- Names for any scoped type variables
- -- Invariant: correspond 1-1 with an initial
- -- segment of sig_tvs (see Note [Scoped])
-
- sig_tvs :: [TcTyVar], -- Instantiated type variables
- -- See Note [Instantiate sig]
-
- sig_theta :: TcThetaType, -- Instantiated theta
- sig_tau :: TcTauType, -- Instantiated tau
- sig_loc :: InstLoc -- The location of the signature
- }
-
--- Note [Scoped]
--- There may be more instantiated type variables than scoped
--- ones. For example:
--- type T a = forall b. b -> (a,b)
--- f :: forall c. T c
--- Here, the signature for f will have one scoped type variable, c,
--- but two instantiated type variables, c' and b'.
---
--- We assume that the scoped ones are at the *front* of sig_tvs,
--- and remember the names from the original HsForAllTy in sig_scoped
-
--- Note [Instantiate sig]
--- It's vital to instantiate a type signature with fresh variable.
--- For example:
--- type S = forall a. a->a
--- f,g :: S
--- f = ...
--- g = ...
--- Here, we must use distinct type variables when checking f,g's right hand sides.
--- (Instantiation is only necessary because of type synonyms. Otherwise,
--- it's all cool; each signature has distinct type variables from the renamer.)
-
-type TcSigFun = Name -> Maybe TcSigInfo
-
-instance Outputable TcSigInfo where
- ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
- = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
-
-lookupSig :: [TcSigInfo] -> TcSigFun -- Search for a particular signature
-lookupSig sigs = lookupNameEnv env
+pprHsSigCtxt :: UserTypeCtxt -> LHsType Name -> SDoc
+pprHsSigCtxt ctxt hs_ty = vcat [ ptext SLIT("In") <+> pprUserTypeCtxt ctxt <> colon,
+ nest 2 (pp_sig ctxt) ]
where
- env = mkNameEnv [(idName (sig_id sig), sig) | sig <- sigs]
+ pp_sig (FunSigCtxt n) = pp_n_colon n
+ pp_sig (ConArgCtxt n) = pp_n_colon n
+ pp_sig (ForSigCtxt n) = pp_n_colon n
+ pp_sig (RuleSigCtxt n) = pp_n_colon n
+ pp_sig other = ppr (unLoc hs_ty)
+
+ pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty)
+
+
+wobblyPatSig sig_tvs
+ = hang (ptext SLIT("A pattern type signature cannot bind scoped type variables")
+ <+> pprQuotedList sig_tvs)
+ 2 (ptext SLIT("unless the pattern has a rigid type context"))
+
+scopedNonVar n ty
+ = vcat [sep [ptext SLIT("The scoped type variable") <+> quotes (ppr n),
+ nest 2 (ptext SLIT("is bound to the type") <+> quotes (ppr ty))],
+ nest 2 (ptext SLIT("You can only bind scoped type variables to type variables"))]
+
+dupInScope n n' ty
+ = hang (ptext SLIT("The scoped type variables") <+> quotes (ppr n) <+> ptext SLIT("and") <+> quotes (ppr n'))
+ 2 (vcat [ptext SLIT("are bound to the same type (variable)"),
+ ptext SLIT("Distinct scoped type variables must be distinct")])
\end{code}
--------------------------------
-- Creating new mutable type variables
newFlexiTyVar,
- newTyFlexiVarTy, -- Kind -> TcM TcType
- newTyFlexiVarTys, -- Int -> Kind -> TcM [TcType]
+ newFlexiTyVarTy, -- Kind -> TcM TcType
+ newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType]
newKindVar, newKindVars,
- lookupTcTyVar, condLookupTcTyVar, LookupTyVarResult(..),
- newMetaTyVar, readMetaTyVar, writeMetaTyVar, putMetaTyVar,
+ lookupTcTyVar, LookupTyVarResult(..),
+ newMetaTyVar, readMetaTyVar, writeMetaTyVar,
+
+ --------------------------------
+ -- Boxy type variables
+ newBoxyTyVar, newBoxyTyVars, readFilledBox,
--------------------------------
-- Instantiation
- tcInstTyVar, tcInstTyVars, tcInstType,
- tcSkolType, tcSkolTyVars, tcInstSigType,
+ tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxy, tcInstBoxyTyVar,
+ tcInstSigTyVars, zonkSigTyVar,
+ tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType,
tcSkolSigType, tcSkolSigTyVars,
--------------------------------
-- Checking type validity
- Rank, UserTypeCtxt(..), checkValidType, pprHsSigCtxt,
+ Rank, UserTypeCtxt(..), checkValidType,
SourceTyCtxt(..), checkValidTheta, checkFreeness,
checkValidInstHead, instTypeErr, checkAmbiguity,
arityErr,
-- friends:
-import HsSyn ( LHsType )
import TypeRep ( Type(..), PredType(..), -- Friend; can see representation
ThetaType
)
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..),
- MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef,
- tcCmpPred, tcEqType, isClassPred,
+ MetaDetails(..), SkolemInfo(..), BoxInfo(..),
+ BoxyTyVar, BoxyThetaType, BoxySigmaType,
+ UserTypeCtxt(..),
+ isMetaTyVar, isSigTyVar, metaTvRef,
+ tcCmpPred, isClassPred, tcEqType, tcGetTyVar,
tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
tcValidInstHeadTy, tcSplitForAllTys,
tcIsTyVarTy, tcSplitSigmaTy,
- isUnLiftedType, isIPPred, isImmutableTyVar,
- typeKind, isFlexi, isSkolemTyVar,
+ isUnLiftedType, isIPPred,
+ typeKind, isSkolemTyVar,
mkAppTy, mkTyVarTy, mkTyVarTys,
tyVarsOfPred, getClassPredTys_maybe,
tyVarsOfType, tyVarsOfTypes, tcView,
pprPred, pprTheta, pprClassPred )
-import Kind ( Kind(..), KindVar, kindVarRef, mkKindVar, isSubKind,
+import Kind ( Kind(..), KindVar, kindVarRef, mkKindVar,
isLiftedTypeKind, isArgTypeKind, isOpenTypeKind,
- liftedTypeKind, defaultKind
+ liftedTypeKind, openTypeKind, defaultKind
)
import Type ( TvSubst, zipTopTvSubst, substTy )
import Class ( Class, classArity, className )
import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
tyConArity, tyConName )
-import Var ( TyVar, tyVarKind, tyVarName,
- mkTyVar, mkTcTyVar, tcTyVarDetails, isTcTyVar )
+import Var ( TyVar, tyVarKind, tyVarName, isTcTyVar,
+ mkTyVar, mkTcTyVar, tcTyVarDetails )
+
+ -- Assertions
+#ifdef DEBUG
+import TcType ( isFlexi, isBoxyTyVar, isImmutableTyVar )
+import Kind ( isSubKind )
+#endif
-- others:
import TcRnMonad -- TcType, amongst others
import FunDeps ( grow )
import Name ( Name, setNameUnique, mkSysTvName )
import VarSet
-import VarEnv
import DynFlags ( dopt, DynFlag(..) )
-import UniqSupply ( uniqsFromSupply )
import Util ( nOfThem, isSingleton, notNull )
import ListSetOps ( removeDups, findDupsEq )
-import SrcLoc ( unLoc )
import Outputable
\end{code}
%************************************************************************
%* *
-\subsection{New type variables}
+ Instantiation in general
%* *
%************************************************************************
\begin{code}
-newMetaTyVar :: Name -> Kind -> MetaDetails -> TcM TyVar
-newMetaTyVar name kind details
- = do { ref <- newMutVar details ;
- return (mkTcTyVar name kind (MetaTv ref)) }
+tcInstType :: ([TyVar] -> TcM [TcTyVar]) -- How to instantiate the type variables
+ -> TcType -- Type to instantiate
+ -> TcM ([TcTyVar], TcThetaType, TcType) -- Result
+tcInstType inst_tyvars ty
+ = case tcSplitForAllTys ty of
+ ([], rho) -> let -- There may be overloading despite no type variables;
+ -- (?x :: Int) => Int -> Int
+ (theta, tau) = tcSplitPhiTy rho
+ in
+ return ([], theta, tau)
-readMetaTyVar :: TyVar -> TcM MetaDetails
-readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
- readMutVar (metaTvRef tyvar)
+ (tyvars, rho) -> do { tyvars' <- inst_tyvars tyvars
-writeMetaTyVar :: TyVar -> MetaDetails -> TcM ()
-writeMetaTyVar tyvar val = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
- writeMutVar (metaTvRef tyvar) val
+ ; let tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars')
+ -- Either the tyvars are freshly made, by inst_tyvars,
+ -- or (in the call from tcSkolSigType) any nested foralls
+ -- have different binders. Either way, zipTopTvSubst is ok
-newFlexiTyVar :: Kind -> TcM TcTyVar
-newFlexiTyVar kind
- = newUnique `thenM` \ uniq ->
- newMetaTyVar (mkSysTvName uniq FSLIT("t")) kind Flexi
+ ; let (theta, tau) = tcSplitPhiTy (substTy tenv rho)
+ ; return (tyvars', theta, tau) }
+\end{code}
-newTyFlexiVarTy :: Kind -> TcM TcType
-newTyFlexiVarTy kind
- = newFlexiTyVar kind `thenM` \ tc_tyvar ->
- returnM (TyVarTy tc_tyvar)
-newTyFlexiVarTys :: Int -> Kind -> TcM [TcType]
-newTyFlexiVarTys n kind = mappM newTyFlexiVarTy (nOfThem n kind)
+%************************************************************************
+%* *
+ Kind variables
+%* *
+%************************************************************************
+\begin{code}
newKindVar :: TcM TcKind
newKindVar = do { uniq <- newUnique
; ref <- newMutVar Nothing
%************************************************************************
%* *
-\subsection{Type instantiation}
+ SkolemTvs (immutable)
%* *
%************************************************************************
-Instantiating a bunch of type variables
-
-Note [TyVarName]
-~~~~~~~~~~~~~~~~
-Note that we don't change the print-name
-This won't confuse the type checker but there's a chance
-that two different tyvars will print the same way
-in an error message. -dppr-debug will show up the difference
-Better watch out for this. If worst comes to worst, just
-use mkSystemName.
-
-
\begin{code}
------------------------
-tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst)
-tcInstTyVars tyvars
- = do { tc_tvs <- mappM tcInstTyVar tyvars
- ; let tys = mkTyVarTys tc_tvs
- ; returnM (tc_tvs, tys, zipTopTvSubst tyvars tys) }
- -- Since the tyvars are freshly made,
- -- they cannot possibly be captured by
- -- any existing for-alls. Hence zipTopTvSubst
-
-tcInstTyVar tyvar -- Freshen the Name of the tyvar
- = do { uniq <- newUnique
- ; newMetaTyVar (setNameUnique (tyVarName tyvar) uniq)
- (tyVarKind tyvar) Flexi }
-
-tcInstType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType)
--- tcInstType instantiates the outer-level for-alls of a TcType with
--- fresh (mutable) type variables, splits off the dictionary part,
--- and returns the pieces.
-tcInstType ty = tc_inst_type (mappM tcInstTyVar) ty
-
-
----------------------------------------------
-tcInstSigType :: Name -> [Name] -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
--- Instantiate a type with fresh SigSkol variables
--- See Note [Signature skolems] in TcType.
---
--- Tne new type variables have the sane Name as the original *iff* they are scoped.
--- For scoped tyvars, we don't need a fresh unique, because the renamer has made them
--- unique, and it's better not to do so because we extend the envt
--- with them as scoped type variables, and we'd like to avoid spurious
--- 's = s' bindings in error messages
---
--- For non-scoped ones, we *must* instantiate fresh ones:
---
--- type T = forall a. [a] -> [a]
--- f :: T;
--- f = g where { g :: T; g = <rhs> }
---
--- We must not use the same 'a' from the defn of T at both places!!
-
-tcInstSigType id_name scoped_names ty = tc_inst_type (tcInstSigTyVars id_name scoped_names) ty
-
-tcInstSigTyVars :: Name -> [Name] -> [TyVar] -> TcM [TcTyVar]
-tcInstSigTyVars id_name scoped_names tyvars
- = mapM new_tv tyvars
- where
- new_tv tv
- = do { let name = tyVarName tv
- ; ref <- newMutVar Flexi
- ; name' <- if name `elem` scoped_names
- then return name
- else do { uniq <- newUnique; return (setNameUnique name uniq) }
- ; return (mkTcTyVar name' (tyVarKind tv)
- (SigSkolTv id_name ref)) }
-
-
----------------------------------------------
-tcSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
--- Instantiate a type with fresh skolem constants
-tcSkolType info ty = tc_inst_type (tcSkolTyVars info) ty
-
-tcSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
-tcSkolTyVars info tyvars
- = do { us <- newUniqueSupply
- ; return (zipWith skol_tv tyvars (uniqsFromSupply us)) }
- where
- skol_tv tv uniq = mkTcTyVar (setNameUnique (tyVarName tv) uniq)
- (tyVarKind tv) (SkolemTv info)
- -- See Note [TyVarName]
-
+mkSkolTyVar :: Name -> Kind -> SkolemInfo -> TcTyVar
+mkSkolTyVar name kind info = mkTcTyVar name kind (SkolemTv info)
----------------------------------------------
tcSkolSigType :: SkolemInfo -> Type -> TcM ([TcTyVar], TcThetaType, TcType)
-- Instantiate a type signature with skolem constants, but
-- do *not* give them fresh names, because we want the name to
-- be in the type environment -- it is lexically scoped.
-tcSkolSigType info ty
- = tc_inst_type (\tvs -> return (tcSkolSigTyVars info tvs)) ty
+tcSkolSigType info ty = tcInstType (\tvs -> return (tcSkolSigTyVars info tvs)) ty
tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar]
-tcSkolSigTyVars info tyvars = [ mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv info)
+-- Make skolem constants, but do *not* give them new names, as above
+tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info
| tv <- tyvars ]
------------------------
-tc_inst_type :: ([TyVar] -> TcM [TcTyVar]) -- How to instantiate the type variables
- -> TcType -- Type to instantiate
- -> TcM ([TcTyVar], TcThetaType, TcType) -- Result
-tc_inst_type inst_tyvars ty
- = case tcSplitForAllTys ty of
- ([], rho) -> let -- There may be overloading despite no type variables;
- -- (?x :: Int) => Int -> Int
- (theta, tau) = tcSplitPhiTy rho
- in
- return ([], theta, tau)
-
- (tyvars, rho) -> do { tyvars' <- inst_tyvars tyvars
+tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
+-- Instantiate a type with fresh skolem constants
+tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty
- ; let tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars')
- -- Either the tyvars are freshly made, by inst_tyvars,
- -- or (in the call from tcSkolSigType) any nested foralls
- -- have different binders. Either way, zipTopTvSubst is ok
+tcInstSkolTyVar :: SkolemInfo -> TyVar -> TcM TcTyVar
+tcInstSkolTyVar info tyvar
+ = do { uniq <- newUnique
+ ; let name = setNameUnique (tyVarName tyvar) uniq
+ kind = tyVarKind tyvar
+ ; return (mkSkolTyVar name kind info) }
- ; let (theta, tau) = tcSplitPhiTy (substTy tenv rho)
- ; return (tyvars', theta, tau) }
+tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
+tcInstSkolTyVars info tyvars = mapM (tcInstSkolTyVar info) tyvars
\end{code}
%************************************************************************
%* *
-\subsection{Putting and getting mutable type variables}
+ MetaTvs (meta type variables; mutable)
%* *
%************************************************************************
\begin{code}
-putMetaTyVar :: TcTyVar -> TcType -> TcM ()
+newMetaTyVar :: BoxInfo -> Kind -> TcM TcTyVar
+-- Make a new meta tyvar out of thin air
+newMetaTyVar box_info kind
+ = do { uniq <- newUnique
+ ; ref <- newMutVar Flexi ;
+ ; let name = mkSysTvName uniq fs
+ fs = case box_info of
+ BoxTv -> FSLIT("bx")
+ TauTv -> FSLIT("t")
+ SigTv _ -> FSLIT("a")
+ ; return (mkTcTyVar name kind (MetaTv box_info ref)) }
+
+instMetaTyVar :: BoxInfo -> TyVar -> TcM TcTyVar
+-- Make a new meta tyvar whose Name and Kind
+-- come from an existing TyVar
+instMetaTyVar box_info tyvar
+ = do { uniq <- newUnique
+ ; ref <- newMutVar Flexi ;
+ ; let name = setNameUnique (tyVarName tyvar) uniq
+ kind = tyVarKind tyvar
+ ; return (mkTcTyVar name kind (MetaTv box_info ref)) }
+
+readMetaTyVar :: TyVar -> TcM MetaDetails
+readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
+ readMutVar (metaTvRef tyvar)
+
+writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
#ifndef DEBUG
-putMetaTyVar tyvar ty = writeMetaTyVar tyvar (Indirect ty)
+writeMetaTyVar tyvar ty = writeMutVar (metaTvRef tyvar) (Indirect ty)
#else
-putMetaTyVar tyvar ty
+writeMetaTyVar tyvar ty
| not (isMetaTyVar tyvar)
- = pprTrace "putTcTyVar" (ppr tyvar) $
+ = pprTrace "writeMetaTyVar" (ppr tyvar) $
returnM ()
| otherwise
= ASSERT( isMetaTyVar tyvar )
ASSERT2( k2 `isSubKind` k1, (ppr tyvar <+> ppr k1) $$ (ppr ty <+> ppr k2) )
- do { ASSERTM( do { details <- readMetaTyVar tyvar; return (isFlexi details) } )
- ; writeMetaTyVar tyvar (Indirect ty) }
+ do { ASSERTM2( do { details <- readMetaTyVar tyvar; return (isFlexi details) }, ppr tyvar )
+ ; writeMutVar (metaTvRef tyvar) (Indirect ty) }
where
k1 = tyVarKind tyvar
k2 = typeKind ty
#endif
\end{code}
+
+%************************************************************************
+%* *
+ MetaTvs: TauTvs
+%* *
+%************************************************************************
+
+\begin{code}
+newFlexiTyVar :: Kind -> TcM TcTyVar
+newFlexiTyVar kind = newMetaTyVar TauTv kind
+
+newFlexiTyVarTy :: Kind -> TcM TcType
+newFlexiTyVarTy kind
+ = newFlexiTyVar kind `thenM` \ tc_tyvar ->
+ returnM (TyVarTy tc_tyvar)
+
+newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
+newFlexiTyVarTys n kind = mappM newFlexiTyVarTy (nOfThem n kind)
+
+tcInstTyVar :: TyVar -> TcM TcTyVar
+-- Instantiate with a META type variable
+tcInstTyVar tyvar = instMetaTyVar TauTv tyvar
+
+tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst)
+-- Instantiate with META type variables
+tcInstTyVars tyvars
+ = do { tc_tvs <- mapM tcInstTyVar tyvars
+ ; let tys = mkTyVarTys tc_tvs
+ ; returnM (tc_tvs, tys, zipTopTvSubst tyvars tys) }
+ -- Since the tyvars are freshly made,
+ -- they cannot possibly be captured by
+ -- any existing for-alls. Hence zipTopTvSubst
+\end{code}
+
+
+%************************************************************************
+%* *
+ MetaTvs: SigTvs
+%* *
+%************************************************************************
+
+\begin{code}
+tcInstSigTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
+-- Instantiate with meta SigTvs
+tcInstSigTyVars skol_info tyvars
+ = mapM (instMetaTyVar (SigTv skol_info)) tyvars
+
+zonkSigTyVar :: TcTyVar -> TcM TcTyVar
+zonkSigTyVar sig_tv
+ | isSkolemTyVar sig_tv
+ = return sig_tv -- Happens in the call in TcBinds.checkDistinctTyVars
+ | otherwise
+ = ASSERT( isSigTyVar sig_tv )
+ do { ty <- zonkTcTyVar sig_tv
+ ; return (tcGetTyVar "zonkSigTyVar" ty) }
+ -- 'ty' is bound to be a type variable, because SigTvs
+ -- can only be unified with type variables
+\end{code}
+
+
+%************************************************************************
+%* *
+ MetaTvs: BoxTvs
+%* *
+%************************************************************************
+
+\begin{code}
+newBoxyTyVar :: TcM BoxyTyVar -- Of openTypeKind
+newBoxyTyVar = newMetaTyVar BoxTv openTypeKind
+
+newBoxyTyVars :: Int -> TcM [BoxyTyVar] -- Of openTypeKind
+newBoxyTyVars n = sequenceM [newMetaTyVar BoxTv openTypeKind | i <- [1..n]]
+
+readFilledBox :: BoxyTyVar -> TcM TcType
+-- Read the contents of the box, which should be filled in by now
+readFilledBox box_tv = ASSERT( isBoxyTyVar box_tv )
+ do { cts <- readMetaTyVar box_tv
+ ; case cts of
+ Flexi -> pprPanic "readFilledBox" (ppr box_tv)
+ Indirect ty -> return ty }
+
+tcInstBoxyTyVar :: TyVar -> TcM BoxyTyVar
+-- Instantiate with a BOXY type variable
+tcInstBoxyTyVar tyvar = instMetaTyVar BoxTv tyvar
+
+tcInstBoxy :: TcType -> TcM ([BoxyTyVar], BoxyThetaType, BoxySigmaType)
+-- tcInstType instantiates the outer-level for-alls of a TcType with
+-- fresh BOXY type variables, splits off the dictionary part,
+-- and returns the pieces.
+tcInstBoxy ty = tcInstType (mapM tcInstBoxyTyVar) ty
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Putting and getting mutable type variables}
+%* *
+%************************************************************************
+
But it's more fun to short out indirections on the way: If this
version returns a TyVar, then that TyVar is unbound. If it returns
any other type, then there might be bound TyVars embedded inside it.
\begin{code}
data LookupTyVarResult -- The result of a lookupTcTyVar call
- = DoneTv TcTyVarDetails -- Unrefined SkolemTv or virgin MetaTv/SigSkolTv
- | IndirectTv Bool TcType
- -- True => This is a non-wobbly type refinement,
- -- gotten from GADT match unification
- -- False => This is a wobbly type,
- -- gotten from inference unification
+ = DoneTv TcTyVarDetails -- SkolemTv or virgin MetaTv
+ | IndirectTv TcType
lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult
--- This function is the ONLY PLACE that we consult the
--- type refinement carried by the monad
lookupTcTyVar tyvar
- = let
- details = tcTyVarDetails tyvar
- in
- case details of
- MetaTv ref -> lookup_wobbly details ref
-
- SkolemTv _ -> do { type_reft <- getTypeRefinement
- ; case lookupVarEnv type_reft tyvar of
- Just ty -> return (IndirectTv True ty)
- Nothing -> return (DoneTv details)
- }
-
- -- For SigSkolTvs try the refinement, and, failing that
- -- see if it's been unified to anything. It's a combination
- -- of SkolemTv and MetaTv
- SigSkolTv _ ref -> do { type_reft <- getTypeRefinement
- ; case lookupVarEnv type_reft tyvar of
- Just ty -> return (IndirectTv True ty)
- Nothing -> lookup_wobbly details ref
- }
-
--- Look up a meta type variable, conditionally consulting
--- the current type refinement
-condLookupTcTyVar :: Bool -> TcTyVar -> TcM LookupTyVarResult
-condLookupTcTyVar use_refinement tyvar
- | use_refinement = lookupTcTyVar tyvar
- | otherwise
= case details of
- MetaTv ref -> lookup_wobbly details ref
- SkolemTv _ -> return (DoneTv details)
- SigSkolTv _ ref -> lookup_wobbly details ref
- where
- details = tcTyVarDetails tyvar
-
-lookup_wobbly :: TcTyVarDetails -> IORef MetaDetails -> TcM LookupTyVarResult
-lookup_wobbly details ref
- = do { meta_details <- readMutVar ref
- ; case meta_details of
- Indirect ty -> return (IndirectTv False ty)
- Flexi -> return (DoneTv details)
- }
+ SkolemTv _ -> return (DoneTv details)
+ MetaTv _ ref -> do { meta_details <- readMutVar ref
+ ; case meta_details of
+ Indirect ty -> return (IndirectTv ty)
+ Flexi -> return (DoneTv details) }
+ where
+ details = tcTyVarDetails tyvar
{-
-- gaw 2004 We aren't shorting anything out anymore, at least for now
returnM (tyVarsOfTypes tys)
zonkTcTyVar :: TcTyVar -> TcM TcType
-zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnM (TyVarTy tv)) True tyvar
+zonkTcTyVar tyvar = ASSERT( isTcTyVar tyvar )
+ zonk_tc_tyvar (\ tv -> returnM (TyVarTy tv)) tyvar
\end{code}
----------------- Types
\begin{code}
zonkTcType :: TcType -> TcM TcType
-zonkTcType ty = zonkType (\ tv -> returnM (TyVarTy tv)) True ty
+zonkTcType ty = zonkType (\ tv -> returnM (TyVarTy tv)) ty
zonkTcTypes :: [TcType] -> TcM [TcType]
zonkTcTypes tys = mappM zonkTcType tys
-- [Sept 04] I don't think this should happen
-- See note [Silly Type Synonym]
- other -> writeMetaTyVar tv (Indirect (mkTyVarTy final_tv))
+ Flexi -> writeMetaTyVar tv (mkTyVarTy final_tv)
-- Return the new tyvar
; return final_tv }
where a is fresh.
* Now abstract over the 'a', but float out the Num (C d a) constraint
- because it does not 'really' mention a. (see Type.tyVarsOfType)
+ because it does not 'really' mention a. (see exactTyVarsOfType)
The arg to foo becomes
/\a -> \t -> t+t
zonkType :: (TcTyVar -> TcM Type) -- What to do with unbound mutable type variables
-- see zonkTcType, and zonkTcTypeToType
- -> Bool -- Should we consult the current type refinement?
-> TcType
-> TcM Type
-zonkType unbound_var_fn rflag ty
+zonkType unbound_var_fn ty
= go ty
where
- go (TyConApp tycon tys) = mappM go tys `thenM` \ tys' ->
- returnM (TyConApp tycon tys')
-
- go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
-
- go (PredTy p) = go_pred p `thenM` \ p' ->
- returnM (PredTy p')
-
- go (FunTy arg res) = go arg `thenM` \ arg' ->
- go res `thenM` \ res' ->
- returnM (FunTy arg' res')
-
- go (AppTy fun arg) = go fun `thenM` \ fun' ->
- go arg `thenM` \ arg' ->
- returnM (mkAppTy fun' arg')
+ go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
+
+ go (TyConApp tc tys) = mappM go tys `thenM` \ tys' ->
+ returnM (TyConApp tc tys')
+
+ go (PredTy p) = go_pred p `thenM` \ p' ->
+ returnM (PredTy p')
+
+ go (FunTy arg res) = go arg `thenM` \ arg' ->
+ go res `thenM` \ res' ->
+ returnM (FunTy arg' res')
+
+ go (AppTy fun arg) = go fun `thenM` \ fun' ->
+ go arg `thenM` \ arg' ->
+ returnM (mkAppTy fun' arg')
-- NB the mkAppTy; we might have instantiated a
-- type variable to a type constructor, so we need
-- to pull the TyConApp to the top.
-- The two interesting cases!
- go (TyVarTy tyvar) = zonkTyVar unbound_var_fn rflag tyvar
+ go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar unbound_var_fn tyvar
+ | otherwise = return (TyVarTy tyvar)
+ -- Ordinary (non Tc) tyvars occur inside quantified types
go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar )
go ty `thenM` \ ty' ->
go_pred (IParam n ty) = go ty `thenM` \ ty' ->
returnM (IParam n ty')
-zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable variable
- -> Bool -- Consult the type refinement?
- -> TcTyVar -> TcM TcType
-zonkTyVar unbound_var_fn rflag tyvar
- | not (isTcTyVar tyvar) -- When zonking (forall a. ...a...), the occurrences of
- -- the quantified variable 'a' are TyVars not TcTyVars
+zonk_tc_tyvar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable variable
+ -> TcTyVar -> TcM TcType
+zonk_tc_tyvar unbound_var_fn tyvar
+ | not (isMetaTyVar tyvar) -- Skolems
= returnM (TyVarTy tyvar)
- | otherwise
- = condLookupTcTyVar rflag tyvar `thenM` \ details ->
- case details of
- -- If b is true, the variable was refined, and therefore it is okay
- -- to continue refining inside. Otherwise it was wobbly and we should
- -- not refine further inside.
- IndirectTv b ty -> zonkType unbound_var_fn b ty -- Bound flexi/refined rigid
- DoneTv (MetaTv _) -> unbound_var_fn tyvar -- Unbound meta type variable
- DoneTv other -> return (TyVarTy tyvar) -- Rigid, no zonking necessary
+ | otherwise -- Mutables
+ = do { cts <- readMetaTyVar tyvar
+ ; case cts of
+ Flexi -> unbound_var_fn tyvar -- Unbound meta type variable
+ Indirect ty -> zonkType unbound_var_fn ty }
\end{code}
\begin{code}
-data UserTypeCtxt
- = FunSigCtxt Name -- Function type signature
- -- Also used for types in SPECIALISE pragmas
- | ExprSigCtxt -- Expression type signature
- | ConArgCtxt Name -- Data constructor argument
- | TySynCtxt Name -- RHS of a type synonym decl
- | GenPatCtxt -- Pattern in generic decl
- -- f{| a+b |} (Inl x) = ...
- | PatSigCtxt -- Type sig in pattern
- -- f (x::t) = ...
- | ResSigCtxt -- Result type sig
- -- f x :: t = ....
- | ForSigCtxt Name -- Foreign inport or export signature
- | RuleSigCtxt Name -- Signature on a forall'd variable in a RULE
- | DefaultDeclCtxt -- Types in a default declaration
- | SpecInstCtxt -- SPECIALISE instance pragma
-
--- Notes re TySynCtxt
--- We allow type synonyms that aren't types; e.g. type List = []
---
--- If the RHS mentions tyvars that aren't in scope, we'll
--- quantify over them:
--- e.g. type T = a->a
--- will become type T = forall a. a->a
---
--- With gla-exts that's right, but for H98 we should complain.
-
-
-pprHsSigCtxt :: UserTypeCtxt -> LHsType Name -> SDoc
-pprHsSigCtxt ctxt hs_ty = pprUserTypeCtxt (unLoc hs_ty) ctxt
-
-pprUserTypeCtxt ty (FunSigCtxt n) = sep [ptext SLIT("In the type signature:"), pp_sig n ty]
-pprUserTypeCtxt ty ExprSigCtxt = sep [ptext SLIT("In an expression type signature:"), nest 2 (ppr ty)]
-pprUserTypeCtxt ty (ConArgCtxt c) = sep [ptext SLIT("In the type of the constructor"), pp_sig c ty]
-pprUserTypeCtxt ty (TySynCtxt c) = sep [ptext SLIT("In the RHS of the type synonym") <+> quotes (ppr c) <> comma,
- nest 2 (ptext SLIT(", namely") <+> ppr ty)]
-pprUserTypeCtxt ty GenPatCtxt = sep [ptext SLIT("In the type pattern of a generic definition:"), nest 2 (ppr ty)]
-pprUserTypeCtxt ty PatSigCtxt = sep [ptext SLIT("In a pattern type signature:"), nest 2 (ppr ty)]
-pprUserTypeCtxt ty ResSigCtxt = sep [ptext SLIT("In a result type signature:"), nest 2 (ppr ty)]
-pprUserTypeCtxt ty (ForSigCtxt n) = sep [ptext SLIT("In the foreign declaration:"), pp_sig n ty]
-pprUserTypeCtxt ty (RuleSigCtxt n) = sep [ptext SLIT("In the type signature:"), pp_sig n ty]
-pprUserTypeCtxt ty DefaultDeclCtxt = sep [ptext SLIT("In a type in a `default' declaration:"), nest 2 (ppr ty)]
-pprUserTypeCtxt ty SpecInstCtxt = sep [ptext SLIT("In a SPECIALISE instance pragma:"), nest 2 (ppr ty)]
-
-pp_sig n ty = nest 2 (ppr n <+> dcolon <+> ppr ty)
-\end{code}
-
-\begin{code}
checkValidType :: UserTypeCtxt -> Type -> TcM ()
-- Checks that the type is valid for the given context
checkValidType ctxt ty
| otherwise
= case ctxt of -- Haskell 98
GenPatCtxt -> Rank 0
- PatSigCtxt -> Rank 0
+ LamPatSigCtxt -> Rank 0
+ BindPatSigCtxt -> Rank 0
DefaultDeclCtxt-> Rank 0
ResSigCtxt -> Rank 0
TySynCtxt _ -> Rank 0
check_arg_type :: Type -> TcM ()
-- The sort of type that can instantiate a type variable,
-- or be the argument of a type constructor.
--- Not an unboxed tuple, not a forall.
+-- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
-- Other unboxed types are very occasionally allowed as type
-- arguments depending on the kind of the type constructor
--
-- Anyway, they are dealt with by a special case in check_tau_type
check_arg_type ty
- = check_tau_type (Rank 0) UT_NotOk ty `thenM_`
+ = check_poly_type Arbitrary UT_NotOk ty `thenM_`
checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty)
----------------------------------------
check_tau_type rank ubx_tup (TyVarTy _) = returnM ()
check_tau_type rank ubx_tup ty@(FunTy arg_ty res_ty)
= check_poly_type rank UT_NotOk arg_ty `thenM_`
- check_tau_type rank UT_Ok res_ty
+ check_poly_type rank UT_Ok res_ty
check_tau_type rank ubx_tup (AppTy ty1 ty2)
= check_arg_type ty1 `thenM_` check_arg_type ty2
check_tau_type rank ubx_tup ty@(TyConApp tc tys)
| isSynTyCon tc
- = -- NB: Type.mkSynTy builds a TyConApp (not a NoteTy) for an unsaturated
- -- synonym application, leaving it to checkValidType (i.e. right here)
- -- to find the error
- do { -- It's OK to have an *over-applied* type synonym
+ = do { -- It's OK to have an *over-applied* type synonym
-- data Tree a b = ...
-- type Foo a = Tree [a]
-- f :: Foo a b -> ...
check_valid_theta ctxt theta
= getDOpts `thenM` \ dflags ->
warnTc (notNull dups) (dupPredWarn dups) `thenM_`
- -- Actually, in instance decls and type signatures,
- -- duplicate constraints are eliminated by TcHsType.hoistForAllTys,
- -- so this error can only fire for the context of a class or
- -- data type decl.
mappM_ (check_source_ty dflags ctxt) theta
where
(_,dups) = removeDups tcCmpPred theta
\begin{code}
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
- tcMatchPats, matchCtxt, TcMatchCtxt(..),
+ matchCtxt, TcMatchCtxt(..),
tcStmts, tcDoStmts,
- tcDoStmt, tcMDoStmt, tcGuardStmt,
- tcThingWithSig
+ tcDoStmt, tcMDoStmt, tcGuardStmt
) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcCheckRho, tcInferRho, tcMonoExpr, tcCheckSigma )
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..),
Match(..), LMatch, GRHSs(..), GRHS(..),
Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
- LPat, pprMatch, isIrrefutableHsPat,
- pprMatchContext, pprStmtContext, pprMatchRhsContext,
- collectPatsBinders, noSyntaxExpr
- )
-import TcHsSyn ( ExprCoFn, isIdCoercion, (<$>), (<.>) )
+ pprMatch, isIrrefutableHsPat,
+ pprMatchContext, pprStmtContext,
+ noSyntaxExpr, matchGroupArity, pprMatches,
+ ExprCoFn )
import TcRnMonad
-import TcHsType ( tcHsPatSigType, UserTypeCtxt(..) )
-import Inst ( tcInstCall, newMethodFromName )
+import TcHsType ( tcPatSig, UserTypeCtxt(..) )
+import Inst ( newMethodFromName )
import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv,
- tcExtendTyVarEnv )
-import TcPat ( PatCtxt(..), tcPats )
-import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, zonkTcType )
-import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, mkFunTys,
- tyVarsOfTypes, tidyOpenTypes, isSigmaTy,
- liftedTypeKind, openTypeKind, mkFunTy, mkAppTy )
+ tcExtendTyVarEnv2 )
+import TcPat ( PatCtxt(..), tcPats, tcPat )
+import TcMType ( newFlexiTyVarTy, newFlexiTyVarTys )
+import TcType ( TcType, TcRhoType,
+ BoxySigmaType, BoxyRhoType,
+ mkFunTys, mkFunTy, mkAppTy, mkTyConApp,
+ liftedTypeKind )
import TcBinds ( tcLocalBinds )
-import TcUnify ( Expected(..), zapExpectedType, readExpectedType,
- unifyTauTy, subFunTys, unifyTyConApp,
- checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen,
- unifyAppTy, zapToListTy, zapToTyConApp )
+import TcUnify ( boxySplitAppTy, boxySplitTyConApp, boxySplitListTy,
+ subFunTys, tcSubExp, withBox )
import TcSimplify ( bindInstsOfLocalFuns )
import Name ( Name )
import TysWiredIn ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
import PrelNames ( bindMName, returnMName, mfixName, thenMName, failMName )
import Id ( idType, mkLocalId )
import TyCon ( TyCon )
-import CoreFVs ( idFreeTyVars )
-import VarSet
import Util ( isSingleton )
import Outputable
import SrcLoc ( Located(..) )
+import ErrUtils ( Message )
import List ( nub )
\end{code}
\begin{code}
tcMatchesFun :: Name
-> MatchGroup Name
- -> Expected TcRhoType -- Expected type of function
- -> TcM (MatchGroup TcId) -- Returns type of body
+ -> BoxyRhoType -- Expected type of function
+ -> TcM (ExprCoFn, MatchGroup TcId) -- Returns type of body
tcMatchesFun fun_name matches exp_ty
= do { -- Check that they all have the same no of arguments
-- This is one of two places places we call subFunTys
-- The point is that if expected_y is a "hole", we want
-- to make pat_tys and rhs_ty as "holes" too.
- ; exp_ty' <- zapExpectedBranches matches exp_ty
- ; subFunTys ctxt matches exp_ty' $ \ pat_tys rhs_ty ->
+ ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty matches
}
where
- ctxt = FunRhs fun_name
- match_ctxt = MC { mc_what = ctxt, mc_body = tcMonoExpr }
+ doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
+ <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
+ n_pats = matchGroupArity matches
+ match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcPolyExpr }
\end{code}
@tcMatchesCase@ doesn't do the argument-count check because the
tcMatchesCase :: TcMatchCtxt -- Case context
-> TcRhoType -- Type of scrutinee
-> MatchGroup Name -- The case alternatives
- -> Expected TcRhoType -- Type of whole case expressions
+ -> BoxyRhoType -- Type of whole case expressions
-> TcM (MatchGroup TcId) -- Translated alternatives
-tcMatchesCase ctxt scrut_ty matches exp_ty
- = do { exp_ty' <- zapExpectedBranches matches exp_ty
- ; tcMatches ctxt [Check scrut_ty] exp_ty' matches }
+tcMatchesCase ctxt scrut_ty matches res_ty
+ = tcMatches ctxt [scrut_ty] res_ty matches
-tcMatchLambda :: MatchGroup Name -> Expected TcRhoType -> TcM (MatchGroup TcId)
-tcMatchLambda match exp_ty -- One branch so no unifyBranches needed
- = subFunTys LambdaExpr match exp_ty $ \ pat_tys rhs_ty ->
+tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (ExprCoFn, MatchGroup TcId)
+tcMatchLambda match res_ty
+ = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty match
where
+ n_pats = matchGroupArity match
+ doc = sep [ ptext SLIT("The lambda expression")
+ <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match),
+ -- The pprSetDepth makes the abstraction print briefly
+ ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("arguments"))]
match_ctxt = MC { mc_what = LambdaExpr,
- mc_body = tcMonoExpr }
+ mc_body = tcPolyExpr }
\end{code}
@tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
\begin{code}
-tcGRHSsPat :: GRHSs Name
- -> Expected TcRhoType
- -> TcM (GRHSs TcId)
-tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty
+tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
+tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
where
match_ctxt = MC { mc_what = PatBindRhs,
- mc_body = tcMonoExpr }
+ mc_body = tcPolyExpr }
\end{code}
\begin{code}
tcMatches :: TcMatchCtxt
- -> [Expected TcRhoType] -- Expected pattern types
- -> Expected TcRhoType -- Expected result-type of the Match.
+ -> [BoxySigmaType] -- Expected pattern types
+ -> BoxyRhoType -- Expected result-type of the Match.
-> MatchGroup Name
-> TcM (MatchGroup TcId)
data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
= MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
mc_body :: LHsExpr Name -- Type checker for a body of an alternative
- -> Expected TcRhoType
+ -> BoxyRhoType
-> TcM (LHsExpr TcId) }
tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
= do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
- ; pat_tys' <- mapM readExpectedType pat_tys
- ; rhs_ty' <- readExpectedType rhs_ty
- ; return (MatchGroup matches' (mkFunTys pat_tys' rhs_ty')) }
+ ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
-------------
tcMatch :: TcMatchCtxt
- -> [Expected TcRhoType] -- Expected pattern types
- -> Expected TcRhoType -- Expected result-type of the Match.
+ -> [BoxySigmaType] -- Expected pattern types
+ -> BoxyRhoType -- Expected result-type of the Match.
-> LMatch Name
-> TcM (LMatch TcId)
tcMatch ctxt pat_tys rhs_ty match
= wrapLocM (tc_match ctxt pat_tys rhs_ty) match
+ where
+ tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
+ = addErrCtxt (matchCtxt (mc_what ctxt) match) $
+ do { (pats', grhss') <- tcPats LamPat pats pat_tys rhs_ty $
+ tc_grhss ctxt maybe_rhs_sig grhss
+ ; returnM (Match pats' Nothing grhss') }
-tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
- = addErrCtxt (matchCtxt (mc_what ctxt) match) $
- do { (pats', grhss') <- tcMatchPats pats pat_tys rhs_ty $
- tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
- ; returnM (Match pats' Nothing grhss') }
+ tc_grhss ctxt Nothing grhss rhs_ty
+ = tcGRHSs ctxt grhss rhs_ty -- No result signature
+ tc_grhss ctxt (Just res_sig) grhss rhs_ty
+ = do { (inner_ty, sig_tvs) <- tcPatSig ResSigCtxt res_sig rhs_ty
+ ; tcExtendTyVarEnv2 sig_tvs $
+ tcGRHSs ctxt grhss inner_ty }
-------------
-tc_grhss ctxt Nothing grhss rhs_ty
- = tcGRHSs ctxt grhss rhs_ty -- No result signature
-
-tc_grhss ctxt (Just res_sig) grhss rhs_ty
- = do { (sig_tvs, sig_ty) <- tcHsPatSigType ResSigCtxt res_sig
- ; traceTc (text "tc_grhss" <+> ppr sig_tvs)
- ; (co_fn, grhss') <- tcExtendTyVarEnv sig_tvs $
- tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty
-
- -- Push the coercion down to the right hand sides,
- -- because there is no convenient place to hang it otherwise.
- ; if isIdCoercion co_fn then
- return grhss'
- else
- return (lift_grhss co_fn grhss') }
+tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
--------------
-lift_grhss co_fn (GRHSs grhss binds)
- = GRHSs (map (fmap lift_grhs) grhss) binds
- where
- lift_grhs (GRHS stmts rhs) = GRHS stmts (fmap (co_fn <$>) rhs)
+-- Notice that we pass in the full res_ty, so that we get
+-- good inference from simple things like
+-- f = \(x::forall a.a->a) -> <stuff>
+-- We used to force it to be a monotype when there was more than one guard
+-- but we don't need to do that any more
--------------
-tcGRHSs :: TcMatchCtxt -> GRHSs Name
- -> Expected TcRhoType
- -> TcM (GRHSs TcId)
-
- -- Special case when there is just one equation with a degenerate
- -- guard; then we pass in the full Expected type, so that we get
- -- good inference from simple things like
- -- f = \(x::forall a.a->a) -> <stuff>
- -- This is a consequence of the fact that tcStmts takes a TcType,
- -- not a Expected TcType, a decision we could revisit if necessary
-tcGRHSs ctxt (GRHSs [L loc1 (GRHS [] rhs)] binds) exp_ty
- = do { (binds', rhs') <- tcLocalBinds binds $
- mc_body ctxt rhs exp_ty
- ; returnM (GRHSs [L loc1 (GRHS [] rhs')] binds') }
-
-tcGRHSs ctxt (GRHSs grhss binds) exp_ty
- = do { exp_ty' <- zapExpectedType exp_ty openTypeKind
- -- Even if there is only one guard, we zap the RHS type to
- -- a monotype. Reason: it makes tcStmts much easier,
- -- and even a one-armed guard has a notional second arm
-
- ; (binds', grhss') <- tcLocalBinds binds $
- mappM (wrapLocM (tcGRHS ctxt exp_ty')) grhss
+tcGRHSs ctxt (GRHSs grhss binds) res_ty
+ = do { (binds', grhss') <- tcLocalBinds binds $
+ mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
; returnM (GRHSs grhss' binds') }
-------------
-tcGRHS :: TcMatchCtxt -> TcRhoType
- -> GRHS Name -> TcM (GRHS TcId)
+tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
-tcGRHS ctxt exp_ty' (GRHS guards rhs)
- = do { (guards', rhs') <- tcStmts stmt_ctxt (tcGuardStmt exp_ty') guards $
- addErrCtxt (grhsCtxt match_ctxt rhs) $
- tcCheckRho rhs exp_ty'
+tcGRHS ctxt res_ty (GRHS guards rhs)
+ = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
+ mc_body ctxt rhs
; return (GRHS guards' rhs') }
where
- match_ctxt = mc_what ctxt
- stmt_ctxt = PatGuard match_ctxt
-\end{code}
-
-
-\begin{code}
-tcThingWithSig :: TcSigmaType -- Type signature
- -> (TcRhoType -> TcM r) -- How to type check the thing inside
- -> Expected TcRhoType -- Overall expected result type
- -> TcM (ExprCoFn, r)
--- Used for expressions with a type signature, and for result type signatures
-
-tcThingWithSig sig_ty thing_inside res_ty
- | not (isSigmaTy sig_ty)
- = thing_inside sig_ty `thenM` \ result ->
- tcSubExp res_ty sig_ty `thenM` \ co_fn ->
- returnM (co_fn, result)
-
- | otherwise -- The signature has some outer foralls
- = -- Must instantiate the outer for-alls of sig_tc_ty
- -- else we risk instantiating a ? res_ty to a forall-type
- -- which breaks the invariant that tcMonoExpr only returns phi-types
- tcGen sig_ty emptyVarSet thing_inside `thenM` \ (gen_fn, result) ->
- tcInstCall InstSigOrigin sig_ty `thenM` \ (inst_fn, _, inst_sig_ty) ->
- tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
- returnM (co_fn <.> inst_fn <.> gen_fn, result)
- -- Note that we generalise, then instantiate. Ah well.
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{tcMatchPats}
-%* *
-%************************************************************************
-
-\begin{code}
-tcMatchPats :: [LPat Name]
- -> [Expected TcSigmaType] -- Pattern types
- -> Expected TcRhoType -- Result type;
- -- used only to check existential escape
- -> TcM a
- -> TcM ([LPat TcId], a)
--- Typecheck the patterns, extend the environment to bind the variables,
--- do the thing inside, use any existentially-bound dictionaries to
--- discharge parts of the returning LIE, and deal with pattern type
--- signatures
-
-tcMatchPats pats tys body_ty thing_inside
- = do { (pats', ex_tvs, res) <- tcPats LamPat pats tys thing_inside
- ; tcCheckExistentialPat pats' ex_tvs tys body_ty
- ; returnM (pats', res) }
-
-tcCheckExistentialPat :: [LPat TcId] -- Patterns (just for error message)
- -> [TcTyVar] -- Existentially quantified tyvars bound by pattern
- -> [Expected TcSigmaType] -- Types of the patterns
- -> Expected TcRhoType -- Type of the body of the match
- -- Tyvars in either of these must not escape
- -> TcM ()
- -- NB: we *must* pass "pats_tys" not just "body_ty" to tcCheckExistentialPat
- -- For example, we must reject this program:
- -- data C = forall a. C (a -> Int)
- -- f (C g) x = g x
- -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
-
-tcCheckExistentialPat pats [] pat_tys body_ty
- = return () -- Short cut for case when there are no existentials
-
-tcCheckExistentialPat pats ex_tvs pat_tys body_ty
- = do { tys <- mapM readExpectedType (body_ty : pat_tys)
- ; addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs tys) $
- checkSigTyVarsWrt (tyVarsOfTypes tys) ex_tvs }
+ stmt_ctxt = PatGuard (mc_what ctxt)
\end{code}
tcDoStmts :: HsStmtContext Name
-> [LStmt Name]
-> LHsExpr Name
- -> Expected TcRhoType
+ -> BoxyRhoType
-> TcM (HsExpr TcId) -- Returns a HsDo
tcDoStmts ListComp stmts body res_ty
- = do { elt_ty <- zapToListTy res_ty
- ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon elt_ty) stmts $
- addErrCtxt (doBodyCtxt ListComp body) $
- tcCheckRho body elt_ty
+ = do { elt_ty <- boxySplitListTy res_ty
+ ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty $
+ tcBody (doBodyCtxt ListComp body) body
; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
tcDoStmts PArrComp stmts body res_ty
- = do { [elt_ty] <- zapToTyConApp parrTyCon res_ty
- ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon elt_ty) stmts $
- addErrCtxt (doBodyCtxt PArrComp body) $
- tcCheckRho body elt_ty
+ = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
+ ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty $
+ tcBody (doBodyCtxt PArrComp body) body
; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
tcDoStmts DoExpr stmts body res_ty
- = do { res_ty' <- zapExpectedType res_ty liftedTypeKind
- ; (m_ty, _) <- unifyAppTy res_ty'
- ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty res_ty') stmts $
- addErrCtxt (doBodyCtxt DoExpr body) $
- tcCheckRho body res_ty'
+ = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
+ ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
+ ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts res_ty' $
+ tcBody (doBodyCtxt DoExpr body) body
; return (HsDo DoExpr stmts' body' res_ty') }
-tcDoStmts cxt@(MDoExpr _) stmts body res_ty
- = do { res_ty' <- zapExpectedType res_ty liftedTypeKind
- ; (m_ty, _) <- unifyAppTy res_ty'
- ; let tc_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
- ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
- ; unifyTauTy m_ty n_ty
- ; return (rhs', pat_ty) }
+tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
+ = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
+ ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
+ tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
+ tcMonoExpr rhs (mkAppTy m_ty pat_ty)
- ; (stmts', body') <- tcStmts cxt (tcMDoStmt res_ty' tc_rhs) stmts $
- addErrCtxt (doBodyCtxt cxt body) $
- tcCheckRho body res_ty'
+ ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $
+ tcBody (doBodyCtxt ctxt body) body
; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
; insts <- mapM (newMethodFromName DoOrigin m_ty) names
; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
+
+tcBody :: Message -> LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
+tcBody ctxt body res_ty
+ = -- addErrCtxt ctxt $ -- This context adds little that is useful
+ tcPolyExpr body res_ty
\end{code}
type TcStmtChecker
= forall thing. HsStmtContext Name
-> Stmt Name
- -> TcM thing
+ -> BoxyRhoType -- Result type for comprehension
+ -> (BoxyRhoType -> TcM thing) -- Checker for what follows the stmt
-> TcM (Stmt TcId, thing)
+ -- The incoming BoxyRhoType may be refined by type refinements
+ -- before being passed to the thing_inside
+
tcStmts :: HsStmtContext Name
-> TcStmtChecker -- NB: higher-rank type
-> [LStmt Name]
- -> TcM thing
+ -> BoxyRhoType
+ -> (BoxyRhoType -> TcM thing)
-> TcM ([LStmt TcId], thing)
-- Note the higher-rank type. stmt_chk is applied at different
-- types in the equations for tcStmts
-tcStmts ctxt stmt_chk [] thing_inside
- = do { thing <- thing_inside
+tcStmts ctxt stmt_chk [] res_ty thing_inside
+ = do { thing <- thing_inside res_ty
; return ([], thing) }
-- LetStmts are handled uniformly, regardless of context
-tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) thing_inside
+tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
= do { (binds', (stmts',thing)) <- tcLocalBinds binds $
- tcStmts ctxt stmt_chk stmts thing_inside
+ tcStmts ctxt stmt_chk stmts res_ty thing_inside
; return (L loc (LetStmt binds') : stmts', thing) }
-- For the vanilla case, handle the location-setting part
-tcStmts ctxt stmt_chk (L loc stmt : stmts) thing_inside
+tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
= do { (stmt', (stmts', thing)) <-
- setSrcSpan loc $
- addErrCtxt (stmtCtxt ctxt stmt) $
- stmt_chk ctxt stmt $
- popErrCtxt $
- tcStmts ctxt stmt_chk stmts $
+ setSrcSpan loc $
+ addErrCtxt (stmtCtxt ctxt stmt) $
+ stmt_chk ctxt stmt res_ty $ \ res_ty' ->
+ popErrCtxt $
+ tcStmts ctxt stmt_chk stmts res_ty' $
thing_inside
; return (L loc stmt' : stmts', thing) }
--------------------------------
-- Pattern guards
-tcGuardStmt :: TcType -> TcStmtChecker
-tcGuardStmt res_ty ctxt (ExprStmt guard _ _) thing_inside
- = do { guard' <- tcCheckRho guard boolTy
- ; thing <- thing_inside
+tcGuardStmt :: TcStmtChecker
+tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
+ = do { guard' <- tcMonoExpr guard boolTy
+ ; thing <- thing_inside res_ty
; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
-tcGuardStmt res_ty ctxt (BindStmt pat rhs _ _) thing_inside
+tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRho rhs
- ; (pat', thing) <- tcBindPat pat rhs_ty res_ty thing_inside
+ ; (pat', thing) <- tcPat LamPat pat rhs_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-tcGuardStmt res_ty ctxt stmt thing_inside
+tcGuardStmt ctxt stmt res_ty thing_inside
= pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
-- List comprehensions and PArrays
tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
- -> TcType -- The element type of the list or PArray
-> TcStmtChecker
-- A generator, pat <- rhs
-tcLcStmt m_tc elt_ty ctxt (BindStmt pat rhs _ _) thing_inside
- = do { (rhs', rhs_ty) <- tcInferRho rhs
- ; [pat_ty] <- unifyTyConApp m_tc rhs_ty
- ; (pat', thing) <- tcBindPat pat pat_ty elt_ty thing_inside
+tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+ = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
+ tcMonoExpr rhs (mkTyConApp m_tc [ty])
+ ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-- A boolean guard
-tcLcStmt m_tc elt_ty ctxt (ExprStmt rhs _ _) thing_inside
- = do { rhs' <- tcCheckRho rhs boolTy
- ; thing <- thing_inside
+tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
+ = do { rhs' <- tcMonoExpr rhs boolTy
+ ; thing <- thing_inside res_ty
; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
-- A parallel set of comprehensions
-- So the binders of the first parallel group will be in scope in the second
-- group. But that's fine; there's no shadowing to worry about.
-tcLcStmt m_tc elt_ty ctxt (ParStmt bndr_stmts_s) thing_inside
+tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
= do { (pairs', thing) <- loop bndr_stmts_s
; return (ParStmt pairs', thing) }
where
-- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
- loop [] = do { thing <- thing_inside
- ; return ([], thing) }
+ loop [] = do { thing <- thing_inside elt_ty -- No refinement from pattern
+ ; return ([], thing) } -- matching in the branches
loop ((stmts, names) : pairs)
= do { (stmts', (ids, pairs', thing))
- <- tcStmts ctxt (tcLcStmt m_tc elt_ty) stmts $
+ <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
do { ids <- tcLookupLocalIds names
; (pairs', thing) <- loop pairs
; return (ids, pairs', thing) }
; return ( (stmts', ids) : pairs', thing ) }
-tcLcStmt m_tc elt_ty ctxt stmt thing_inside
+tcLcStmt m_tc ctxt stmt elt_ty thing_inside
= pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
--------------------------------
-- The main excitement here is dealing with rebindable syntax
tcDoStmt :: TcType -- Monad type, m
- -> TcType -- Result type, m b
-> TcStmtChecker
- -- BindStmt
-tcDoStmt m_ty res_ty ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
- = do { -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
- ; (rhs', rhs_ty) <- tcInferRho rhs
+
+tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
+ = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty ->
+ tcMonoExpr rhs (mkAppTy m_ty pat_ty)
-- We should use type *inference* for the RHS computations, becuase of GADTs.
-- do { pat <- rhs; <rest> }
-- is rather like
-- We do inference on rhs, so that information about its type can be refined
-- when type-checking the pattern.
- ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
- ; unifyTauTy m_ty n_ty
- ; let bind_ty = mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty
-
- ; (pat', thing) <- tcBindPat pat pat_ty res_ty thing_inside
+ ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
- -- Rebindable syntax stuff
+ -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
+ ; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty,
+ mkFunTy pat_ty res_ty] res_ty
; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
-- If (but only if) the pattern can fail,
-- typecheck the 'fail' operator
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
-tcDoStmt m_ty res_ty ctxt (ExprStmt rhs then_op _) thing_inside
+tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) res_ty thing_inside
= do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
- a_ty <- newTyFlexiVarTy liftedTypeKind
+ a_ty <- newFlexiTyVarTy liftedTypeKind
; let rhs_ty = mkAppTy m_ty a_ty
then_ty = mkFunTys [rhs_ty, res_ty] res_ty
; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
- ; rhs' <- tcCheckSigma rhs rhs_ty
- ; thing <- thing_inside
+ ; rhs' <- tcPolyExpr rhs rhs_ty
+ ; thing <- thing_inside res_ty
; return (ExprStmt rhs' then_op' rhs_ty, thing) }
-tcDoStmt m_ty res_ty ctxt stmt thing_inside
+tcDoStmt m_ty ctxt stmt res_ty thing_inside
= pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
--------------------------------
-- (a) RecStmts, and
-- (b) no rebindable syntax
-tcMDoStmt :: TcType -- Result type, m b
- -> (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
+tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
-> TcStmtChecker
-tcMDoStmt res_ty tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
+tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
= do { (rhs', pat_ty) <- tc_rhs rhs
- ; (pat', thing) <- tcBindPat pat pat_ty res_ty thing_inside
+ ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-tcMDoStmt res_ty tc_rhs ctxt (ExprStmt rhs then_op _) thing_inside
+tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
= do { (rhs', elt_ty) <- tc_rhs rhs
- ; thing <- thing_inside
+ ; thing <- thing_inside res_ty
; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
-tcMDoStmt res_ty tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) thing_inside
- = do { rec_tys <- newTyFlexiVarTys (length recNames) liftedTypeKind
+tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
+ = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
; let rec_ids = zipWith mkLocalId recNames rec_tys
; tcExtendIdEnv rec_ids $ do
{ (stmts', (later_ids, rec_rets))
- <- tcStmts ctxt (tcMDoStmt res_ty tc_rhs) stmts $
+ <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
-- ToDo: res_ty not really right
do { rec_rets <- zipWithM tc_ret recNames rec_tys
; later_ids <- tcLookupLocalIds laterNames
; return (later_ids, rec_rets) }
- ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE thing_inside)
+ ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
-- NB: The rec_ids for the recursive things
-- already scope over this part. This binding may shadow
-- some of them with polymorphic things with the same Name
where
-- Unify the types of the "final" Ids with those of "knot-tied" Ids
tc_ret rec_name mono_ty
- = tcLookupId rec_name `thenM` \ poly_id ->
+ = do { poly_id <- tcLookupId rec_name
-- poly_id may have a polymorphic type
-- but mono_ty is just a monomorphic type variable
- tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
- returnM (co_fn <$> HsVar poly_id)
+ ; co_fn <- tcSubExp (idType poly_id) mono_ty
+ ; return (HsCoerce co_fn (HsVar poly_id)) }
-tcMDoStmt res_ty tc_rhs ctxt stmt thing_inside
+tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
= pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
------------------
-tcBindPat :: LPat Name -> TcType
- -> TcType -- Result type; used only to check existential escape
- -> TcM a
- -> TcM (LPat TcId, a)
-tcBindPat pat pat_ty res_ty thing_inside
- = do { ([pat'],thing) <- tcMatchPats [pat] [Check pat_ty]
- (Check res_ty) thing_inside
- ; return (pat', thing) }
\end{code}
matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
4 (pprMatch ctxt match)
-grhsCtxt ctxt rhs = hang (ptext SLIT("In") <+> pprMatchRhsContext ctxt <> colon)
- 4 (ppr rhs)
-
doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc
doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon)
4 (ppr body)
stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)
4 (ppr stmt)
-
-sigPatCtxt bound_ids bound_tvs tys tidy_env
- = -- tys is (body_ty : pat_tys)
- mapM zonkTcType tys `thenM` \ tys' ->
- let
- (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
- (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
- in
- returnM (env1,
- sep [ptext SLIT("When checking an existential match that binds"),
- nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
- ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
- ptext SLIT("The body has type:") <+> ppr tidy_body_ty
- ])
- where
- show_ids = filter is_interesting bound_ids
- is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
-
- ppr_id id ty = ppr id <+> dcolon <+> ppr ty
- -- Don't zonk the types so we get the separate, un-unified versions
\end{code}
\begin{code}
module TcMatches where
-import HsSyn ( GRHSs, MatchGroup )
+import HsSyn ( GRHSs, MatchGroup, ExprCoFn )
import Name ( Name )
import Var ( Id )
-import TcType ( TcType, Expected )
+import TcType ( BoxyRhoType )
import TcRnTypes( TcM )
tcGRHSsPat :: GRHSs Name
- -> Expected TcType
+ -> BoxyRhoType
-> TcM (GRHSs Id)
tcMatchesFun :: Name
-> MatchGroup Name
- -> Expected TcType
- -> TcM (MatchGroup Id)
+ -> BoxyRhoType
+ -> TcM (ExprCoFn, MatchGroup Id)
\end{code}
\section[TcPat]{Typechecking patterns}
\begin{code}
-module TcPat ( tcPat, tcPats, PatCtxt(..), badFieldCon, polyPatSig, refineTyVars ) where
+module TcPat ( tcPat, tcPats, tcOverloadedLit,
+ PatCtxt(..), badFieldCon, polyPatSig ) where
#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcSyntaxOp )
-import HsSyn ( Pat(..), LPat, HsConDetails(..),
- LHsBinds, emptyLHsBinds, isEmptyLHsBinds )
+import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..), HsExpr(..),
+ LHsBinds, emptyLHsBinds, isEmptyLHsBinds,
+ collectPatsBinders, nlHsLit )
import TcHsSyn ( TcId, hsLitType )
import TcRnMonad
-import Inst ( InstOrigin(..), tcOverloadedLit,
- newDicts, instToId, tcInstStupidTheta
+import Inst ( InstOrigin(..), shortCutFracLit, shortCutIntLit,
+ newDicts, instToId, tcInstStupidTheta, isHsVar
)
import Id ( Id, idType, mkLocalId )
-import Var ( tyVarName )
-import Name ( Name )
+import CoreFVs ( idFreeTyVars )
+import Name ( Name, mkSystemVarName )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2,
- tcLookupClass, tcLookupDataCon, tcLookupId )
-import TcMType ( newTyFlexiVarTy, arityErr, tcSkolTyVars, readMetaTyVar )
-import TcType ( TcType, TcTyVar, TcSigmaType, TcTauType, zipTopTvSubst,
- SkolemInfo(PatSkol), isMetaTyVar, pprTcTyVar,
- TvSubst, mkOpenTvSubst, substTyVar, substTy, MetaDetails(..),
+ tcLookupClass, tcLookupDataCon, tcLookupId, refineEnvironment,
+ tcMetaTy )
+import TcMType ( newFlexiTyVarTy, arityErr, tcInstSkolTyVars, newBoxyTyVar, zonkTcType )
+import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType,
+ SkolemInfo(PatSkol),
+ BoxySigmaType, BoxyRhoType,
+ pprSkolTvBinding, isRefineableTy, isRigidTy, tcTyVarsOfTypes, mkTyVarTy, lookupTyVar,
+ emptyTvSubst, substTyVar, substTy, mkTopTvSubst, zipTopTvSubst, zipOpenTvSubst,
mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy,
- mkFunTy, mkFunTys )
-import VarEnv ( mkVarEnv ) -- ugly
-import Kind ( argTypeKind, liftedTypeKind )
-import TcUnify ( tcSubPat, Expected(..), zapExpectedType,
- zapExpectedTo, zapToListTy, zapToTyConApp )
-import TcHsType ( UserTypeCtxt(..), TcSigInfo( sig_tau ), TcSigFun, tcHsPatSigType )
+ mkFunTy, mkFunTys, exactTyVarsOfTypes,
+ tidyOpenTypes )
+import VarSet ( elemVarSet, mkVarSet )
+import Kind ( liftedTypeKind )
+import TcUnify ( boxySplitTyConApp, boxySplitListTy,
+ unBox, stripBoxyType, zapToMonotype,
+ boxyMatchTypes, boxyUnify, boxyUnifyList, checkSigTyVarsWrt )
+import TcHsType ( UserTypeCtxt(..), tcPatSig )
import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
-import Unify ( MaybeErr(..), gadtRefineTys, BindFlag(..) )
+import Unify ( MaybeErr(..), gadtRefineTys )
import Type ( substTys, substTheta )
import StaticFlags ( opt_IrrefutableTuples )
import TyCon ( TyCon )
-import DataCon ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys,
+import DataCon ( DataCon, dataConTyCon, isVanillaDataCon,
dataConFieldLabels, dataConSourceArity, dataConSig )
-import PrelNames ( integralClassName )
+import PrelNames ( integralClassName, fromIntegerName, integerTyConName,
+ fromRationalName, rationalTyConName )
import BasicTypes ( isBoxed )
import SrcLoc ( Located(..), SrcSpan, noLoc )
-import Maybes ( catMaybes )
import ErrUtils ( Message )
+import Util ( takeList, zipEqual )
import Outputable
import FastString
\end{code}
%* *
%************************************************************************
-Note [Nesting]
-
-tcPat takes a "thing inside" over which the patter scopes. This is partly
-so that tcPat can extend the environment for the thing_inside, but also
-so that constraints arising in the thing_inside can be discharged by the
-pattern.
-
-This does not work so well for the ErrCtxt carried by the monad: we don't
-want the error-context for the pattern to scope over the RHS.
-Hence the getErrCtxt/setErrCtxt stuff in tcPat.
-
\begin{code}
-tcPat :: PatCtxt
- -> LPat Name -> Expected TcSigmaType
- -> TcM a -- Thing inside
- -> TcM (LPat TcId, -- Translated pattern
- [TcTyVar], -- Existential binders
- a) -- Result of thing inside
-
-tcPat ctxt (L span pat) exp_ty thing_inside
- = do { -- Restore error context before doing thing_inside
- -- See note [Nesting] above
- err_ctxt <- getErrCtxt
- ; let real_thing_inside = setErrCtxt err_ctxt thing_inside
-
- -- It's OK to keep setting the SrcSpan;
- -- it just overwrites the previous value
- ; (pat', tvs, res) <- setSrcSpan span $
- maybeAddErrCtxt (patCtxt pat) $
- tc_pat ctxt pat exp_ty $
- real_thing_inside
-
- ; return (L span pat', tvs, res)
- }
-
---------------------
tcPats :: PatCtxt
- -> [LPat Name]
- -> [Expected TcSigmaType] -- Excess types discarded
- -> TcM a
- -> TcM ([LPat TcId], [TcTyVar], a)
-
-tcPats ctxt [] _ thing_inside
- = do { res <- thing_inside
- ; return ([], [], res) }
-
-tcPats ctxt (p:ps) (ty:tys) thing_inside
- = do { (p', p_tvs, (ps', ps_tvs, res))
- <- tcPat ctxt p ty $
- tcPats ctxt ps tys thing_inside
- ; return (p':ps', p_tvs ++ ps_tvs, res) }
-
---------------------
-tcCheckPats :: PatCtxt
- -> [LPat Name] -> [TcSigmaType]
- -> TcM a
- -> TcM ([LPat TcId], [TcTyVar], a)
-tcCheckPats ctxt pats tys thing_inside -- A trivial wrapper
- = tcPats ctxt pats (map Check tys) thing_inside
+ -> [LPat Name] -- Patterns,
+ -> [BoxySigmaType] -- and their types
+ -> BoxyRhoType -- Result type,
+ -> (BoxyRhoType -> TcM a) -- and the checker for the body
+ -> TcM ([LPat TcId], a)
+
+-- This is the externally-callable wrapper function
+-- Typecheck the patterns, extend the environment to bind the variables,
+-- do the thing inside, use any existentially-bound dictionaries to
+-- discharge parts of the returning LIE, and deal with pattern type
+-- signatures
+
+-- 1. Initialise the PatState
+-- 2. Check the patterns
+-- 3. Apply the refinement
+-- 4. Check the body
+-- 5. Check that no existentials escape
+
+tcPats ctxt pats tys res_ty thing_inside
+ = do { let init_state = PS { pat_ctxt = ctxt, pat_reft = emptyTvSubst }
+
+ ; (pats', ex_tvs, res) <- tc_lpats init_state pats tys $ \ pstate' ->
+ thing_inside (refineType (pat_reft pstate') res_ty)
+
+ ; tcCheckExistentialPat ctxt pats' ex_tvs tys res_ty
+
+ ; returnM (pats', res) }
+
+
+-----------------
+tcPat :: PatCtxt
+ -> LPat Name -> TcType
+ -> BoxyRhoType -- Result type
+ -> (BoxyRhoType -> TcM a) -- Checker for body, given its result type
+ -> TcM (LPat TcId, a)
+tcPat ctxt pat pat_ty res_ty thing_inside
+ = do { ([pat'],thing) <- tcPats ctxt [pat] [pat_ty] res_ty thing_inside
+ ; return (pat', thing) }
+
+
+-----------------
+tcCheckExistentialPat :: PatCtxt
+ -> [LPat TcId] -- Patterns (just for error message)
+ -> [TcTyVar] -- Existentially quantified tyvars bound by pattern
+ -> [BoxySigmaType] -- Types of the patterns
+ -> BoxyRhoType -- Type of the body of the match
+ -- Tyvars in either of these must not escape
+ -> TcM ()
+-- NB: we *must* pass "pats_tys" not just "body_ty" to tcCheckExistentialPat
+-- For example, we must reject this program:
+-- data C = forall a. C (a -> Int)
+-- f (C g) x = g x
+-- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
+
+tcCheckExistentialPat ctxt pats [] pat_tys body_ty
+ = return () -- Short cut for case when there are no existentials
+
+tcCheckExistentialPat (LetPat _) pats ex_tvs pat_tys body_ty
+ -- Don't know how to deal with pattern-bound existentials yet
+ = failWithTc (existentialExplode pats)
+
+tcCheckExistentialPat ctxt pats ex_tvs pat_tys body_ty
+ = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys) $
+ checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs
+
+data PatState = PS {
+ pat_ctxt :: PatCtxt,
+ pat_reft :: GadtRefinement -- Binds rigid TcTyVars to their refinements
+ }
+
+data PatCtxt
+ = LamPat
+ | LetPat (Name -> Maybe TcRhoType) -- Used for let(rec) bindings
+
+patSigCtxt :: PatState -> UserTypeCtxt
+patSigCtxt (PS { pat_ctxt = LetPat _ }) = BindPatSigCtxt
+patSigCtxt other = LamPatSigCtxt
\end{code}
+
%************************************************************************
%* *
Binders
%************************************************************************
\begin{code}
-data PatCtxt = LamPat -- Used for lambda, case, do-notation etc
- | LetPat TcSigFun -- Used for let(rec) bindings
-
--------------------
-tcPatBndr :: PatCtxt -> Name -> Expected TcSigmaType -> TcM TcId
-tcPatBndr LamPat bndr_name pat_ty
- = do { pat_ty' <- zapExpectedType pat_ty argTypeKind
- -- If pat_ty is Expected, this returns the appropriate
- -- SigmaType. In Infer mode, we create a fresh type variable.
- -- Note argTypeKind: the variable can have an unboxed type,
- -- but not an unboxed tuple.
- -- Note the SigmaType: we can get
+tcPatBndr :: PatState -> Name -> BoxySigmaType -> TcM TcId
+tcPatBndr (PS { pat_ctxt = LamPat }) bndr_name pat_ty
+ = do { pat_ty' <- unBox pat_ty
+ -- We have an undecorated binder, so we do rule ABS1,
+ -- by unboxing the boxy type, forcing any un-filled-in
+ -- boxes to become monotypes
+ -- NB that pat_ty' can still be a polytype:
-- data T = MkT (forall a. a->a)
-- f t = case t of { MkT g -> ... }
-- Here, the 'g' must get type (forall a. a->a) from the
-- MkT context
; return (mkLocalId bndr_name pat_ty') }
-tcPatBndr (LetPat lookup_sig) bndr_name pat_ty
- | Just sig <- lookup_sig bndr_name
- = do { let mono_ty = sig_tau sig
- ; mono_name <- newLocalName bndr_name
- ; tcSubPat mono_ty pat_ty
+tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty
+ | Just mono_ty <- lookup_sig bndr_name
+ = do { mono_name <- newLocalName bndr_name
+ ; boxyUnify mono_ty pat_ty
; return (mkLocalId mono_name mono_ty) }
| otherwise
- = do { mono_name <- newLocalName bndr_name
- ; pat_ty' <- zapExpectedType pat_ty argTypeKind
+ = do { pat_ty' <- unBox pat_ty
+ ; mono_name <- newLocalName bndr_name
; return (mkLocalId mono_name pat_ty') }
%************************************************************************
%* *
- tc_pat: the main worker function
+ The main worker functions
%* *
%************************************************************************
+Note [Nesting]
+~~~~~~~~~~~~~~
+tcPat takes a "thing inside" over which the patter scopes. This is partly
+so that tcPat can extend the environment for the thing_inside, but also
+so that constraints arising in the thing_inside can be discharged by the
+pattern.
+
+This does not work so well for the ErrCtxt carried by the monad: we don't
+want the error-context for the pattern to scope over the RHS.
+Hence the getErrCtxt/setErrCtxt stuff in tc_lpats.
+
\begin{code}
-tc_pat :: PatCtxt
- -> Pat Name -> Expected TcSigmaType
- -> TcM a -- Thing inside
+--------------------
+tc_lpats :: PatState
+ -> [LPat Name]
+ -> [BoxySigmaType]
+ -> (PatState -> TcM a)
+ -> TcM ([LPat TcId], [TcTyVar], a)
+
+tc_lpats pstate pats pat_tys thing_inside
+ = do { err_ctxt <- getErrCtxt
+ ; let loop pstate [] []
+ = do { res <- thing_inside pstate
+ ; return ([], [], res) }
+
+ loop pstate (p:ps) (ty:tys)
+ = do { (p', p_tvs, (ps', ps_tvs, res))
+ <- tc_lpat pstate p ty $ \ pstate' ->
+ setErrCtxt err_ctxt $
+ loop pstate' ps tys
+ -- setErrCtxt: restore context before doing the next pattern
+ -- See note [Nesting] above
+
+ ; return (p':ps', p_tvs ++ ps_tvs, res) }
+
+ loop _ _ _ = pprPanic "tc_lpats" (ppr pats $$ ppr pat_tys)
+
+ ; loop pstate pats pat_tys }
+
+--------------------
+tc_lpat :: PatState
+ -> LPat Name
+ -> BoxySigmaType
+ -> (PatState -> TcM a)
+ -> TcM (LPat TcId, [TcTyVar], a)
+tc_lpat pstate (L span pat) pat_ty thing_inside
+ = setSrcSpan span $
+ maybeAddErrCtxt (patCtxt pat) $
+ do { let pat_ty' = refineType (pat_reft pstate) pat_ty
+ -- Make sure the result type reflects the current refinement
+ ; (pat', tvs, res) <- tc_pat pstate pat pat_ty' thing_inside
+ ; return (L span pat', tvs, res) }
+
+
+--------------------
+tc_pat :: PatState
+ -> Pat Name -> BoxySigmaType -- Fully refined result type
+ -> (PatState -> TcM a) -- Thing inside
-> TcM (Pat TcId, -- Translated pattern
[TcTyVar], -- Existential binders
a) -- Result of thing inside
-tc_pat ctxt (VarPat name) pat_ty thing_inside
- = do { id <- tcPatBndr ctxt name pat_ty
+tc_pat pstate (VarPat name) pat_ty thing_inside
+ = do { id <- tcPatBndr pstate name pat_ty
; (res, binds) <- bindInstsOfPatId id $
tcExtendIdEnv1 name id $
(traceTc (text "binding" <+> ppr name <+> ppr (idType id))
- >> thing_inside)
+ >> thing_inside pstate)
; let pat' | isEmptyLHsBinds binds = VarPat id
| otherwise = VarPatOut id binds
; return (pat', [], res) }
-tc_pat ctxt (ParPat pat) pat_ty thing_inside
- = do { (pat', tvs, res) <- tcPat ctxt pat pat_ty thing_inside
+tc_pat pstate (ParPat pat) pat_ty thing_inside
+ = do { (pat', tvs, res) <- tc_lpat pstate pat pat_ty thing_inside
; return (ParPat pat', tvs, res) }
-- There's a wrinkle with irrefuatable patterns, namely that we
--
-- Nor should a lazy pattern bind any existential type variables
-- because they won't be in scope when we do the desugaring
-tc_pat ctxt lpat@(LazyPat pat) pat_ty thing_inside
- = do { reft <- getTypeRefinement
- ; (pat', pat_tvs, res) <- tcPat ctxt pat pat_ty $
- setTypeRefinement reft thing_inside
+tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
+ = do { (pat', pat_tvs, res) <- tc_lpat pstate pat pat_ty $ \ _ ->
+ thing_inside pstate
+ -- Ignore refined pstate',
+ -- revert to pstate
; if (null pat_tvs) then return ()
else lazyPatErr lpat pat_tvs
; return (LazyPat pat', [], res) }
-tc_pat ctxt (WildPat _) pat_ty thing_inside
- = do { pat_ty' <- zapExpectedType pat_ty argTypeKind
- -- Note argTypeKind, so that
- -- f _ = 3
- -- is rejected when f applied to an unboxed tuple
- -- However, this means that
- -- (case g x of _ -> ...)
- -- is rejected g returns an unboxed tuple, which is perhpas
- -- annoying. I suppose we could pass the context into tc_pat...
- ; res <- thing_inside
+tc_pat pstate (WildPat _) pat_ty thing_inside
+ = do { pat_ty' <- unBox pat_ty -- Make sure it's filled in with monotypes
+ ; res <- thing_inside pstate
; return (WildPat pat_ty', [], res) }
-tc_pat ctxt (AsPat (L nm_loc name) pat) pat_ty thing_inside
- = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty)
+tc_pat pstate (AsPat (L nm_loc name) pat) pat_ty thing_inside
+ = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $
- tcPat ctxt pat (Check (idType bndr_id)) thing_inside
+ tc_lpat pstate pat (idType bndr_id) thing_inside
-- NB: if we do inference on:
-- \ (y@(x::forall a. a->a)) = e
-- we'll fail. The as-pattern infers a monotype for 'y', which then
-- If you fix it, don't forget the bindInstsOfPatIds!
; return (AsPat (L nm_loc bndr_id) pat', tvs, res) }
-tc_pat ctxt (SigPatIn pat sig) pat_ty thing_inside
- = do { -- See Note [Pattern coercions] below
- (sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig
- ; tcSubPat sig_ty pat_ty
- ; subst <- refineTyVars sig_tvs -- See note [Type matching]
- ; let tv_binds = [(tyVarName tv, substTyVar subst tv) | tv <- sig_tvs]
- sig_ty' = substTy subst sig_ty
- ; (pat', tvs, res)
- <- tcExtendTyVarEnv2 tv_binds $
- tcPat ctxt pat (Check sig_ty') thing_inside
-
- ; return (SigPatOut pat' sig_ty', tvs, res) }
+-- Type signatures in patterns
+-- See Note [Pattern coercions] below
+tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
+ = do { (inner_ty, tv_binds) <- tcPatSig (patSigCtxt pstate) sig_ty pat_ty
+ ; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $
+ tc_lpat pstate pat inner_ty thing_inside
+ ; return (SigPatOut pat' inner_ty, tvs, res) }
-tc_pat ctxt pat@(TypePat ty) pat_ty thing_inside
+tc_pat pstate pat@(TypePat ty) pat_ty thing_inside
= failWithTc (badTypePat pat)
------------------------
-- Lists, tuples, arrays
-tc_pat ctxt (ListPat pats _) pat_ty thing_inside
- = do { elem_ty <- zapToListTy pat_ty
- ; (pats', pats_tvs, res) <- tcCheckPats ctxt pats (repeat elem_ty) thing_inside
- ; return (ListPat pats' elem_ty, pats_tvs, res) }
-
-tc_pat ctxt (PArrPat pats _) pat_ty thing_inside
- = do { [elem_ty] <- zapToTyConApp parrTyCon pat_ty
- ; (pats', pats_tvs, res) <- tcCheckPats ctxt pats (repeat elem_ty) thing_inside
- ; return (PArrPat pats' elem_ty, pats_tvs, res) }
-
-tc_pat ctxt (TuplePat pats boxity) pat_ty thing_inside
- = do { let arity = length pats
- tycon = tupleTyCon boxity arity
- ; arg_tys <- zapToTyConApp tycon pat_ty
- ; (pats', pats_tvs, res) <- tcCheckPats ctxt pats arg_tys thing_inside
+tc_pat pstate (ListPat pats _) pat_ty thing_inside
+ = do { elt_ty <- boxySplitListTy pat_ty
+ ; let elt_tys = takeList pats (repeat elt_ty)
+ ; (pats', pats_tvs, res) <- tc_lpats pstate pats elt_tys thing_inside
+ ; return (ListPat pats' elt_ty, pats_tvs, res) }
+
+tc_pat pstate (PArrPat pats _) pat_ty thing_inside
+ = do { [elt_ty] <- boxySplitTyConApp parrTyCon pat_ty
+ ; let elt_tys = takeList pats (repeat elt_ty)
+ ; (pats', pats_tvs, res) <- tc_lpats pstate pats elt_tys thing_inside
+ ; ifM (null pats) (zapToMonotype pat_ty) -- c.f. ExplicitPArr in TcExpr
+ ; return (PArrPat pats' elt_ty, pats_tvs, res) }
+
+tc_pat pstate (TuplePat pats boxity) pat_ty thing_inside
+ = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length pats)) pat_ty
+ ; (pats', pats_tvs, res) <- tc_lpats pstate pats arg_tys thing_inside
-- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
-- so that we can experiment with lazy tuple-matching.
| opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result)
| otherwise = unmangled_result
- ; ASSERT( length arg_tys == arity ) -- Syntactically enforced
+ ; ASSERT( length arg_tys == length pats ) -- Syntactically enforced
return (possibly_mangled_result, pats_tvs, res) }
------------------------
-- Data constructors
-tc_pat ctxt pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside
+tc_pat pstate pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside
= do { data_con <- tcLookupDataCon con_name
; let tycon = dataConTyCon data_con
- ; ty_args <- zapToTyConApp tycon pat_ty
- ; (pat', tvs, res) <- tcConPat ctxt con_span data_con tycon ty_args arg_pats thing_inside
- ; return (pat', tvs, res) }
+ ; tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside }
------------------------
-- Literal patterns
-tc_pat ctxt (LitPat simple_lit) pat_ty thing_inside
- = do { -- All other simple lits
- zapExpectedTo pat_ty (hsLitType simple_lit)
- ; res <- thing_inside
+tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
+ = do { boxyUnify (hsLitType simple_lit) pat_ty
+ ; res <- thing_inside pstate
; returnM (LitPat simple_lit, [], res) }
------------------------
-- Overloaded patterns: n, and n+k
-tc_pat ctxt pat@(NPat over_lit mb_neg eq _) pat_ty thing_inside
- = do { pat_ty' <- zapExpectedType pat_ty liftedTypeKind
- ; let orig = LiteralOrigin over_lit
- ; lit' <- tcOverloadedLit orig over_lit pat_ty'
- ; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty', pat_ty'] boolTy)
+tc_pat pstate pat@(NPat over_lit mb_neg eq _) pat_ty thing_inside
+ = do { let orig = LiteralOrigin over_lit
+ ; lit' <- tcOverloadedLit orig over_lit pat_ty
+ ; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
; mb_neg' <- case mb_neg of
Nothing -> return Nothing -- Positive literal
Just neg -> -- Negative literal
-- The 'negate' is re-mappable syntax
- do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty' pat_ty')
+ do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty)
; return (Just neg') }
- ; res <- thing_inside
- ; returnM (NPat lit' mb_neg' eq' pat_ty', [], res) }
+ ; res <- thing_inside pstate
+ ; returnM (NPat lit' mb_neg' eq' pat_ty, [], res) }
-tc_pat ctxt pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
- = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty)
+tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
+ = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
; let pat_ty' = idType bndr_id
orig = LiteralOrigin lit
; lit' <- tcOverloadedLit orig lit pat_ty'
; dicts <- newDicts orig [mkClassPred icls [pat_ty']]
; extendLIEs dicts
- ; res <- tcExtendIdEnv1 name bndr_id thing_inside
+ ; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
\end{code}
%************************************************************************
\begin{code}
-tcConPat :: PatCtxt -> SrcSpan -> DataCon -> TyCon -> [TcTauType]
- -> HsConDetails Name (LPat Name) -> TcM a
+tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon
+ -> BoxySigmaType -- Type of the pattern
+ -> HsConDetails Name (LPat Name) -> (PatState -> TcM a)
-> TcM (Pat TcId, [TcTyVar], a)
-tcConPat ctxt span data_con tycon ty_args arg_pats thing_inside
+tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
| isVanillaDataCon data_con
- = do { let arg_tys = dataConInstOrigArgTys data_con ty_args
+ = do { ty_args <- boxySplitTyConApp tycon pat_ty
+ ; let (tvs, _, arg_tys, _, _) = dataConSig data_con
+ arg_tvs = exactTyVarsOfTypes arg_tys
+ -- See Note [Silly type synonyms in smart-app] in TcExpr
+ -- for why we must use exactTyVarsOfTypes
+ inst_prs = zipEqual "tcConPat" tvs ty_args
+ subst = mkTopTvSubst inst_prs
+ arg_tys' = substTys subst arg_tys
+ unconstrained_ty_args = [ty_arg | (tv,ty_arg) <- inst_prs,
+ not (tv `elemVarSet` arg_tvs)]
+ ; mapM unBox unconstrained_ty_args -- Zap these to monotypes
; tcInstStupidTheta data_con ty_args
- ; traceTc (text "tcConPat" <+> vcat [ppr data_con, ppr ty_args, ppr arg_tys])
- ; (arg_pats', tvs, res) <- tcConArgs ctxt data_con arg_pats arg_tys thing_inside
- ; return (ConPatOut (L span data_con) [] [] emptyLHsBinds
+ ; traceTc (text "tcConPat" <+> vcat [ppr data_con, ppr ty_args, ppr arg_tys'])
+ ; (arg_pats', tvs, res) <- tcConArgs pstate data_con arg_pats arg_tys' thing_inside
+ ; return (ConPatOut (L con_span data_con) [] [] emptyLHsBinds
arg_pats' (mkTyConApp tycon ty_args),
tvs, res) }
| otherwise -- GADT case
- = do { let (tvs, theta, arg_tys, _, res_tys) = dataConSig data_con
- ; traceTc (text "tcConPat: GADT" <+> ppr data_con)
- ; span <- getSrcSpanM
- ; let rigid_info = PatSkol data_con span
- ; tvs' <- tcSkolTyVars rigid_info tvs
- ; let tv_tys' = mkTyVarTys tvs'
- tenv = zipTopTvSubst tvs tv_tys'
- theta' = substTheta tenv theta
- arg_tys' = substTys tenv arg_tys
- res_tys' = substTys tenv res_tys
- ; dicts <- newDicts (SigOrigin rigid_info) theta'
+ = do { ty_args <- boxySplitTyConApp tycon pat_ty
+ ; span <- getSrcSpanM -- The whole pattern
+
+ -- Instantiate the constructor type variables and result type
+ ; let (tvs, theta, arg_tys, _, res_tys) = dataConSig data_con
+ arg_tvs = exactTyVarsOfTypes arg_tys
+ -- See Note [Silly type synonyms in smart-app] in TcExpr
+ -- for why we must use exactTyVarsOfTypes
+ skol_info = PatSkol data_con span
+ arg_flags = [ tv `elemVarSet` arg_tvs | tv <- tvs ]
+ ; tvs' <- tcInstSkolTyVars skol_info tvs
+ ; let res_tys' = substTys (zipTopTvSubst tvs (mkTyVarTys tvs')) res_tys
-- Do type refinement!
- ; traceTc (text "tcGadtPat" <+> vcat [ppr data_con, ppr tvs', ppr arg_tys', ppr res_tys',
+ ; traceTc (text "tcGadtPat" <+> vcat [ppr data_con, ppr tvs', ppr res_tys',
text "ty-args:" <+> ppr ty_args ])
- ; refineAlt ctxt data_con tvs' ty_args res_tys' $ do
+ ; refineAlt pstate data_con tvs' arg_flags res_tys' ty_args
+ $ \ pstate' tv_tys' -> do
- { ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
+ -- ToDo: arg_tys should be boxy, but I don't think theta' should be,
+ -- or the tv_tys' in the call to tcInstStupidTheta
+ { let tenv' = zipTopTvSubst tvs tv_tys'
+ theta' = substTheta tenv' theta
+ arg_tys' = substTys tenv' arg_tys -- Boxy types
+
+ ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
do { tcInstStupidTheta data_con tv_tys'
-- The stupid-theta mentions the newly-bound tyvars, so
-- it must live inside the getLIE, so that the
- -- tcSimplifyCheck will apply the type refinement to it
- ; tcConArgs ctxt data_con arg_pats arg_tys' thing_inside }
+ -- tcSimplifyCheck will apply the type refinement to it
+ ; tcConArgs pstate' data_con arg_pats arg_tys' thing_inside }
+ ; dicts <- newDicts (SigOrigin skol_info) theta'
; dict_binds <- tcSimplifyCheck doc tvs' dicts lie_req
- ; return (ConPatOut (L span data_con)
+ ; return (ConPatOut (L con_span data_con)
tvs' (map instToId dicts) dict_binds
arg_pats' (mkTyConApp tycon ty_args),
- tvs' ++ inner_tvs, res) } }
+ tvs' ++ inner_tvs, res)
+ } }
where
doc = ptext SLIT("existential context for") <+> quotes (ppr data_con)
-tcConArgs :: PatCtxt -> DataCon
+tcConArgs :: PatState -> DataCon
-> HsConDetails Name (LPat Name) -> [TcSigmaType]
- -> TcM a
+ -> (PatState -> TcM a)
-> TcM (HsConDetails TcId (LPat Id), [TcTyVar], a)
-tcConArgs ctxt data_con (PrefixCon arg_pats) arg_tys thing_inside
+tcConArgs pstate data_con (PrefixCon arg_pats) arg_tys thing_inside
= do { checkTc (con_arity == no_of_args) -- Check correct arity
(arityErr "Constructor" data_con con_arity no_of_args)
- ; (arg_pats', tvs, res) <- tcCheckPats ctxt arg_pats arg_tys thing_inside
+ ; (arg_pats', tvs, res) <- tc_lpats pstate arg_pats arg_tys thing_inside
; return (PrefixCon arg_pats', tvs, res) }
where
con_arity = dataConSourceArity data_con
no_of_args = length arg_pats
-tcConArgs ctxt data_con (InfixCon p1 p2) arg_tys thing_inside
+tcConArgs pstate data_con (InfixCon p1 p2) arg_tys thing_inside
= do { checkTc (con_arity == 2) -- Check correct arity
(arityErr "Constructor" data_con con_arity 2)
- ; ([p1',p2'], tvs, res) <- tcCheckPats ctxt [p1,p2] arg_tys thing_inside
+ ; ([p1',p2'], tvs, res) <- tc_lpats pstate [p1,p2] arg_tys thing_inside
; return (InfixCon p1' p2', tvs, res) }
where
con_arity = dataConSourceArity data_con
-tcConArgs ctxt data_con (RecCon rpats) arg_tys thing_inside
- = do { (rpats', tvs, res) <- tc_fields rpats thing_inside
+tcConArgs pstate data_con (RecCon rpats) arg_tys thing_inside
+ = do { (rpats', tvs, res) <- tc_fields pstate rpats thing_inside
; return (RecCon rpats', tvs, res) }
where
- tc_fields :: [(Located Name, LPat Name)] -> TcM a
+ tc_fields :: PatState -> [(Located Name, LPat Name)]
+ -> (PatState -> TcM a)
-> TcM ([(Located TcId, LPat TcId)], [TcTyVar], a)
- tc_fields [] thing_inside
- = do { res <- thing_inside
+ tc_fields pstate [] thing_inside
+ = do { res <- thing_inside pstate
; return ([], [], res) }
- tc_fields (rpat : rpats) thing_inside
+ tc_fields pstate (rpat : rpats) thing_inside
= do { (rpat', tvs1, (rpats', tvs2, res))
- <- tc_field rpat (tc_fields rpats thing_inside)
+ <- tc_field pstate rpat $ \ pstate' ->
+ tc_fields pstate' rpats thing_inside
; return (rpat':rpats', tvs1 ++ tvs2, res) }
- tc_field (field_lbl, pat) thing_inside
+ tc_field pstate (field_lbl, pat) thing_inside
= do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
- ; (pat', tvs, res) <- tcPat ctxt pat (Check pat_ty) thing_inside
+ ; (pat', tvs, res) <- tc_lpat pstate pat pat_ty thing_inside
; return ((sel_id, pat'), tvs, res) }
find_field_ty field_lbl
-- If foo isn't one of R's fields, we don't want to crash when
-- typechecking the "a+b".
[] -> do { addErrTc (badFieldCon data_con field_lbl)
- ; bogus_ty <- newTyFlexiVarTy liftedTypeKind
+ ; bogus_ty <- newFlexiTyVarTy liftedTypeKind
; return (error "Bogus selector Id", bogus_ty) }
-- The normal case, when the field comes from the right constructor
%************************************************************************
\begin{code}
-refineAlt :: PatCtxt -> DataCon
- -> [TcTyVar] -- Freshly bound type variables
- -> [TcType] -- Types from the scrutinee (context)
- -> [TcType] -- Types from the pattern
- -> TcM a -> TcM a
-refineAlt ctxt con ex_tvs ctxt_tys pat_tys thing_inside
- = do { old_subst <- getTypeRefinement
- ; case gadtRefineTys bind_fn old_subst pat_tys ctxt_tys of
- Failed msg -> failWithTc (inaccessibleAlt msg)
- Succeeded new_subst -> do {
- traceTc (text "refineTypes:match" <+> ppr con <+> ppr new_subst)
- ; setTypeRefinement new_subst thing_inside } }
-
- where
- bind_fn tv | isMetaTyVar tv = WildCard -- Wobbly types behave as wild cards
- | otherwise = BindMe
+refineAlt :: PatState
+ -> DataCon -- For tracing only
+ -> [TcTyVar] -- Type variables from pattern
+ -> [Bool] -- Flags indicating which type variables occur
+ -- in the type of at least one argument
+ -> [TcType] -- Result types from the pattern
+ -> [BoxySigmaType] -- Result types from the scrutinee (context)
+ -> (PatState -> [BoxySigmaType] -> TcM a)
+ -- Possibly-refined existentials
+ -> TcM a
+refineAlt pstate con pat_tvs arg_flags pat_res_tys ctxt_res_tys thing_inside
+ | not (all isRigidTy ctxt_res_tys)
+ -- The context is not a rigid type, so we do no type refinement here.
+ = do { let arg_tvs = mkVarSet [ tv | (tv, True) <- pat_tvs `zip` arg_flags]
+ subst = boxyMatchTypes arg_tvs pat_res_tys ctxt_res_tys
+
+ res_tvs = tcTyVarsOfTypes pat_res_tys
+ -- The tvs are (already) all fresh skolems. We need a
+ -- fresh skolem for each type variable (to bind in the pattern)
+ -- even if it's refined away by the type refinement
+ find_inst tv
+ | not (tv `elemVarSet` res_tvs) = return (mkTyVarTy tv)
+ | Just boxy_ty <- lookupTyVar subst tv = return boxy_ty
+ | otherwise = do { tv <- newBoxyTyVar
+ ; return (mkTyVarTy tv) }
+ ; pat_tys' <- mapM find_inst pat_tvs
+
+ -- Do the thing inside
+ ; res <- thing_inside pstate pat_tys'
+
+ -- Unbox the types that have been filled in by the thing_inside
+ -- I.e. the ones whose type variables are mentioned in at least one arg
+ ; let strip ty in_arg_tv | in_arg_tv = stripBoxyType ty
+ | otherwise = return ty
+ ; pat_tys'' <- zipWithM strip pat_tys' arg_flags
+ ; let subst = zipOpenTvSubst pat_tvs pat_tys''
+ ; boxyUnifyList (substTys subst pat_res_tys) ctxt_res_tys
+
+ ; return res } -- All boxes now filled
+
+ | otherwise -- The context is rigid, so we can do type refinement
+ = case gadtRefineTys (pat_reft pstate) con pat_tvs pat_res_tys ctxt_res_tys of
+ Failed msg -> failWithTc (inaccessibleAlt msg)
+ Succeeded (new_subst, all_bound_here)
+ | all_bound_here -- All the new bindings are for pat_tvs, so no need
+ -- to refine the environment or pstate
+ -> do { traceTc trace_msg
+ ; thing_inside pstate pat_tvs' }
+ | otherwise -- New bindings affect the context, so refine
+ -- the environment and pstate
+ -> refineEnvironment (pat_reft pstate') $
+ do { traceTc trace_msg
+ ; thing_inside pstate' pat_tvs' }
+ where
+ pat_tvs' = map (substTyVar new_subst) pat_tvs
+ pstate' = pstate { pat_reft = new_subst }
+ trace_msg = text "refineTypes:match" <+> ppr con <+> ppr new_subst
+
+refineType :: GadtRefinement -> BoxyRhoType -> BoxyRhoType
+-- Refine the type if it is rigid
+refineType reft ty
+ | isRefineableTy ty = substTy reft ty
+ | otherwise = ty
\end{code}
-Note [Type matching]
-~~~~~~~~~~~~~~~~~~~~
-This little function @refineTyVars@ is a little tricky. Suppose we have a pattern type
-signature
- f = \(x :: Term a) -> body
-Then 'a' should be bound to a wobbly type. But if we have
- f :: Term b -> some-type
- f = \(x :: Term a) -> body
-then 'a' should be bound to the rigid type 'b'. So we want to
- * instantiate the type sig with fresh meta tyvars (e.g. \alpha)
- * unify with the type coming from the context
- * read out whatever information has been gleaned
- from that unificaiton (e.g. unifying \alpha with 'b')
- * and replace \alpha by 'b' in the type, when typechecking the
- pattern inside the type sig (x in this case)
-It amounts to combining rigid info from the context and from the sig.
-
-Exactly the same thing happens for 'smart function application'.
+
+%************************************************************************
+%* *
+ Overloaded literals
+%* *
+%************************************************************************
+
+In tcOverloadedLit we convert directly to an Int or Integer if we
+know that's what we want. This may save some time, by not
+temporarily generating overloaded literals, but it won't catch all
+cases (the rest are caught in lookupInst).
\begin{code}
-refineTyVars :: [TcTyVar] -- Newly instantiated meta-tyvars of the function
- -> TcM TvSubst -- Substitution mapping any of the meta-tyvars that
- -- has been unifies to what it was instantiated to
--- Just one level of de-wobblification though. What a hack!
-refineTyVars tvs
- = do { mb_prs <- mapM mk_pr tvs
- ; return (mkOpenTvSubst (mkVarEnv (catMaybes mb_prs))) }
- where
- mk_pr tv = do { details <- readMetaTyVar tv
- ; case details of
- Indirect ty -> return (Just (tv,ty))
- other -> return Nothing
- }
+tcOverloadedLit :: InstOrigin
+ -> HsOverLit Name
+ -> BoxyRhoType
+ -> TcM (HsOverLit TcId)
+tcOverloadedLit orig lit@(HsIntegral i fi) res_ty
+ | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
+ -- Reason: If we do, tcSimplify will call lookupInst, which
+ -- will call tcSyntaxName, which does unification,
+ -- which tcSimplify doesn't like
+ -- ToDo: noLoc sadness
+ = do { integer_ty <- tcMetaTy integerTyConName
+ ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty res_ty)
+ ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
+
+ | Just expr <- shortCutIntLit i res_ty
+ = return (HsIntegral i expr)
+
+ | otherwise
+ = do { expr <- newLitInst orig lit res_ty
+ ; return (HsIntegral i expr) }
+
+tcOverloadedLit orig lit@(HsFractional r fr) res_ty
+ | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
+ = do { rat_ty <- tcMetaTy rationalTyConName
+ ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty res_ty)
+ -- Overloaded literals must have liftedTypeKind, because
+ -- we're instantiating an overloaded function here,
+ -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
+ -- However this'll be picked up by tcSyntaxOp if necessary
+ ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
+
+ | Just expr <- shortCutFracLit r res_ty
+ = return (HsFractional r expr)
+
+ | otherwise
+ = do { expr <- newLitInst orig lit res_ty
+ ; return (HsFractional r expr) }
+
+newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
+newLitInst orig lit res_ty -- Make a LitInst
+ = do { loc <- getInstLoc orig
+ ; res_tau <- zapToMonotype res_ty
+ ; new_uniq <- newUnique
+ ; let
+ lit_nm = mkSystemVarName new_uniq FSLIT("lit")
+ lit_inst = LitInst lit_nm lit res_tau loc
+ ; extendLIE lit_inst
+ ; return (HsVar (instToId lit_inst)) }
\end{code}
+
%************************************************************************
%* *
Note [Pattern coercions]
patCtxt (VarPat _) = Nothing
patCtxt (ParPat _) = Nothing
patCtxt (AsPat _ _) = Nothing
-patCtxt pat = Just (hang (ptext SLIT("When checking the pattern:"))
+patCtxt pat = Just (hang (ptext SLIT("In the pattern:"))
4 (ppr pat))
+-----------------------------------------------
+
+existentialExplode pats
+ = hang (vcat [text "My brain just exploded.",
+ text "I can't handle pattern bindings for existentially-quantified constructors.",
+ text "In the binding group for"])
+ 4 (vcat (map ppr pats))
+
+sigPatCtxt bound_ids bound_tvs tys tidy_env
+ = -- tys is (body_ty : pat_tys)
+ mapM zonkTcType tys `thenM` \ tys' ->
+ let
+ (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
+ (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
+ in
+ returnM (env1,
+ sep [ptext SLIT("When checking an existential match that binds"),
+ nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
+ ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
+ ptext SLIT("The body has type:") <+> ppr tidy_body_ty
+ ])
+ where
+ show_ids = filter is_interesting bound_ids
+ is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
+
+ ppr_id id ty = ppr id <+> dcolon <+> ppr ty
+ -- Don't zonk the types so we get the separate, un-unified versions
+
badFieldCon :: DataCon -> Name -> SDoc
badFieldCon con field
= hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
lazyPatErr pat tvs
= failWithTc $
hang (ptext SLIT("A lazy (~) pattern connot bind existential type variables"))
- 2 (vcat (map pprTcTyVar tvs))
+ 2 (vcat (map pprSkolTvBinding tvs))
inaccessibleAlt msg
= hang (ptext SLIT("Inaccessible case alternative:")) 2 msg
import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
mkExternalName )
import NameSet
-import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
+import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import DriverPhases ( HscSource(..), isHsBoot )
import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..),
HsLocalBinds(..), HsValBinds(..),
- LStmt, LHsExpr, LHsType, mkMatchGroup, mkMatch, emptyLocalBinds,
+ LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
collectLStmtsBinders, collectLStmtBinders, nlVarPat,
- placeHolderType, noSyntaxExpr )
+ mkFunBind, placeHolderType, noSyntaxExpr )
import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
import RnSource ( addTcgDUs )
TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
+ tcDump tcg_env ;
(bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
rules fords ;
| tyConKind boot_tc == tyConKind real_tc
= return ()
where
- (tvs1, defn1) = getSynTyConDefn boot_tc
- (tvs2, defn2) = getSynTyConDefn boot_tc
+ (tvs1, defn1) = synTyConDefn boot_tc
+ (tvs2, defn2) = synTyConDefn boot_tc
check_thing (AnId boot_id) (AnId real_id)
| idType boot_id `tcEqType` idType real_id
mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
= do { uniq <- newUnique -- is treated very specially
; let fresh_it = itName uniq
- the_bind = L loc $ FunBind (L loc fresh_it) False matches emptyNameSet
- matches = mkMatchGroup [mkMatch [] expr emptyLocalBinds]
+ the_bind = L loc $ mkFunBind (L loc fresh_it) matches
+ matches = [mkMatch [] expr emptyLocalBinds]
let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
(HsVar bindIOName) noSyntaxExpr
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
((tc_stmts, ids), lie) <- getLIE $
- tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $
+ tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
mappM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
import Module ( Module, unitModuleEnv )
import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv,
LocalRdrEnv, emptyLocalRdrEnv )
-import Name ( Name, isInternalName, mkInternalName, getOccName, getSrcLoc )
+import Name ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
import Type ( Type )
-import NameEnv ( extendNameEnvList )
+import TcType ( tcIsTyVarTy, tcGetTyVar )
+import NameEnv ( extendNameEnvList, nameEnvElts )
import InstEnv ( emptyInstEnv )
+import Var ( setTyVarName )
import VarSet ( emptyVarSet )
-import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv )
+import VarEnv ( TidyEnv, emptyTidyEnv, extendVarEnv )
import ErrUtils ( Message, Messages, emptyMessages, errorsFound,
mkWarnMsg, printErrorsAndWarnings,
mkLocMessage, mkLongErrMsg )
import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
import NameEnv ( emptyNameEnv )
import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )
-import OccName ( emptyOccEnv )
+import OccName ( emptyOccEnv, tidyOccName )
import Bag ( emptyBag )
import Outputable
import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
tcl_tyvars = tvs_var,
- tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE
- tcl_gadt = emptyVarEnv
+ tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE
} ;
} ;
newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name -- Make a clone
= newUnique `thenM` \ uniq ->
- returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
+ returnM (mkInternalName uniq (nameOccName name) (getSrcLoc name))
\end{code}
traceOptTcRn flag doc = ifOptM flag $ do
{ ctxt <- getErrCtxt
; loc <- getSrcSpanM
- ; ctxt_msgs <- do_ctxt emptyTidyEnv ctxt
+ ; env0 <- tcInitTidyEnv
+ ; ctxt_msgs <- do_ctxt env0 ctxt
; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
; dumpTcRn real_doc }
addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
= do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;
-
errs_var <- getErrsVar ;
rdr_env <- getGlobalRdrEnv ;
let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
setErrCtxt :: ErrCtxt -> TcM a -> TcM a
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
-addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
-addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
-
addErrCtxt :: Message -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
+addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
+addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
+
-- Helper function for the above
updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
\begin{code}
addErrTc :: Message -> TcM ()
-addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+addErrTc err_msg = do { env0 <- tcInitTidyEnv
+ ; addErrTcM (env0, err_msg) }
addErrsTc :: [Message] -> TcM ()
addErrsTc err_msgs = mappM_ addErrTc err_msgs
addWarnTc :: Message -> TcM ()
addWarnTc msg
= do { ctxt <- getErrCtxt ;
- ctxt_msgs <- do_ctxt emptyTidyEnv ctxt ;
+ env0 <- tcInitTidyEnv ;
+ ctxt_msgs <- do_ctxt env0 ctxt ;
addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) }
warnTc :: Bool -> Message -> TcM ()
| otherwise = return ()
\end{code}
- Helper functions
+-----------------------------------
+ Tidying
+
+We initialise the "tidy-env", used for tidying types before printing,
+by building a reverse map from the in-scope type variables to the
+OccName that the programmer originally used for them
+
+\begin{code}
+tcInitTidyEnv :: TcM TidyEnv
+tcInitTidyEnv
+ = do { lcl_env <- getLclEnv
+ ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
+ | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
+ , tcIsTyVarTy ty ]
+ ; return (foldl add emptyTidyEnv nm_tv_prs) }
+ where
+ add (env,subst) (name, tyvar)
+ = case tidyOccName env (nameOccName name) of
+ (env', occ') -> (env', extendVarEnv subst tyvar tyvar')
+ where
+ tyvar' = setTyVarName tyvar name'
+ name' = tidyNameOcc name occ'
+\end{code}
+
+-----------------------------------
+ Other helper functions
\begin{code}
add_err_tcm tidy_env err_msg loc ctxt
| otherwise = take 3 ctxt
\end{code}
-debugTc is useful for monadi debugging code
+debugTc is useful for monadic debugging code
\begin{code}
debugTc :: TcM () -> TcM ()
Just r -> r) }
\end{code}
-%************************************************************************
-%* *
- Stuff for GADTs
-%* *
-%************************************************************************
-
-\begin{code}
-getTypeRefinement :: TcM GadtRefinement
-getTypeRefinement = do { lcl_env <- getLclEnv; return (tcl_gadt lcl_env) }
-setTypeRefinement :: GadtRefinement -> TcM a -> TcM a
-setTypeRefinement gadt = updLclEnv (\env -> env { tcl_gadt = gadt })
-\end{code}
WhereFrom(..), mkModDeps,
-- Typechecker types
- TcTyThing(..), pprTcTyThingCategory, GadtRefinement,
+ TcTyThing(..), pprTcTyThingCategory,
+ GadtRefinement,
-- Template Haskell
ThStage(..), topStage, topSpliceStage,
GenAvailInfo(..), AvailInfo, HscSource(..),
availName, IsBootInterface, Deprecations )
import Packages ( PackageId, HomeModules )
-import Type ( Type, TvSubstEnv, pprParendType, pprTyThingCategory )
-import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, SkolemInfo,
+import Type ( Type, pprTyThingCategory )
+import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst,
TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo )
import InstEnv ( Instance, InstEnv )
import IOEnv
-- plus the tyvars mentioned in the types of Ids bound in tcl_lenv
-- Why mutable? see notes with tcGetGlobalTyVars
- tcl_lie :: TcRef LIE, -- Place to accumulate type constraints
- tcl_gadt :: GadtRefinement -- The current type refinement for GADTs
-
------------------------------------------------------------
--- Not yet; it's a new complication and I want to see whether it bites
--- tcl_given :: [Inst] -- Insts available in the current context (see Note [Given Insts])
------------------------------------------------------------
+ tcl_lie :: TcRef LIE -- Place to accumulate type constraints
}
-type GadtRefinement = TvSubstEnv -- Binds rigid type variables to their refinements
+type GadtRefinement = TvSubst
{- Note [Given Insts]
~~~~~~~~~~~~~~~~~~
---------------------------
data TcTyThing
- = AGlobal TyThing -- Used only in the return type of a lookup
+ = AGlobal TyThing -- Used only in the return type of a lookup
- | ATcId TcId ThLevel -- Ids defined in this module; may not be fully zonked
+ | ATcId TcId -- Ids defined in this module; may not be fully zonked
+ ThLevel
+ Bool -- True <=> apply the type refinement to me
- | ATyVar Name TcType -- Type variables; tv -> type. It can't just be a TyVar
- -- that is mutated to point to the type it is bound to,
- -- because that would make it a wobbly type, and we
- -- want pattern-bound lexically-scoped type variables to
- -- be able to stand for rigid types
+ | ATyVar Name TcType -- The type to which the lexically scoped type vaiable
+ -- is currently refined. We only need the Name
+ -- for error-message purposes
- | AThing TcKind -- Used temporarily, during kind checking, for the
- -- tycons and clases in this recursive group
+ | AThing TcKind -- Used temporarily, during kind checking, for the
+ -- tycons and clases in this recursive group
instance Outputable TcTyThing where -- Debugging only
ppr (AGlobal g) = ppr g
- ppr (ATcId g tl) = text "Identifier" <>
- ifPprDebug (brackets (ppr g <> comma <> ppr tl))
- ppr (ATyVar tv ty) = text "Type variable" <+> quotes (ppr tv) <+> pprParendType ty
+ ppr (ATcId g tl rig) = text "Identifier" <>
+ ifPprDebug (brackets (ppr g <> comma <> ppr tl <+> ppr rig))
+ ppr (ATyVar tv _) = text "Type variable" <+> quotes (ppr tv)
ppr (AThing k) = text "AThing" <+> ppr k
pprTcTyThingCategory :: TcTyThing -> SDoc
pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing
-pprTcTyThingCategory (ATyVar _ _) = ptext SLIT("Type variable")
-pprTcTyThingCategory (ATcId _ _) = ptext SLIT("Local identifier")
-pprTcTyThingCategory (AThing _) = ptext SLIT("Kinded thing")
+pprTcTyThingCategory (ATyVar {}) = ptext SLIT("Type variable")
+pprTcTyThingCategory (ATcId {}) = ptext SLIT("Local identifier")
+pprTcTyThingCategory (AThing {}) = ptext SLIT("Kinded thing")
\end{code}
\begin{code}
TcThetaType -- The (types of the) dictionaries to which the function
-- must be applied to get the method
- TcTauType -- The tau-type of the method
-
InstLoc
-- INVARIANT 1: in (Method u f tys theta tau loc)
EQ -> True
other -> False
-cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = pred1 `tcCmpPred` pred2
-cmpInst (Dict _ _ _) other = LT
+cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = pred1 `tcCmpPred` pred2
+cmpInst (Dict _ _ _) other = LT
-cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
-cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
-cmpInst (Method _ _ _ _ _ _) other = LT
+cmpInst (Method _ _ _ _ _) (Dict _ _ _) = GT
+cmpInst (Method _ id1 tys1 _ _) (Method _ id2 tys2 _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
+cmpInst (Method _ _ _ _ _) other = LT
-cmpInst (LitInst _ _ _ _) (Dict _ _ _) = GT
-cmpInst (LitInst _ _ _ _) (Method _ _ _ _ _ _) = GT
-cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
+cmpInst (LitInst _ _ _ _) (Dict _ _ _) = GT
+cmpInst (LitInst _ _ _ _) (Method _ _ _ _ _) = GT
+cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
\end{code}
import HsSyn ( RuleDecl(..), LRuleDecl, RuleBndr(..), mkHsDictLet )
import TcRnMonad
import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck )
-import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar )
-import TcType ( tyVarsOfTypes, openTypeKind )
+import TcMType ( newFlexiTyVarTy, zonkQuantifiedTyVar, tcSkolSigTyVars )
+import TcType ( tyVarsOfTypes, openTypeKind, SkolemInfo(..), substTyWith, mkTyVarTys )
import TcHsType ( UserTypeCtxt(..), tcHsPatSigType )
-import TcExpr ( tcCheckRho )
+import TcExpr ( tcMonoExpr )
import TcEnv ( tcExtendIdEnv, tcExtendTyVarEnv )
import Inst ( instToId )
import Id ( idType, mkLocalId )
= addErrCtxt (ruleCtxt name) $
traceTc (ptext SLIT("---- Rule ------")
<+> ppr name) `thenM_`
- newTyFlexiVarTy openTypeKind `thenM` \ rule_ty ->
+ newFlexiTyVarTy openTypeKind `thenM` \ rule_ty ->
-- Deal with the tyvars mentioned in signatures
tcRuleBndrs vars (\ ids ->
-- Now LHS and RHS
- getLIE (tcCheckRho lhs rule_ty) `thenM` \ (lhs', lhs_lie) ->
- getLIE (tcCheckRho rhs rule_ty) `thenM` \ (rhs', rhs_lie) ->
+ getLIE (tcMonoExpr lhs rule_ty) `thenM` \ (lhs', lhs_lie) ->
+ getLIE (tcMonoExpr rhs rule_ty) `thenM` \ (rhs', rhs_lie) ->
returnM (ids, lhs', rhs', lhs_lie, rhs_lie)
) `thenM` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
tcRuleBndrs [] thing_inside = thing_inside []
tcRuleBndrs (RuleBndr var : vars) thing_inside
- = do { ty <- newTyFlexiVarTy openTypeKind
+ = do { ty <- newFlexiTyVarTy openTypeKind
; let id = mkLocalId (unLoc var) ty
; tcExtendIdEnv [id] $
tcRuleBndrs vars (\ids -> thing_inside (id:ids)) }
tcRuleBndrs (RuleBndrSig var rn_ty : vars) thing_inside
- = do { (tyvars, ty) <- tcHsPatSigType (RuleSigCtxt (unLoc var)) rn_ty
- ; let id = mkLocalId (unLoc var) ty
- ; tcExtendTyVarEnv tyvars $
+-- e.g x :: a->a
+-- The tyvar 'a' is brought into scope first, just as if you'd written
+-- a::*, x :: a->a
+ = do { let ctxt = RuleSigCtxt (unLoc var)
+ ; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty
+ ; let skol_tvs = tcSkolSigTyVars (SigSkol ctxt) tyvars
+ id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty
+ id = mkLocalId (unLoc var) id_ty
+ ; tcExtendTyVarEnv skol_tvs $
tcExtendIdEnv [id] $
tcRuleBndrs vars (\ids -> thing_inside (id:ids)) }
#include "HsVersions.h"
-import {-# SOURCE #-} TcUnify( unifyTauTy )
+import {-# SOURCE #-} TcUnify( unifyType )
import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
= addErrCtxt doc $
tcInstTyVars (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
mapM_ (unif_pr tenv) pairs
- unif_pr tenv (ty1,ty2) = unifyTauTy (substTy tenv ty1) (substTy tenv ty2)
+ unif_pr tenv (ty1,ty2) = unifyType (substTy tenv ty1) (substTy tenv ty2)
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
choose_default default_ty -- Commit to tyvar = default_ty
= -- Bind the type variable
- unifyTauTy default_ty (mkTyVarTy tyvar) `thenM_`
+ unifyType default_ty (mkTyVarTy tyvar) `thenM_`
-- and reduce the context, for real this time
simpleReduceLoop (text "disambig" <+> ppr dicts)
reduceMe dicts `thenM` \ (frees, binds, ambigs) ->
= addErrTcM (tidy_env, mk_msg tidy_ips)
where
(tidy_env, tidy_ips) = tidyInsts ips
- mk_msg ips = vcat [sep [ptext SLIT("Implicit parameters escape from the monomorphic top-level binding(s) of"),
- pprBinders bndrs <> colon],
+ mk_msg ips = vcat [sep [ptext SLIT("Implicit parameters escape from"),
+ nest 2 (ptext SLIT("the monomorphic top-level binding(s) of")
+ <+> pprBinders bndrs <> colon)],
nest 2 (vcat (map ppr_ip ips)),
monomorphism_fix]
ppr_ip ip = pprPred (dictPred ip) <+> pprInstLoc (instLoc ip)
ispecs = [ispec | (_, ispec) <- matches]
mk_probable_fix tidy_env dicts
- = returnM (tidy_env, sep [ptext SLIT("Probable fix:"), nest 2 (vcat fixes)])
+ = returnM (tidy_env, sep [ptext SLIT("Possible fix:"), nest 2 (vcat fixes)])
where
fixes = add_ors (fix1 ++ fix2)
import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName )
import RdrName ( RdrName, lookupLocalRdrEnv, isSrcRdrName )
import RnTypes ( rnLHsType )
-import TcExpr ( tcCheckRho, tcMonoExpr )
+import TcExpr ( tcMonoExpr )
import TcHsSyn ( mkHsDictLet, zonkTopLExpr )
import TcSimplify ( tcSimplifyTop, tcSimplifyBracket )
-import TcUnify ( Expected, zapExpectedTo, zapExpectedType )
-import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
+import TcUnify ( boxyUnify, unBox )
+import TcType ( TcType, TcKind, BoxyRhoType, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
import TcEnv ( spliceOK, tcMetaTy, bracketOK )
-import TcMType ( newTyFlexiVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType )
+import TcMType ( newFlexiTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType )
import TcHsType ( tcHsSigType, kcHsType )
import TcIface ( tcImportDecl )
import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification
import TcRnMonad
import IfaceEnv ( lookupOrig )
import Class ( Class, classExtraBigSig )
-import TyCon ( TyCon, tyConTyVars, getSynTyConDefn,
+import TyCon ( TyCon, tyConTyVars, synTyConDefn,
isSynTyCon, isNewTyCon, tyConDataCons, isPrimTyCon, isFunTyCon,
tyConArity, tyConStupidTheta, isUnLiftedTyCon )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks,
\begin{code}
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
-tcSpliceExpr :: HsSplice Name -> Expected TcType -> TcM (HsExpr TcId)
+tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
#ifndef GHCI
%************************************************************************
\begin{code}
-tcBracket :: HsBracket Name -> Expected TcType -> TcM (LHsExpr Id)
+tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr Id)
tcBracket brack res_ty
= getStage `thenM` \ level ->
case bracketOK level of {
tcSimplifyBracket lie `thenM_`
-- Make the expected type have the right shape
- zapExpectedTo res_ty meta_ty `thenM_`
+ boxyUnify meta_ty res_ty `thenM_`
-- Return the original expression, not the type-decorated one
readMutVar pending_splices `thenM` \ pendings ->
= tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
tc_bracket (ExpBr expr)
- = newTyFlexiVarTy liftedTypeKind `thenM` \ any_ty ->
- tcCheckRho expr any_ty `thenM_`
+ = newFlexiTyVarTy liftedTypeKind `thenM` \ any_ty ->
+ tcMonoExpr expr any_ty `thenM_`
tcMetaTy expQTyConName
-- Result type is Expr (= Q Exp)
-- Here (h 4) :: Q Exp
-- but $(h 4) :: forall a.a i.e. anything!
- zapExpectedType res_ty liftedTypeKind `thenM_`
+ unBox res_ty `thenM_`
tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
setStage (Splice next_level) (
setLIEVar lie_var $
- tcCheckRho expr meta_exp_ty
+ tcMonoExpr expr meta_exp_ty
) `thenM` \ expr' ->
-- Write the pending splice into the bucket
-- The recursive call to tcMonoExpr will simply expand the
-- inner escape before dealing with the outer one
-tcTopSplice :: LHsExpr Name -> Expected TcType -> TcM (LHsExpr Id)
+tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
tcTopSplice expr res_ty
= tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
do { recordThUse -- Record that TH is used (for pkg depdendency)
-- Typecheck the expression
- ; (expr', lie) <- getLIE (tcCheckRho expr meta_ty)
+ ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
-- Solve the constraints
; const_binds <- tcSimplifyTop lie
; meta_ty <- tcMetaTy typeQTyConName
; expr' <- setStage (Splice next_level) $
setLIEVar lie_var $
- tcCheckRho hs_expr meta_ty
+ tcMonoExpr hs_expr meta_ty
-- Write the pending splice into the bucket
; ps <- readMutVar ps_var
; fix <- reifyFixity name
; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
-reifyThing (ATcId id _)
+reifyThing (ATcId id _ _)
= do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
-- though it may be incomplete
; ty2 <- reifyType ty1
| isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
| isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
| isSynTyCon tc
- = do { let (tvs, rhs) = getSynTyConDefn tc
+ = do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
import Name ( Name )
import RdrName ( RdrName )
import TcRnTypes( TcM )
-import TcType ( TcType, TcKind, Expected )
+import TcType ( TcKind, BoxyRhoType )
tcSpliceExpr :: HsSplice Name
- -> Expected TcType
+ -> BoxyRhoType
-> TcM (HsExpr Id)
kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
tcBracket :: HsBracket Name
- -> Expected TcType
+ -> BoxyRhoType
-> TcM (LHsExpr Id)
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ),
tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
- tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName )
+ tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName )
import DataCon ( DataCon, dataConWrapId, dataConName,
- -- dataConSig,
dataConFieldLabels, dataConTyCon,
dataConTyVars, dataConFieldType, dataConResTys )
import Var ( TyVar, idType, idName )
mappM_ check_fields groups
where
- syn_ctxt = TySynCtxt name
- name = tyConName tc
- (_, syn_rhs) = getSynTyConDefn tc
- data_cons = tyConDataCons tc
+ syn_ctxt = TySynCtxt name
+ name = tyConName tc
+ syn_rhs = synTyConRhs tc
+ data_cons = tyConDataCons tc
groups = equivClasses cmp_fld (concatMap get_fields data_cons)
cmp_fld (f1,_) (f2,_) = f1 `compare` f2
ptext SLIT("give different types for field"), quotes (ppr field_name)]
dataConCtxt con = ptext SLIT("In the definition of data constructor") <+> quotes (ppr con)
-{- If the data constructor returns the wrong data type, then we get
- zip_ty_env failures when printing its argument types; so best
- to be less ambitious about complaining here
- nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
- where
- (ex_tvs, ex_theta, arg_tys, _, _) = dataConSig con
- ex_part | null ex_tvs = empty
- | otherwise = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot
- -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote
- -- data T a = Eq a => T a a
- -- So we make sure to print it
-
- fields = dataConFieldLabels con
- arg_part | null fields = sep (map pprParendType arg_tys)
- | otherwise = braces (sep (punctuate comma
- [ ppr n <+> dcolon <+> ppr ty
- | (n,ty) <- fields `zip` arg_tys]))
--}
classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"),
nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
import Type ( predTypeRep, tcView )
import HscTypes ( TyThing(..), ModDetails(..) )
import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
- getSynTyConDefn, isSynTyCon, isAlgTyCon,
+ synTyConDefn, isSynTyCon, isAlgTyCon,
tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
import Class ( classTyCon )
import DataCon ( dataConOrigArgTys )
argtys = concatMap dataConOrigArgTys data_cons -- Rep? or Orig?
tcaoIter oi tc | isSynTyCon tc
- = let (tyvs,ty) = getSynTyConDefn tc
+ = let (tyvs,ty) = synTyConDefn tc
-- we use the already-computed result for tycons not in this SCC
in map (\v -> vrcInTy (lookup oi) v ty) tyvs
module TcType where
data TcTyVarDetails
+
+pprTcTyVarDetails :: TcTyVarDetails -> Outputable.SDoc
\ No newline at end of file
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcKind,
+ BoxyTyVar, BoxySigmaType, BoxyRhoType, BoxyThetaType, BoxyType,
+
--------------------------------
-- MetaDetails
- Expected(..), TcRef, TcTyVarDetails(..),
- MetaDetails(Flexi, Indirect), SkolemInfo(..), pprTcTyVar, pprSkolInfo,
- isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isExistentialTyVar, metaTvRef,
+ UserTypeCtxt(..), pprUserTypeCtxt,
+ TcTyVarDetails(..), BoxInfo(..), pprTcTyVarDetails,
+ MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolTvBinding, pprSkolInfo,
+ isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isBoxyTyVar, isSigTyVar, isExistentialTyVar,
+ metaTvRef,
isFlexi, isIndirect,
--------------------------------
-- Builders
- mkPhiTy, mkSigmaTy, hoistForAllTys,
+ mkPhiTy, mkSigmaTy,
--------------------------------
-- Splitters
-- These are important because they do not look through newtypes
tcView,
tcSplitForAllTys, tcSplitPhiTy,
- tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
+ tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
- tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
+ tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys,
tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar,
+ tcSplitSigmaTy, tcMultiSplitSigmaTy,
---------------------------------
-- Predicates.
-- Again, newtypes are opaque
tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
- isSigmaTy, isOverloadedTy,
+ isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy,
isDoubleTy, isFloatTy, isIntTy, isStringTy,
isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
- isTauTy, tcIsTyVarTy, tcIsForAllTy,
+ isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
---------------------------------
-- Misc type manipulators
mkDictTy, tcSplitPredTy_maybe,
isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
- dataConsStupidTheta,
+ dataConsStupidTheta, isRefineableTy,
---------------------------------
-- Foreign import and export
Type, PredType(..), ThetaType,
mkForAllTy, mkForAllTys,
mkFunTy, mkFunTys, zipFunTys,
- mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
+ mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
-- Type substitutions
TvSubst(..), -- Representation visible to a few friends
TvSubstEnv, emptyTvSubst,
- mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst,
- getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
- extendTvSubst, extendTvSubstList, isInScope,
+ mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar,
+ extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
isUnLiftedType, -- Source types are always lifted
typeKind, tidyKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
+ tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes,
pprKind, pprParendKind,
pprType, pprParendType, pprTyThingCategory,
mkArrowKinds, mkForAllTy, mkForAllTys,
defaultKind, isArgTypeKind, isOpenTypeKind,
mkFunTy, mkFunTys, zipFunTys,
- mkTyConApp, mkGenTyConApp, mkAppTy,
- mkAppTys, mkSynTy, applyTy, applyTys,
+ mkTyConApp, mkAppTy,
+ mkAppTys, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
mkPredTys, isUnLiftedType,
isUnboxedTupleType, isPrimitiveType,
tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar,
tidyOpenTyVars, tidyKind,
- isSubKind, deShadowTy, tcView,
+ isSubKind, tcView,
tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
tcEqPred, tcCmpPred, tcEqTypeX,
TvSubst(..),
- TvSubstEnv, emptyTvSubst,
+ TvSubstEnv, emptyTvSubst, mkTvSubst, zipTyEnv,
mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst,
getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
- extendTvSubst, extendTvSubstList, isInScope,
+ extendTvSubst, extendTvSubstList, isInScope, notElemTvSubst,
substTy, substTys, substTyWith, substTheta,
- substTyVar, substTyVarBndr, substPred,
+ substTyVar, substTyVarBndr, substPred, lookupTyVar,
typeKind, repType,
pprKind, pprParendKind,
pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
)
-import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, tyConUnique )
+import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique )
import DataCon ( DataCon, dataConStupidTheta, dataConResTys )
import Class ( Class )
import Var ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
import OccName ( OccName, mkDictOcc )
import PrelNames -- Lots (e.g. in isFFIArgumentTy)
import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
-import BasicTypes ( IPName(..), ipNameName )
+import BasicTypes ( IPName(..), Arity, ipNameName )
import SrcLoc ( SrcLoc, SrcSpan )
import Util ( snocView, equalLength )
import Maybes ( maybeToBool, expectJust, mapCatMaybes )
-- provided it expands to the required form.
\begin{code}
-type TcType = Type -- A TcType can have mutable type variables
+type TcTyVar = TyVar -- Used only during type inference
+type TcType = Type -- A TcType can have mutable type variables
-- Invariant on ForAllTy in TcTypes:
-- forall a. T
-- a cannot occur inside a MutTyVar in T; that is,
-- T is "flattened" before quantifying over a
+-- These types do not have boxy type variables in them
type TcPredType = PredType
type TcThetaType = ThetaType
type TcSigmaType = TcType
type TcKind = Kind
type TcTyVarSet = TyVarSet
-type TcRef a = IORef a
-data Expected ty = Infer (TcRef ty) -- The hole to fill in for type inference
- | Check ty -- The type to check during type checking
+-- These types may have boxy type variables in them
+type BoxyTyVar = TcTyVar
+type BoxyRhoType = TcType
+type BoxyThetaType = TcThetaType
+type BoxySigmaType = TcType
+type BoxyType = TcType
\end{code}
It's knot-tied back to Var.lhs. There is no reason in principle
why Var.lhs shouldn't actually have the definition, but it "belongs" here.
+
Note [Signature skolems]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
On the other hand, we *must* use skolems for signature type variables,
becuase GADT type refinement refines skolems only.
-One solution woudl be insist that in the above defn the programmer uses
+One solution would be insist that in the above defn the programmer uses
the same type variable in both type signatures. But that takes explanation.
The alternative (currently implemented) is to have a special kind of skolem
\begin{code}
-type TcTyVar = TyVar -- Used only during type inference
-
-- A TyVarDetails is inside a TyVar
data TcTyVarDetails
- = MetaTv (IORef MetaDetails) -- A meta type variable stands for a tau-type
- | SkolemTv SkolemInfo -- A skolem constant
- | SigSkolTv Name (IORef MetaDetails) -- Ditto, but from a type signature;
- -- see Note [Signature skolems]
- -- The MetaDetails, if filled in, will
- -- always be another SigSkolTv
+ = SkolemTv SkolemInfo -- A skolem constant
+
+ | MetaTv BoxInfo (IORef MetaDetails)
+
+data BoxInfo
+ = BoxTv -- The contents is a (non-boxy) sigma-type
+ -- That is, this MetaTv is a "box"
+
+ | TauTv -- The contents is a (non-boxy) tau-type
+ -- That is, this MetaTv is an ordinary unification variable
+
+ | SigTv SkolemInfo -- A variant of TauTv, except that it should not be
+ -- unified with a type, only with a type variable
+ -- SigTvs are only distinguished to improve error messages
+ -- see Note [Signature skolems]
+ -- The MetaDetails, if filled in, will
+ -- always be another SigTv or a SkolemTv
+
+-- INVARIANTS:
+-- A TauTv is always filled in with a tau-type, which
+-- never contains any BoxTvs, nor any ForAlls
+--
+-- However, a BoxTv can contain a type that contains further BoxTvs
+-- Notably, when typechecking an explicit list, say [e1,e2], with
+-- expected type being a box b1, we fill in b1 with (List b2), where
+-- b2 is another (currently empty) box.
+
+data MetaDetails
+ = Flexi -- Flexi type variables unify to become
+ -- Indirects.
+
+ | Indirect TcType -- INVARIANT:
+ -- For a BoxTv, this type must be non-boxy
+ -- For a TauTv, this type must be a tau-type
data SkolemInfo
- = SigSkol Name -- Bound at a type signature
+ = SigSkol UserTypeCtxt -- A skolem that is created by instantiating
+ -- a programmer-supplied type signature
+ -- Location of the binding site is on the TyVar
+
+ -- The rest are for non-scoped skolems
| ClsSkol Class -- Bound at a class decl
| InstSkol Id -- Bound at an instance decl
| PatSkol DataCon -- An existential type variable bound by a pattern for
TcType -- (forall tvs. ty)
SrcSpan
-data MetaDetails
- = Flexi -- Flexi type variables unify to become
- -- Indirects.
+ | UnkSkol -- Unhelpful info (until I improve it)
+
+-------------------------------------
+-- UserTypeCtxt describes the places where a
+-- programmer-written type signature can occur
+data UserTypeCtxt
+ = FunSigCtxt Name -- Function type signature
+ -- Also used for types in SPECIALISE pragmas
+ | ExprSigCtxt -- Expression type signature
+ | ConArgCtxt Name -- Data constructor argument
+ | TySynCtxt Name -- RHS of a type synonym decl
+ | GenPatCtxt -- Pattern in generic decl
+ -- f{| a+b |} (Inl x) = ...
+ | LamPatSigCtxt -- Type sig in lambda pattern
+ -- f (x::t) = ...
+ | BindPatSigCtxt -- Type sig in pattern binding pattern
+ -- (x::t, y) = e
+ | ResSigCtxt -- Result type sig
+ -- f x :: t = ....
+ | ForSigCtxt Name -- Foreign inport or export signature
+ | RuleSigCtxt Name -- Signature on a forall'd variable in a RULE
+ | DefaultDeclCtxt -- Types in a default declaration
+ | SpecInstCtxt -- SPECIALISE instance pragma
+
+-- Notes re TySynCtxt
+-- We allow type synonyms that aren't types; e.g. type List = []
+--
+-- If the RHS mentions tyvars that aren't in scope, we'll
+-- quantify over them:
+-- e.g. type T = a->a
+-- will become type T = forall a. a->a
+--
+-- With gla-exts that's right, but for H98 we should complain.
+\end{code}
- | Indirect TcType -- Type indirections, treated as wobbly
- -- for the purpose of GADT unification.
+%************************************************************************
+%* *
+ Pretty-printing
+%* *
+%************************************************************************
+\begin{code}
+pprTcTyVarDetails :: TcTyVarDetails -> SDoc
+-- For debugging
+pprTcTyVarDetails (SkolemTv _) = ptext SLIT("sk")
+pprTcTyVarDetails (MetaTv BoxTv _) = ptext SLIT("box")
+pprTcTyVarDetails (MetaTv TauTv _) = ptext SLIT("tau")
+pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext SLIT("sig")
+
+pprUserTypeCtxt :: UserTypeCtxt -> SDoc
+pprUserTypeCtxt (FunSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n)
+pprUserTypeCtxt ExprSigCtxt = ptext SLIT("an expression type signature")
+pprUserTypeCtxt (ConArgCtxt c) = ptext SLIT("the type of the constructor") <+> quotes (ppr c)
+pprUserTypeCtxt (TySynCtxt c) = ptext SLIT("the RHS of the type synonym") <+> quotes (ppr c)
+pprUserTypeCtxt GenPatCtxt = ptext SLIT("the type pattern of a generic definition")
+pprUserTypeCtxt LamPatSigCtxt = ptext SLIT("a pattern type signature")
+pprUserTypeCtxt BindPatSigCtxt = ptext SLIT("a pattern type signature")
+pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature")
+pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign declaration for") <+> quotes (ppr n)
+pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n)
+pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a type in a `default' declaration")
+pprUserTypeCtxt SpecInstCtxt = ptext SLIT("a SPECIALISE instance pragma")
+
+
+--------------------------------
tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
-- Tidy the type inside a GenSkol, preparatory to printing it
tidySkolemTyVar env tv
(env2, ty1) = tidyOpenType env1 ty
info -> (env, info)
-pprTcTyVar :: TcTyVar -> SDoc
--- Print tyvar with info about its binding
-pprTcTyVar tv
- = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
+pprSkolTvBinding :: TcTyVar -> SDoc
+-- Print info about the binding of a skolem tyvar,
+-- or nothing if we don't have anything useful to say
+pprSkolTvBinding tv
+ = ppr_details (tcTyVarDetails tv)
where
- ppr_details (MetaTv _) = ptext SLIT("is a meta type variable")
- ppr_details (SigSkolTv id _) = ptext SLIT("is bound by") <+> pprSkolInfo (SigSkol id)
- ppr_details (SkolemTv info) = ptext SLIT("is bound by") <+> pprSkolInfo info
+ ppr_details (MetaTv TauTv _) = quotes (ppr tv) <+> ptext SLIT("is a meta type variable")
+ ppr_details (MetaTv BoxTv _) = quotes (ppr tv) <+> ptext SLIT("is a boxy type variable")
+ ppr_details (MetaTv (SigTv info) _) = ppr_skol info
+ ppr_details (SkolemTv info) = ppr_skol info
+
+ ppr_skol UnkSkol = empty -- Unhelpful; omit
+ ppr_skol (SigSkol ctxt) = sep [quotes (ppr tv) <+> ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt,
+ nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))]
+ ppr_skol info = quotes (ppr tv) <+> pprSkolInfo info
pprSkolInfo :: SkolemInfo -> SDoc
-pprSkolInfo (SigSkol id) = ptext SLIT("the type signature for") <+> quotes (ppr id)
-pprSkolInfo (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
-pprSkolInfo (InstSkol df) = ptext SLIT("the instance declaration at") <+> ppr (getSrcLoc df)
-pprSkolInfo (ArrowSkol loc) = ptext SLIT("the arrow form at") <+> ppr loc
-pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("the pattern for") <+> quotes (ppr dc),
+pprSkolInfo (SigSkol ctxt) = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt
+pprSkolInfo (ClsSkol cls) = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls)
+pprSkolInfo (InstSkol df) = ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df)
+pprSkolInfo (ArrowSkol loc) = ptext SLIT("is bound by the arrow form at") <+> ppr loc
+pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc),
nest 2 (ptext SLIT("at") <+> ppr loc)]
-pprSkolInfo (GenSkol tvs ty loc) = sep [ptext SLIT("the polymorphic type")
- <+> quotes (ppr (mkForAllTys tvs ty)),
+pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"),
+ nest 2 (quotes (ppr (mkForAllTys tvs ty)))],
nest 2 (ptext SLIT("at") <+> ppr loc)]
+-- UnkSkol, SigSkol
+-- For type variables the others are dealt with by pprSkolTvBinding.
+-- For Insts, these cases should not happen
+pprSkolInfo UnkSkol = panic "UnkSkol"
instance Outputable MetaDetails where
ppr Flexi = ptext SLIT("Flexi")
ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
+\end{code}
+
-isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isMetaTyVar :: TyVar -> Bool
+%************************************************************************
+%* *
+ Predicates
+%* *
+%************************************************************************
+
+\begin{code}
+isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isBoxyTyVar, isMetaTyVar :: TyVar -> Bool
isImmutableTyVar tv
| isTcTyVar tv = isSkolemTyVar tv
| otherwise = True
isSkolemTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
- SkolemTv _ -> True
- SigSkolTv _ _ -> True
- MetaTv _ -> False
+ SkolemTv _ -> True
+ MetaTv _ _ -> False
isExistentialTyVar tv -- Existential type variable, bound by a pattern
= ASSERT( isTcTyVar tv )
other -> False
isMetaTyVar tv
- = ASSERT( isTcTyVar tv )
+ = ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
- MetaTv _ -> True
+ MetaTv _ _ -> True
other -> False
+isBoxyTyVar tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ MetaTv BoxTv _ -> True
+ other -> False
+
+isSigTyVar tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ MetaTv (SigTv _) _ -> True
+ other -> False
+
metaTvRef :: TyVar -> IORef MetaDetails
metaTvRef tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
- MetaTv ref -> ref
+ MetaTv _ ref -> ref
other -> pprPanic "metaTvRef" (ppr tv)
isFlexi, isIndirect :: MetaDetails -> Bool
mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
\end{code}
-@isTauTy@ tests for nested for-alls.
+@isTauTy@ tests for nested for-alls. It should not be called on a boxy type.
\begin{code}
isTauTy :: Type -> Bool
isTauTy ty | Just ty' <- tcView ty = isTauTy ty'
-isTauTy (TyVarTy v) = True
-isTauTy (TyConApp _ tys) = all isTauTy tys
-isTauTy (AppTy a b) = isTauTy a && isTauTy b
-isTauTy (FunTy a b) = isTauTy a && isTauTy b
-isTauTy (PredTy p) = True -- Don't look through source types
-isTauTy other = False
-\end{code}
-
-\begin{code}
+isTauTy (TyVarTy tv) = ASSERT( not (isTcTyVar tv && isBoxyTyVar tv) )
+ True
+isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc
+isTauTy (AppTy a b) = isTauTy a && isTauTy b
+isTauTy (FunTy a b) = isTauTy a && isTauTy b
+isTauTy (PredTy p) = True -- Don't look through source types
+isTauTy other = False
+
+
+isTauTyCon :: TyCon -> Bool
+-- Returns False for type synonyms whose expansion is a polytype
+isTauTyCon tc | isSynTyCon tc = isTauTy (snd (synTyConDefn tc))
+ | otherwise = True
+
+---------------
+isBoxyTy :: TcType -> Bool
+isBoxyTy ty = any isBoxyTyVar (varSetElems (tcTyVarsOfType ty))
+
+isRigidTy :: TcType -> Bool
+-- A type is rigid if it has no meta type variables in it
+isRigidTy ty = all isSkolemTyVar (varSetElems (tcTyVarsOfType ty))
+
+isRefineableTy :: TcType -> Bool
+-- A type should have type refinements applied to it if it has
+-- free type variables, and they are all rigid
+isRefineableTy ty = not (null tc_tvs) && all isSkolemTyVar tc_tvs
+ where
+ tc_tvs = varSetElems (tcTyVarsOfType ty)
+
+---------------
getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
-- construct a dictionary function name
getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty'
(tvs, rho) -> case tcSplitPhiTy rho of
(theta, tau) -> (tvs, theta, tau)
+-----------------------
+tcMultiSplitSigmaTy
+ :: TcSigmaType
+ -> ( [([TyVar], ThetaType)], -- forall as.C => forall bs.D
+ TcSigmaType) -- The rest of the type
+
+-- We need a loop here because we are now prepared to entertain
+-- types like
+-- f:: forall a. Eq a => forall b. Baz b => tau
+-- We want to instantiate this to
+-- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
+
+tcMultiSplitSigmaTy sigma
+ = case (tcSplitSigmaTy sigma) of
+ ([],[],ty) -> ([], sigma)
+ (tvs, theta, ty) -> case tcMultiSplitSigmaTy ty of
+ (pairs, rest) -> ((tvs,theta):pairs, rest)
+
+-----------------------
tcTyConAppTyCon :: Type -> TyCon
tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
-- as tycon applications by the type checker
tcSplitTyConApp_maybe other = Nothing
-tcValidInstHeadTy :: Type -> Bool
--- Used in Haskell-98 mode, for the argument types of an instance head
--- These must not be type synonyms, but everywhere else type synonyms
--- are transparent, so we need a special function here
-tcValidInstHeadTy ty
- = case ty of
- NoteTy _ ty -> tcValidInstHeadTy ty
- TyConApp tc tys -> not (isSynTyCon tc) && ok tys
- FunTy arg res -> ok [arg, res]
- other -> False
- where
- -- Check that all the types are type variables,
- -- and that each is distinct
- ok tys = equalLength tvs tys && hasNoDups tvs
- where
- tvs = mapCatMaybes get_tv tys
-
- get_tv (NoteTy _ ty) = get_tv ty -- through synonyms
- get_tv (TyVarTy tv) = Just tv -- Again, do not look
- get_tv other = Nothing
-
+-----------------------
tcSplitFunTys :: Type -> ([Type], Type)
tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
Nothing -> ([], ty)
tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res)
tcSplitFunTy_maybe other = Nothing
+tcSplitFunTysN
+ :: TcRhoType
+ -> Arity -- N: Number of desired args
+ -> ([TcSigmaType], -- Arg types (N or fewer)
+ TcSigmaType) -- The rest of the type
+
+tcSplitFunTysN ty n_args
+ | n_args == 0
+ = ([], ty)
+ | Just (arg,res) <- tcSplitFunTy_maybe ty
+ = case tcSplitFunTysN res (n_args - 1) of
+ (args, res) -> (arg:args, res)
+ | otherwise
+ = ([], ty)
+
tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
+-----------------------
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty'
tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
Just (ty', arg) -> go ty' (arg:args)
Nothing -> (ty,args)
+-----------------------
tcGetTyVar_maybe :: Type -> Maybe TyVar
tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'
tcGetTyVar_maybe (TyVarTy tv) = Just tv
tcIsTyVarTy :: Type -> Bool
tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
+-----------------------
tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
-- Split the type of a dictionary function
tcSplitDFunTy ty
tcSplitDFunHead tau
= case tcSplitPredTy_maybe tau of
Just (ClassP clas tys) -> (clas, tys)
+
+tcValidInstHeadTy :: Type -> Bool
+-- Used in Haskell-98 mode, for the argument types of an instance head
+-- These must not be type synonyms, but everywhere else type synonyms
+-- are transparent, so we need a special function here
+tcValidInstHeadTy ty
+ = case ty of
+ NoteTy _ ty -> tcValidInstHeadTy ty
+ TyConApp tc tys -> not (isSynTyCon tc) && ok tys
+ FunTy arg res -> ok [arg, res]
+ other -> False
+ where
+ -- Check that all the types are type variables,
+ -- and that each is distinct
+ ok tys = equalLength tvs tys && hasNoDups tvs
+ where
+ tvs = mapCatMaybes get_tv tys
+
+ get_tv (NoteTy _ ty) = get_tv ty -- through synonyms
+ get_tv (TyVarTy tv) = Just tv -- Again, do not look
+ get_tv other = Nothing
\end{code}
\end{code}
-
-
%************************************************************************
%* *
- Hoisting for-alls
+\subsection{Misc}
%* *
%************************************************************************
-hoistForAllTys is used for user-written type signatures only
-We want to 'look through' type synonyms when doing this
-so it's better done on the Type than the HsType
-
-It moves all the foralls and constraints to the top
-e.g. T -> forall a. a ==> forall a. T -> a
- T -> (?x::Int) -> Int ==> (?x::Int) -> T -> Int
-
-Also: it eliminates duplicate constraints. These can show up
-when hoisting constraints, notably implicit parameters.
-
-It tries hard to retain type synonyms if hoisting does not break one
-up. Not only does this improve error messages, but there's a tricky
-interaction with Haskell 98. H98 requires no unsaturated type
-synonyms, which is checked by checkValidType. This runs after
-hoisting, so we don't want hoisting to remove the SynNotes! (We can't
-run validity checking before hoisting because in mutually-recursive
-type definitions we postpone validity checking until after the knot is
-tied.)
-
\begin{code}
-hoistForAllTys :: Type -> Type
-hoistForAllTys ty
- = go ty
-
- where
- go :: Type -> Type
-
- go (TyVarTy tv) = TyVarTy tv
- go ty@(TyConApp tc tys)
- | isSynTyCon tc, any isSigmaTy tys'
- = go (expectJust "hoistForAllTys" (tcView ty))
- -- Revolting special case. If a type synonym has foralls
- -- at the top of its argument, then expanding the type synonym
- -- might lead to more hositing. So we just abandon the synonym
- -- altogether right here.
- -- Note that we must go back to hoistForAllTys, because
- -- expanding the type synonym may expose new binders. Yuk.
- | otherwise
- = TyConApp tc tys'
- where
- tys' = map go tys
- go (PredTy pred) = PredTy pred -- No nested foralls
- go (NoteTy _ ty2) = go ty2 -- Discard the free tyvar note
- go (FunTy arg res) = mk_fun_ty (go arg) (go res)
- go (AppTy fun arg) = AppTy (go fun) (go arg)
- go (ForAllTy tv ty) = ForAllTy tv (go ty)
-
- -- mk_fun_ty does all the work.
- -- It's building t1 -> t2:
- -- if t2 is a for-all type, push t1 inside it
- -- if t2 is (pred -> t3), check for duplicates
- mk_fun_ty ty1 ty2
- | not (isSigmaTy ty2) -- No forall's, or context =>
- = FunTy ty1 ty2
- | PredTy p1 <- ty1 -- ty1 is a predicate
- = if p1 `elem` theta2 then -- so check for duplicates
- ty2
- else
- mkSigmaTy tvs2 (p1:theta2) tau2
- | otherwise
- = mkSigmaTy tvs2 theta2 (FunTy ty1 tau2)
- where
- (tvs2, theta2, tau2) = tcSplitSigmaTy $
- deShadowTy (tyVarsOfType ty1) $
- deNoteType ty2
-
- -- deShadowTy is important. For example:
- -- type Foo r = forall a. a -> r
- -- foo :: Foo (Foo ())
- -- Here the hoisting should give
- -- foo :: forall a a1. a -> a1 -> ()
-
- -- deNoteType is important too, so that the deShadow sees that
- -- synonym expanded! Sigh
+deNoteType :: Type -> Type
+-- Remove all *outermost* type synonyms and other notes
+deNoteType ty | Just ty' <- tcView ty = deNoteType ty'
+deNoteType ty = ty
\end{code}
+\begin{code}
+tcTyVarsOfType :: Type -> TcTyVarSet
+-- Just the tc type variables free in the type
+tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv
+ else emptyVarSet
+tcTyVarsOfType (TyConApp tycon tys) = tcTyVarsOfTypes tys
+tcTyVarsOfType (NoteTy _ ty) = tcTyVarsOfType ty
+tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty
+tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
+tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
+tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar
+ -- We do sometimes quantify over skolem TcTyVars
+
+tcTyVarsOfTypes :: [Type] -> TyVarSet
+tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
+
+tcTyVarsOfPred :: PredType -> TyVarSet
+tcTyVarsOfPred (IParam _ ty) = tcTyVarsOfType ty
+tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys
+\end{code}
-%************************************************************************
-%* *
-\subsection{Misc}
-%* *
-%************************************************************************
+Note [Silly type synonym]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ type T a = Int
+What are the free tyvars of (T x)? Empty, of course!
+Here's the example that Ralf Laemmel showed me:
+ foo :: (forall a. C u a -> C u a) -> u
+ mappend :: Monoid u => u -> u -> u
+
+ bar :: Monoid u => u
+ bar = foo (\t -> t `mappend` t)
+We have to generalise at the arg to f, and we don't
+want to capture the constraint (Monad (C u a)) because
+it appears to mention a. Pretty silly, but it was useful to him.
+
+exactTyVarsOfType is used by the type checker to figure out exactly
+which type variables are mentioned in a type. It's also used in the
+smart-app checking code --- see TcExpr.tcIdApp
\begin{code}
-deNoteType :: Type -> Type
--- Remove *outermost* type synonyms and other notes
-deNoteType ty | Just ty' <- tcView ty = deNoteType ty'
-deNoteType ty = ty
+exactTyVarsOfType :: TcType -> TyVarSet
+-- Find the free type variables (of any kind)
+-- but *expand* type synonyms. See Note [Silly type synonym] belos.
+exactTyVarsOfType ty
+ = go ty
+ where
+ go ty | Just ty' <- tcView ty = go ty' -- This is the key line
+ go (TyVarTy tv) = unitVarSet tv
+ go (TyConApp tycon tys) = exactTyVarsOfTypes tys
+ go (PredTy ty) = go_pred ty
+ go (FunTy arg res) = go arg `unionVarSet` go res
+ go (AppTy fun arg) = go fun `unionVarSet` go arg
+ go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
+
+ go_pred (IParam _ ty) = go ty
+ go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
+
+exactTyVarsOfTypes :: [TcType] -> TyVarSet
+exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
\end{code}
Find the free tycons and classes of a type. This is used in the front
isByteArrayLikeTyCon tc =
getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
\end{code}
-
-
\begin{code}
module TcType where
+import Outputable( SDoc )
data TcTyVarDetails
+pprTcTyVarDetails :: TcTyVarDetails -> SDoc
\end{code}
-- This boot file exists only to tie the knot between
-- TcUnify and TcSimplify
-unifyTauTy :: TcType.TcTauType -> TcType.TcTauType -> TcRnTypes.TcM ()
+unifyType :: TcType.TcTauType -> TcType.TcTauType -> TcRnTypes.TcM ()
+zapToMonotype :: TcType.BoxyType -> TcRnTypes.TcM TcType.TcTauType
\begin{code}
module TcUnify (
-- Full-blown subsumption
- tcSubPat, tcSubExp, tcSub, tcGen,
+ tcSubExp, tcGen,
checkSigTyVars, checkSigTyVarsWrt, bleatEscapedTvs, sigCtxt,
-- Various unifications
- unifyTauTy, unifyTauTyList, unifyTheta,
+ unifyType, unifyTypeList, unifyTheta,
unifyKind, unifyKinds, unifyFunKind,
- checkExpectedKind,
+ checkExpectedKind,
+ boxySubMatchType, boxyMatchTypes,
--------------------------------
-- Holes
- Expected(..), tcInfer, readExpectedType,
- zapExpectedType, zapExpectedTo, zapExpectedBranches,
- subFunTys, unifyFunTys,
- zapToListTy, unifyListTy,
- zapToTyConApp, unifyTyConApp,
- unifyAppTy
+ tcInfer, subFunTys, unBox, stripBoxyType, withBox,
+ boxyUnify, boxyUnifyList, zapToMonotype,
+ boxySplitListTy, boxySplitTyConApp, boxySplitAppTy,
+ wrapFunResCoercion
) where
#include "HsVersions.h"
-import HsSyn ( HsExpr(..) , MatchGroup(..), HsMatchContext(..),
- hsLMatchPats, pprMatches, pprMatchContext )
-import TcHsSyn ( mkHsDictLet, mkHsDictLam,
- ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) )
+import HsSyn ( ExprCoFn(..), idCoercion, isIdCoercion, (<.>) )
import TypeRep ( Type(..), PredType(..) )
+import TcMType ( lookupTcTyVar, LookupTyVarResult(..),
+ tcInstSkolType, newKindVar, newMetaTyVar,
+ tcInstBoxy, newBoxyTyVar, readFilledBox,
+ readMetaTyVar, writeMetaTyVar, newFlexiTyVarTy,
+ tcInstSkolTyVars,
+ zonkTcKind, zonkType, zonkTcType, zonkTcTyVarsAndFV,
+ readKindVar, writeKindVar )
+import TcSimplify ( tcSimplifyCheck )
+import TcEnv ( tcGetGlobalTyVars, findGlobals )
+import TcIface ( checkWiredInTyCon )
import TcRnMonad -- TcType, amongst others
-import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
- TcTyVarSet, TcThetaType, Expected(..), TcTyVarDetails(..),
- SkolemInfo( GenSkol ), MetaDetails(..),
- pprTcTyVar, isTauTy, isSigmaTy, mkFunTy, mkFunTys, mkTyConApp,
- tcSplitAppTy_maybe, tcEqType,
- tyVarsOfType, mkPhiTy, mkTyVarTy, mkPredTy, isMetaTyVar,
- typeKind, tcSplitFunTy_maybe, mkForAllTys, mkAppTy,
+import TcType ( TcKind, TcType, TcTyVar, TcTauType,
+ BoxySigmaType, BoxyRhoType, BoxyType,
+ TcTyVarSet, TcThetaType, TcTyVarDetails(..), BoxInfo(..),
+ SkolemInfo( GenSkol, UnkSkol ), MetaDetails(..), isImmutableTyVar,
+ pprSkolTvBinding, isTauTy, isTauTyCon, isSigmaTy,
+ mkFunTy, mkFunTys, mkTyConApp, isMetaTyVar,
+ tcSplitForAllTys, tcSplitAppTy_maybe, mkTyVarTys,
+ tyVarsOfType, mkPhiTy, mkTyVarTy, mkPredTy,
+ typeKind, mkForAllTys, mkAppTy, isBoxyTyVar,
tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
- pprType, tidyKind, tidySkolemTyVar, isSkolemTyVar, tcView )
+ pprType, tidyKind, tidySkolemTyVar, isSkolemTyVar, tcView,
+ TvSubst, mkTvSubst, zipTyEnv, substTy, emptyTvSubst,
+ lookupTyVar, extendTvSubst )
import Kind ( Kind(..), SimpleKind, KindVar, isArgTypeKind,
- openTypeKind, liftedTypeKind, mkArrowKind,
+ openTypeKind, liftedTypeKind, mkArrowKind, defaultKind,
isOpenTypeKind, argTypeKind, isLiftedTypeKind, isUnliftedTypeKind,
isSubKind, pprKind, splitKindFunTys )
-import Inst ( newDicts, instToId, tcInstCall )
-import TcMType ( condLookupTcTyVar, LookupTyVarResult(..),
- tcSkolType, newKindVar, tcInstTyVars, newMetaTyVar,
- newTyFlexiVarTy, zonkTcKind, zonkType, zonkTcType, zonkTcTyVarsAndFV,
- readKindVar, writeKindVar )
-import TcSimplify ( tcSimplifyCheck )
-import TcIface ( checkWiredInTyCon )
-import TcEnv ( tcGetGlobalTyVars, findGlobals )
-import TyCon ( TyCon, tyConArity, tyConTyVars, isFunTyCon, isSynTyCon,
- getSynTyConDefn )
+import TysPrim ( alphaTy, betaTy )
+import Inst ( newDicts, instToId )
+import TyCon ( TyCon, tyConArity, tyConTyVars, isSynTyCon )
import TysWiredIn ( listTyCon )
import Id ( Id, mkSysLocal )
-import Var ( Var, varName, tyVarKind )
-import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems )
+import Var ( Var, varName, tyVarKind, isTcTyVar, tcTyVarDetails )
+import VarSet ( emptyVarSet, mkVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems,
+ extendVarSet, intersectsVarSet )
import VarEnv
-import Name ( Name, isSystemName, mkSysTvName )
+import Name ( isSystemName )
import ErrUtils ( Message )
-import SrcLoc ( noLoc )
+import Maybes ( fromJust )
import BasicTypes ( Arity )
+import UniqSupply ( uniqsFromSupply )
import Util ( notNull, equalLength )
import Outputable
-\end{code}
-Notes on holes
-~~~~~~~~~~~~~~
-* A hole is always filled in with an ordinary type, not another hole.
+-- Assertion imports
+#ifdef DEBUG
+import TcType ( isBoxyTy, isFlexi )
+#endif
+\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-newHole = newMutVar (error "Empty hole in typechecker")
-
-tcInfer :: (Expected ty -> TcM a) -> TcM (a,ty)
+tcInfer :: (BoxyType -> TcM a) -> TcM (a, TcType)
tcInfer tc_infer
- = do { hole <- newHole
- ; res <- tc_infer (Infer hole)
- ; res_ty <- readMutVar hole
+ = do { box <- newBoxyTyVar
+ ; res <- tc_infer (mkTyVarTy box)
+ ; res_ty <- readFilledBox box -- Guaranteed filled-in by now
; return (res, res_ty) }
-
-readExpectedType :: Expected ty -> TcM ty
-readExpectedType (Infer hole) = readMutVar hole
-readExpectedType (Check ty) = returnM ty
-
-zapExpectedType :: Expected TcType -> Kind -> TcM TcTauType
--- In the inference case, ensure we have a monotype
--- (including an unboxed tuple)
-zapExpectedType (Infer hole) kind
- = do { ty <- newTyFlexiVarTy kind ;
- writeMutVar hole ty ;
- return ty }
-
-zapExpectedType (Check ty) kind
- | typeKind ty `isSubKind` kind = return ty
- | otherwise = do { ty1 <- newTyFlexiVarTy kind
- ; unifyTauTy ty1 ty
- ; return ty }
- -- The unify is to ensure that 'ty' has the desired kind
- -- For example, in (case e of r -> b) we push an OpenTypeKind
- -- type variable
-
-zapExpectedBranches :: MatchGroup id -> Expected TcRhoType -> TcM (Expected TcRhoType)
--- If there is more than one branch in a case expression,
--- and exp_ty is a 'hole', all branches must be types, not type schemes,
--- otherwise the order in which we check them would affect the result.
-zapExpectedBranches (MatchGroup [match] _) exp_ty
- = return exp_ty -- One branch
-zapExpectedBranches matches (Check ty)
- = return (Check ty)
-zapExpectedBranches matches (Infer hole)
- = do { -- Many branches, and inference mode,
- -- so switch to checking mode with a monotype
- ty <- newTyFlexiVarTy openTypeKind
- ; writeMutVar hole ty
- ; return (Check ty) }
-
-zapExpectedTo :: Expected TcType -> TcTauType -> TcM ()
-zapExpectedTo (Check ty1) ty2 = unifyTauTy ty1 ty2
-zapExpectedTo (Infer hole) ty2 = do { ty2' <- zonkTcType ty2; writeMutVar hole ty2' }
- -- See Note [Zonk return type]
-
-instance Outputable ty => Outputable (Expected ty) where
- ppr (Check ty) = ptext SLIT("Expected type") <+> ppr ty
- ppr (Infer hole) = ptext SLIT("Inferring type")
\end{code}
%************************************************************************
%* *
-\subsection[Unify-fun]{@unifyFunTy@}
+ subFunTys
%* *
%************************************************************************
-@subFunTy@ and @unifyFunTy@ is used to avoid the fruitless
-creation of type variables.
-
-* subFunTy is used when we might be faced with a "hole" type variable,
- in which case we should create two new holes.
-
-* unifyFunTy is used when we expect to encounter only "ordinary"
- type variables, so we should create new ordinary type variables
-
\begin{code}
-subFunTys :: HsMatchContext Name
- -> MatchGroup Name
- -> Expected TcRhoType -- Fail if ty isn't a function type
- -> ([Expected TcRhoType] -> Expected TcRhoType -> TcM a)
- -> TcM a
-
-subFunTys ctxt (MatchGroup (match:null_matches) _) (Infer hole) thing_inside
- = -- This is the interesting case
- ASSERT( null null_matches )
- do { pat_holes <- mapM (\ _ -> newHole) (hsLMatchPats match)
- ; res_hole <- newHole
-
- -- Do the business
- ; res <- thing_inside (map Infer pat_holes) (Infer res_hole)
-
- -- Extract the answers
- ; arg_tys <- mapM readMutVar pat_holes
- ; res_ty <- readMutVar res_hole
-
- -- Write the answer into the incoming hole
- ; writeMutVar hole (mkFunTys arg_tys res_ty)
-
- -- And return the answer
- ; return res }
-
-subFunTys ctxt group@(MatchGroup (match:matches) _) (Check ty) thing_inside
- = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
- -- Assertion just checks that all the matches have the same number of pats
- do { (pat_tys, res_ty) <- unifyFunTys msg n_pats ty
- ; thing_inside (map Check pat_tys) (Check res_ty) }
- where
- n_pats = length (hsLMatchPats match)
- msg = case ctxt of
- FunRhs fun -> ptext SLIT("The equation(s) for") <+> quotes (ppr fun)
- <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
- LambdaExpr -> sep [ ptext SLIT("The lambda expression")
- <+> quotes (pprSetDepth 1 $ pprMatches ctxt group),
- -- The pprSetDepth makes the abstraction print briefly
- ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("arguments"))]
- other -> pprPanic "subFunTys" (pprMatchContext ctxt)
-
-
-unifyFunTys :: SDoc -> Arity -> TcRhoType -> TcM ([TcSigmaType], TcRhoType)
--- Fail if ty isn't a function type, otherwise return arg and result types
--- The result types are guaranteed wobbly if the argument is wobbly
---
--- Does not allocate unnecessary meta variables: if the input already is
--- a function, we just take it apart. Not only is this efficient, it's important
--- for (a) higher rank: the argument might be of form
--- (forall a. ty) -> other
--- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd
--- blow up with the meta var meets the forall
+subFunTys :: SDoc -- Somthing like "The function f has 3 arguments"
+ -- or "The abstraction (\x.e) takes 1 argument"
+ -> Arity -- Expected # of args
+ -> BoxyRhoType -- res_ty
+ -> ([BoxySigmaType] -> BoxyRhoType -> TcM a)
+ -> TcM (ExprCoFn, a)
+-- Attempt to decompse res_ty to have enough top-level arrows to
+-- match the number of patterns in the match group
+--
+-- If (subFunTys n_args res_ty thing_inside) = (co_fn, res)
+-- and the inner call to thing_inside passes args: [a1,...,an], b
+-- then co_fn :: (a1 -> ... -> an -> b) -> res_ty
--
--- (b) GADTs: if the argument is not wobbly we do not want the result to be
+-- Note that it takes a BoxyRho type, and guarantees to return a BoxyRhoType
-{-
- Error messages from unifyFunTys
- The first line is passed in as error_herald
+
+{- Error messages from subFunTys
The abstraction `\Just 1 -> ...' has two arguments
but its type `Maybe a -> a' has only one
but its type `Int -> Int' has only one
-}
-unifyFunTys error_herald arity ty
- -- error_herald is the whole first line of the error message above
- = do { (ok, args, res) <- unify_fun_ty True arity ty
- ; if ok then return (args, res)
- else failWithTc (mk_msg (length args)) }
+
+subFunTys error_herald n_pats res_ty thing_inside
+ = loop n_pats [] res_ty
where
- mk_msg n_actual
+ -- In 'loop', the parameter 'arg_tys' accumulates
+ -- the arg types so far, in *reverse order*
+ loop n args_so_far res_ty
+ | Just res_ty' <- tcView res_ty = loop n args_so_far res_ty'
+
+ loop n args_so_far res_ty
+ | isSigmaTy res_ty -- Do this first, because we guarantee to return
+ -- a BoxyRhoType, not a BoxySigmaType
+ = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet $ \ res_ty' ->
+ loop n args_so_far res_ty'
+ ; return (gen_fn <.> co_fn, res) }
+
+ loop 0 args_so_far res_ty = do { res <- thing_inside (reverse args_so_far) res_ty
+ ; return (idCoercion, res) }
+ loop n args_so_far (FunTy arg_ty res_ty)
+ = do { (co_fn, res) <- loop (n-1) (arg_ty:args_so_far) res_ty
+ ; co_fn' <- wrapFunResCoercion [arg_ty] co_fn
+ ; return (co_fn', res) }
+
+ loop n args_so_far (TyVarTy tv)
+ | not (isImmutableTyVar tv)
+ = do { cts <- readMetaTyVar tv
+ ; case cts of
+ Indirect ty -> loop n args_so_far ty
+ Flexi -> do { (res_ty:arg_tys) <- withMetaTvs tv kinds mk_res_ty
+ ; res <- thing_inside (reverse args_so_far ++ arg_tys) res_ty
+ ; return (idCoercion, res) } }
+ where
+ mk_res_ty (res_ty' : arg_tys') = mkFunTys arg_tys' res_ty'
+ kinds = openTypeKind : take n (repeat argTypeKind)
+ -- Note argTypeKind: the args can have an unboxed type,
+ -- but not an unboxed tuple.
+
+ loop n args_so_far res_ty
+ = failWithTc (mk_msg (length args_so_far))
+
+ mk_msg n_actual
= error_herald <> comma $$
- sep [ptext SLIT("but its type") <+> quotes (pprType ty),
+ sep [ptext SLIT("but its type") <+> quotes (pprType res_ty),
if n_actual == 0 then ptext SLIT("has none")
else ptext SLIT("has only") <+> speakN n_actual]
-
-unify_fun_ty :: Bool -> Arity -> TcRhoType
- -> TcM (Bool, -- Arity satisfied?
- [TcSigmaType], -- Arg types found; length <= arity
- TcRhoType) -- Result type
-
-unify_fun_ty use_refinement arity ty
- | arity == 0
- = do { res_ty <- wobblify use_refinement ty
- ; return (True, [], ty) }
-
-unify_fun_ty use_refinement arity ty
- | Just ty' <- tcView ty
- = unify_fun_ty use_refinement arity ty'
-
-unify_fun_ty use_refinement arity ty@(TyVarTy tv)
- = do { details <- condLookupTcTyVar use_refinement tv
- ; case details of
- IndirectTv use' ty' -> unify_fun_ty use' arity ty'
- DoneTv (MetaTv ref) -> ASSERT( liftedTypeKind `isSubKind` tyVarKind tv )
- -- The argument to unifyFunTys is always a type
- -- Occurs check can't happen, of course
- do { args <- mappM newTyFlexiVarTy (replicate arity argTypeKind)
- ; res <- newTyFlexiVarTy openTypeKind
- ; writeMutVar ref (Indirect (mkFunTys args res))
- ; return (True, args, res) }
- DoneTv skol -> return (False, [], ty)
- }
-
-unify_fun_ty use_refinement arity ty
- | Just (arg,res) <- tcSplitFunTy_maybe ty
- = do { arg' <- wobblify use_refinement arg
- ; (ok, args', res') <- unify_fun_ty use_refinement (arity-1) res
- ; return (ok, arg':args', res') }
-
-unify_fun_ty use_refinement arity ty
--- Common cases are all done by now
--- At this point we usually have an error, but ty could
--- be (a Int Bool), or (a Bool), which can match
--- So just use the unifier. But catch any error so we just
--- return the success/fail boolean
- = do { arg <- newTyFlexiVarTy argTypeKind
- ; res <- newTyFlexiVarTy openTypeKind
- ; let fun_ty = mkFunTy arg res
- ; (_, mb_unit) <- tryTc (uTys True ty ty True fun_ty fun_ty)
- ; case mb_unit of {
- Nothing -> return (False, [], ty) ;
- Just _ ->
- do { (ok, args', res') <- unify_fun_ty use_refinement (arity-1) res
- ; return (ok, arg:args', res')
- } } }
\end{code}
\begin{code}
----------------------
-zapToTyConApp :: TyCon -- T :: k1 -> ... -> kn -> *
- -> Expected TcSigmaType -- Expected type (T a b c)
- -> TcM [TcType] -- Element types, a b c
- -- Insists that the Expected type is not a forall-type
+boxySplitTyConApp :: TyCon -- T :: k1 -> ... -> kn -> *
+ -> BoxyRhoType -- Expected type (T a b c)
+ -> TcM [BoxySigmaType] -- Element types, a b c
-- It's used for wired-in tycons, so we call checkWiredInTyCOn
-- Precondition: never called with FunTyCon
-zapToTyConApp tc (Check ty)
- = ASSERT( not (isFunTyCon tc) ) -- Never called with FunTyCon
- do { checkWiredInTyCon tc ; unifyTyConApp tc ty } -- NB: fails for a forall-type
-
-zapToTyConApp tc (Infer hole)
- = do { (_, elt_tys, _) <- tcInstTyVars (tyConTyVars tc)
- ; let tc_app = mkTyConApp tc elt_tys
- ; writeMutVar hole tc_app
- ; traceTc (text "zap" <+> ppr tc)
- ; checkWiredInTyCon tc
- ; return elt_tys }
-
-zapToListTy :: Expected TcType -> TcM TcType -- Special case for lists
-zapToListTy exp_ty = do { [elt_ty] <- zapToTyConApp listTyCon exp_ty
- ; return elt_ty }
-
-----------------------
-unifyTyConApp :: TyCon -> TcType -> TcM [TcType]
-unifyTyConApp tc ty
- = ASSERT( not (isFunTyCon tc) ) -- Never called with FunTyCon
- unify_tc_app (tyConArity tc) True tc ty
- -- Add a boolean flag to remember whether
- -- to use the type refinement or not
-
-unifyListTy :: TcType -> TcM TcType -- Special case for lists
-unifyListTy exp_ty = do { [elt_ty] <- unifyTyConApp listTyCon exp_ty
- ; return elt_ty }
+ -- Precondition: input type :: *
-----------
-unify_tc_app n_args use_refinement tc ty
- | Just ty' <- tcView ty
- = unify_tc_app n_args use_refinement tc ty'
-
-unify_tc_app n_args use_refinement tc (TyConApp tycon arg_tys)
- | tycon == tc
- = ASSERT( n_args == length arg_tys ) -- ty::*
- mapM (wobblify use_refinement) arg_tys
-
-unify_tc_app n_args use_refinement tc (AppTy fun_ty arg_ty)
- = do { arg_ty' <- wobblify use_refinement arg_ty
- ; arg_tys <- unify_tc_app (n_args - 1) use_refinement tc fun_ty
- ; return (arg_tys ++ [arg_ty']) }
-
-unify_tc_app n_args use_refinement tc ty@(TyVarTy tyvar)
- = do { traceTc (text "unify_tc_app: tyvar" <+> pprTcTyVar tyvar)
- ; details <- condLookupTcTyVar use_refinement tyvar
- ; case details of
- IndirectTv use' ty' -> unify_tc_app n_args use' tc ty'
- other -> unify_tc_app_help n_args tc ty
+boxySplitTyConApp tc orig_ty
+ = do { checkWiredInTyCon tc
+ ; loop (tyConArity tc) [] orig_ty }
+ where
+ loop n_req args_so_far ty
+ | Just ty' <- tcView ty = loop n_req args_so_far ty'
+
+ loop n_req args_so_far (TyConApp tycon args)
+ | tc == tycon
+ = ASSERT( n_req == length args) -- ty::*
+ return (args ++ args_so_far)
+
+ loop n_req args_so_far (AppTy fun arg)
+ = loop (n_req - 1) (arg:args_so_far) fun
+
+ loop n_req args_so_far (TyVarTy tv)
+ | not (isImmutableTyVar tv)
+ = do { cts <- readMetaTyVar tv
+ ; case cts of
+ Indirect ty -> loop n_req args_so_far ty
+ Flexi -> do { arg_tys <- withMetaTvs tv arg_kinds mk_res_ty
+ ; return (arg_tys ++ args_so_far) }
}
+ where
+ mk_res_ty arg_tys' = mkTyConApp tc arg_tys'
+ arg_kinds = map tyVarKind (take n_req (tyConTyVars tc))
-unify_tc_app n_args use_refinement tc ty = unify_tc_app_help n_args tc ty
+ loop _ _ _ = boxySplitFailure (mkTyConApp tc (mkTyVarTys (tyConTyVars tc))) orig_ty
-unify_tc_app_help n_args tc ty -- Revert to ordinary unification
- = do { (_, elt_tys, _) <- tcInstTyVars (take n_args (tyConTyVars tc))
- ; let tc_app = mkTyConApp tc elt_tys
- ; if not (isTauTy ty) then -- Can happen if we call zapToTyConApp tc (forall a. ty)
- unifyMisMatch ty tc_app
- else do
- { unifyTauTy ty tc_app
- ; returnM elt_tys } }
+----------------------
+boxySplitListTy :: BoxyRhoType -> TcM BoxySigmaType -- Special case for lists
+boxySplitListTy exp_ty = do { [elt_ty] <- boxySplitTyConApp listTyCon exp_ty
+ ; return elt_ty }
----------------------
-unifyAppTy :: TcType -- Type to split: m a
- -> TcM (TcType, TcType) -- (m,a)
--- Assumes (m:*->*)
+boxySplitAppTy :: BoxyRhoType -- Type to split: m a
+ -> TcM (BoxySigmaType, BoxySigmaType) -- Returns m, a
+-- Assumes (m: * -> k), where k is the kind of the incoming type
+-- If the incoming type is boxy, then so are the result types; and vice versa
-unifyAppTy ty = unify_app_ty True ty
+boxySplitAppTy orig_ty
+ = loop orig_ty
+ where
+ loop ty
+ | Just ty' <- tcView ty = loop ty'
+
+ loop ty
+ | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
+ = return (fun_ty, arg_ty)
+
+ loop (TyVarTy tv)
+ | not (isImmutableTyVar tv)
+ = do { cts <- readMetaTyVar tv
+ ; case cts of
+ Indirect ty -> loop ty
+ Flexi -> do { [fun_ty,arg_ty] <- withMetaTvs tv kinds mk_res_ty
+ ; return (fun_ty, arg_ty) } }
+ where
+ mk_res_ty [fun_ty', arg_ty'] = mkAppTy fun_ty' arg_ty'
+ tv_kind = tyVarKind tv
+ kinds = [mkArrowKind liftedTypeKind (defaultKind tv_kind),
+ -- m :: * -> k
+ liftedTypeKind] -- arg type :: *
+ -- The defaultKind is a bit smelly. If you remove it,
+ -- try compiling f x = do { x }
+ -- and you'll get a kind mis-match. It smells, but
+ -- not enough to lose sleep over.
+
+ loop _ = boxySplitFailure (mkAppTy alphaTy betaTy) orig_ty
-unify_app_ty use ty
- | Just ty' <- tcView ty = unify_app_ty use ty'
+------------------
+boxySplitFailure actual_ty expected_ty
+ = unifyMisMatch False actual_ty expected_ty
+\end{code}
-unify_app_ty use ty@(TyVarTy tyvar)
- = do { details <- condLookupTcTyVar use tyvar
- ; case details of
- IndirectTv use' ty' -> unify_app_ty use' ty'
- other -> unify_app_ty_help ty
- }
-unify_app_ty use ty
- | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
- = do { fun' <- wobblify use fun_ty
- ; arg' <- wobblify use arg_ty
- ; return (fun', arg') }
+--------------------------------
+-- withBoxes: the key utility function
+--------------------------------
- | otherwise = unify_app_ty_help ty
+\begin{code}
+withMetaTvs :: TcTyVar -- An unfilled-in, non-skolem, meta type variable
+ -> [Kind] -- Make fresh boxes (with the same BoxTv/TauTv setting as tv)
+ -> ([BoxySigmaType] -> BoxySigmaType)
+ -- Constructs the type to assign
+ -- to the original var
+ -> TcM [BoxySigmaType] -- Return the fresh boxes
+
+-- It's entirely possible for the [kind] to be empty.
+-- For example, when pattern-matching on True,
+-- we call boxySplitTyConApp passing a boolTyCon
+
+-- Invariant: tv is still Flexi
+
+withMetaTvs tv kinds mk_res_ty
+ | isBoxyTyVar tv
+ = do { box_tvs <- mapM (newMetaTyVar BoxTv) kinds
+ ; let box_tys = mkTyVarTys box_tvs
+ ; writeMetaTyVar tv (mk_res_ty box_tys)
+ ; return box_tys }
+
+ | otherwise -- Non-boxy meta type variable
+ = do { tau_tys <- mapM newFlexiTyVarTy kinds
+ ; writeMetaTyVar tv (mk_res_ty tau_tys) -- Write it *first*
+ -- Sure to be a tau-type
+ ; return tau_tys }
+
+withBox :: Kind -> (BoxySigmaType -> TcM a) -> TcM (a, TcType)
+-- Allocate a *boxy* tyvar
+withBox kind thing_inside
+ = do { box_tv <- newMetaTyVar BoxTv kind
+ ; res <- thing_inside (mkTyVarTy box_tv)
+ ; ty <- readFilledBox box_tv
+ ; return (res, ty) }
+\end{code}
-unify_app_ty_help ty -- Revert to ordinary unification
- = do { fun_ty <- newTyFlexiVarTy (mkArrowKind liftedTypeKind liftedTypeKind)
- ; arg_ty <- newTyFlexiVarTy liftedTypeKind
- ; unifyTauTy (mkAppTy fun_ty arg_ty) ty
- ; return (fun_ty, arg_ty) }
+%************************************************************************
+%* *
+ Approximate boxy matching
+%* *
+%************************************************************************
-----------------------
-wobblify :: Bool -- True <=> don't wobblify
- -> TcTauType
- -> TcM TcTauType
--- Return a wobbly type. At the moment we do that by
--- allocating a fresh meta type variable.
-wobblify True ty = return ty -- Don't wobblify
-
-wobblify False ty@(TyVarTy tv)
- | isMetaTyVar tv = return ty -- Already wobbly
-
-wobblify False ty = do { uniq <- newUnique
- ; tv <- newMetaTyVar (mkSysTvName uniq FSLIT("w"))
- (typeKind ty)
- (Indirect ty)
- ; return (mkTyVarTy tv) }
+\begin{code}
+boxySubMatchType
+ :: TcTyVarSet -> TcType -- The "template"; the tyvars are skolems
+ -> BoxyRhoType -- Type to match (note a *Rho* type)
+ -> TvSubst -- Substitution of the [TcTyVar] to BoxySigmaTypes
+
+boxyMatchTypes
+ :: TcTyVarSet -> [TcType] -- The "template"; the tyvars are skolems
+ -> [BoxySigmaType] -- Type to match
+ -> TvSubst -- Substitution of the [TcTyVar] to BoxySigmaTypes
+
+-- Find a *boxy* substitution that makes the template look as much
+-- like the BoxySigmaType as possible.
+-- It's always ok to return an empty substitution;
+-- anything more is jam on the pudding
+--
+-- NB1: This is a pure, non-monadic function.
+-- It does no unification, and cannot fail
+--
+-- Note [Matching kinds]
+-- The target type might legitimately not be a sub-kind of template.
+-- For example, suppose the target is simply a box with an OpenTypeKind,
+-- and the template is a type variable with LiftedTypeKind.
+-- Then it's ok (because the target type will later be refined).
+-- We simply don't bind the template type variable.
+--
+-- It might also be that the kind mis-match is an error. For example,
+-- suppose we match the template (a -> Int) against (Int# -> Int),
+-- where the template type variable 'a' has LiftedTypeKind. This
+-- matching function does not fail; it simply doesn't bind the template.
+-- Later stuff will fail.
+--
+-- Precondition: the arg lengths are equal
+-- Precondition: none of the template type variables appear in the [BoxySigmaType]
+-- Precondition: any nested quantifiers in either type differ from
+-- the template type variables passed as arguments
+--
+-- Note [Sub-match]
+-- ~~~~~~~~~~~~~~~~
+-- Consider this
+-- head :: [a] -> a
+-- |- head xs : <rhobox>
+-- We will do a boxySubMatchType between a ~ <rhobox>
+-- But we *don't* want to match [a |-> <rhobox>] because
+-- (a) The box should be filled in with a rho-type, but
+-- but the returned substitution maps TyVars to boxy *sigma*
+-- types
+-- (b) In any case, the right final answer might be *either*
+-- instantiate 'a' with a rho-type or a sigma type
+-- head xs : Int vs head xs : forall b. b->b
+-- So the matcher MUST NOT make a choice here. In general, we only
+-- bind a template type variable in boxyMatchType, not in boxySubMatchType.
+
+boxySubMatchType tmpl_tvs tmpl_ty boxy_ty
+ = go tmpl_ty boxy_ty
+ where
+ go t_ty b_ty
+ | Just t_ty' <- tcView t_ty = go t_ty' b_ty
+ | Just b_ty' <- tcView b_ty = go t_ty b_ty'
+
+ go (FunTy arg1 res1) (FunTy arg2 res2)
+ = do_match arg1 arg2 (go res1 res2)
+ -- Match the args, and sub-match the results
+
+ go (TyVarTy _) b_ty = emptyTvSubst -- Do not bind! See Note [Sub-match]
+
+ go t_ty b_ty = do_match t_ty b_ty emptyTvSubst -- Otherwise we are safe to bind
+
+ do_match t_ty b_ty subst = boxy_match tmpl_tvs t_ty emptyVarSet b_ty subst
+
+------------
+boxyMatchTypes tmpl_tvs tmpl_tys boxy_tys
+ = ASSERT( length tmpl_tys == length boxy_tys )
+ boxy_match_s tmpl_tvs tmpl_tys emptyVarSet boxy_tys emptyTvSubst
+ -- ToDo: add error context?
+
+boxy_match_s tmpl_tvs [] boxy_tvs [] subst
+ = subst
+boxy_match_s tmpl_tvs (t_ty:t_tys) boxy_tvs (b_ty:b_tys) subst
+ = boxy_match_s tmpl_tvs t_tys boxy_tvs b_tys $
+ boxy_match tmpl_tvs t_ty boxy_tvs b_ty subst
+
+------------
+boxy_match :: TcTyVarSet -> TcType -- Template
+ -> TcTyVarSet -- boxy_tvs: do not bind template tyvars to any of these
+ -> BoxySigmaType -- Match against this type
+ -> TvSubst
+ -> TvSubst
+
+-- The boxy_tvs argument prevents this match:
+-- [a] forall b. a ~ forall b. b
+-- We don't want to bind the template variable 'a'
+-- to the quantified type variable 'b'!
+
+boxy_match tmpl_tvs orig_tmpl_ty boxy_tvs orig_boxy_ty subst
+ = go orig_tmpl_ty orig_boxy_ty
+ where
+ go t_ty b_ty
+ | Just t_ty' <- tcView t_ty = go t_ty' b_ty
+ | Just b_ty' <- tcView b_ty = go t_ty b_ty'
+
+ go (ForAllTy _ ty1) (ForAllTy tv2 ty2)
+ = boxy_match tmpl_tvs ty1 (boxy_tvs `extendVarSet` tv2) ty2 subst
+
+ go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+ | tc1 == tc2 = go_s tys1 tys2
+
+ go (FunTy arg1 res1) (FunTy arg2 res2)
+ = go_s [arg1,res1] [arg2,res2]
+
+ go t_ty b_ty
+ | Just (s1,t1) <- tcSplitAppTy_maybe t_ty,
+ Just (s2,t2) <- tcSplitAppTy_maybe b_ty,
+ typeKind t2 `isSubKind` typeKind t1 -- Maintain invariant
+ = go_s [s1,t1] [s2,t2]
+
+ go (TyVarTy tv) b_ty
+ | tv `elemVarSet` tmpl_tvs -- Template type variable in the template
+ , not (intersectsVarSet boxy_tvs (tyVarsOfType orig_boxy_ty))
+ , typeKind b_ty `isSubKind` tyVarKind tv
+ = extendTvSubst subst tv boxy_ty'
+ where
+ boxy_ty' = case lookupTyVar subst tv of
+ Nothing -> orig_boxy_ty
+ Just ty -> ty `boxyLub` orig_boxy_ty
+
+ go _ _ = subst -- Always safe
+
+ --------
+ go_s tys1 tys2 = boxy_match_s tmpl_tvs tys1 boxy_tvs tys2 subst
+
+
+boxyLub :: BoxySigmaType -> BoxySigmaType -> BoxySigmaType
+-- Combine boxy information from the two types
+-- If there is a conflict, return the first
+boxyLub orig_ty1 orig_ty2
+ = go orig_ty1 orig_ty2
+ where
+ go (AppTy f1 a1) (AppTy f2 a2) = AppTy (boxyLub f1 f2) (boxyLub a1 a2)
+ go (FunTy f1 a1) (FunTy f2 a2) = AppTy (boxyLub f1 f2) (boxyLub a1 a2)
+ go (TyConApp tc1 ts1) (TyConApp tc2 ts2)
+ | tc1 == tc2, length ts1 == length ts2
+ = TyConApp tc1 (zipWith boxyLub ts1 ts2)
+
+ go (TyVarTy tv1) ty2 -- This is the whole point;
+ | isTcTyVar tv1, isMetaTyVar tv1 -- choose ty2 if ty2 is a box
+ = ty2
+
+ -- Look inside type synonyms, but only if the naive version fails
+ go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2
+ | Just ty2' <- tcView ty1 = go ty1 ty2'
+
+ -- For now, we don't look inside ForAlls, PredTys
+ go ty1 ty2 = orig_ty1 -- Default
\end{code}
%************************************************************************
%* *
-\subsection{Subsumption}
+ Subsumption checking
%* *
%************************************************************************
expected_ty.
\begin{code}
------------------------
--- tcSubExp is used for expressions
-tcSubExp :: Expected TcRhoType -> TcRhoType -> TcM ExprCoFn
-
-tcSubExp (Infer hole) offered_ty
- = do { offered' <- zonkTcType offered_ty
- -- Note [Zonk return type]
- -- zonk to take advantage of the current GADT type refinement.
- -- If we don't we get spurious "existential type variable escapes":
- -- case (x::Maybe a) of
- -- Just b (y::b) -> y
- -- We need the refinement [b->a] to be applied to the result type
- ; writeMutVar hole offered'
- ; return idCoercion }
-
-tcSubExp (Check expected_ty) offered_ty
- = tcSub expected_ty offered_ty
-
------------------------
--- tcSubPat is used for patterns
-tcSubPat :: TcSigmaType -- Pattern type signature
- -> Expected TcSigmaType -- Type from context
- -> TcM ()
--- In patterns we insist on an exact match; hence no CoFn returned
--- See Note [Pattern coercions] in TcPat
--- However, we can't call unify directly, because both types might be
--- polymorphic; hence the call to tcSub, followed by a check for
--- equal types. (We can't just check for the identity coercion, because
--- in the polymorphic case we might get back something eta-equivalent to
--- the identity coercion, but that's not easy to tell.)
-
-tcSubPat sig_ty (Infer hole)
- = do { sig_ty' <- zonkTcType sig_ty
- ; writeMutVar hole sig_ty' -- See notes with tcSubExp above
- ; return () }
-
--- This tcSub followed by tcEqType checks for identical types
--- It'd be done more neatly by augmenting the unifier to deal with
--- (identically shaped) for-all types.
-
-tcSubPat sig_ty (Check exp_ty)
- = do { co_fn <- tcSub sig_ty exp_ty
- ; sig_ty' <- zonkTcType sig_ty
- ; exp_ty' <- zonkTcType exp_ty
- ; if tcEqType sig_ty' exp_ty' then
- return ()
- else do
- { (env, msg) <- misMatchMsg sig_ty' exp_ty'
- ; failWithTcM (env, msg $$ extra) } }
- where
- extra | isTauTy sig_ty = empty
- | otherwise = ptext SLIT("Polymorphic types must match exactly in patterns")
-\end{code}
-
-
-
-%************************************************************************
-%* *
- tcSub: main subsumption-check code
-%* *
-%************************************************************************
-
-No holes expected now. Add some error-check context info.
-
-\begin{code}
-----------------
-tcSub :: TcSigmaType -> TcSigmaType -> TcM ExprCoFn -- Locally used only
- -- tcSub exp act checks that
+tcSubExp :: BoxySigmaType -> BoxySigmaType -> TcM ExprCoFn -- Locally used only
+ -- (tcSub act exp) checks that
-- act <= exp
-tcSub expected_ty actual_ty
+tcSubExp actual_ty expected_ty
= traceTc (text "tcSub" <+> details) `thenM_`
- addErrCtxtM (unifyCtxt "type" expected_ty actual_ty)
- (tc_sub expected_ty expected_ty actual_ty actual_ty)
+ addErrCtxtM (unifyCtxt "type" actual_ty expected_ty)
+ (tc_sub actual_ty actual_ty expected_ty expected_ty)
where
details = vcat [text "Expected:" <+> ppr expected_ty,
text "Actual: " <+> ppr actual_ty]
-----------------
-tc_sub :: TcSigmaType -- expected_ty, before expanding synonyms
- -> TcSigmaType -- ..and after
- -> TcSigmaType -- actual_ty, before
- -> TcSigmaType -- ..and after
+tc_sub :: BoxySigmaType -- actual_ty, before expanding synonyms
+ -> BoxySigmaType -- ..and after
+ -> BoxySigmaType -- expected_ty, before
+ -> BoxySigmaType -- ..and after
-> TcM ExprCoFn
+tc_sub act_sty act_ty exp_sty exp_ty
+ | Just exp_ty' <- tcView exp_ty = tc_sub act_sty act_ty exp_sty exp_ty'
+tc_sub act_sty act_ty exp_sty exp_ty
+ | Just act_ty' <- tcView act_ty = tc_sub act_sty act_ty' exp_sty exp_ty
+
-----------------------------------
--- Expand synonyms
-tc_sub exp_sty exp_ty act_sty act_ty
- | Just exp_ty' <- tcView exp_ty = tc_sub exp_sty exp_ty' act_sty act_ty
-tc_sub exp_sty exp_ty act_sty act_ty
- | Just act_ty' <- tcView act_ty = tc_sub exp_sty exp_ty act_sty act_ty'
+-- Rule SBOXY, plus other cases when act_ty is a type variable
+-- Just defer to boxy matching
+-- This rule takes precedence over SKOL!
+tc_sub act_sty (TyVarTy tv) exp_sty exp_ty
+ = do { uVar False tv False exp_sty exp_ty
+ ; return idCoercion }
-----------------------------------
--- Generalisation case
+-- Skolemisation case (rule SKOL)
-- actual_ty: d:Eq b => b->b
-- expected_ty: forall a. Ord a => a->a
-- co_fn e /\a. \d2:Ord a. let d = eqFromOrd d2 in e
-- g :: Ord b => b->b
-- Consider f g !
-tc_sub exp_sty expected_ty act_sty actual_ty
- | isSigmaTy expected_ty
- = tcGen expected_ty (tyVarsOfType actual_ty) (
- -- It's really important to check for escape wrt the free vars of
- -- both expected_ty *and* actual_ty
- \ body_exp_ty -> tc_sub body_exp_ty body_exp_ty act_sty actual_ty
- ) `thenM` \ (gen_fn, co_fn) ->
- returnM (gen_fn <.> co_fn)
+tc_sub act_sty act_ty exp_sty exp_ty
+ | isSigmaTy exp_ty
+ = do { (gen_fn, co_fn) <- tcGen exp_ty act_tvs $ \ body_exp_ty ->
+ tc_sub act_sty act_ty body_exp_ty body_exp_ty
+ ; return (gen_fn <.> co_fn) }
+ where
+ act_tvs = tyVarsOfType act_ty
+ -- It's really important to check for escape wrt the free vars of
+ -- both expected_ty *and* actual_ty
-----------------------------------
--- Specialisation case:
+-- Specialisation case (rule ASPEC):
-- actual_ty: forall a. Ord a => a->a
-- expected_ty: Int -> Int
-- co_fn e = e Int dOrdInt
-tc_sub exp_sty expected_ty act_sty actual_ty
+tc_sub act_sty actual_ty exp_sty expected_ty
| isSigmaTy actual_ty
- = tcInstCall InstSigOrigin actual_ty `thenM` \ (inst_fn, _, body_ty) ->
- tc_sub exp_sty expected_ty body_ty body_ty `thenM` \ co_fn ->
- returnM (co_fn <.> inst_fn)
-
------------------------------------
--- Function case
-
-tc_sub _ (FunTy exp_arg exp_res) _ (FunTy act_arg act_res)
- = tcSub_fun exp_arg exp_res act_arg act_res
+ = do { (tyvars, theta, tau) <- tcInstBoxy actual_ty
+ ; dicts <- newDicts InstSigOrigin theta
+ ; extendLIEs dicts
+ ; let inst_fn = CoApps (CoTyApps CoHole (mkTyVarTys tyvars))
+ (map instToId dicts)
+ ; co_fn <- tc_sub tau tau exp_sty expected_ty
+ ; return (co_fn <.> inst_fn) }
-----------------------------------
--- Type variable meets function: imitate
---
--- NB 1: we can't just unify the type variable with the type
--- because the type might not be a tau-type, and we aren't
--- allowed to instantiate an ordinary type variable with
--- a sigma-type
---
--- NB 2: can we short-cut to an error case?
--- when the arg/res is not a tau-type?
--- NO! e.g. f :: ((forall a. a->a) -> Int) -> Int
--- then x = (f,f)
--- is perfectly fine, because we can instantiate f's type to a monotype
---
--- However, we get can get jolly unhelpful error messages.
--- e.g. foo = id runST
---
--- Inferred type is less polymorphic than expected
--- Quantified type variable `s' escapes
--- Expected type: ST s a -> t
--- Inferred type: (forall s1. ST s1 a) -> a
--- In the first argument of `id', namely `runST'
--- In a right-hand side of function `foo': id runST
---
--- I'm not quite sure what to do about this!
-
-tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ act_ty
- = do { (act_arg, act_res) <- unify_fun act_ty
- ; tcSub_fun exp_arg exp_res act_arg act_res }
+-- Function case (rule F1)
+tc_sub _ (FunTy act_arg act_res) _ (FunTy exp_arg exp_res)
+ = tc_sub_funs act_arg act_res exp_arg exp_res
+
+-- Function case (rule F2)
+tc_sub act_sty act_ty@(FunTy act_arg act_res) exp_sty (TyVarTy exp_tv)
+ | isBoxyTyVar exp_tv
+ = do { cts <- readMetaTyVar exp_tv
+ ; case cts of
+ Indirect ty -> do { u_tys False act_sty act_ty True exp_sty ty
+ ; return idCoercion }
+ Flexi -> do { [arg_ty,res_ty] <- withMetaTvs exp_tv fun_kinds mk_res_ty
+ ; tc_sub_funs act_arg act_res arg_ty res_ty } }
+ where
+ mk_res_ty [arg_ty', res_ty'] = mkFunTy arg_ty' res_ty'
+ fun_kinds = [argTypeKind, openTypeKind]
+
+-- Everything else: defer to boxy matching
+tc_sub act_sty actual_ty exp_sty expected_ty
+ = do { u_tys False act_sty actual_ty False exp_sty expected_ty
+ ; return idCoercion }
-tc_sub _ exp_ty act_sty act_ty@(FunTy act_arg act_res)
- = do { (exp_arg, exp_res) <- unify_fun exp_ty
- ; tcSub_fun exp_arg exp_res act_arg act_res }
-----------------------------------
--- Unification case
--- If none of the above match, we revert to the plain unifier
-tc_sub exp_sty expected_ty act_sty actual_ty
- = uTys True exp_sty expected_ty True act_sty actual_ty `thenM_`
- returnM idCoercion
+tc_sub_funs act_arg act_res exp_arg exp_res
+ = do { uTys False act_arg False exp_arg
+ ; co_fn_res <- tc_sub act_res act_res exp_res exp_res
+ ; wrapFunResCoercion [exp_arg] co_fn_res }
-----------------------------------
--- A helper to make a function type match
--- The error message isn't very good, but that's a problem with
--- all of this subsumption code
-unify_fun ty
- = do { (ok, args, res) <- unify_fun_ty True 1 ty
- ; if ok then return (head args, res)
- else failWithTc (ptext SLIT("Expecting a function type, but found") <+> quotes (ppr ty))}
-\end{code}
-
-\begin{code}
-tcSub_fun exp_arg exp_res act_arg act_res
- = tc_sub act_arg act_arg exp_arg exp_arg `thenM` \ co_fn_arg ->
- tc_sub exp_res exp_res act_res act_res `thenM` \ co_fn_res ->
- newUnique `thenM` \ uniq ->
- let
- -- co_fn_arg :: HsExpr exp_arg -> HsExpr act_arg
- -- co_fn_res :: HsExpr act_res -> HsExpr exp_res
- -- co_fn :: HsExpr (act_arg -> act_res) -> HsExpr (exp_arg -> exp_res)
- arg_id = mkSysLocal FSLIT("sub") uniq exp_arg
- coercion | isIdCoercion co_fn_arg,
- isIdCoercion co_fn_res = idCoercion
- | otherwise = mkCoercion co_fn
-
- co_fn e = DictLam [arg_id]
- (noLoc (co_fn_res <$> (HsApp (noLoc e) (noLoc (co_fn_arg <$> HsVar arg_id)))))
- -- Slight hack; using a "DictLam" to get an ordinary simple lambda
- -- HsVar arg_id :: HsExpr exp_arg
- -- co_fn_arg $it :: HsExpr act_arg
- -- HsApp e $it :: HsExpr act_res
- -- co_fn_res $it :: HsExpr exp_res
- in
- returnM coercion
+wrapFunResCoercion
+ :: [TcType] -- Type of args
+ -> ExprCoFn -- HsExpr a -> HsExpr b
+ -> TcM ExprCoFn -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b)
+wrapFunResCoercion arg_tys co_fn_res
+ | isIdCoercion co_fn_res = return idCoercion
+ | null arg_tys = return co_fn_res
+ | otherwise
+ = do { us <- newUniqueSupply
+ ; let arg_ids = zipWith (mkSysLocal FSLIT("sub")) (uniqsFromSupply us) arg_tys
+ ; return (CoLams arg_ids (co_fn_res <.> (CoApps CoHole arg_ids))) }
\end{code}
+
%************************************************************************
%* *
\subsection{Generalisation}
%************************************************************************
\begin{code}
-tcGen :: TcSigmaType -- expected_ty
+tcGen :: BoxySigmaType -- expected_ty
-> TcTyVarSet -- Extra tyvars that the universally
-- quantified tyvars of expected_ty
-- must not be unified
- -> (TcRhoType -> TcM result) -- spec_ty
+ -> (BoxyRhoType -> TcM result) -- spec_ty
-> TcM (ExprCoFn, result)
-- The expression has type: spec_ty -> expected_ty
-- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
-- Hence the tiresome but innocuous fixM
((forall_tvs, theta, rho_ty), skol_info) <- fixM (\ ~(_, skol_info) ->
- do { (forall_tvs, theta, rho_ty) <- tcSkolType skol_info expected_ty
+ do { (forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
; span <- getSrcSpanM
; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty) span
; return ((forall_tvs, theta, rho_ty), skol_info) })
-- 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.
- dict_ids = map instToId dicts
- co_fn e = TyLam forall_tvs (mkHsDictLam dict_ids (mkHsDictLet inst_binds (noLoc e)))
- ; returnM (mkCoercion co_fn, result) }
+ dict_ids = map instToId dicts
+ co_fn = CoTyLams forall_tvs $ CoLams dict_ids $ CoLet inst_binds CoHole
+ ; returnM (co_fn, result) }
where
free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
sig_msg = ptext SLIT("expected type of an expression")
%************************************************************************
%* *
-\subsection[Unify-exported]{Exported unification functions}
+ Boxy unification
%* *
%************************************************************************
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
- = -- The unifier should only ever see tau-types
- -- (no quantification whatsoever)
- ASSERT2( isTauTy ty1, ppr ty1 )
- ASSERT2( isTauTy ty2, ppr ty2 )
+boxyUnify :: BoxyType -> BoxyType -> TcM ()
+-- Acutal and expected, respectively
+boxyUnify ty1 ty2
+ = addErrCtxtM (unifyCtxt "type" ty1 ty2) $
+ uTys False ty1 False ty2
+
+---------------
+boxyUnifyList :: [BoxyType] -> [BoxyType] -> TcM ()
+-- Arguments should have equal length
+-- Acutal and expected types
+boxyUnifyList tys1 tys2 = uList boxyUnify tys1 tys2
+
+---------------
+unifyType :: TcTauType -> TcTauType -> TcM ()
+-- No boxes expected inside these types
+-- Acutal and expected types
+unifyType ty1 ty2 -- ty1 expected, ty2 inferred
+ = ASSERT2( not (isBoxyTy ty1), ppr ty1 )
+ ASSERT2( not (isBoxyTy ty2), ppr ty2 )
addErrCtxtM (unifyCtxt "type" ty1 ty2) $
- uTys True ty1 ty1 True ty2 ty2
+ uTys True ty1 True ty2
+
+---------------
+unifyPred :: PredType -> PredType -> TcM ()
+-- Acutal and expected types
+unifyPred p1 p2 = addErrCtxtM (unifyCtxt "type constraint" (mkPredTy p1) (mkPredTy p2)) $
+ uPred True p1 True p2
unifyTheta :: TcThetaType -> TcThetaType -> TcM ()
+-- Acutal and expected types
unifyTheta theta1 theta2
- = do { checkTc (equalLength theta1 theta2)
- (ptext SLIT("Contexts differ in length"))
- ; unifyTauTyLists True (map mkPredTy theta1) True (map mkPredTy theta2) }
-\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 :: Bool -> -- Allow refinements on tys1
- [TcTauType] ->
- Bool -> -- Allow refinements on tys2
- [TcTauType] -> TcM ()
--- Precondition: lists must be same length
--- Having the caller check gives better error messages
--- Actually the caller neve does need to check; see Note [Tycon app]
-unifyTauTyLists r1 [] r2 [] = returnM ()
-unifyTauTyLists r1 (ty1:tys1) r2 (ty2:tys2) = uTys r1 ty1 ty1 r2 ty2 ty2 `thenM_`
- unifyTauTyLists r1 tys1 r2 tys2
-unifyTauTyLists r1 ty1s r2 ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!"
+ = do { checkTc (equalLength theta1 theta2)
+ (ptext SLIT("Contexts differ in length"))
+ ; uList unifyPred theta1 theta2 }
+
+---------------
+uList :: (a -> a -> TcM ())
+ -> [a] -> [a] -> TcM ()
+-- Unify corresponding elements of two lists of types, which
+-- should be f equal length. We charge down the list explicitly so that
+-- we can complain if their lengths differ.
+uList unify [] [] = return ()
+uList unify (ty1:tys1) (ty2:tys2) = do { unify ty1 ty2; uList unify tys1 tys2 }
+uList unify ty1s ty2s = panic "Unify.uList: mismatched type lists!"
\end{code}
-@unifyTauTyList@ takes a single list of @TauType@s and unifies them
+@unifyTypeList@ 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 [] = returnM ()
-unifyTauTyList [ty] = returnM ()
-unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenM_`
- unifyTauTyList tys
+unifyTypeList :: [TcTauType] -> TcM ()
+unifyTypeList [] = returnM ()
+unifyTypeList [ty] = returnM ()
+unifyTypeList (ty1:tys@(ty2:_)) = do { unifyType ty1 ty2
+ ; unifyTypeList tys }
\end{code}
%************************************************************************
We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''.
\begin{code}
-uTys :: Bool -- Allow refinements to ty1
- -> TcTauType -> TcTauType -- Error reporting ty1 and real ty1
- -- ty1 is the *expected* type
- -> Bool -- Allow refinements to ty2
- -> TcTauType -> TcTauType -- Error reporting ty2 and real ty2
- -- ty2 is the *actual* type
+type NoBoxes = Bool -- True <=> definitely no boxes in this type
+ -- False <=> there might be boxes (always safe)
+
+uTys :: NoBoxes -> TcType -- ty1 is the *expected* type
+ -> NoBoxes -> TcType -- ty2 is the *actual* type
-> TcM ()
+uTys nb1 ty1 nb2 ty2 = u_tys nb1 ty1 ty1 nb2 ty2 ty2
+
+
+--------------
+uTys_s :: NoBoxes -> [TcType] -- ty1 is the *actual* types
+ -> NoBoxes -> [TcType] -- ty2 is the *expected* types
+ -> TcM ()
+uTys_s nb1 [] nb2 [] = returnM ()
+uTys_s nb1 (ty1:tys1) nb2 (ty2:tys2) = do { uTys nb1 ty1 nb2 ty2
+ ; uTys_s nb1 tys1 nb2 tys2 }
+uTys_s nb1 ty1s nb2 ty2s = panic "Unify.uTys_s: mismatched type lists!"
+
+--------------
+u_tys :: NoBoxes -> TcType -> TcType -- ty1 is the *actual* type
+ -> NoBoxes -> TcType -> TcType -- ty2 is the *expected* type
+ -> TcM ()
+
+u_tys nb1 orig_ty1 ty1 nb2 orig_ty2 ty2
+ = go ty1 ty2
+ where
-- Always expand synonyms (see notes at end)
-- (this also throws away FTVs)
-uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2
- | Just ty1' <- tcView ty1 = uTys r1 ps_ty1 ty1' r2 ps_ty2 ty2
-uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2
- | Just ty2' <- tcView ty2 = uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2'
+ go ty1 ty2
+ | Just ty1' <- tcView ty1 = go ty1' ty2
+ | Just ty2' <- tcView ty2 = go ty1 ty2'
-- Variables; go for uVar
-uTys r1 ps_ty1 (TyVarTy tyvar1) r2 ps_ty2 ty2 = uVar False r1 tyvar1 r2 ps_ty2 ty2
-uTys r1 ps_ty1 ty1 r2 ps_ty2 (TyVarTy tyvar2) = uVar True r2 tyvar2 r1 ps_ty1 ty1
- -- "True" means args swapped
-
+ go (TyVarTy tyvar1) ty2 = uVar False tyvar1 nb2 orig_ty2 ty2
+ go ty1 (TyVarTy tyvar2) = uVar True tyvar2 nb1 orig_ty1 ty1
+ -- "True" means args swapped
-- Predicates
-uTys r1 _ (PredTy (IParam n1 t1)) r2 _ (PredTy (IParam n2 t2))
- | n1 == n2 = uTys r1 t1 t1 r2 t2 t2
-uTys r1 _ (PredTy (ClassP c1 tys1)) r2 _ (PredTy (ClassP c2 tys2))
- | c1 == c2 = unifyTauTyLists r1 tys1 r2 tys2
- -- Guaranteed equal lengths because the kinds check
-
- -- Functions; just check the two parts
-uTys r1 _ (FunTy fun1 arg1) r2 _ (FunTy fun2 arg2)
- = uTys r1 fun1 fun1 r2 fun2 fun2 `thenM_` uTys r1 arg1 arg1 r2 arg2 arg2
+ go (PredTy p1) (PredTy p2) = uPred nb1 p1 nb2 p2
-- Type constructors must match
-uTys r1 ps_ty1 (TyConApp con1 tys1) r2 ps_ty2 (TyConApp con2 tys2)
- | con1 == con2 = unifyTauTyLists r1 tys1 r2 tys2
+ go (TyConApp con1 tys1) (TyConApp con2 tys2)
+ | con1 == con2 = uTys_s nb1 tys1 nb2 tys2
-- See Note [TyCon app]
+ -- Functions; just check the two parts
+ go (FunTy fun1 arg1) (FunTy fun2 arg2)
+ = do { uTys nb1 fun1 nb2 fun2
+ ; uTys nb1 arg1 nb2 arg2 }
+
-- 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 r1 ps_ty1 (AppTy s1 t1) r2 ps_ty2 ty2
- = case tcSplitAppTy_maybe ty2 of
- Just (s2,t2) -> uTys r1 s1 s1 r2 s2 s2 `thenM_` uTys r1 t1 t1 r2 t2 t2
- Nothing -> unifyMisMatch ps_ty1 ps_ty2
+ go (AppTy s1 t1) ty2
+ = case tcSplitAppTy_maybe ty2 of
+ Just (s2,t2) -> do { uTys nb1 s1 nb2 s2; uTys nb1 t1 nb2 t2 }
+ Nothing -> unifyMisMatch False orig_ty1 orig_ty2
-- Now the same, but the other way round
-- Don't swap the types, because the error messages get worse
-uTys r1 ps_ty1 ty1 r2 ps_ty2 (AppTy s2 t2)
- = case tcSplitAppTy_maybe ty1 of
- Just (s1,t1) -> uTys r1 s1 s1 r2 s2 s2 `thenM_` uTys r1 t1 t1 r2 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!
+ go ty1 (AppTy s2 t2)
+ = case tcSplitAppTy_maybe ty1 of
+ Just (s1,t1) -> do { uTys nb1 s1 nb2 s2; uTys nb1 t1 nb2 t2 }
+ Nothing -> unifyMisMatch False orig_ty1 orig_ty2
+
+ go ty1@(ForAllTy _ _) ty2@(ForAllTy _ _)
+ | length tvs1 == length tvs2
+ = do { tvs <- tcInstSkolTyVars UnkSkol tvs1 -- Not a helpful SkolemInfo
+ ; let tys = mkTyVarTys tvs
+ in_scope = mkInScopeSet (mkVarSet tvs)
+ subst1 = mkTvSubst in_scope (zipTyEnv tvs1 tys)
+ subst2 = mkTvSubst in_scope (zipTyEnv tvs2 tys)
+ ; uTys nb1 (substTy subst1 body1) nb2 (substTy subst2 body2)
+
+ -- If both sides are inside a box, we should not have
+ -- a polytype at all. This check comes last, because
+ -- the error message is extremely unhelpful.
+ ; ifM (nb1 && nb2) (notMonoType ty1)
+ }
+ where
+ (tvs1, body1) = tcSplitForAllTys ty1
+ (tvs2, body2) = tcSplitForAllTys ty2
-- Anything else fails
-uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2
+ go _ _ = unifyMisMatch False orig_ty1 orig_ty2
+
+----------
+uPred nb1 (IParam n1 t1) nb2 (IParam n2 t2)
+ | n1 == n2 = uTys nb1 t1 nb2 t2
+uPred nb1 (ClassP c1 tys1) nb2 (ClassP c2 tys2)
+ | c1 == c2 = uTys_s nb1 tys1 nb2 tys2 -- Guaranteed equal lengths because the kinds check
+uPred _ p1 _ p2 = unifyMisMatch False (mkPredTy p1) (mkPredTy p2)
\end{code}
Note [Tycon app]
-- 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 unifyTypepeLists args1 args2
-- NO else
-- NO -- Never mind. Just expand them and try again
-- NO uTys ty1 ty2
\begin{code}
uVar :: Bool -- False => tyvar is the "expected"
-- True => ty is the "expected" thing
- -> Bool -- True, allow refinements to tv1, False don't
-> TcTyVar
- -> Bool -- Allow refinements to ty2?
+ -> NoBoxes -- True <=> definitely no boxes in t2
-> TcTauType -> TcTauType -- printing and real versions
-> TcM ()
-uVar swapped r1 tv1 r2 ps_ty2 ty2
- = traceTc (text "uVar" <+> ppr swapped <+> ppr tv1 <+> (ppr ps_ty2 $$ ppr ty2)) `thenM_`
- condLookupTcTyVar r1 tv1 `thenM` \ details ->
- case details of
- IndirectTv r1' ty1 | swapped -> uTys r2 ps_ty2 ty2 r1' ty1 ty1 -- Swap back
- | otherwise -> uTys r1' ty1 ty1 r2 ps_ty2 ty2 -- Same order
- DoneTv details1 -> uDoneVar swapped tv1 details1 r2 ps_ty2 ty2
+uVar swapped tv1 nb2 ps_ty2 ty2
+ = do { let expansion | showSDoc (ppr ty2) == showSDoc (ppr ps_ty2) = empty
+ | otherwise = brackets (equals <+> ppr ty2)
+ ; traceTc (text "uVar" <+> ppr swapped <+>
+ sep [ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1 ),
+ nest 2 (ptext SLIT(" :=: ")),
+ ppr ps_ty2 <+> dcolon <+> ppr (typeKind ty2) <+> expansion])
+ ; details <- lookupTcTyVar tv1
+ ; case details of
+ IndirectTv ty1
+ | swapped -> u_tys nb2 ps_ty2 ty2 True ty1 ty1 -- Swap back
+ | otherwise -> u_tys True ty1 ty1 nb2 ps_ty2 ty2 -- Same order
+ -- The 'True' here says that ty1
+ -- is definitely box-free
+ DoneTv details1 -> uUnfilledVar swapped tv1 details1 nb2 ps_ty2 ty2
+ }
----------------
-uDoneVar :: Bool -- Args are swapped
- -> TcTyVar -> TcTyVarDetails -- Tyvar 1
- -> Bool -- Allow refinements to ty2
- -> TcTauType -> TcTauType -- Type 2
- -> TcM ()
+uUnfilledVar :: Bool -- Args are swapped
+ -> TcTyVar -> TcTyVarDetails -- Tyvar 1
+ -> NoBoxes -> TcTauType -> TcTauType -- Type 2
+ -> TcM ()
-- Invariant: tyvar 1 is not unified with anything
-uDoneVar swapped tv1 details1 r2 ps_ty2 ty2
+uUnfilledVar swapped tv1 details1 nb2 ps_ty2 ty2
| Just ty2' <- tcView ty2
= -- Expand synonyms; ignore FTVs
- uDoneVar swapped tv1 details1 r2 ps_ty2 ty2'
+ uUnfilledVar swapped tv1 details1 nb2 ps_ty2 ty2'
-uDoneVar swapped tv1 details1 r2 ps_ty2 ty2@(TyVarTy tv2)
+uUnfilledVar swapped tv1 details1 nb2 ps_ty2 ty2@(TyVarTy tv2)
-- Same type variable => no-op
| tv1 == tv2
= returnM ()
-- Distinct type variables
| otherwise
- = do { lookup2 <- condLookupTcTyVar r2 tv2
+ = do { lookup2 <- lookupTcTyVar tv2
; case lookup2 of
- IndirectTv b ty2' -> uDoneVar swapped tv1 details1 b ty2' ty2'
- DoneTv details2 -> uDoneVars swapped tv1 details1 tv2 details2
+ IndirectTv ty2' -> uUnfilledVar swapped tv1 details1 True ty2' ty2'
+ DoneTv details2 -> uUnfilledVars swapped tv1 details1 tv2 details2
}
-uDoneVar swapped tv1 details1 r2 ps_ty2 non_var_ty2 -- ty2 is not a type variable
+uUnfilledVar swapped tv1 details1 nb2 ps_ty2 non_var_ty2 -- ty2 is not a type variable
= case details1 of
- MetaTv ref1 -> do { -- Do the occurs check, and check that we are not
- -- unifying a type variable with a polytype
- -- Returns a zonked type ready for the update
- ty2 <- checkValue tv1 r2 ps_ty2 non_var_ty2
- ; updateMeta swapped tv1 ref1 ty2 }
+ MetaTv (SigTv _) ref1 -> mis_match -- Can't update a skolem with a non-type-variable
+ MetaTv info ref1 -> uMetaVar swapped tv1 info ref1 nb2 ps_ty2 non_var_ty2
+ skolem_details -> mis_match
+ where
+ mis_match = unifyMisMatch swapped (TyVarTy tv1) ps_ty2
- skolem_details -> unifyMisMatch (TyVarTy tv1) ps_ty2
+----------------
+uMetaVar :: Bool
+ -> TcTyVar -> BoxInfo -> IORef MetaDetails
+ -> NoBoxes -> TcType -> TcType
+ -> TcM ()
+-- tv1 is an un-filled-in meta type variable (maybe boxy, maybe tau)
+-- ty2 is not a type variable
+uMetaVar swapped tv1 info1 ref1 nb2 ps_ty2 non_var_ty2
+ = do { final_ty <- case info1 of
+ BoxTv -> unBox ps_ty2 -- No occurs check
+ other -> checkTauTvUpdate tv1 ps_ty2 -- Occurs check + monotype check
+ ; checkUpdateMeta swapped tv1 ref1 final_ty }
----------------
-uDoneVars :: Bool -- Args are swapped
- -> TcTyVar -> TcTyVarDetails -- Tyvar 1
- -> TcTyVar -> TcTyVarDetails -- Tyvar 2
- -> TcM ()
--- Invarant: the type variables are distinct,
--- and are not already unified with anything
-
-uDoneVars swapped tv1 (MetaTv ref1) tv2 details2
- = case details2 of
- MetaTv ref2 | update_tv2 -> updateMeta (not swapped) tv2 ref2 (mkTyVarTy tv1)
- other -> updateMeta swapped tv1 ref1 (mkTyVarTy tv2)
- -- Note that updateMeta does a sub-kind check
- -- We might unify (a b) with (c d) where b::*->* and d::*; this should fail
- where
- k1 = tyVarKind tv1
- k2 = tyVarKind tv2
- update_tv2 = k1 `isSubKind` k2 && (k1 /= k2 || nicer_to_update_tv2)
+uUnfilledVars :: Bool -- Args are swapped
+ -> TcTyVar -> TcTyVarDetails -- Tyvar 1
+ -> TcTyVar -> TcTyVarDetails -- Tyvar 2
+ -> TcM ()
+-- Invarant: The type variables are distinct,
+-- Neither is filled in yet
+-- They might be boxy or not
+
+uUnfilledVars swapped tv1 (SkolemTv _) tv2 (SkolemTv _)
+ = unifyMisMatch swapped (mkTyVarTy tv1) (mkTyVarTy tv2)
+
+uUnfilledVars swapped tv1 (MetaTv info1 ref1) tv2 (SkolemTv _)
+ = checkUpdateMeta swapped tv1 ref1 (mkTyVarTy tv2)
+uUnfilledVars swapped tv1 (SkolemTv _) tv2 (MetaTv info2 ref2)
+ = checkUpdateMeta (not swapped) tv2 ref2 (mkTyVarTy tv1)
+
+-- ToDo: this function seems too long for what it acutally does!
+uUnfilledVars swapped tv1 (MetaTv info1 ref1) tv2 (MetaTv info2 ref2)
+ = case (info1, info2) of
+ (BoxTv, BoxTv) -> box_meets_box
+
+ -- If a box meets a TauTv, but the fomer has the smaller kind
+ -- then we must create a fresh TauTv with the smaller kind
+ (_, BoxTv) | k1_sub_k2 -> update_tv2
+ | otherwise -> box_meets_box
+ (BoxTv, _ ) | k2_sub_k1 -> update_tv1
+ | otherwise -> box_meets_box
+
+ -- Avoid SigTvs if poss
+ (SigTv _, _ ) | k1_sub_k2 -> update_tv2
+ (_, SigTv _) | k2_sub_k1 -> update_tv1
+
+ (_, _) | k1_sub_k2 -> if k2_sub_k1 && nicer_to_update_tv1
+ then update_tv1 -- Same kinds
+ else update_tv2
+ | k2_sub_k1 -> update_tv1
+ | otherwise -> kind_err
+
-- Update the variable with least kind info
-- See notes on type inference in Kind.lhs
-- The "nicer to" part only applies if the two kinds are the same,
-- so we can choose which to do.
+ where
+ -- Kinds should be guaranteed ok at this point
+ update_tv1 = updateMeta tv1 ref1 (mkTyVarTy tv2)
+ update_tv2 = updateMeta tv2 ref2 (mkTyVarTy tv1)
+
+ box_meets_box | k1_sub_k2 = fill_with k1
+ | k2_sub_k1 = fill_with k2
+ | otherwise = kind_err
+
+ fill_with kind = do { tau_ty <- newFlexiTyVarTy kind
+ ; updateMeta tv1 ref1 tau_ty
+ ; updateMeta tv2 ref2 tau_ty }
+
+ kind_err = addErrCtxtM (unifyKindCtxt swapped tv1 (mkTyVarTy tv2)) $
+ unifyKindMisMatch k1 k2
+
+ k1 = tyVarKind tv1
+ k2 = tyVarKind tv2
+ k1_sub_k2 = k1 `isSubKind` k2
+ k2_sub_k1 = k2 `isSubKind` k1
- nicer_to_update_tv2 = isSystemName (varName tv2)
+ nicer_to_update_tv1 = isSystemName (varName tv1)
-- Try to update sys-y type variables in preference to ones
-- gotten (say) by instantiating a polymorphic function with
-- a user-written type sig
-uDoneVars swapped tv1 (SkolemTv _) tv2 details2
- = case details2 of
- MetaTv ref2 -> updateMeta (not swapped) tv2 ref2 (mkTyVarTy tv1)
- other -> unifyMisMatch (mkTyVarTy tv1) (mkTyVarTy tv2)
-
-uDoneVars swapped tv1 (SigSkolTv _ ref1) tv2 details2
- = case details2 of
- MetaTv ref2 -> updateMeta (not swapped) tv2 ref2 (mkTyVarTy tv1)
- SigSkolTv _ _ -> updateMeta swapped tv1 ref1 (mkTyVarTy tv2)
- other -> unifyMisMatch (mkTyVarTy tv1) (mkTyVarTy tv2)
-
----------------
-updateMeta :: Bool -> TcTyVar -> IORef MetaDetails -> TcType -> TcM ()
+checkUpdateMeta :: Bool -> TcTyVar -> IORef MetaDetails -> TcType -> TcM ()
-- Update tv1, which is flexi; occurs check is alrady done
-updateMeta swapped tv1 ref1 ty2
+-- The 'check' version does a kind check too
+-- We do a sub-kind check here: we might unify (a b) with (c d)
+-- where b::*->* and d::*; this should fail
+
+checkUpdateMeta swapped tv1 ref1 ty2
= do { checkKinds swapped tv1 ty2
+ ; updateMeta tv1 ref1 ty2 }
+
+updateMeta :: TcTyVar -> IORef MetaDetails -> TcType -> TcM ()
+updateMeta tv1 ref1 ty2
+ = ASSERT( isMetaTyVar tv1 )
+ ASSERT( isBoxyTyVar tv1 || isTauTy ty2 )
+ do { ASSERTM2( do { details <- readMetaTyVar tv1; return (isFlexi details) }, ppr tv1 )
+ ; traceTc (text "updateMeta" <+> ppr tv1 <+> text ":=" <+> ppr ty2)
; writeMutVar ref1 (Indirect ty2) }
-\end{code}
-\begin{code}
+----------------
checkKinds swapped tv1 ty2
-- We're about to unify a type variable tv1 with a non-tyvar-type ty2.
-- ty2 has been zonked at this stage, which ensures that
| otherwise = (tk1,tk2)
tk1 = tyVarKind tv1
tk2 = typeKind ty2
-\end{code}
-\begin{code}
-checkValue tv1 r2 ps_ty2 non_var_ty2
--- Do the occurs check, and check that we are not
--- unifying a type variable with a polytype
--- Return the type to update the type variable with, or fail
-
--- 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).
+----------------
+checkTauTvUpdate :: TcTyVar -> TcType -> TcM TcType
+-- (checkTauTvUpdate tv ty)
+-- We are about to update the TauTv tv with ty.
+-- Check (a) that tv doesn't occur in ty (occurs check)
+-- (b) that ty is a monotype
+-- Furthermore, in the interest of (b), if you find an
+-- empty box (BoxTv that is Flexi), fill it in with a TauTv
--
--- That's why we have this two-state occurs-check
- = zonk_tc_type r2 ps_ty2 `thenM` \ ps_ty2' ->
- case okToUnifyWith tv1 ps_ty2' of {
- Nothing -> returnM ps_ty2' ; -- Success
- other ->
-
- zonk_tc_type r2 non_var_ty2 `thenM` \ non_var_ty2' ->
- case okToUnifyWith tv1 non_var_ty2' of
- Nothing -> -- This branch rarely succeeds, except in strange cases
- -- like that in the example above
- returnM non_var_ty2'
-
- Just problem -> failWithTcM (unifyCheck problem tv1 ps_ty2')
- }
+-- Returns the (non-boxy) type to update the type variable with, or fails
+
+checkTauTvUpdate orig_tv orig_ty
+ = go orig_ty
where
- zonk_tc_type refine ty
- = zonkType (\tv -> return (TyVarTy tv)) refine ty
- -- We may already be inside a wobbly type t2, and
- -- should take that into account here
+ go (TyConApp tc tys)
+ | isSynTyCon tc = go_syn tc tys
+ | otherwise = do { tys' <- mappM go tys; return (TyConApp tc tys') }
+ go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
+ go (PredTy p) = do { p' <- go_pred p; return (PredTy p') }
+ go (FunTy arg res) = do { arg' <- go arg; res' <- go res; return (FunTy arg' res') }
+ go (AppTy fun arg) = do { fun' <- go fun; arg' <- go arg; return (mkAppTy fun' arg') }
+ -- NB the mkAppTy; we might have instantiated a
+ -- type variable to a type constructor, so we need
+ -- to pull the TyConApp to the top.
+ go (ForAllTy tv ty) = notMonoType orig_ty -- (b)
+
+ go (TyVarTy tv)
+ | orig_tv == tv = occurCheck tv orig_ty -- (a)
+ | isTcTyVar tv = go_tyvar tv (tcTyVarDetails tv)
+ | otherwise = return (TyVarTy tv)
+ -- Ordinary (non Tc) tyvars
+ -- occur inside quantified types
+
+ go_pred (ClassP c tys) = do { tys' <- mapM go tys; return (ClassP c tys') }
+ go_pred (IParam n ty) = do { ty' <- go ty; return (IParam n ty') }
+
+ go_tyvar tv (SkolemTv _) = return (TyVarTy tv)
+ go_tyvar tv (MetaTv box ref)
+ = do { cts <- readMutVar ref
+ ; case cts of
+ Indirect ty -> go ty
+ Flexi -> case box of
+ BoxTv -> do { tau <- newFlexiTyVarTy (tyVarKind tv)
+ ; writeMutVar ref (Indirect tau)
+ ; return tau }
+ other -> return (TyVarTy tv)
+ }
+
+ -- go_syn is called for synonyms only
+ -- See Note [Type synonyms and the occur check]
+ go_syn tc tys
+ | not (isTauTyCon tc)
+ = notMonoType orig_ty -- (b) again
+ | otherwise
+ = do { (msgs, mb_tys') <- tryTc (mapM go tys)
+ ; case mb_tys' of
+ Just tys' -> return (TyConApp tc tys')
+ -- Retain the synonym (the common case)
+ Nothing -> go (fromJust (tcView (TyConApp tc tys)))
+ -- Try again, expanding the synonym
+ }
+\end{code}
+
+Note [Type synonyms and the occur 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 = ()
-data Problem = OccurCheck | NotMonoType
+ f :: (A a -> a -> ()) -> ()
+ f = \ _ -> ()
-okToUnifyWith :: TcTyVar -> TcType -> Maybe Problem
--- (okToUnifyWith tv ty) checks whether it's ok to unify
--- tv :=: ty
--- Nothing => ok
--- Just p => not ok, problem p
+ x :: ()
+ x = f (\ x p -> p x)
-okToUnifyWith tv ty
- = ok ty
+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).
+
+\begin{code}
+stripBoxyType :: BoxyType -> TcM TcType
+-- Strip all boxes from the input type, returning a non-boxy type.
+-- It's fine for there to be a polytype inside a box (c.f. unBox)
+-- All of the boxes should have been filled in by now;
+-- hence we return a TcType
+stripBoxyType ty = zonkType strip_tv ty
where
- ok (TyVarTy tv') | tv == tv' = Just OccurCheck
- | otherwise = Nothing
- ok (AppTy t1 t2) = ok t1 `and` ok t2
- ok (FunTy t1 t2) = ok t1 `and` ok t2
- ok (TyConApp tc ts) = oks ts `and` ok_syn tc
- ok (ForAllTy _ _) = Just NotMonoType
- ok (PredTy st) = ok_st st
- ok (NoteTy _ t) = ok t
-
- oks ts = foldr (and . ok) Nothing ts
-
- ok_st (ClassP _ ts) = oks ts
- ok_st (IParam _ t) = ok t
-
- -- Check that a type synonym doesn't have a forall in the RHS
- ok_syn tc | not (isSynTyCon tc) = Nothing
- | otherwise = ok (snd (getSynTyConDefn tc))
-
- Nothing `and` m = m
- Just p `and` m = Just p
+ strip_tv tv = ASSERT( not (isBoxyTyVar tv) ) return (TyVarTy tv)
+ -- strip_tv will be called for *Flexi* meta-tyvars
+ -- There should not be any Boxy ones; hence the ASSERT
+
+zapToMonotype :: BoxySigmaType -> TcM TcTauType
+-- Subtle... we must zap the boxy res_ty
+-- to kind * before using it to instantiate a LitInst
+-- Calling unBox instead doesn't do the job, because the box
+-- often has an openTypeKind, and we don't want to instantiate
+-- with that type.
+zapToMonotype res_ty
+ = do { res_tau <- newFlexiTyVarTy liftedTypeKind
+ ; boxyUnify res_tau res_ty
+ ; return res_tau }
+
+unBox :: BoxyType -> TcM TcType
+-- unBox implements the judgement
+-- |- s' ~ box(s)
+-- with input s', and result s
+--
+-- It remove all boxes from the input type, returning a non-boxy type.
+-- A filled box in the type can only contain a monotype; unBox fails if not
+-- The type can have empty boxes, which unBox fills with a monotype
+--
+-- Compare this wth checkTauTvUpdate
+--
+-- For once, it's safe to treat synonyms as opaque!
+
+unBox (NoteTy n ty) = do { ty' <- unBox ty; return (NoteTy n ty') }
+unBox (TyConApp tc tys) = do { tys' <- mapM unBox tys; return (TyConApp tc tys') }
+unBox (AppTy f a) = do { f' <- unBox f; a' <- unBox a; return (mkAppTy f' a') }
+unBox (FunTy f a) = do { f' <- unBox f; a' <- unBox a; return (FunTy f' a') }
+unBox (PredTy p) = do { p' <- unBoxPred p; return (PredTy p') }
+unBox (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv )
+ do { ty' <- unBox ty; return (ForAllTy tv ty') }
+unBox (TyVarTy tv)
+ | isTcTyVar tv -- It's a boxy type variable
+ , MetaTv BoxTv ref <- tcTyVarDetails tv -- NB: non-TcTyVars are possible
+ = do { cts <- readMutVar ref -- under nested quantifiers
+ ; case cts of
+ Indirect ty -> do { non_boxy_ty <- unBox ty
+ ; if isTauTy non_boxy_ty
+ then return non_boxy_ty
+ else notMonoType non_boxy_ty }
+ Flexi -> do { tau <- newFlexiTyVarTy (tyVarKind tv)
+ ; writeMutVar ref (Indirect tau)
+ ; return tau }
+ }
+ | otherwise -- Skolems, and meta-tau-variables
+ = return (TyVarTy tv)
+
+unBoxPred (ClassP cls tys) = do { tys' <- mapM unBox tys; return (ClassP cls tys') }
+unBoxPred (IParam ip ty) = do { ty' <- unBox ty; return (IParam ip ty') }
\end{code}
+
%************************************************************************
%* *
Kind unification
~~~~~~
\begin{code}
-unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred
+unifyCtxt s ty1 ty2 tidy_env -- ty1 inferred, ty2 expected
= zonkTcType ty1 `thenM` \ ty1' ->
zonkTcType ty2 `thenM` \ ty2' ->
returnM (err ty1' ty2')
err ty1 ty2 = (env1,
nest 2
(vcat [
- text "Expected" <+> text s <> colon <+> ppr tidy_ty1,
- text "Inferred" <+> text s <> colon <+> ppr tidy_ty2
+ text "Expected" <+> text s <> colon <+> ppr tidy_ty2,
+ text "Inferred" <+> text s <> colon <+> ppr tidy_ty1
]))
where
(env1, [tidy_ty1,tidy_ty2]) = tidyOpenTypes tidy_env [ty1,ty2]
pp1 = ppr tv1' <+> dcolon <+> ppr (tyVarKind tv1)
pp2 = ppr ty2' <+> dcolon <+> ppr (typeKind ty2)
-unifyMisMatch ty1 ty2
- = do { (env, msg) <- misMatchMsg ty1 ty2
+unifyMisMatch swapped ty1 ty2
+ = do { (env, msg) <- if swapped then misMatchMsg ty2 ty1
+ else misMatchMsg ty1 ty2
; failWithTcM (env, msg) }
misMatchMsg ty1 ty2
- = do { (env1, pp1, extra1) <- ppr_ty emptyTidyEnv ty1
+ = do { env0 <- tcInitTidyEnv
+ ; (env1, pp1, extra1) <- ppr_ty env0 ty1
; (env2, pp2, extra2) <- ppr_ty env1 ty2
; return (env2, sep [sep [ptext SLIT("Couldn't match") <+> pp1,
nest 7 (ptext SLIT("against") <+> pp2)],
; case tidy_ty of
TyVarTy tv
| isSkolemTyVar tv -> return (env2, pp_rigid tv',
- pprTcTyVar tv')
+ pprSkolTvBinding tv')
| otherwise -> return simple_result
where
(env2, tv') = tidySkolemTyVar env1 tv
where
pp_rigid tv = ptext SLIT("the rigid variable") <+> quotes (ppr tv)
-unifyCheck problem tyvar ty
- = (env2, hang msg
- 2 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty]))
- where
- (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar
- (env2, tidy_ty) = tidyOpenType env1 ty
- msg = case problem of
- OccurCheck -> ptext SLIT("Occurs check: cannot construct the infinite type:")
- NotMonoType -> ptext SLIT("Cannot unify a type variable with a type scheme:")
+notMonoType ty
+ = do { ty' <- zonkTcType ty
+ ; env0 <- tcInitTidyEnv
+ ; let (env1, tidy_ty) = tidyOpenType env0 ty'
+ msg = ptext SLIT("Cannot match a monotype with") <+> ppr tidy_ty
+ ; failWithTcM (env1, msg) }
+
+occurCheck tyvar ty
+ = do { env0 <- tcInitTidyEnv
+ ; ty' <- zonkTcType ty
+ ; let (env1, tidy_tyvar) = tidyOpenTyVar env0 tyvar
+ (env2, tidy_ty) = tidyOpenType env1 ty
+ extra = sep [ppr tidy_tyvar, char '=', ppr tidy_ty]
+ ; failWithTcM (env2, hang msg 2 extra) }
+ where
+ msg = ptext SLIT("Occurs check: cannot construct the infinite type:")
\end{code}
zonkTcKind exp_kind `thenM` \ exp_kind ->
zonkTcKind act_kind `thenM` \ act_kind ->
+ tcInitTidyEnv `thenM` \ env0 ->
let (exp_as, _) = splitKindFunTys exp_kind
(act_as, _) = splitKindFunTys act_kind
n_exp_as = length exp_as
n_act_as = length act_as
- (env1, tidy_exp_kind) = tidyKind emptyTidyEnv exp_kind
- (env2, tidy_act_kind) = tidyKind env1 act_kind
+ (env1, tidy_exp_kind) = tidyKind env0 exp_kind
+ (env2, tidy_act_kind) = tidyKind env1 act_kind
err | n_exp_as < n_act_as -- E.g. [Maybe]
= quotes (ppr ty) <+> ptext SLIT("is not applied to enough type arguments")
checkSigTyVars sig_tvs = check_sig_tyvars emptyVarSet sig_tvs
checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM ()
+-- The extra_tvs can include boxy type variables;
+-- e.g. TcMatches.tcCheckExistentialPat
checkSigTyVarsWrt extra_tvs sig_tvs
- = zonkTcTyVarsAndFV (varSetElems extra_tvs) `thenM` \ extra_tvs' ->
- check_sig_tyvars extra_tvs' sig_tvs
+ = do { extra_tvs' <- zonkTcTyVarsAndFV (varSetElems extra_tvs)
+ ; check_sig_tyvars extra_tvs' sig_tvs }
check_sig_tyvars
:: TcTyVarSet -- Global type variables. The universally quantified
-- escapes. The first list contains the original signature type variable,
-- while the second contains the type variable it is unified to (usually itself)
bleatEscapedTvs globals sig_tvs zonked_tvs
- = do { (env3, msgs) <- foldlM check (env2, []) (tidy_tvs `zip` tidy_zonked_tvs)
+ = do { env0 <- tcInitTidyEnv
+ ; let (env1, tidy_tvs) = tidyOpenTyVars env0 sig_tvs
+ (env2, tidy_zonked_tvs) = tidyOpenTyVars env1 zonked_tvs
+
+ ; (env3, msgs) <- foldlM check (env2, []) (tidy_tvs `zip` tidy_zonked_tvs)
; failWithTcM (env3, main_msg $$ nest 2 (vcat msgs)) }
where
- (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tvs
- (env2, tidy_zonked_tvs) = tidyOpenTyVars env1 zonked_tvs
-
main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
check (tidy_env, msgs) (sig_tv, zonked_tv)
\begin{code}
module TcUnify where
-import TcType ( TcTauType )
+import TcType ( TcTauType, BoxyType )
import TcRnTypes( TcM )
-- This boot file exists only to tie the knot between
-- TcUnify and TcSimplify
-unifyTauTy :: TcTauType -> TcTauType -> TcM ()
+unifyType :: TcTauType -> TcTauType -> TcM ()
+zapToMonotype :: BoxyType -> TcM TcTauType
\end{code}
mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
mkTyConGenericBinds tycon
- = unitBag (L loc (FunBind (L loc from_RDR) False {- Not infix -}
- from_matches placeHolderNames))
-
+ = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
`unionBags`
- unitBag (L loc (FunBind (L loc to_RDR) False
- to_matches placeHolderNames))
+ unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
where
- from_matches = mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
- to_matches = mkMatchGroup [mkSimpleHsAlt to_pat to_body]
+ from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
+ to_matches = [mkSimpleHsAlt to_pat to_body]
loc = srcLocSpan (getSrcLoc tycon)
datacons = tyConDataCons tycon
(from_RDR, to_RDR) = mkGenericNames tycon
tyConStupidTheta,
tyConArity,
isClassTyCon, tyConClass_maybe,
- getSynTyConDefn,
+ synTyConDefn, synTyConRhs,
tyConExtName, -- External name for foreign types
maybeTyConSingleCon,
\end{code}
\begin{code}
-getSynTyConDefn :: TyCon -> ([TyVar], Type)
-getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = (tyvars,ty)
-getSynTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon)
+synTyConDefn :: TyCon -> ([TyVar], Type)
+synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = (tyvars,ty)
+synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon)
+
+synTyConRhs :: TyCon -> Type
+synTyConRhs tc = synTcRhs tc
\end{code}
\begin{code}
splitFunTys, splitFunTysN,
funResultTy, funArgTy, zipFunTys, isFunTy,
- mkGenTyConApp, mkTyConApp, mkTyConTy,
+ mkTyConApp, mkTyConTy,
tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp,
- mkSynTy,
-
repType, typePrimRep, coreView, tcView,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
TvSubst(..), emptyTvSubst, -- Representation visible to a few friends
mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
- extendTvSubst, extendTvSubstList, isInScope, composeTvSubst,
+ extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
-- Performing substitution on types
substTy, substTys, substTyWith, substTheta,
- substPred, substTyVar, substTyVarBndr, deShadowTy,
+ substPred, substTyVar, substTyVarBndr, deShadowTy, lookupTyVar,
-- Pretty-printing
pprType, pprParendType, pprTyThingCategory,
import VarEnv
import VarSet
-import Name ( NamedThing(..), mkInternalName, tidyOccName )
+import OccName ( tidyOccName )
+import Name ( NamedThing(..), mkInternalName, tidyNameOcc )
import Class ( Class, classTyCon )
import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
-- others
import StaticFlags ( opt_DictsStrict )
import SrcLoc ( noSrcLoc )
-import Unique ( Uniquable(..) )
import Util ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual, all2 )
import Outputable
import UniqSet ( sizeUniqSet ) -- Should come via VarSet
= mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
- mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2])
+ mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
mk_app ty1 = AppTy orig_ty1 orig_ty2
- -- We call mkGenTyConApp because the TyConApp could be an
+ -- Note that the TyConApp could be an
-- under-saturated type synonym. GHC allows that; e.g.
-- type Foo k = k a -> k a
-- type Id x = x
= mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
- mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ orig_tys2)
- -- mkGenTyConApp: see notes with mkAppTy
+ mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
+ -- mkTyConApp: see notes with mkAppTy
mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
splitAppTy_maybe :: Type -> Maybe (Type, Type)
as apppropriate.
\begin{code}
-mkGenTyConApp :: TyCon -> [Type] -> Type
-mkGenTyConApp tc tys
- = mkTyConApp tc tys
-
mkTyConApp :: TyCon -> [Type] -> Type
mkTyConApp tycon tys
| isFunTyCon tycon, [ty1,ty2] <- tys
SynTy
~~~~~
-\begin{code}
-mkSynTy tycon tys = panic "No longer used"
-{- Delete in due course
- | n_args == arity -- Exactly saturated
- = mk_syn tys
- | n_args > arity -- Over-saturated
- = case splitAt arity tys of { (as,bs) -> mkAppTys (mk_syn as) bs }
- -- Its important to use mkAppTys, rather than (foldl AppTy),
- -- because (mk_syn as) might well return a partially-applied
- -- type constructor; indeed, usually will!
- | otherwise -- Un-saturated
- = TyConApp tycon tys
- -- For the un-saturated case we build TyConApp directly
- -- (mkTyConApp ASSERTs that the tc isn't a SynTyCon).
- -- Here we are relying on checkValidType to find
- -- the error. What we can't do is use mkSynTy with
- -- too few arg tys, because that is utterly bogus.
-
- where
- mk_syn tys = NoteTy (SynNote (TyConApp tycon tys))
- (substTyWith tyvars tys body)
-
- (tyvars, body) = ASSERT( isSynTyCon tycon ) getSynTyConDefn tycon
- arity = tyConArity tycon
- n_args = length tys
--}
-\end{code}
-
Notes on type synonyms
~~~~~~~~~~~~~~~~~~~~~~
The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
tyVarsOfType :: Type -> TyVarSet
+-- NB: for type synonyms tyVarsOfType does *not* expand the synonym
tyVarsOfType (TyVarTy tv) = unitVarSet tv
tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
tyVarsOfType (PredTy sty) = tyVarsOfPred sty
tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
-tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
-
--- Note [Syn]
--- Consider
--- type T a = Int
--- What are the free tyvars of (T x)? Empty, of course!
--- Here's the example that Ralf Laemmel showed me:
--- foo :: (forall a. C u a -> C u a) -> u
--- mappend :: Monoid u => u -> u -> u
---
--- bar :: Monoid u => u
--- bar = foo (\t -> t `mappend` t)
--- We have to generalise at the arg to f, and we don't
--- want to capture the constraint (Monad (C u a)) because
--- it appears to mention a. Pretty silly, but it was useful to him.
-
+tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar
tyVarsOfTypes :: [Type] -> TyVarSet
tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
\end{code}
+
%************************************************************************
%* *
\subsection{TidyType}
where
subst' = extendVarEnv subst tyvar tyvar'
tyvar' = setTyVarName tyvar name'
- name' = mkInternalName (getUnique name) occ' noSrcLoc
- -- Note: make a *user* tyvar, so it printes nicely
- -- Could extract src loc, but no need.
+ name' = tidyNameOcc name occ'
where
name = tyVarName tyvar
(subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
substTyVar :: TvSubst -> TyVar -> Type
-substTyVar (TvSubst in_scope env) tv
- = case (lookupVarEnv env tv) of
+substTyVar subst tv
+ = case lookupTyVar subst tv of
Nothing -> TyVarTy tv
Just ty' -> ty' -- See Note [Apply Once]
+lookupTyVar :: TvSubst -> TyVar -> Maybe Type
+lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv
+
substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
substTyVarBndr subst@(TvSubst in_scope env) old_var
| old_var == new_var -- No need to clone
tv_set = mkVarSet tvs
all_bound_here env = all bound_here (varEnvKeys env)
bound_here uniq = elemVarSetByKey uniq tv_set
-
-----------------------------
-gadtRefineTys
- :: (TyVar -> BindFlag) -- Try to unify these
- -> TvSubstEnv -- Not idempotent
- -> [Type] -> [Type]
- -> MaybeErr Message TvSubstEnv -- Not idempotent
--- This one is used by the type checker. Neither the input nor result
--- substitition is idempotent
-gadtRefineTys bind_fn subst tys1 tys2
- = initUM bind_fn (unify_tys subst tys1 tys2)
+-- This version is used by the type checker
+gadtRefineTys :: TvSubst
+ -> DataCon -> [TyVar]
+ -> [Type] -> [Type]
+ -> MaybeErr Message (TvSubst, Bool)
+-- The bool is True <=> the only *new* bindings are for pat_tvs
+
+gadtRefineTys (TvSubst in_scope env1) con pat_tvs pat_tys ctxt_tys
+ = initUM (tryToBind tv_set) $
+ do { -- Run the unifier, starting with an empty env
+ ; env2 <- unify_tys env1 pat_tys ctxt_tys
+
+ -- Find the fixed point of the resulting non-idempotent substitution
+ ; let subst2 = TvSubst in_scope subst_env_fixpt
+ subst_env_fixpt = mapVarEnv (substTy subst2) env2
+
+ ; return (subst2, all_bound_here env2) }
+ where
+ -- 'tvs' are the tyvars bound by the pattern
+ tv_set = mkVarSet pat_tvs
+ all_bound_here env = all bound_here (varEnvKeys env)
+ bound_here uniq = elemVarEnvByKey uniq env1 || elemVarSetByKey uniq tv_set
+ -- The bool is True <=> the only *new* bindings are for pat_tvs
----------------------------
tryToBind :: TyVarSet -> TyVar -> BindFlag
foldrM :: (b -> a -> IOEnv env a) -> a -> [b] -> IOEnv env a
mapAndUnzipM :: (a -> IOEnv env (b,c)) -> [a] -> IOEnv env ([b],[c])
mapAndUnzip3M :: (a -> IOEnv env (b,c,d)) -> [a] -> IOEnv env ([b],[c],[d])
-checkM :: Bool -> IOEnv env () -> IOEnv env () -- Perform arg if bool is False
-ifM :: Bool -> IOEnv env () -> IOEnv env () -- Perform arg if bool is True
+checkM :: Bool -> IOEnv env a -> IOEnv env () -- Perform arg if bool is False
+ifM :: Bool -> IOEnv env a -> IOEnv env () -- Perform arg if bool is True
mappM f [] = return []
mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) }
return (r:rs, s:ss, t:ts) }
checkM True err = return ()
-checkM False err = err
+checkM False err = do { err; return () }
-ifM True do_it = do_it
+ifM True do_it = do { do_it; return () }
ifM False do_it = return ()
intersectUFM_C,
foldUFM,
mapUFM,
- elemUFM,
+ elemUFM, elemUFM_Directly,
filterUFM, filterUFM_Directly,
sizeUFM,
hashUFM,
#include "HsVersions.h"
import Unique ( Uniquable(..), Unique, getKey#, mkUniqueGrimily )
-import Panic
+import Maybes ( maybeToBool )
import FastTypes
import Outputable
sizeUFM :: UniqFM elt -> Int
hashUFM :: UniqFM elt -> Int
elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
+elemUFM_Directly:: Unique -> UniqFM elt -> Bool
lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM_Directly -- when you've got the Unique already
Lookup up a binary tree is easy (and fast).
\begin{code}
-elemUFM key fm = case lookUp fm (getKey# (getUnique key)) of
- Nothing -> False
- Just _ -> True
+elemUFM key fm = maybeToBool (lookupUFM fm key)
+elemUFM_Directly key fm = maybeToBool (lookupUFM_Directly fm key)
lookupUFM fm key = lookUp fm (getKey# (getUnique key))
lookupUFM_Directly fm key = lookUp fm (getKey# key)
projects / ghc-hetmet.git / commitdiff