#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
#define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg))
-#define ASSERTM(e) ASSERT(e) do
+#define ASSERTM(mbool) do { bool <- mbool; ASSERT(bool) return () }
+#define ASSERTM2(mbool,msg) do { bool <- mbool; ASSERT2(bool,msg) return () }
#else
#define ASSERT(e) if False then error "ASSERT" else
#define ASSERT2(e,msg) if False then error "ASSERT2" else
#define ASSERTM(e)
+#define ASSERTM2(e)
#define WARN(e,msg) if False then error "WARN" else
#endif
--- temporary usage assertion control KSW 2000-10
-#ifdef DO_USAGES
-#define UASSERT(e) ASSERT(e)
-#define UASSERT2(e,msg) ASSERT2(e,msg)
-#else
-#define UASSERT(e)
-#define UASSERT2(e,msg)
-#endif
-
-- This #ifndef lets us switch off the "import FastString"
-- when compiling FastString itself
#ifndef COMPILING_FAST_STRING
+*** unexpected failure for jtod_circint(opt)
+
+
New back end thoughts
-----------------------------------------------------------------------------
data DataCon
dataConName :: DataCon -> Name.Name
-isExistentialDataCon :: DataCon -> GHC.Base.Bool
+isVanillaDataCon :: DataCon -> GHC.Base.Bool
ConTag, fIRST_TAG,
mkDataCon,
dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
- dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys,
- dataConRepArgTys, dataConTheta,
+ dataConTyVars, dataConStupidTheta,
+ dataConArgTys, dataConOrigArgTys,
+ dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConStrictMarks, dataConExStricts,
dataConSourceArity, dataConRepArity,
- dataConNumInstArgs, dataConIsInfix,
+ dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness,
- isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
- isExistentialDataCon, classDataCon, dataConExistentialTyVars,
+ isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
+ isVanillaDataCon, classDataCon,
splitProductType_maybe, splitProductType,
) where
#include "HsVersions.h"
-import {-# SOURCE #-} Subst( substTyWith )
-
-import Type ( Type, ThetaType,
+import Type ( Type, ThetaType, substTyWith,
mkForAllTys, mkFunTys, mkTyConApp,
- mkTyVarTys, splitTyConApp_maybe,
+ splitTyConApp_maybe,
mkPredTys, isStrictPred, pprType
)
-import TyCon ( TyCon, tyConDataCons, tyConDataCons, isProductTyCon,
- isTupleTyCon, isUnboxedTupleTyCon )
+import TyCon ( TyCon, FieldLabel, tyConDataCons, tyConDataCons,
+ isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id )
-import FieldLabel ( FieldLabel )
import BasicTypes ( Arity, StrictnessMark(..) )
import Outputable
import Unique ( Unique, Uniquable(..) )
import ListSetOps ( assoc )
-import Util ( zipEqual, zipWithEqual, notNull )
+import Util ( zipEqual, zipWithEqual )
\end{code}
are immediately discarded -- they do nothing and have no benefit.
It's a flaw in the language.
-Up to now [March 2002] I have put this stupid context into the type of
-the "wrapper" constructors functions, T1 and T2, but that turned out
-to be jolly inconvenient for generics, and record update, and other
-functions that build values of type T (because they don't have
-suitable dictionaries available).
+ Up to now [March 2002] I have put this stupid context into the
+ type of the "wrapper" constructors functions, T1 and T2, but
+ that turned out to be jolly inconvenient for generics, and
+ record update, and other functions that build values of type T
+ (because they don't have suitable dictionaries available).
+
+ So now I've taken the stupid context out. I simply deal with
+ it separately in the type checker on occurrences of a
+ constructor, either in an expression or in a pattern.
-So now I've taken the stupid context out. I simply deal with it
-separately in the type checker on occurrences of a constructor, either
-in an expression or in a pattern.
+ [May 2003: actually I think this decision could evasily be
+ reversed now, and probably should be. Generics could be
+ disabled for types with a stupid context; record updates now
+ (H98) needs the context too; etc. It's an unforced change, so
+ I'm leaving it for now --- but it does seem odd that the
+ wrapper doesn't include the stupid context.]
-[May 2003: actually I think this decision could evasily be reversed now,
-and probably should be. Generics could be disabled for types with
-a stupid context; record updates now (H98) needs the context too; etc.
-It's an unforced change, so I'm leaving it for now --- but it does seem
-odd that the wrapper doesn't include the stupid context.]
+[July 04] With the advent of generalised data types, it's less obvious
+what the "stupid context" is. Consider
+ C :: forall a. Ord a => a -> a -> T (Foo a)
+Does the C constructor in Core contain the Ord dictionary? Yes, it must:
+ f :: T b -> Ordering
+ f = /\b. \x:T b.
+ case x of
+ C a (d:Ord a) (p:a) (q:a) -> compare d p q
+Note that (Foo a) might not be an instance of Ord.
%************************************************************************
%* *
\begin{code}
data DataCon
- = MkData { -- Used for data constructors only;
- -- there *is* no constructor for a newtype
-
+ = MkData {
dcName :: Name, -- This is the name of the *source data con*
-- (see "Note [Data Constructor Naming]" above)
-
- dcUnique :: Unique, -- Cached from Name
+ dcUnique :: Unique, -- Cached from Name
dcTag :: ConTag,
-- Running example:
--
-- data Eq a => T a = forall b. Ord b => MkT a [b]
- dcRepType :: Type, -- Type of the constructor
- -- forall a b . Ord b => a -> [b] -> MkT a
- -- (this is *not* of the constructor wrapper Id:
- -- see notes after this data type declaration)
- --
- -- Notice that the existential type parameters come *second*.
- -- Reason: in a case expression we may find:
- -- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... }
- -- It's convenient to apply the rep-type of MkT to 't', to get
- -- forall b. Ord b => ...
- -- and use that to check the pattern. Mind you, this is really only
- -- use in CoreLint.
-
-
-- The next six fields express the type of the constructor, in pieces
-- e.g.
--
- -- dcTyVars = [a]
- -- dcTheta = [Eq a]
- -- dcExTyVars = [b]
- -- dcExTheta = [Ord b]
- -- dcOrigArgTys = [a,List b]
- -- dcTyCon = T
-
- dcTyVars :: [TyVar], -- Type vars for the data type decl
- -- These are ALWAYS THE SAME AS THE TYVARS
- -- FOR THE PARENT TyCon. We occasionally rely on
- -- this just to avoid redundant instantiation
-
- dcStupidTheta :: ThetaType, -- This is a "thinned" version of the context of
- -- the data decl.
+ -- dcTyVars = [a,b]
+ -- dcStupidTheta = [Eq a]
+ -- dcTheta = [Ord b]
+ -- dcOrigArgTys = [a,List b]
+ -- dcTyCon = T
+ -- dcTyArgs = [a,b]
+
+ dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor
+ -- Its type is of form
+ -- forall a1..an . t1 -> ... tm -> T a1..an
+ -- No existentials, no GADTs, nothing.
+
+ dcTyVars :: [TyVar], -- Universally-quantified type vars
+ -- for the data constructor.
+ -- dcVanilla = True <=> The [TyVar] are identical to those of the parent tycon
+ -- False <=> The [TyVar] are NOT NECESSARILY THE SAME AS THE TYVARS
+ -- FOR THE PARENT TyCon. (With GADTs the data
+ -- con might not even have the same number of
+ -- type variables.)
+
+ dcStupidTheta :: ThetaType, -- This is a "thinned" version of
+ -- the context of the data decl.
-- "Thinned", because the Report says
-- to eliminate any constraints that don't mention
-- tyvars free in the arg types for this constructor
-- that makes it harder to use the wrap-id to rebuild
-- values after record selection or in generics.
- dcExTyVars :: [TyVar], -- Ditto for the context of the constructor,
- dcExTheta :: ThetaType, -- the existentially quantified stuff
+ dcTheta :: ThetaType, -- The existentially quantified stuff
dcOrigArgTys :: [Type], -- Original argument types
-- (before unboxing and flattening of
-- strict fields)
+ -- Result type of constructor is T t1..tn
+ dcTyCon :: TyCon, -- Result tycon, T
+ dcResTys :: [Type], -- Result type args, t1..tn
+
-- Now the strictness annotations and field labels of the constructor
dcStrictMarks :: [StrictnessMark],
-- Strictness annotations as decided by the compiler.
-- after unboxing and flattening,
-- and *including* existential dictionaries
- dcRepStrictness :: [StrictnessMark], -- One for each representation argument
+ dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument
+
+ dcRepType :: Type, -- Type of the constructor
+ -- forall a b . Ord b => a -> [b] -> MkT a
+ -- (this is *not* of the constructor wrapper Id:
+ -- see notes after this data type declaration)
+ --
+ -- Notice that the existential type parameters come *second*.
+ -- Reason: in a case expression we may find:
+ -- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... }
+ -- It's convenient to apply the rep-type of MkT to 't', to get
+ -- forall b. Ord b => ...
+ -- and use that to check the pattern. Mind you, this is really only
+ -- use in CoreLint.
- dcTyCon :: TyCon, -- Result tycon
-- Finally, the curried worker function that corresponds to the constructor
-- It doesn't have an unfolding; the code generator saturates these Ids
-- and allocates a real constructor when it finds one.
--
-- An entirely separate wrapper function is built in TcTyDecls
-
dcIds :: DataConIds,
dcInfix :: Bool -- True <=> declared infix
\begin{code}
mkDataCon :: Name
-> Bool -- Declared infix
+ -> Bool -- Vanilla (see notes with dcVanilla)
-> [StrictnessMark] -> [FieldLabel]
- -> [TyVar] -> ThetaType
- -> [TyVar] -> ThetaType
- -> [Type] -> TyCon
+ -> [TyVar] -> ThetaType -> ThetaType
+ -> [Type] -> TyCon -> [Type]
-> DataConIds
-> DataCon
-- Can get the tag from the TyCon
-mkDataCon name declared_infix
+mkDataCon name declared_infix vanilla
arg_stricts -- Must match orig_arg_tys 1-1
fields
- tyvars theta ex_tyvars ex_theta orig_arg_tys tycon
+ tyvars stupid_theta theta orig_arg_tys tycon res_tys
ids
= con
where
con = MkData {dcName = name,
- dcUnique = nameUnique name,
- dcTyVars = tyvars, dcStupidTheta = theta,
- dcOrigArgTys = orig_arg_tys,
+ dcUnique = nameUnique name, dcVanilla = vanilla,
+ dcTyVars = tyvars, dcStupidTheta = stupid_theta, dcTheta = theta,
+ dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, dcResTys = res_tys,
dcRepArgTys = rep_arg_tys,
- dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts,
- dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
+ dcFields = fields, dcTag = tag, dcRepType = ty,
dcIds = ids, dcInfix = declared_infix}
-- Strictness marks for source-args
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
- ex_dict_tys = mkPredTys ex_theta
- real_arg_tys = ex_dict_tys ++ orig_arg_tys
- real_stricts = map mk_dict_strict_mark ex_theta ++ arg_stricts
+ dict_tys = mkPredTys theta
+ real_arg_tys = dict_tys ++ orig_arg_tys
+ real_stricts = map mk_dict_strict_mark theta ++ arg_stricts
-- Representation arguments and demands
(rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
- ty = mkForAllTys (tyvars ++ ex_tyvars)
- (mkFunTys rep_arg_tys result_ty)
+ ty = mkForAllTys tyvars (mkFunTys rep_arg_tys result_ty)
-- NB: the existential dict args are already in rep_arg_tys
- result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
+ result_ty = mkTyConApp tycon res_tys
mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
| otherwise = NotMarkedStrict
dataConIsInfix :: DataCon -> Bool
dataConIsInfix = dcInfix
+dataConTyVars :: DataCon -> [TyVar]
+dataConTyVars = dcTyVars
+
dataConWorkId :: DataCon -> Id
dataConWorkId dc = case dcIds dc of
AlgDC _ wrk_id -> wrk_id
dataConExStricts :: DataCon -> [StrictnessMark]
-- Strictness of *existential* arguments only
-- Usually empty, so we don't bother to cache this
-dataConExStricts dc = map mk_dict_strict_mark (dcExTheta dc)
-
--- Number of type-instantiation arguments
--- All the remaining arguments of the DataCon are (notionally)
--- stored in the DataCon, and are matched in a case expression
-dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars
+dataConExStricts dc = map mk_dict_strict_mark (dcTheta dc)
dataConSourceArity :: DataCon -> Arity
-- Source-level arity of the data constructor
-- dictionaries
dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
-isNullaryDataCon con = dataConRepArity con == 0
+isNullarySrcDataCon, isNullaryRepDataCon :: DataCon -> Bool
+isNullarySrcDataCon dc = null (dcOrigArgTys dc)
+isNullaryRepDataCon dc = null (dcRepArgTys dc)
dataConRepStrictness :: DataCon -> [StrictnessMark]
-- Give the demands on the arguments of a
dataConRepStrictness dc = dcRepStrictness dc
dataConSig :: DataCon -> ([TyVar], ThetaType,
- [TyVar], ThetaType,
- [Type], TyCon)
+ [Type], TyCon, [Type])
-dataConSig (MkData {dcTyVars = tyvars, dcStupidTheta = theta,
- dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
- dcOrigArgTys = arg_tys, dcTyCon = tycon})
- = (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon)
+dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
+ dcOrigArgTys = arg_tys, dcTyCon = tycon, dcResTys = res_tys})
+ = (tyvars, theta, arg_tys, tycon, res_tys)
dataConArgTys :: DataCon
-> [Type] -- Instantiated at these types
-- NB: these INCLUDE the existentially quantified dict args
-- but EXCLUDE the data-decl context which is discarded
-- It's all post-flattening etc; this is a representation type
+dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars}) inst_tys
+ = map (substTyWith tyvars inst_tys) arg_tys
-dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
- dcExTyVars = ex_tyvars}) inst_tys
- = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
-
-dataConTheta :: DataCon -> ThetaType
-dataConTheta dc = dcStupidTheta dc
-
-dataConExistentialTyVars :: DataCon -> [TyVar]
-dataConExistentialTyVars dc = dcExTyVars dc
-
--- And the same deal for the original arg tys:
-
+-- And the same deal for the original arg tys
+-- This one only works for vanilla DataCons
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
-dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
- dcExTyVars = ex_tyvars}) inst_tys
- = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
+dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars, dcVanilla = is_vanilla}) inst_tys
+ = ASSERT( is_vanilla )
+ map (substTyWith tyvars inst_tys) arg_tys
+
+dataConStupidTheta :: DataCon -> ThetaType
+dataConStupidTheta dc = dcStupidTheta dc
\end{code}
These two functions get the real argument types of the constructor,
isUnboxedTupleCon :: DataCon -> Bool
isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
-isExistentialDataCon :: DataCon -> Bool
-isExistentialDataCon (MkData {dcExTyVars = tvs}) = notNull tvs
+isVanillaDataCon :: DataCon -> Bool
+isVanillaDataCon dc = dcVanilla dc
\end{code}
globalIdDetails
)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
+import TyCon ( FieldLabel, TyCon )
import Type ( Type, typePrimRep, addFreeTyVars, seqType,
splitTyConApp_maybe, PrimRep )
import TysPrim ( statePrimTyCon )
)
import Module ( Module )
import OccName ( EncodedFS, mkWorkerOcc )
-import FieldLabel ( FieldLabel )
import Maybes ( orElse )
import SrcLoc ( SrcLoc )
import Outputable
\begin{code}
-recordSelectorFieldLabel :: Id -> FieldLabel
+recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
recordSelectorFieldLabel id = case globalIdDetails id of
- RecordSelId lbl -> lbl
+ RecordSelId tycon lbl -> (tycon,lbl)
other -> panic "recordSelectorFieldLabel"
isRecordSelector id = case globalIdDetails id of
- RecordSelId lbl -> True
+ RecordSelId _ _ -> True
other -> False
isPrimOpId id = case globalIdDetails id of
-- file, even if it's mentioned in some other interface unfolding.
isImplicitId id
= case globalIdDetails id of
- RecordSelId _ -> True
+ RecordSelId _ _ -> True
FCallId _ -> True
PrimOpId _ -> True
ClassOpId _ -> True
Activation(..)
)
import DataCon ( DataCon )
+import TyCon ( TyCon, FieldLabel )
import ForeignCall ( ForeignCall )
-import FieldLabel ( FieldLabel )
import NewDemand
import Outputable
import Maybe ( isJust )
data GlobalIdDetails
= VanillaGlobal -- Imported from elsewhere, a default method Id.
- | RecordSelId FieldLabel -- The Id for a record selector
+ | RecordSelId TyCon FieldLabel -- The Id for a record selector
+
| DataConWorkId DataCon -- The Id for a data constructor *worker*
| DataConWrapId DataCon -- The Id for a data constructor *wrapper*
-- [the only reasons we need to know is so that
ppr (ClassOpId _) = ptext SLIT("[ClassOp]")
ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
ppr (FCallId _) = ptext SLIT("[ForeignCall]")
- ppr (RecordSelId _) = ptext SLIT("[RecSel]")
+ ppr (RecordSelId _ _) = ptext SLIT("[RecSel]")
\end{code}
module Literal
( Literal(..) -- Exported to ParseIface
, mkMachInt, mkMachWord
- , mkMachInt64, mkMachWord64
+ , mkMachInt64, mkMachWord64, mkStringLit,
, litSize
, litIsDupable, litIsTrivial
, literalType,
import FastString
import Binary
+import UnicodeUtil ( stringToUtf8 )
import Ratio ( numerator )
import FastString ( uniqueOfFS, lengthFS )
import DATA_INT ( Int8, Int16, Int32 )
mkMachInt64 x = MachInt64 x
mkMachWord64 x = MachWord64 x
+mkStringLit :: String -> Literal
+mkStringLit s = MachStr (mkFastString (stringToUtf8 s))
+
inIntRange, inWordRange :: Integer -> Bool
inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
)
import CoreUtils ( exprType )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
-import Literal ( Literal(..), nullAddrLit )
+import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
- tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
-import Class ( Class, classTyCon, classTyVars, classSelIds )
+ tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
+import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var )
import VarSet ( isEmptyVarSet )
import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
import OccName ( mkOccFS, varName )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
-import DataCon ( DataCon, DataConIds(..),
+import DataCon ( DataCon, DataConIds(..), dataConTyVars,
dataConFieldLabels, dataConRepArity,
- dataConArgTys, dataConRepType,
- dataConOrigArgTys, dataConTheta,
+ dataConRepArgTys, dataConRepType,
+ dataConStupidTheta, dataConOrigArgTys,
dataConSig, dataConStrictMarks, dataConExStricts,
- splitProductType
+ splitProductType, isVanillaDataCon
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
import NewDemand ( mkStrictSig, DmdResult(..),
mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
Demand(..), Demands(..) )
-import FieldLabel ( fieldLabelName, firstFieldLabelTag,
- allFieldLabelTags, fieldLabelType
- )
import DmdAnal ( dmdAnalTopRhs )
import CoreSyn
import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
import Outputable
import FastString
import ListSetOps ( assoc, assocMaybe )
-import UnicodeUtil ( stringToUtf8 )
import List ( nubBy )
\end{code}
| otherwise -- Algebraic, no wrapper
= AlgDC Nothing wrk_id
where
- (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
- all_tyvars = tyvars ++ ex_tyvars
+ (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
- ex_dict_tys = mkPredTys ex_theta
- all_arg_tys = ex_dict_tys ++ orig_arg_tys
- result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
+ dict_tys = mkPredTys theta
+ all_arg_tys = dict_tys ++ orig_arg_tys
+ result_ty = mkTyConApp tycon res_tys
- wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
+ wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty)
-- We used to include the stupid theta in the wrapper's args
-- but now we don't. Instead the type checker just injects these
-- extra constraints where necessary.
nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
`setUnfoldingInfo` newtype_unf
- newtype_unf = ASSERT( null ex_tyvars && null ex_theta &&
- isSingleton orig_arg_tys )
+ newtype_unf = ASSERT( isVanillaDataCon data_con &&
+ isSingleton orig_arg_tys )
-- No existentials on a newtype, but it can have a context
-- e.g. newtype Eq a => T a = MkT (...)
mkTopUnfolding $ Note InlineMe $
-- we want to see that w is strict in its two arguments
alg_unf = mkTopUnfolding $ Note InlineMe $
- mkLams all_tyvars $
- mkLams ex_dict_args $ mkLams id_args $
+ mkLams tyvars $
+ mkLams dict_args $ mkLams id_args $
foldr mk_case con_app
- (zip (ex_dict_args ++ id_args) all_strict_marks)
+ (zip (dict_args ++ id_args) all_strict_marks)
i3 []
con_app i rep_ids = mkApps (Var wrk_id)
- (map varToCoreExpr (all_tyvars ++ reverse rep_ids))
+ (map varToCoreExpr (tyvars ++ reverse rep_ids))
- (ex_dict_args,i2) = mkLocals 1 ex_dict_tys
- (id_args,i3) = mkLocals i2 orig_arg_tys
- alg_arity = i3-1
+ (dict_args,i2) = mkLocals 1 dict_tys
+ (id_args,i3) = mkLocals i2 orig_arg_tys
+ alg_arity = i3-1
mk_case
:: (Id, StrictnessMark) -- Arg, strictness
MarkedStrict
| isUnLiftedType (idType arg) -> body i (arg:rep_args)
| otherwise ->
- Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
+-- gaw 2004
+ Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
MarkedUnboxed
-> case splitProductType "do_unbox" (idType arg) of
(tycon, tycon_args, con, tys) ->
- Case (Var arg) arg [(DataAlt con, con_args,
+-- gaw 2004
+ Case (Var arg) arg result_ty [(DataAlt con, con_args,
body i' (reverse con_args ++ rep_args))]
where
(con_args, i') = mkLocals i tys
unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
\begin{code}
-mkRecordSelId tycon field_label
+mkRecordSelId tycon field_label field_ty
-- Assumes that all fields with the same field label have the same type
= sel_id
where
- sel_id = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info
- field_ty = fieldLabelType field_label
+ sel_id = mkGlobalId (RecordSelId tycon field_label) field_label selector_ty info
data_cons = tyConDataCons tycon
tyvars = tyConTyVars tycon -- These scope over the types in
-- the FieldLabels of constructors of this type
--
-- NB: this code relies on the fact that DataCons are quantified over
-- the identical type variables as their parent TyCon
- tycon_theta = tyConTheta tycon -- The context on the data decl
- -- eg data (Eq a, Ord b) => T a b = ...
- needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConTheta dc]
+ needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConStupidTheta dc]
dict_tys = map mkPredTy (nubBy tcEqPred needed_preds)
n_dict_tys = length dict_tys
`setAllStrictnessInfo` Just strict_sig
-- Allocate Ids. We do it a funny way round because field_dict_tys is
- -- almost always empty. Also note that we use length_tycon_theta
+ -- almost always empty. Also note that we use max_dict_tys
-- rather than n_dict_tys, because the latter gives an infinite loop:
-- n_dict tys depends on the_alts, which depens on arg_ids, which depends
-- on arity, which depends on n_dict tys. Sigh! Mega sigh!
- field_dict_base = length tycon_theta + 1
- dict_id_base = field_dict_base + n_field_dict_tys
- field_base = dict_id_base + 1
- dict_ids = mkTemplateLocalsNum 1 dict_tys
- field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
- data_id = mkTemplateLocal dict_id_base data_ty
+ dict_ids = mkTemplateLocalsNum 1 dict_tys
+ max_dict_tys = length (tyConStupidTheta tycon)
+ field_dict_base = max_dict_tys + 1
+ field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
+ dict_id_base = field_dict_base + n_field_dict_tys
+ data_id = mkTemplateLocal dict_id_base data_ty
+ arg_base = dict_id_base + 1
alts = map mk_maybe_alt data_cons
the_alts = catMaybes alts
Lam data_id $ sel_body
sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
- | otherwise = Case (Var data_id) data_id (default_alt ++ the_alts)
+ | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts)
mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
-- We pull the field lambdas to the top, so we need to
mk_maybe_alt data_con
= case maybe_the_arg_id of
Nothing -> Nothing
- Just the_arg_id -> Just (mkReboxingAlt uniqs data_con arg_ids body)
- where
- body = mk_result (Var the_arg_id)
+ Just the_arg_id -> Just (mkReboxingAlt uniqs data_con arg_ids $
+ mk_result (Var the_arg_id))
where
- arg_ids = mkTemplateLocalsNum field_base (dataConOrigArgTys data_con)
- -- No need to instantiate; same tyvars in datacon as tycon
- -- Records can't be existential, so no existential tyvars or dicts
+ arg_ids = ASSERT( isVanillaDataCon data_con )
+ mkTemplateLocalsNum arg_base (dataConOrigArgTys data_con)
+ -- Records can't be existential, so no existential tyvars or dicts
+ -- Vanilla data con => tycon's tyvars will do
- unpack_base = field_base + length arg_ids
+ unpack_base = arg_base + length arg_ids
uniqs = map mkBuiltinUnique [unpack_base..]
- -- arity+1 avoids all shadowing
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
field_lbls = dataConFieldLabels data_con
-- But it's type must expose the representation of the dictionary
-- to gat (say) C a -> (a -> a)
- tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
-
info = noCafIdInfo
`setArityInfo` 1
`setUnfoldingInfo` mkTopUnfolding rhs
| otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
| id <- arg_ids ])
- tyvars = classTyVars clas
-
tycon = classTyCon clas
[data_con] = tyConDataCons tycon
- tyvar_tys = mkTyVarTys tyvars
- arg_tys = dataConArgTys data_con tyvar_tys
- the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
+ tyvars = dataConTyVars data_con
+ arg_tys = dataConRepArgTys data_con
+ the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
- pred = mkClassPred clas tyvar_tys
+ pred = mkClassPred clas (mkTyVarTys tyvars)
(dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
mkNewTypeBody tycon (head arg_tys) (Var dict_id)
| otherwise = mkLams tyvars $ Lam dict_id $
- Case (Var dict_id) dict_id
+ Case (Var dict_id) dict_id (idType the_arg_id)
[(DataAlt data_con, arg_ids, Var the_arg_id)]
mkNewTypeBody tycon result_ty result_expr
(class_tyvars, sc_theta, _, _) = classBigSig clas
not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
- sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
+ sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta
dfun_theta = case inst_decl_theta of
[] -> [] -- If inst_decl_theta is empty, then we don't
-- want to have any dict arguments, so that we can
ty = mkForAllTys [alphaTyVar,openBetaTyVar]
(mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
[x,y] = mkTemplateLocals [alphaTy, openBetaTy]
- rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)])
+-- gaw 2004
+ rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
-- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
-- Used to lazify pseq: pseq a b = a `seq` lazy b
mkRuntimeErrorApp err_id res_ty err_msg
= mkApps (Var err_id) [Type res_ty, err_string]
where
- err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg)))
+ err_string = Lit (mkStringLit err_msg)
rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
Internal -> pprInternal sty uniq occ
pprExternal sty uniq mod occ is_wired is_builtin
- | codeStyle sty = ppr mod_name <> char '_' <> pprOccName occ
+ | codeStyle sty = ppr mod_name <> char '_' <> ppr_occ_name occ
-- In code style, always qualify
-- ToDo: maybe we could print all wired-in things unqualified
-- in code style, to reduce symbol table bloat?
- | debugStyle sty = sep [ppr mod_name <> dot <> pprOccName occ,
- hsep [text "{-"
- , if is_wired then ptext SLIT("(w)") else empty
- , pprUnique uniq
--- (overkill) , case mb_p of
--- Nothing -> empty
--- Just n -> brackets (ppr n)
- , text "-}"]]
- | BuiltInSyntax <- is_builtin = pprOccName occ
+ | debugStyle sty = ppr mod_name <> dot <> ppr_occ_name occ
+ <> braces (hsep [if is_wired then ptext SLIT("(w)") else empty,
+ text (briefOccNameFlavour occ),
+ pprUnique uniq])
+ | BuiltInSyntax <- is_builtin = ppr_occ_name occ
-- never qualify builtin syntax
- | unqualStyle sty mod_name occ = pprOccName occ
- | otherwise = ppr mod_name <> dot <> pprOccName occ
+ | unqualStyle sty mod_name occ = ppr_occ_name occ
+ | otherwise = ppr mod_name <> dot <> ppr_occ_name occ
where
mod_name = moduleName mod
pprInternal sty uniq occ
| codeStyle sty = pprUnique uniq
- | debugStyle sty = pprOccName occ <> text "{-" <> pprUnique uniq <> text "-}"
- | otherwise = pprOccName occ -- User style
+ | debugStyle sty = ppr_occ_name occ <> braces (hsep [text (briefOccNameFlavour occ),
+ pprUnique uniq])
+ | otherwise = ppr_occ_name occ -- User style
-- Like Internal, except that we only omit the unique in Iface style
pprSystem sty uniq occ
| codeStyle sty = pprUnique uniq
- | otherwise = pprOccName occ <> char '_' <> pprUnique uniq
+ | debugStyle sty = ppr_occ_name occ <> char '_' <> pprUnique uniq
+ <> braces (text (briefOccNameFlavour occ))
+ | otherwise = ppr_occ_name occ <> char '_' <> pprUnique uniq
-- If the tidy phase hasn't run, the OccName
-- is unlikely to be informative (like 's'),
-- so print the unique
+
+ppr_occ_name occ = pprEncodedFS (occNameFS occ)
+ -- Don't use pprOccName; instead, just print the string of the OccName;
+ -- we print the namespace in the debug stuff above
\end{code}
%************************************************************************
TyVar, mkTyVar, mkTcTyVar,
tyVarName, tyVarKind,
setTyVarName, setTyVarUnique,
- tcTyVarRef, tcTyVarDetails,
+ tcTyVarDetails,
-- Ids
Id, DictId,
#include "HsVersions.h"
import {-# SOURCE #-} TypeRep( Type )
-import {-# SOURCE #-} TcType( TyVarDetails )
-import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId,
- IdInfo, seqIdInfo )
+import {-# SOURCE #-} TcType( TcTyVarDetails )
+import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, IdInfo, seqIdInfo )
import Name ( Name, OccName, NamedThing(..),
setNameUnique, setNameOcc, nameUnique
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# )
import FastTypes
import Outputable
-import DATA_IOREF
\end{code}
tyVarKind :: Kind }
| TcTyVar { -- Used only during type inference
- varName :: !Name, -- Could we get away without a Name?
+ varName :: !Name,
realUnique :: FastInt,
tyVarKind :: Kind,
- tcTyVarRef :: IORef (Maybe Type),
- tcTyVarDetails :: TyVarDetails }
+ tcTyVarDetails :: TcTyVarDetails }
| GlobalId { -- Used for imported Ids, dict selectors etc
varName :: !Name,
, tyVarKind = kind
}
-mkTcTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar
-mkTcTyVar name kind details ref
+mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
+mkTcTyVar name kind details
= TcTyVar { varName = name,
realUnique = getKey# (nameUnique name),
tyVarKind = kind,
- tcTyVarRef = ref,
tcTyVarDetails = details
}
\end{code}
module VarEnv (
VarEnv, IdEnv, TyVarEnv,
emptyVarEnv, unitVarEnv, mkVarEnv,
- elemVarEnv, rngVarEnv,
+ elemVarEnv, varEnvElts,
extendVarEnv, extendVarEnv_C, extendVarEnvList,
plusVarEnv, plusVarEnv_C,
delVarEnvList, delVarEnv,
lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
mapVarEnv, zipVarEnv,
modifyVarEnv, modifyVarEnv_Directly,
- isEmptyVarEnv, foldVarEnv,
+ isEmptyVarEnv, foldVarEnv,
+ lookupVarEnv_Directly,
+ filterVarEnv_Directly,
- -- TidyEnvs
- TidyEnv, emptyTidyEnv,
+ -- InScopeSet
+ InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet,
+ extendInScopeSet, extendInScopeSetList, modifyInScopeSet,
+ getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
- -- SubstEnvs
- SubstEnv, TyVarSubstEnv, SubstResult(..),
- emptySubstEnv, substEnvEnv, elemSubstEnv,
- mkSubstEnv, lookupSubstEnv, extendSubstEnv, extendSubstEnvList,
- delSubstEnv, delSubstEnvList, noTypeSubst, isEmptySubstEnv
+ -- TidyEnvs
+ TidyEnv, emptyTidyEnv
) where
#include "HsVersions.h"
-import {-# SOURCE #-} CoreSyn( CoreExpr )
-import {-# SOURCE #-} TypeRep( Type )
-
-import BasicTypes ( OccInfo )
import OccName ( TidyOccEnv, emptyTidyOccEnv )
-import Var ( Var, Id )
+import Var ( Var, setVarUnique )
+import VarSet
import UniqFM
+import Unique ( Unique, deriveUnique, getUnique )
import Util ( zipEqual )
+import CmdLineOpts ( opt_PprStyle_Debug )
+import Outputable
+import FastTypes
\end{code}
%************************************************************************
%* *
-\subsection{Tidying}
+ In-scope sets
%* *
%************************************************************************
-When tidying up print names, we keep a mapping of in-scope occ-names
-(the TidyOccEnv) and a Var-to-Var of the current renamings.
-
\begin{code}
-type TidyEnv = (TidyOccEnv, VarEnv Var)
+data InScopeSet = InScope (VarEnv Var) FastInt
+ -- The Int# is a kind of hash-value used by uniqAway
+ -- For example, it might be the size of the set
+ -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
+
+instance Outputable InScopeSet where
+ ppr (InScope s i) = ptext SLIT("InScope") <+> ppr s
+
+emptyInScopeSet :: InScopeSet
+emptyInScopeSet = InScope emptyVarSet 1#
+
+getInScopeVars :: InScopeSet -> VarEnv Var
+getInScopeVars (InScope vs _) = vs
+
+mkInScopeSet :: VarEnv Var -> InScopeSet
+mkInScopeSet in_scope = InScope in_scope 1#
+
+extendInScopeSet :: InScopeSet -> Var -> InScopeSet
+extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
+
+extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
+extendInScopeSetList (InScope in_scope n) vs
+ = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
+ (n +# iUnbox (length vs))
+
+modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
+-- Exploit the fact that the in-scope "set" is really a map
+-- Make old_v map to new_v
+modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
+
+delInScopeSet :: InScopeSet -> Var -> InScopeSet
+delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
+
+elemInScopeSet :: Var -> InScopeSet -> Bool
+elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
+
+lookupInScope :: InScopeSet -> Var -> Maybe Var
+-- It's important to look for a fixed point
+-- When we see (case x of y { I# v -> ... })
+-- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
+-- When we lookup up an occurrence of x, we map to y, but then
+-- we want to look up y in case it has acquired more evaluation information by now.
+lookupInScope (InScope in_scope n) v
+ = go v
+ where
+ go v = case lookupVarEnv in_scope v of
+ Just v' | v == v' -> Just v' -- Reached a fixed point
+ | otherwise -> go v'
+ Nothing -> Nothing
+\end{code}
-emptyTidyEnv :: TidyEnv
-emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
+\begin{code}
+uniqAway :: InScopeSet -> Var -> Var
+-- (uniqAway in_scope v) finds a unique that is not used in the
+-- in-scope set, and gives that to v. It starts with v's current unique, of course,
+-- in the hope that it won't have to change it, and thereafter uses a combination
+-- of that and the hash-code found in the in-scope set
+uniqAway (InScope set n) var
+ | not (var `elemVarSet` set) = var -- Nothing to do
+ | otherwise = try 1#
+ where
+ orig_unique = getUnique var
+ try k
+#ifdef DEBUG
+ | k ># 1000#
+ = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
+#endif
+ | uniq `elemVarSetByKey` set = try (k +# 1#)
+#ifdef DEBUG
+ | opt_PprStyle_Debug && k ># 3#
+ = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
+ setVarUnique var uniq
+#endif
+ | otherwise = setVarUnique var uniq
+ where
+ uniq = deriveUnique orig_unique (iBox (n *# k))
\end{code}
%************************************************************************
%* *
-\subsection{Substitution environments}
+ Tidying
%* *
%************************************************************************
-\begin{code}
-
-noTys :: SubstResult -> Bool -> Bool
-noTys (DoneTy ty) no_tys = False
-noTys other no_tys = no_tys
-
-data SubstEnv = SE (VarEnv SubstResult)
- Bool -- True => definitely no type substitutions in the env
-
-noTypeSubst :: SubstEnv -> Bool
-noTypeSubst (SE _ nt) = nt
-
-substEnvEnv :: SubstEnv -> VarEnv SubstResult
-substEnvEnv (SE env _) = env
-
-type TyVarSubstEnv = SubstEnv -- of the form (DoneTy ty) *only*
-
-data SubstResult
- = DoneEx CoreExpr -- Completed term
- | DoneId Id OccInfo -- Completed term variable, with occurrence info; only
- -- used by the simplifier
- | DoneTy Type -- Completed type
- | ContEx SubstEnv CoreExpr -- A suspended substitution
-
-emptySubstEnv :: SubstEnv
-emptySubstEnv = SE emptyVarEnv True
-
-isEmptySubstEnv :: SubstEnv -> Bool
-isEmptySubstEnv (SE s _) = isEmptyVarEnv s
-
-lookupSubstEnv :: SubstEnv -> Var -> Maybe SubstResult
-lookupSubstEnv (SE s _) v = lookupVarEnv s v
-
-elemSubstEnv :: Var -> SubstEnv -> Bool
-elemSubstEnv v (SE s _) = elemVarEnv v s
-
-extendSubstEnv :: SubstEnv -> Var -> SubstResult -> SubstEnv
-extendSubstEnv (SE s nt) v r = SE (extendVarEnv s v r) (noTys r nt)
-
-mkSubstEnv :: [Var] -> [SubstResult] -> SubstEnv
-mkSubstEnv bs vs = extendSubstEnvList emptySubstEnv bs vs
-
-extendSubstEnvList :: SubstEnv -> [Var] -> [SubstResult] -> SubstEnv
-extendSubstEnvList env [] [] = env
-extendSubstEnvList (SE env nt) (b:bs) (r:rs) = extendSubstEnvList (SE (extendVarEnv env b r) (noTys r nt)) bs rs
+When tidying up print names, we keep a mapping of in-scope occ-names
+(the TidyOccEnv) and a Var-to-Var of the current renamings.
-delSubstEnv :: SubstEnv -> Var -> SubstEnv
-delSubstEnv (SE s nt) v = SE (delVarEnv s v) nt
+\begin{code}
+type TidyEnv = (TidyOccEnv, VarEnv Var)
-delSubstEnvList :: SubstEnv -> [Var] -> SubstEnv
-delSubstEnvList (SE s nt) vs = SE (delVarEnvList s vs) nt
+emptyTidyEnv :: TidyEnv
+emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
\end{code}
plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a
extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a
+lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
+filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
delVarEnv :: VarEnv a -> Var -> VarEnv a
plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a
-rngVarEnv :: VarEnv a -> [a]
+varEnvElts :: VarEnv a -> [a]
isEmptyVarEnv :: VarEnv a -> Bool
lookupVarEnv :: VarEnv a -> Var -> Maybe a
mapVarEnv = mapUFM
mkVarEnv = listToUFM
emptyVarEnv = emptyUFM
-rngVarEnv = eltsUFM
+varEnvElts = eltsUFM
unitVarEnv = unitUFM
isEmptyVarEnv = isNullUFM
foldVarEnv = foldUFM
+lookupVarEnv_Directly = lookupUFM_Directly
+filterVarEnv_Directly = filterUFM_Directly
zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx }
intersectVarSet, intersectsVarSet,
isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet,
- lookupVarSet, mapVarSet, sizeVarSet, seqVarSet
+ lookupVarSet, mapVarSet, sizeVarSet, seqVarSet,
+ elemVarSetByKey
) where
#include "HsVersions.h"
extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet
delVarSetByKey :: VarSet -> Unique -> VarSet
+elemVarSetByKey :: Unique -> VarSet -> Bool
emptyVarSet = emptyUniqSet
unitVarSet = unitUniqSet
filterVarSet = filterUniqSet
extendVarSet_C combine s x = addToUFM_C combine s x x
delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet
+elemVarSetByKey = elemUniqSet_Directly
\end{code}
\begin{code}
pprPanic "cgPanic"
(vcat [ppr id,
ptext SLIT("static binds for:"),
- vcat [ ppr (cg_id info) | info <- rngVarEnv static_binds ],
+ vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
ptext SLIT("local binds for:"),
- vcat [ ppr (cg_id info) | info <- rngVarEnv local_binds ],
+ vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
ptext SLIT("SRT label") <+> pprCLabel srt
])
\end{code}
\begin{code}
nukeVolatileBinds :: CgBindings -> CgBindings
nukeVolatileBinds binds
- = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
+ = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
where
keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
keep_if_stable info acc
let (dead_stk_slots, bs') =
dead_slots live_vars
[] []
- [ (cg_id b, b) | b <- rngVarEnv binds ]
+ [ (cg_id b, b) | b <- varEnvElts binds ]
setBinds $ mkVarEnv bs'
freeStackSlots dead_stk_slots
\end{code}
getLiveStackSlots
= do { binds <- getBinds
; return [off | CgIdInfo { cg_stb = VirStkLoc off,
- cg_rep = rep } <- rngVarEnv binds,
+ cg_rep = rep } <- varEnvElts binds,
isFollowableArg rep] }
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.70 2004/08/13 13:25:45 simonmar Exp $
+% $Id: CgCase.lhs,v 1.71 2004/09/30 10:35:36 simonpj Exp $
%
%********************************************************
%* *
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.63 2004/08/13 13:05:54 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.64 2004/09/30 10:35:39 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
currentCCS )
import Constants ( mIN_INTLIKE, mAX_INTLIKE, mIN_CHARLIKE, mAX_CHARLIKE )
import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, tyConName )
-import DataCon ( DataCon, dataConRepArgTys, isNullaryDataCon,
+import DataCon ( DataCon, dataConRepArgTys, isNullaryRepDataCon,
isUnboxedTupleCon, dataConWorkId,
dataConName, dataConRepArity
)
cgDataCon :: DataCon -> Code
cgDataCon data_con
= do { -- Don't need any dynamic closure code for zero-arity constructors
- whenC (not (isNullaryDataCon data_con))
+ whenC (not (isNullaryRepDataCon data_con))
(emit_info dyn_cl_info tickyEnterDynCon)
-- Dynamic-Closure first, to reduce forward references
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.59 2004/08/13 13:05:58 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.60 2004/09/30 10:35:43 simonpj Exp $
%
%********************************************************
%* *
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.40 2004/08/13 13:06:00 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.41 2004/09/30 10:35:45 simonpj Exp $
%
\section[CgHeapery]{Heap management functions}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-% $Id: CgLetNoEscape.lhs,v 1.25 2004/08/13 13:06:03 simonmar Exp $
+% $Id: CgLetNoEscape.lhs,v 1.26 2004/09/30 10:35:47 simonpj Exp $
%
%********************************************************
%* *
emitSetCCC cc
| not opt_SccProfilingOn = nopC
| otherwise = do
- ASSERTM(sccAbleCostCentre cc)
tmp <- newTemp wordRep
- pushCostCentre tmp curCCS cc
+ ASSERT( sccAbleCostCentre cc )
+ pushCostCentre tmp curCCS cc
stmtC (CmmStore curCCSAddr (CmmReg tmp))
when (isSccCountCostCentre cc) $
stmtC (bumpSccCount curCCS)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.26 2004/08/17 15:23:48 simonpj Exp $
+% $Id: CgStackery.lhs,v 1.27 2004/09/30 10:35:49 simonpj Exp $
%
\section[CgStackery]{Stack management functions}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.39 2004/08/13 13:06:13 simonmar Exp $
+% $Id: CgTailCall.lhs,v 1.40 2004/09/30 10:35:50 simonpj Exp $
%
%********************************************************
%* *
opt_Parallel, opt_DoTickyProfiling,
opt_SMP )
import Id ( Id, idType, idArity, idName )
-import DataCon ( DataCon, dataConTyCon, isNullaryDataCon, dataConName )
+import DataCon ( DataCon, dataConTyCon, isNullaryRepDataCon, dataConName )
import Name ( Name, nameUnique, getOccName, getOccString )
import OccName ( occNameUserString )
import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
= needsSRT srt
staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
- = not (isNullaryDataCon con) && not_nocaf_constr
+ = not (isNullaryRepDataCon con) && not_nocaf_constr
where
not_nocaf_constr =
case sm_rep of
import TyCon ( isDataTyCon )
import Module ( Module, mkModuleName )
import ErrUtils ( dumpIfSet_dyn, showPass )
-import Panic ( assertPanic, trace )
+import Panic ( assertPanic )
import qualified Module ( moduleName )
#ifdef DEBUG
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
-expr_fvs (Case scrut bndr alts)
- = expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts)
+-- gaw 2004
+expr_fvs (Case scrut bndr ty alts)
+ = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
+ (foldr (union . alt_fvs) noVars alts)
where
alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
where
(bs, rs) = unzip prs
-exprFreeNames (Case e b as) = exprFreeNames e `unionNameSets`
- (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b)
+-- gaw 2004
+exprFreeNames (Case e b ty as) = exprFreeNames e `unionNameSets` tyClsNamesOfType ty
+ `unionNameSets`
+ (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b)
-- Helpers
altFreeNames (_,bs,r) = exprFreeNames r `del_binders` bs
fun2 = freeVars fun
arg2 = freeVars arg
-freeVars (Case scrut bndr alts)
- = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2,
- AnnCase scrut2 bndr alts2)
+freeVars (Case scrut bndr ty alts)
+-- gaw 2004
+ = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
+ AnnCase scrut2 bndr ty alts2)
where
scrut2 = freeVars scrut
import CoreSyn
import CoreFVs ( idFreeVars )
import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
-
+import Unify ( coreRefineTys )
import Bag
import Literal ( literalType )
-import DataCon ( dataConRepType )
+import DataCon ( dataConRepType, isVanillaDataCon, dataConTyCon )
import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
import VarSet
-import Subst ( substTyWith )
import Name ( getSrcLoc )
import PprCore
import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
mkLocMessage, debugTraceMsg )
import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
import Type ( Type, tyVarsOfType, eqType,
- splitFunTy_maybe, mkTyVarTy,
- splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
+ splitFunTy_maybe,
+ splitForAllTy_maybe, splitTyConApp_maybe,
isUnLiftedType, typeKind,
- isUnboxedTupleType,
- isSubKind
- )
-import TyCon ( isPrimTyCon )
+ isUnboxedTupleType, isSubKind,
+ substTyWith, emptyTvSubst, extendTvInScope,
+ TvSubst, TvSubstEnv, setTvSubstEnv, substTy,
+ extendTvSubst, isInScope )
+import TyCon ( isPrimTyCon, TyCon )
import BasicTypes ( RecFlag(..), isNonRec )
import CmdLineOpts
import Outputable
import Maybe
-infixr 9 `thenL`, `seqL`
\end{code}
%************************************************************************
-- This is because transformation rules can bring something
-- into use 'unexpectedly'
lint_binds binds = addInScopeVars (bindersOfBinds binds) $
- mapL lint_bind binds
+ mapM lint_bind binds
- lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
- returnL ()
+ lint_bind (Rec prs) = mapM_ (lintSingleBinding Recursive) prs
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
display bad_news
\begin{code}
lintSingleBinding rec_flag (binder,rhs)
= addLoc (RhsOf binder) $
-
- -- Check the rhs
- lintCoreExpr rhs `thenL` \ ty ->
-
- -- Check match to RHS type
- lintBinder binder `seqL`
- checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
-
- -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
- checkL (not (isUnLiftedType binder_ty)
+ -- Check the rhs
+ do { ty <- lintCoreExpr rhs
+ ; lintBinder binder -- Check match to RHS type
+ ; binder_ty <- applySubst binder_ty
+ ; checkTys binder_ty ty (mkRhsMsg binder ty)
+ -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
+ ; checkL (not (isUnLiftedType binder_ty)
|| (isNonRec rec_flag && exprOkForSpeculation rhs))
- (mkRhsPrimMsg binder rhs) `seqL`
-
+ (mkRhsPrimMsg binder rhs)
-- Check whether binder's specialisations contain any out-of-scope variables
- mapL (checkBndrIdInScope binder) bndr_vars `seqL`
- returnL ()
+ ; mapM_ (checkBndrIdInScope binder) bndr_vars }
-- We should check the unfolding, if any, but this is tricky because
-- the unfolding is a SimplifiableCoreExpr. Give up for now.
%************************************************************************
\begin{code}
+
lintCoreExpr :: CoreExpr -> LintM Type
+-- The returned type has the substitution from the monad
+-- already applied to it:
+-- lintCoreExpr e subst = exprTpye (subst e)
+
+lintCoreExpr (Var var)
+ = do { checkIdInScope var
+ ; applySubst (idType var) }
-lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
-lintCoreExpr (Lit lit) = returnL (literalType lit)
+lintCoreExpr (Lit lit)
+ = return (literalType lit)
lintCoreExpr (Note (Coerce to_ty from_ty) expr)
- = lintCoreExpr expr `thenL` \ expr_ty ->
- lintTy to_ty `seqL`
- lintTy from_ty `seqL`
- checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
- returnL to_ty
+ = do { expr_ty <- lintCoreExpr expr
+ ; to_ty <- lintTy to_ty
+ ; from_ty <- lintTy from_ty
+ ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
+ ; return to_ty }
lintCoreExpr (Note other_note expr)
= lintCoreExpr expr
lintCoreExpr (Let (NonRec bndr rhs) body)
- = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
- addLoc (BodyOfLetRec [bndr])
- (addInScopeVars [bndr] (lintCoreExpr body))
+ = do { lintSingleBinding NonRecursive (bndr,rhs)
+ ; addLoc (BodyOfLetRec [bndr])
+ (addInScopeVars [bndr] (lintCoreExpr body)) }
-lintCoreExpr (Let (Rec pairs) body)
+lintCoreExpr (Let (Rec pairs) body)
= addInScopeVars bndrs $
- mapL (lintSingleBinding Recursive) pairs `seqL`
- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
+ do { mapM (lintSingleBinding Recursive) pairs
+ ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
where
bndrs = map fst pairs
+lintCoreExpr (App fun (Type ty))
+-- This is like 'let' for types
+-- It's needed when dealing with desugarer output for GADTs. Consider
+-- data T = forall a. T a (a->Int) Bool
+-- f :: T -> ... ->
+-- f (T x f True) = <e1>
+-- f (T y g False) = <e2>
+-- After desugaring we get
+-- f t b = case t of
+-- T a (x::a) (f::a->Int) (b:Bool) ->
+-- case b of
+-- True -> <e1>
+-- False -> (/\b. let y=x; g=f in <e2>) a
+-- And for a reason I now forget, the ...<e2>... can mention a; so
+-- we want Lint to know that b=a. Ugh.
+--
+-- I tried quite hard to make the necessity for this go away, by changing the
+-- desugarer, but the fundamental problem is this:
+--
+-- T a (x::a) (y::Int) -> let fail::a = ...
+-- in (/\b. ...(case ... of
+-- True -> x::b
+-- False -> fail)
+-- ) a
+-- Now the inner case look as though it has incompatible branches.
+ = go fun [ty]
+ where
+ go (App fun (Type ty)) tys
+ = do { go fun (ty:tys) }
+ go (Lam tv body) (ty:tys)
+ = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate
+ ; ty' <- lintTy ty;
+ ; checkKinds tv ty'
+ -- Now extend the substitution so we
+ -- take advantage of it in the body
+ ; addInScopeVars [tv] $
+ extendSubstL tv ty' $
+ go body tys }
+ go fun tys
+ = do { fun_ty <- lintCoreExpr fun
+ ; lintCoreArgs fun_ty (map Type tys) }
+
lintCoreExpr e@(App fun arg)
- = lintCoreExpr fun `thenL` \ ty ->
- addLoc (AnExpr e) $
- lintCoreArg ty arg
+ = do { ty <- lintCoreExpr fun
+ ; addLoc (AnExpr e) $
+ lintCoreArg ty arg }
lintCoreExpr (Lam var expr)
- = addLoc (LambdaBodyOf var) $
- (if isId var then
- checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
- else
- returnL ())
- `seqL`
- (addInScopeVars [var] $
- lintCoreExpr expr `thenL` \ ty ->
-
- returnL (mkPiType var ty))
-
-lintCoreExpr e@(Case scrut var alts)
- = -- Check the scrutinee
- lintCoreExpr scrut `thenL` \ scrut_ty ->
-
- -- Check the binder
- lintBinder var `seqL`
-
- -- If this is an unboxed tuple case, then the binder must be dead
- {-
- checkL (if isUnboxedTupleType (idType var)
- then isDeadBinder var
- else True) (mkUnboxedTupleMsg var) `seqL`
- -}
-
- checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
-
- addInScopeVars [var] (
-
- -- Check the alternatives
- checkCaseAlts e scrut_ty alts `seqL`
-
- mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
- mapL (check alt_ty) alt_tys `seqL`
- returnL alt_ty)
- where
- check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
+ = addLoc (LambdaBodyOf var) $
+ do { lintBinder var
+ ; ty <- addInScopeVars [var] $
+ lintCoreExpr expr
+ ; applySubst (mkPiType var ty) }
+ -- The applySubst is needed to apply the subst to var
+
+lintCoreExpr e@(Case scrut var alt_ty alts) =
+ -- Check the scrutinee
+ do { scrut_ty <- lintCoreExpr scrut
+ ; alt_ty <- lintTy alt_ty
+ ; var_ty <- lintTy (idType var)
+ -- Don't use lintId on var, because unboxed tuple is legitimate
+
+ ; checkTys var_ty scrut_ty (mkScrutMsg var scrut_ty)
+
+ -- If the binder is an unboxed tuple type, don't put it in scope
+ ; let vars = if (isUnboxedTupleType (idType var)) then [] else [var]
+ ; addInScopeVars vars $
+ do { -- Check the alternatives
+ checkCaseAlts e scrut_ty alts
+ ; mapM (lintCoreAlt scrut_ty alt_ty) alts
+ ; return alt_ty } }
lintCoreExpr e@(Type ty)
= addErrL (mkStrangeTyMsg e)
\begin{code}
lintCoreArgs :: Type -> [CoreArg] -> LintM Type
-lintCoreArgs = lintCoreArgs0 checkTys
-
-lintCoreArg :: Type -> CoreArg -> LintM Type
-lintCoreArg = lintCoreArg0 checkTys
+lintCoreArg :: Type -> CoreArg -> LintM Type
+-- First argument has already had substitution applied to it
\end{code}
-The primitive version of these functions takes a check argument,
-allowing a different comparison.
-
\begin{code}
-lintCoreArgs0 check_tys ty [] = returnL ty
-lintCoreArgs0 check_tys ty (a : args)
- = lintCoreArg0 check_tys ty a `thenL` \ res ->
- lintCoreArgs0 check_tys res args
-
-lintCoreArg0 check_tys ty a@(Type arg_ty)
- = lintTy arg_ty `seqL`
- lintTyApp ty arg_ty
-
-lintCoreArg0 check_tys fun_ty arg
- = -- Make sure function type matches argument
- lintCoreExpr arg `thenL` \ arg_ty ->
- let
- err = mkAppMsg fun_ty arg_ty
- in
- case splitFunTy_maybe fun_ty of
- Just (arg,res) -> check_tys arg arg_ty err `seqL`
- returnL res
- _ -> addErrL err
+lintCoreArgs ty [] = return ty
+lintCoreArgs ty (a : args) =
+ do { res <- lintCoreArg ty a
+ ; lintCoreArgs res args }
+
+lintCoreArg ty a@(Type arg_ty) =
+ do { arg_ty <- lintTy arg_ty
+ ; lintTyApp ty arg_ty }
+
+lintCoreArg fun_ty arg =
+ -- Make sure function type matches argument
+ do { arg_ty <- lintCoreExpr arg
+ ; let err = mkAppMsg fun_ty arg_ty
+ ; case splitFunTy_maybe fun_ty of
+ Just (arg,res) ->
+ do { checkTys arg arg_ty err
+ ; return res }
+ _ -> addErrL err }
\end{code}
\begin{code}
+-- Both args have had substitution applied
lintTyApp ty arg_ty
= case splitForAllTy_maybe ty of
Nothing -> addErrL (mkTyAppMsg ty arg_ty)
- Just (tyvar,body) ->
- if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
- let
- tyvar_kind = tyVarKind tyvar
- argty_kind = typeKind arg_ty
- in
- if argty_kind `isSubKind` tyvar_kind
- -- Arg type might be boxed for a function with an uncommitted
- -- tyvar; notably this is used so that we can give
- -- error :: forall a:*. String -> a
- -- and then apply it to both boxed and unboxed types.
- then
- returnL (substTyWith [tyvar] [arg_ty] body)
- else
- addErrL (mkKindErrMsg tyvar arg_ty)
-
-lintTyApps fun_ty []
- = returnL fun_ty
-
-lintTyApps fun_ty (arg_ty : arg_tys)
- = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
- lintTyApps fun_ty' arg_tys
-\end{code}
+ Just (tyvar,body)
+ -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
+ ; checkKinds tyvar arg_ty
+ ; return (substTyWith [tyvar] [arg_ty] body) }
+
+lintTyApps fun_ty [] = return fun_ty
+lintTyApps fun_ty (arg_ty : arg_tys) =
+ do { fun_ty' <- lintTyApp fun_ty arg_ty
+ ; lintTyApps fun_ty' arg_tys }
+
+checkKinds tyvar arg_ty
+ -- Arg type might be boxed for a function with an uncommitted
+ -- tyvar; notably this is used so that we can give
+ -- error :: forall a:*. String -> a
+ -- and then apply it to both boxed and unboxed types.
+ = checkL (argty_kind `isSubKind` tyvar_kind)
+ (mkKindErrMsg tyvar arg_ty)
+ where
+ tyvar_kind = tyVarKind tyvar
+ argty_kind = typeKind arg_ty
+\end{code}
%************************************************************************
checkCaseAlts e ty []
= addErrL (mkNullAltsMsg e)
-checkCaseAlts e ty alts
- = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL`
- checkL (isJust maybe_deflt || not is_infinite_ty)
- (nonExhaustiveAltsMsg e)
+checkCaseAlts e ty alts =
+ do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
+ ; checkL (isJust maybe_deflt || not is_infinite_ty)
+ (nonExhaustiveAltsMsg e) }
where
(con_alts, maybe_deflt) = findDefault alts
\end{code}
\begin{code}
+checkAltExpr :: CoreExpr -> Type -> LintM ()
+checkAltExpr expr ty
+ = do { actual_ty <- lintCoreExpr expr
+ ; ty' <- applySubst ty
+ ; checkTys actual_ty ty' (mkCaseAltMsg expr actual_ty ty') }
+
lintCoreAlt :: Type -- Type of scrutinee
+ -> Type -- Type of the alternative
-> CoreAlt
- -> LintM Type -- Type of alternatives
+ -> LintM ()
-lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
- = checkL (null args) (mkDefaultArgsMsg args) `seqL`
- lintCoreExpr rhs
+lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
+ do { checkL (null args) (mkDefaultArgsMsg args)
+ ; checkAltExpr rhs alt_ty }
-lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
- = checkL (null args) (mkDefaultArgsMsg args) `seqL`
- checkTys lit_ty scrut_ty
- (mkBadPatMsg lit_ty scrut_ty) `seqL`
- lintCoreExpr rhs
+lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
+ do { checkL (null args) (mkDefaultArgsMsg args)
+ ; checkTys lit_ty scrut_ty
+ (mkBadPatMsg lit_ty scrut_ty)
+ ; checkAltExpr rhs alt_ty }
where
lit_ty = literalType lit
-lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
- = addLoc (CaseAlt alt) (
-
- mapL (\arg -> checkL (not (isId arg && isUnboxedTupleType (idType arg)))
- (mkUnboxedTupleMsg arg)) args `seqL`
-
- addInScopeVars args (
-
- -- Check the pattern
- -- Scrutinee type must be a tycon applicn; checked by caller
- -- This code is remarkably compact considering what it does!
- -- NB: args must be in scope here so that the lintCoreArgs line works.
- -- NB: relies on existential type args coming *after* ordinary type args
- case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
- lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
- lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
- checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
- } `seqL`
-
- -- Check the RHS
- lintCoreExpr rhs
- ))
- where
- mk_arg b | isTyVar b = Type (mkTyVarTy b)
- | isId b = Var b
- | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
+lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
+ | isVanillaDataCon con
+ = addLoc (CaseAlt alt) $
+ addInScopeVars args $
+ do { mapM lintBinder args
+ -- FIX! Add check that all args are Ids.
+ -- Check the pattern
+ -- Scrutinee type must be a tycon applicn; checked by caller
+ -- This code is remarkably compact considering what it does!
+ -- NB: args must be in scope here so that the lintCoreArgs line works.
+ -- NB: relies on existential type args coming *after* ordinary type args
+
+ ; case splitTyConApp_maybe scrut_ty of {
+ Just (tycon, tycon_arg_tys) ->
+ do { con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
+ -- Can just map Var as we know that this is a vanilla datacon
+ ; con_result_ty <- lintCoreArgs con_type (map Var args)
+ ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
+ -- Check the RHS
+ ; checkAltExpr rhs alt_ty } ;
+ Nothing -> addErrL (mkBadAltMsg scrut_ty alt)
+ } }
+
+ | otherwise
+ = addLoc (CaseAlt alt) $
+ addInScopeVars args $ -- Put the args in scope before lintBinder, because
+ -- the Ids mention the type variables
+ do { mapM lintBinder args
+ ; case splitTyConApp_maybe scrut_ty of {
+ Nothing -> addErrL (mkBadAltMsg scrut_ty alt) ;
+ Just (tycon, tycon_args_tys) ->
+ do { checkL (tycon == dataConTyCon con) (mkIncTyconMsg tycon alt)
+ ; pat_res_ty <- lintCoreArgs (dataConRepType con) (map varToCoreExpr args)
+ ; subst <- getTvSubst
+ ; case coreRefineTys args subst pat_res_ty scrut_ty of
+ Just senv -> updateTvSubstEnv senv (checkAltExpr rhs alt_ty)
+ Nothing -> return () -- Alternative is dead code
+ } } }
\end{code}
%************************************************************************
\begin{code}
lintBinder :: Var -> LintM ()
-lintBinder v = nopL
--- ToDo: lint its type
--- ToDo: lint its rules
+lintBinder var | isId var = lintId var >> return ()
+ | otherwise = return ()
-lintTy :: Type -> LintM ()
-lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
- returnL ()
- -- ToDo: check the kind structure of the type
+lintId :: Var -> LintM Type
+-- ToDo: lint its rules
+lintId id
+ = do { checkL (not (isUnboxedTupleType (idType id)))
+ (mkUnboxedTupleMsg id)
+ -- No variable can be bound to an unboxed tuple.
+ ; lintTy (idType id) }
+
+lintTy :: Type -> LintM Type
+-- Check the type, and apply the substitution to it
+-- ToDo: check the kind structure of the type
+lintTy ty
+ = do { ty' <- applySubst ty
+ ; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty'))
+ ; return ty' }
\end{code}
%************************************************************************
\begin{code}
-type LintM a = [LintLocInfo] -- Locations
- -> IdSet -- Local vars in scope
- -> Bag Message -- Error messages so far
- -> (Maybe a, Bag Message) -- Result and error messages (if any)
+newtype LintM a =
+ LintM { unLintM ::
+ [LintLocInfo] -> -- Locations
+ TvSubst -> -- Current type substitution; we also use this
+ -- to keep track of all the variables in scope,
+ -- both Ids and TyVars
+ Bag Message -> -- Error messages so far
+ (Maybe a, Bag Message) } -- Result and error messages (if any)
+
+instance Monad LintM where
+ return x = LintM (\ loc subst errs -> (Just x, errs))
+ fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
+ m >>= k = LintM (\ loc subst errs ->
+ let (res, errs') = unLintM m loc subst errs in
+ case res of
+ Just r -> unLintM (k r) loc subst errs'
+ Nothing -> (Nothing, errs'))
data LintLocInfo
= RhsOf Id -- The variable bound
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
\end{code}
+
\begin{code}
initL :: LintM a -> Maybe Message {- errors -}
initL m
- = case m [] emptyVarSet emptyBag of
+ = case unLintM m [] emptyTvSubst emptyBag of
(_, errs) | isEmptyBag errs -> Nothing
| otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
-
-returnL :: a -> LintM a
-returnL r loc scope errs = (Just r, errs)
-
-nopL :: LintM a
-nopL loc scope errs = (Nothing, errs)
-
-thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k loc scope errs
- = case m loc scope errs of
- (Just r, errs') -> k r loc scope errs'
- (Nothing, errs') -> (Nothing, errs')
-
-seqL :: LintM a -> LintM b -> LintM b
-seqL m k loc scope errs
- = case m loc scope errs of
- (_, errs') -> k loc scope errs'
-
-mapL :: (a -> LintM b) -> [a] -> LintM [b]
-mapL f [] = returnL []
-mapL f (x:xs)
- = f x `thenL` \ r ->
- mapL f xs `thenL` \ rs ->
- returnL (r:rs)
\end{code}
\begin{code}
checkL :: Bool -> Message -> LintM ()
-checkL True msg = nopL
+checkL True msg = return ()
checkL False msg = addErrL msg
addErrL :: Message -> LintM a
-addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
+addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
-addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
-addErr errs_so_far msg locs
+addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
+addErr subst errs_so_far msg locs
= ASSERT( notNull locs )
errs_so_far `snocBag` mk_msg msg
where
(loc, cxt1) = dumpLoc (head locs)
cxts = [snd (dumpLoc loc) | loc <- locs]
- context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
+ context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
+ ptext SLIT("Substitution:") <+> ppr subst
| otherwise = cxt1
mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m loc scope errs
- = m (extra_loc:loc) scope errs
+addLoc extra_loc m =
+ LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
addInScopeVars :: [Var] -> LintM a -> LintM a
-addInScopeVars ids m loc scope errs
- = m loc (extendVarSetList scope ids) errs
+addInScopeVars vars m =
+ LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
+
+-- gaw 2004
+updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
+updateTvSubstEnv substenv m =
+ LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
+
+getTvSubst :: LintM TvSubst
+getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))
+
+applySubst :: Type -> LintM Type
+applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
+
+extendSubstL :: TyVar -> Type -> LintM a -> LintM a
+extendSubstL tv ty m
+ = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
\end{code}
\begin{code}
ppr binder
checkInScope :: SDoc -> Var -> LintM ()
-checkInScope loc_msg var loc scope errs
- | mustHaveLocalBinding var && not (var `elemVarSet` scope)
- = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
- | otherwise
- = nopL loc scope errs
+checkInScope loc_msg var =
+ do { subst <- getTvSubst
+ ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
+ (hsep [ppr var, loc_msg]) }
checkTys :: Type -> Type -> Message -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
-checkTys ty1 ty2 msg
- | ty1 `eqType` ty2 = nopL
- | otherwise = addErrL msg
+-- Assumes ty1,ty2 are have alrady had the substitution applied
+checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
\end{code}
-
%************************************************************************
%* *
\subsection{Error messages}
= (noSrcLoc, text "In the expression:" <+> ppr e)
dumpLoc (CaseAlt (con, args, rhs))
- = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
+ = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args))
dumpLoc (ImportedUnfolding locn)
= (locn, brackets (ptext SLIT("in an imported unfolding")))
= hang (text "DEFAULT case with binders")
4 (ppr args)
-mkCaseAltMsg :: CoreExpr -> Message
-mkCaseAltMsg e
- = hang (text "Type of case alternatives not the same:")
- 4 (ppr e)
+mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
+mkCaseAltMsg e ty1 ty2
+ = hang (text "Type of case alternatives not the same as the annotation on case:")
+ 4 (vcat [ppr ty1, ppr ty2, ppr e])
mkScrutMsg :: Id -> Type -> Message
mkScrutMsg var scrut_ty
text "Scrutinee type:" <+> ppr scrut_ty
]
+mkBadAltMsg :: Type -> CoreAlt -> Message
+mkBadAltMsg scrut_ty alt
+ = vcat [ text "Data alternative when scrutinee is not a tycon application",
+ text "Scrutinee type:" <+> ppr scrut_ty,
+ text "Alternative:" <+> pprCoreAlt alt ]
+
+mkIncTyconMsg :: TyCon -> CoreAlt -> Message
+mkIncTyconMsg tycon1 alt@(DataAlt con,_,_)
+ = vcat [ text "Incompatible tycon applications in alternative",
+ text "Scrutinee tycon:" <+> ppr tycon1,
+ text "Alternative tycon:" <+> ppr (dataConTyCon con),
+ text "Alternative:" <+> pprCoreAlt alt ]
+
------------------------------------------------------
-- Other error messages
where
(bndrs,body) = collectBinders expr
-corePrepExprFloat env (Case scrut bndr alts)
+-- gaw 2004
+corePrepExprFloat env (Case scrut bndr ty alts)
= corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
mapUs (sat_alt env') alts `thenUs` \ alts' ->
- returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' alts')
+-- gaw 2004
+ returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' ty alts')
where
sat_alt env (con, bs, rhs)
= cloneBndrs env bs `thenUs` \ (env', bs') ->
| otherwise = deLam body `thenUs` \ body' ->
returnUs (foldrOL mk_bind body' binds)
where
- mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]
+-- gaw 2004
+ mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
etaExpandRhs bndr rhs
| App (Expr b) (Arg b)
| Lam b (Expr b)
| Let (Bind b) (Expr b)
- | Case (Expr b) b [Alt b] -- Binder gets bound to value of scrutinee
+ -- gaw 2004, added Type field
+ | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee
-- Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
-- meaning that it covers all cases that can occur
-- See the example below
\begin{code}
seqExpr :: CoreExpr -> ()
-seqExpr (Var v) = v `seq` ()
-seqExpr (Lit lit) = lit `seq` ()
-seqExpr (App f a) = seqExpr f `seq` seqExpr a
-seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
-seqExpr (Let b e) = seqBind b `seq` seqExpr e
-seqExpr (Case e b as) = seqExpr e `seq` seqBndr b `seq` seqAlts as
-seqExpr (Note n e) = seqNote n `seq` seqExpr e
-seqExpr (Type t) = seqType t
+seqExpr (Var v) = v `seq` ()
+seqExpr (Lit lit) = lit `seq` ()
+seqExpr (App f a) = seqExpr f `seq` seqExpr a
+seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
+seqExpr (Let b e) = seqBind b `seq` seqExpr e
+-- gaw 2004
+seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
+seqExpr (Note n e) = seqNote n `seq` seqExpr e
+seqExpr (Type t) = seqType t
seqExprs [] = ()
seqExprs (e:es) = seqExpr e `seq` seqExprs es
| AnnLit Literal
| AnnLam bndr (AnnExpr bndr annot)
| AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
- | AnnCase (AnnExpr bndr annot) bndr [AnnAlt bndr annot]
+-- gaw 2004
+ | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
| AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
| AnnNote Note (AnnExpr bndr annot)
| AnnType Type
deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
-deAnnotate' (AnnCase scrut v alts)
- = Case (deAnnotate scrut) v (map deAnnAlt alts)
+-- gaw 2004
+deAnnotate' (AnnCase scrut v t alts)
+ = Case (deAnnotate scrut) v t (map deAnnAlt alts)
deAnnAlt :: AnnAlt bndr annot -> Alt bndr
deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
= tidyBind env b =: \ (env', b') ->
Let b' (tidyExpr env' e)
-tidyExpr env (Case e b alts)
+-- gaw 2004
+tidyExpr env (Case e b ty alts)
= tidyBndr env b =: \ (env', b) ->
- Case (tidyExpr env e) b (map (tidyAlt env') alts)
+-- gaw 2004
+ Case (tidyExpr env e) b (tidyType env ty) (map (tidyAlt env') alts)
tidyExpr env (Lam b e)
= tidyBndr env b =: \ (env', b) ->
where
rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
- size_up (Case (Var v) _ alts)
+-- gaw 2004
+ size_up (Case (Var v) _ _ alts)
| v `elem` top_args -- We are scrutinising an argument variable
=
{- I'm nuking this special case; BUT see the comment with case alternatives.
-- The 1+ is a little discount for reduced allocation in the caller
alts_size tot_size _ = tot_size
-
- size_up (Case e _ alts) = nukeScrutDiscount (size_up e) `addSize`
- foldr (addSize . size_up_alt) sizeZero alts
+-- gaw 2004
+ size_up (Case e _ _ alts) = nukeScrutDiscount (size_up e) `addSize`
+ foldr (addSize . size_up_alt) sizeZero alts
-- We don't charge for the case itself
-- It's a strict thing, and the price of the call
-- is paid by scrut. Also consider
findDefault, findAlt,
-- Properties of expressions
- exprType,
+ exprType, coreAltType,
exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
- exprIsConApp_maybe,
+ exprIsConApp_maybe, exprIsBottom,
rhsIsStatic,
-- Arity and eta expansion
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit, Literal( MachLabel ) )
import DataCon ( DataCon, dataConRepArity, dataConArgTys,
- isExistentialDataCon, dataConTyCon )
+ isVanillaDataCon, dataConTyCon )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
funResultTy, applyTy
)
import TyCon ( tyConArity )
+-- gaw 2004
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
import BasicTypes ( Arity )
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
-exprType (Case _ _ alts) = coreAltsType alts
+-- gaw 2004
+exprType (Case _ _ ty alts) = ty
exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
exprType (Note other_note e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
-coreAltsType :: [CoreAlt] -> Type
-coreAltsType ((_,_,rhs) : _) = exprType rhs
+coreAltType :: CoreAlt -> Type
+coreAltType (_,_,rhs) = exprType rhs
\end{code}
@mkPiType@ makes a (->) type or a forall type, depending on whether
-- It's used by the desugarer to avoid building bindings
-- that give Core Lint a heart attack. Actually the simplifier
-- deals with them perfectly well.
+
bindNonRec bndr rhs body
- | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
+-- gaw 2004
+ | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
| otherwise = Let (NonRec bndr rhs) body
needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard then_expr else_expr
- = Case guard (mkWildId boolTy)
+-- gaw 2004
+-- Not going to be refining, so okay to take the type of the "then" clause
+ = Case guard (mkWildId boolTy) (exprType then_expr)
[ (DataAlt trueDataCon, [], then_expr),
(DataAlt falseDataCon, [], else_expr) ]
\end{code}
\begin{code}
exprIsCheap :: CoreExpr -> Bool
-exprIsCheap (Lit lit) = True
-exprIsCheap (Type _) = True
-exprIsCheap (Var _) = True
-exprIsCheap (Note InlineMe e) = True
-exprIsCheap (Note _ e) = exprIsCheap e
-exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
-exprIsCheap (Case e _ alts) = exprIsCheap e &&
+exprIsCheap (Lit lit) = True
+exprIsCheap (Type _) = True
+exprIsCheap (Var _) = True
+exprIsCheap (Note InlineMe e) = True
+exprIsCheap (Note _ e) = exprIsCheap e
+exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
+-- gaw 2004
+exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
and [exprIsCheap rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
-- (and case __coerce x etc.)
-- counts as WHNF
| otherwise = case globalIdDetails id of
DataConWorkId _ -> True
- RecordSelId _ -> True -- I'm experimenting with making record selection
+ RecordSelId _ _ -> True -- I'm experimenting with making record selection
ClassOpId _ -> True -- look cheap, so we will substitute it inside a
-- lambda. Particularly for dictionary field selection
exprIsBottom e = go 0 e
where
-- n is the number of args
- go n (Note _ e) = go n e
- go n (Let _ e) = go n e
- go n (Case e _ _) = go 0 e -- Just check the scrut
- go n (App e _) = go (n+1) e
- go n (Var v) = idAppIsBottom v n
- go n (Lit _) = False
- go n (Lam _ _) = False
+ go n (Note _ e) = go n e
+ go n (Let _ e) = go n e
+-- gaw 2004
+ go n (Case e _ _ _) = go 0 e -- Just check the scrut
+ go n (App e _) = go (n+1) e
+ go n (Var v) = idAppIsBottom v n
+ go n (Lit _) = False
+ go n (Lam _ _) = False
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
case splitTyConApp_maybe to_ty of {
Nothing -> Nothing ;
- Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
- | isExistentialDataCon dc -> Nothing
- | otherwise ->
+ Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
+ | not (isVanillaDataCon dc) -> Nothing
+ | otherwise ->
-- Type constructor must match
-- We knock out existentials to keep matters simple(r)
let
-- ===>
-- f x y = case x of { (a,b) -> e }
-- The difference is observable using 'seq'
-arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
+-- gaw 2004
+arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
xs@(AFun one_shot _) | one_shot -> xs
xs | exprIsCheap scrut -> xs
| otherwise -> ATop
where
env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
eq_rhs (_,r1) (_,r2) = eq env' r1 r2
- eq env (Case e1 v1 a1)
- (Case e2 v2 a2) = eq env e1 e2 &&
+-- gaw 2004
+ eq env (Case e1 v1 t1 a1)
+ (Case e2 v2 t2 a2) = eq env e1 e2 &&
+ t1 `eqType` t2 &&
equalLength a1 a2 &&
and (zipWith (eq_alt env') a1 a2)
where
exprSize :: CoreExpr -> Int
-- A measure of the size of the expressions
-- It also forces the expression pretty drastically as a side effect
-exprSize (Var v) = v `seq` 1
-exprSize (Lit lit) = lit `seq` 1
-exprSize (App f a) = exprSize f + exprSize a
-exprSize (Lam b e) = varSize b + exprSize e
-exprSize (Let b e) = bindSize b + exprSize e
-exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
-exprSize (Note n e) = noteSize n + exprSize e
-exprSize (Type t) = seqType t `seq` 1
+exprSize (Var v) = v `seq` 1
+exprSize (Lit lit) = lit `seq` 1
+exprSize (App f a) = exprSize f + exprSize a
+exprSize (Lam b e) = varSize b + exprSize e
+exprSize (Let b e) = bindSize b + exprSize e
+-- gaw 2004
+exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
+exprSize (Note n e) = noteSize n + exprSize e
+exprSize (Type t) = seqType t `seq` 1
noteSize (SCC cc) = cc `seq` 1
noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
hash_expr (Note _ e) = hash_expr e
hash_expr (Let (NonRec b r) e) = hashId b
hash_expr (Let (Rec ((b,r):_)) e) = hashId b
-hash_expr (Case _ b _) = hashId b
+-- gaw 2004
+hash_expr (Case _ b _ _) = hashId b
hash_expr (App f e) = hash_expr f * fast_hash_expr e
hash_expr (Var v) = hashId v
hash_expr (Lit lit) = hashLiteral lit
data Cdef
= Constr Dcon [Tbind] [Ty]
+ | GadtConstr Dcon Ty
data Vdefg
= Rec [Vdef]
| Appt Exp Ty
| Lam Bind Exp
| Let Vdefg Exp
- | Case Exp Vbind [Alt] {- non-empty list -}
+ | Case Exp Vbind Ty [Alt] {- non-empty list -}
| Coerce Ty Exp
| Note String Exp
| External String Ty
import TypeRep
import Type
import PprExternalCore -- Instances
-import DataCon ( DataCon, dataConExistentialTyVars, dataConRepArgTys,
- dataConName, dataConWrapId_maybe )
+import DataCon ( DataCon, dataConTyVars, dataConRepArgTys,
+ dataConName, dataConTyCon, dataConWrapId_maybe )
import CoreSyn
import Var
import IdInfo
where
dcon_name = make_var_id (dataConName dcon)
existentials = map make_tbind ex_tyvars
- ex_tyvars = dataConExistentialTyVars dcon
+ ex_tyvars = drop (tyConArity (dataConTyCon dcon)) (dataConTyVars dcon)
tys = map make_ty (dataConRepArgTys dcon)
make_tbind :: TyVar -> C.Tbind
make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
make_exp (Let b e) = C.Let (make_vdef b) (make_exp e)
-make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts)
+-- gaw 2004
+make_exp (Case e v ty alts) = C.Case (make_exp e) (make_vbind v) (make_ty ty) (map make_alt alts)
make_exp (Note (SCC cc) e) = C.Note "SCC" (make_exp e) -- temporary
make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e)
make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e)
other -> add_par (hang (pprParendExpr fun) 2 pp_args)
}
-ppr_expr add_par (Case expr var [(con,args,rhs)])
+-- gaw 2004
+ppr_expr add_par (Case expr var ty [(con,args,rhs)])
= add_par $
- sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
+ sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr,
hsep [ptext SLIT("of"),
- ppr_bndr var,
+ ppr_bndr var,
char '{',
ppr_case_pat con args
]],
where
ppr_bndr = pprBndr CaseBind
-ppr_expr add_par (Case expr var alts)
+-- gaw 2004
+ppr_expr add_par (Case expr var ty alts)
= add_par $
- sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
+ sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr,
ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
char '}'
pcdef (Constr dcon tbinds tys) =
(pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
+pcdef (GadtConstr dcon ty) =
+ (pname dcon) <+> text "::" <+> pty ty
pname id = text id
pexp (Lam b e) = char '\\' <+> plamexp [b] e
pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
-pexp (Case e vb alts) = sep [text "%case" <+> paexp e,
+-- gaw 2004
+pexp (Case e vb ty alts) = sep [text "%case" <+> parens (paty ty) <+> paexp e,
text "%of" <+> pvbind vb]
$$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
pexp (Coerce t e) = (text "%coerce" <+> paty t) $$ pexp e
\begin{code}
module Subst (
- -- In-scope set
- InScopeSet, emptyInScopeSet, mkInScopeSet,
- extendInScopeSet, extendInScopeSetList,
- lookupInScope, elemInScopeSet, uniqAway,
-
-
-- Substitution stuff
- Subst, TyVarSubst, IdSubst,
- emptySubst, mkSubst, substEnv, substInScope,
- lookupSubst, lookupIdSubst, isEmptySubst, extendSubst, extendSubstList,
+ Subst, SubstResult(..),
+ emptySubst, mkSubst, substInScope, substTy,
+ lookupIdSubst, lookupTvSubst, isEmptySubst,
+ extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
zapSubstEnv, setSubstEnv,
- setInScope,
- extendInScope, extendInScopeList, extendNewInScope, extendNewInScopeList,
- isInScope, modifyInScope,
+ getTvSubst, getTvSubstEnv, setTvSubstEnv,
bindSubst, unBindSubst, bindSubstList, unBindSubstList,
simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo,
substAndCloneId, substAndCloneIds, substAndCloneRecIds,
- -- Type stuff
- mkTyVarSubst, mkTopTyVarSubst,
- substTyWith, substTy, substTheta, deShadowTy,
+ setInScope, setInScopeSet,
+ extendInScope, extendInScopeIds,
+ isInScope, modifyInScope,
-- Expression stuff
- substExpr, substRules
+ substExpr, substRules, substId
) where
#include "HsVersions.h"
-import CmdLineOpts ( opt_PprStyle_Debug )
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
CoreRules(..), CoreRule(..),
isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding, hasSomeUnfolding,
)
import CoreFVs ( exprFreeVars )
import CoreUtils ( exprIsTrivial )
-import TypeRep ( Type(..), TyNote(..) ) -- friend
-import Type ( ThetaType, PredType(..),
- tyVarsOfType, tyVarsOfTypes, mkAppTy,
- )
+
+import qualified Type ( substTy )
+import Type ( Type, tyVarsOfType, mkTyVarTy,
+ TvSubstEnv, TvSubst(..), substTyVar )
import VarSet
import VarEnv
import Var ( setVarUnique, isId, mustHaveLocalBinding )
WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
)
import BasicTypes ( OccInfo(..) )
-import Unique ( Unique, Uniquable(..), deriveUnique )
-import UniqSet ( elemUniqSet_Directly )
+import Unique ( Unique )
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
import Var ( Var, Id, TyVar, isTyVar )
import Outputable
import PprCore () -- Instances
-import UniqFM ( ufmToList ) -- Yuk (add a new op to VarEnv)
-import Util ( mapAccumL, foldl2, seqList )
+import Util ( mapAccumL, foldl2 )
import FastTypes
\end{code}
%************************************************************************
%* *
-\subsection{The in-scope set}
-%* *
-%************************************************************************
-
-\begin{code}
-data InScopeSet = InScope (VarEnv Var) FastInt
- -- The Int# is a kind of hash-value used by uniqAway
- -- For example, it might be the size of the set
- -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
-
-emptyInScopeSet :: InScopeSet
-emptyInScopeSet = InScope emptyVarSet 1#
-
-mkInScopeSet :: VarEnv Var -> InScopeSet
-mkInScopeSet in_scope = InScope in_scope 1#
-
-extendInScopeSet :: InScopeSet -> Var -> InScopeSet
-extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
-
-extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
-extendInScopeSetList (InScope in_scope n) vs
- = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
- (n +# iUnbox (length vs))
-
-modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
--- Exploit the fact that the in-scope "set" is really a map
--- Make old_v map to new_v
-modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
-
-delInScopeSet :: InScopeSet -> Var -> InScopeSet
-delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
-
-elemInScopeSet :: Var -> InScopeSet -> Bool
-elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
-
-lookupInScope :: InScopeSet -> Var -> Var
--- It's important to look for a fixed point
--- When we see (case x of y { I# v -> ... })
--- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
--- When we lookup up an occurrence of x, we map to y, but then
--- we want to look up y in case it has acquired more evaluation information by now.
-lookupInScope (InScope in_scope n) v
- = go v
- where
- go v = case lookupVarEnv in_scope v of
- Just v' | v == v' -> v' -- Reached a fixed point
- | otherwise -> go v'
- Nothing -> WARN( mustHaveLocalBinding v, ppr v )
- v
-\end{code}
-
-\begin{code}
-uniqAway :: InScopeSet -> Var -> Var
--- (uniqAway in_scope v) finds a unique that is not used in the
--- in-scope set, and gives that to v. It starts with v's current unique, of course,
--- in the hope that it won't have to change it, and thereafter uses a combination
--- of that and the hash-code found in the in-scope set
-uniqAway (InScope set n) var
- | not (var `elemVarSet` set) = var -- Nothing to do
- | otherwise = try 1#
- where
- orig_unique = getUnique var
- try k
-#ifdef DEBUG
- | k ># 1000#
- = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
-#endif
- | uniq `elemUniqSet_Directly` set = try (k +# 1#)
-#ifdef DEBUG
- | opt_PprStyle_Debug && k ># 3#
- = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
- setVarUnique var uniq
-#endif
- | otherwise = setVarUnique var uniq
- where
- uniq = deriveUnique orig_unique (iBox (n *# k))
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Substitutions}
%* *
%************************************************************************
\begin{code}
-data Subst = Subst InScopeSet -- In scope
- SubstEnv -- Substitution itself
+data Subst
+ = Subst InScopeSet -- Variables in in scope (both Ids and TyVars)
+ IdSubstEnv -- Substitution for Ids
+ TvSubstEnv -- Substitution for TyVars
+
-- INVARIANT 1: The (domain of the) in-scope set is a superset
-- of the free vars of the range of the substitution
-- that might possibly clash with locally-bound variables
-- other is an out-Id. So the substitution is idempotent in the sense
-- that we *must not* repeatedly apply it.]
-type IdSubst = Subst
+
+type IdSubstEnv = IdEnv SubstResult
+
+data SubstResult
+ = DoneEx CoreExpr -- Completed term
+ | DoneId Id OccInfo -- Completed term variable, with occurrence info;
+ -- only used by the simplifier
+ | ContEx Subst CoreExpr -- A suspended substitution
\end{code}
The general plan about the substitution and in-scope set for Ids is as follows
\begin{code}
isEmptySubst :: Subst -> Bool
-isEmptySubst (Subst _ env) = isEmptySubstEnv env
+isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env
emptySubst :: Subst
-emptySubst = Subst emptyInScopeSet emptySubstEnv
+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv
+
+mkSubst :: InScopeSet -> Subst
+mkSubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv
+
+getTvSubst :: Subst -> TvSubst
+getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env
+
+getTvSubstEnv :: Subst -> TvSubstEnv
+getTvSubstEnv (Subst _ _ tv_env) = tv_env
+
+setTvSubstEnv :: Subst -> TvSubstEnv -> Subst
+setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs
-mkSubst :: InScopeSet -> SubstEnv -> Subst
-mkSubst in_scope env = Subst in_scope env
-substEnv :: Subst -> SubstEnv
-substEnv (Subst _ env) = env
substInScope :: Subst -> InScopeSet
-substInScope (Subst in_scope _) = in_scope
+substInScope (Subst in_scope _ _) = in_scope
zapSubstEnv :: Subst -> Subst
-zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
+zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv
-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
-extendSubst :: Subst -> Var -> SubstResult -> Subst
-extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
-
-extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
-extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
-
-lookupSubst :: Subst -> Var -> Maybe SubstResult
-lookupSubst (Subst _ env) v = lookupSubstEnv env v
-
-lookupIdSubst :: Subst -> Id -> SubstResult
--- Does the lookup in the in-scope set too
-lookupIdSubst (Subst in_scope env) v
- = case lookupSubstEnv env v of
- Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ
- Just res -> res
- Nothing -> DoneId v' (idOccInfo v')
- -- We don't use DoneId for LoopBreakers, so the idOccInfo is
- -- very important! If isFragileOcc returned True for
- -- loop breakers we could avoid this call, but at the expense
- -- of adding more to the substitution, and building new Ids
- -- in substId a bit more often than really necessary
- where
- v' = lookupInScope in_scope v
+extendIdSubst :: Subst -> Id -> SubstResult -> Subst
+extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs
+
+extendIdSubstList :: Subst -> [(Id, SubstResult)] -> Subst
+extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs
+
+extendTvSubst :: Subst -> TyVar -> Type -> Subst
+extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r)
+extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
+extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs)
+
+lookupIdSubst :: Subst -> Id -> Maybe SubstResult
+lookupIdSubst (Subst in_scope ids tvs) v = lookupVarEnv ids v
+
+lookupTvSubst :: Subst -> TyVar -> Maybe Type
+lookupTvSubst (Subst _ ids tvs) v = lookupVarEnv tvs v
+
+------------------------------
isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _) = v `elemInScopeSet` in_scope
+isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
modifyInScope :: Subst -> Var -> Var -> Subst
-modifyInScope (Subst in_scope env) old_v new_v = Subst (modifyInScopeSet in_scope old_v new_v) env
+modifyInScope (Subst in_scope ids tvs) old_v new_v
+ = Subst (modifyInScopeSet in_scope old_v new_v) ids tvs
-- make old_v map to new_v
extendInScope :: Subst -> Var -> Subst
- -- Add a new variable as in-scope
- -- Remember to delete any existing binding in the substitution!
-extendInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v)
- (env `delSubstEnv` v)
-
-extendInScopeList :: Subst -> [Var] -> Subst
-extendInScopeList (Subst in_scope env) vs = Subst (extendInScopeSetList in_scope vs)
- (delSubstEnvList env vs)
-
--- The "New" variants are guaranteed to be adding freshly-allocated variables
--- It's not clear that the gain (not needing to delete it from the substitution)
--- is worth the extra proof obligation
-extendNewInScope :: Subst -> Var -> Subst
-extendNewInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) env
+extendInScope (Subst in_scope ids tvs) v
+ = Subst (in_scope `extendInScopeSet` v)
+ (ids `delVarEnv` v) (tvs `delVarEnv` v)
-extendNewInScopeList :: Subst -> [Var] -> Subst
-extendNewInScopeList (Subst in_scope env) vs = Subst (in_scope `extendInScopeSetList` vs) env
+extendInScopeIds :: Subst -> [Id] -> Subst
+extendInScopeIds (Subst in_scope ids tvs) vs
+ = Subst (in_scope `extendInScopeSetList` vs)
+ (ids `delVarEnvList` vs) tvs
-------------------------------
bindSubst :: Subst -> Var -> Var -> Subst
-- Extend with a substitution, v1 -> Var v2
-- and extend the in-scopes with v2
-bindSubst (Subst in_scope env) old_bndr new_bndr
+bindSubst (Subst in_scope ids tvs) old_bndr new_bndr
+ | isId old_bndr
= Subst (in_scope `extendInScopeSet` new_bndr)
- (extendSubstEnv env old_bndr subst_result)
- where
- subst_result | isId old_bndr = DoneEx (Var new_bndr)
- | otherwise = DoneTy (TyVarTy new_bndr)
+ (extendVarEnv ids old_bndr (DoneEx (Var new_bndr)))
+ tvs
+ | otherwise
+ = Subst (in_scope `extendInScopeSet` new_bndr)
+ ids
+ (extendVarEnv tvs old_bndr (mkTyVarTy new_bndr))
unBindSubst :: Subst -> Var -> Var -> Subst
-- Reverse the effect of bindSubst
-- If old_bndr was already in the substitution, this doesn't quite work
-unBindSubst (Subst in_scope env) old_bndr new_bndr
- = Subst (in_scope `delInScopeSet` new_bndr) (delSubstEnv env old_bndr)
+unBindSubst (Subst in_scope ids tvs) old_bndr new_bndr
+ = Subst (in_scope `delInScopeSet` new_bndr)
+ (delVarEnv ids old_bndr)
+ (delVarEnv tvs old_bndr)
-- And the "List" forms
bindSubstList :: Subst -> [Var] -> [Var] -> Subst
-------------------------------
+setInScopeSet :: Subst -> InScopeSet -> Subst
+setInScopeSet (Subst _ ids tvs) in_scope
+ = Subst in_scope ids tvs
+
setInScope :: Subst -- Take env part from here
- -> InScopeSet
+ -> Subst -- Take in-scope part from here
-> Subst
-setInScope (Subst in_scope1 env1) in_scope2
- = Subst in_scope2 env1
+setInScope (Subst _ ids tvs) (Subst in_scope _ _)
+ = Subst in_scope ids tvs
-setSubstEnv :: Subst -- Take in-scope part from here
- -> SubstEnv -- ... and env part from here
+setSubstEnv :: Subst -- Take in-scope part from here
+ -> Subst -- ... and env part from here
-> Subst
-setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
+setSubstEnv s1 s2 = setInScope s2 s1
\end{code}
Pretty printing, for debugging only
ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v
ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e
- ppr (DoneTy t) = ptext SLIT("DoneTy") <+> ppr t
-
-instance Outputable SubstEnv where
- ppr se = brackets (fsep (punctuate comma (map ppr_elt (ufmToList (substEnvEnv se)))))
- where
- ppr_elt (uniq,sr) = ppr uniq <+> ptext SLIT("->") <+> ppr sr
instance Outputable Subst where
- ppr (Subst (InScope in_scope _) se)
- = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (rngVarEnv in_scope)))
- $$ ptext SLIT(" Subst =") <+> ppr se <> char '>'
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Type substitution}
-%* *
-%************************************************************************
-
-\begin{code}
-type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
- -- (We could have a variant of Subst, but it doesn't seem worth it.)
-
--- mkTyVarSubst generates the in-scope set from
--- the types given; but it's just a thunk so with a bit of luck
--- it'll never be evaluated
-mkTyVarSubst :: [TyVar] -> [Type] -> Subst
-mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys))
- (zipTyEnv tyvars tys)
-
--- mkTopTyVarSubst is called when doing top-level substitutions.
--- Here we expect that the free vars of the range of the
--- substitution will be empty.
-mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
-mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zipTyEnv tyvars tys)
-
-zipTyEnv tyvars tys
-#ifdef DEBUG
- | length tyvars /= length tys
- = pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv
- | otherwise
-#endif
- = zip_ty_env tyvars tys emptySubstEnv
-
--- Later substitutions in the list over-ride earlier ones
-zip_ty_env [] [] env = env
-zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
- -- There used to be a special case for when
- -- ty == TyVarTy tv
- -- (a not-uncommon case) in which case the substitution was dropped.
- -- But the type-tidier changes the print-name of a type variable without
- -- changing the unique, and that led to a bug. Why? Pre-tidying, we had
- -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype.
- -- And it happened that t was the type variable of the class. Post-tiding,
- -- it got turned into {Foo t2}. The ext-core printer expanded this using
- -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,
- -- and so generated a rep type mentioning t not t2.
- --
- -- Simplest fix is to nuke the "optimisation"
-\end{code}
-
-substTy works with general Substs, so that it can be called from substExpr too.
-
-\begin{code}
-substTyWith :: [TyVar] -> [Type] -> Type -> Type
-substTyWith tvs tys = substTy (mkTyVarSubst tvs tys)
-
-substTy :: Subst -> Type -> Type
-substTy subst ty | isEmptySubst subst = ty
- | otherwise = subst_ty subst ty
-
-deShadowTy :: Type -> Type -- Remove any shadowing from the type
-deShadowTy ty = subst_ty emptySubst ty
-
-substTheta :: TyVarSubst -> ThetaType -> ThetaType
-substTheta subst theta
- | isEmptySubst subst = theta
- | otherwise = map (substPred subst) theta
-
-substPred :: TyVarSubst -> PredType -> PredType
-substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
-substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
-
-subst_ty subst ty
- = go ty
- where
- go (TyConApp tc tys) = let args = map go tys
- in args `seqList` TyConApp tc args
-
- go (NewTcApp tc tys) = let args = map go tys
- in args `seqList` NewTcApp tc args
-
- go (PredTy p) = PredTy $! (substPred subst p)
-
- go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
- go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
-
- go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
- go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
- go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
- Nothing -> ty
- Just (DoneTy ty') -> ty'
-
- go (ForAllTy tv ty) = case substTyVar subst tv of
- (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
-\end{code}
-
-Here is where we invent a new binder if necessary.
-
-\begin{code}
-substTyVar :: Subst -> TyVar -> (Subst, TyVar)
-substTyVar subst@(Subst in_scope env) old_var
- | old_var == new_var -- No need to clone
- -- But we *must* zap any current substitution for the variable.
- -- For example:
- -- (\x.e) with id_subst = [x |-> e']
- -- Here we must simply zap the substitution for x
- --
- -- The new_id isn't cloned, but it may have a different type
- -- etc, so we must return it, not the old id
- = (Subst (in_scope `extendInScopeSet` new_var)
- (delSubstEnv env old_var),
- new_var)
-
- | otherwise -- The new binder is in scope so
- -- we'd better rename it away from the in-scope variables
- -- Extending the substitution to do this renaming also
- -- has the (correct) effect of discarding any existing
- -- substitution for that variable
- = (Subst (in_scope `extendInScopeSet` new_var)
- (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
- new_var)
- where
- new_var = uniqAway in_scope old_var
- -- The uniqAway part makes sure the new variable is not already in scope
+ ppr (Subst in_scope ids tvs)
+ = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
+ $$ ptext SLIT(" IdSubst =") <+> ppr ids
+ $$ ptext SLIT(" TvSubst =") <+> ppr tvs
+ <> char '>'
\end{code}
= go expr
where
- go (Var v) = -- See the notes at the top, with the Subst data type declaration
- case lookupIdSubst subst v of
-
+ go (Var v) = case substId subst v of
ContEx env' e' -> substExpr (setSubstEnv subst env') e'
DoneId v _ -> Var v
DoneEx e' -> e'
(subst', bndrs') = substRecBndrs subst (map fst pairs)
pairs' = bndrs' `zip` rhss'
rhss' = map (substExpr subst' . snd) pairs
-
- go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
- where
- (subst', bndr') = substBndr subst bndr
+ go (Case scrut bndr ty alts) = Case (go scrut) bndr' (go_ty ty) (map (go_alt subst') alts)
+ where
+ (subst', bndr') = substBndr subst bndr
go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
where
go_ty ty = substTy subst ty
+substId :: Subst -> Id -> SubstResult
+substId (Subst in_scope ids tvs) v
+ = case lookupVarEnv ids v of
+ Just (DoneId v occ) -> DoneId (lookup v) occ
+ Just res -> res
+ Nothing -> let v' = lookup v
+ in DoneId v' (idOccInfo v')
+ -- Note [idOccInfo]
+ -- We don't use DoneId for LoopBreakers, so the idOccInfo is
+ -- very important! If isFragileOcc returned True for
+ -- loop breakers we could avoid this call, but at the expense
+ -- of adding more to the substitution, and building new Ids
+ -- in substId a bit more often than really necessary
+ where
+ -- Get the most up-to-date thing from the in-scope set
+ -- Even though it isn't in the substitution, it may be in
+ -- the in-scope set with a different type (we only use the
+ -- substitution if the unique changes).
+ lookup v = case lookupInScope in_scope v of
+ Just v' -> v'
+ Nothing -> WARN( mustHaveLocalBinding v, ppr v ) v
+
+
+substTy :: Subst -> Type -> Type
+substTy subst ty = Type.substTy (getTvSubst subst) ty
\end{code}
-- The substitution is extended only if the variable is cloned, because
-- we *don't* need to use it to track occurrence info.
simplBndr subst bndr
- | isTyVar bndr = substTyVar subst bndr
+ | isTyVar bndr = subst_tv subst bndr
| otherwise = subst_id False subst subst bndr
simplBndrs :: Subst -> [Var] -> (Subst, [Var])
-- if the unique changed, *or*
-- if there's interesting occurrence info
-simplLetId subst@(Subst in_scope env) old_id
- = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
+simplLetId subst@(Subst in_scope env tvs) old_id
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
where
old_info = idInfo old_id
id1 = uniqAway in_scope old_id
-- See the notes with substTyVar for the delSubstEnv
occ_info = occInfo old_info
new_env | new_id /= old_id || isFragileOcc occ_info
- = extendSubstEnv env old_id (DoneId new_id occ_info)
+ = extendVarEnv env old_id (DoneId new_id occ_info)
| otherwise
- = delSubstEnv env old_id
+ = delVarEnv env old_id
simplIdInfo :: Subst -> IdInfo -> IdInfo
-- Used by the simplifier to compute new IdInfo for a let(rec) binder,
substBndr :: Subst -> Var -> (Subst, Var)
substBndr subst bndr
- | isTyVar bndr = substTyVar subst bndr
+ | isTyVar bndr = subst_tv subst bndr
| otherwise = subst_id True {- keep fragile info -} subst subst bndr
substBndrs :: Subst -> [Var] -> (Subst, [Var])
\begin{code}
+subst_tv :: Subst -> TyVar -> (Subst, TyVar)
+-- Unpackage and re-package for substTyVar
+subst_tv (Subst in_scope id_env tv_env) tv
+ = case substTyVar (TvSubst in_scope tv_env) tv of
+ (TvSubst in_scope' tv_env', tv')
+ -> (Subst in_scope' id_env tv_env', tv')
+
subst_id :: Bool -- True <=> keep fragile info
-> Subst -- Substitution to use for the IdInfo
-> Subst -> Id -- Substitition and Id to transform
-- In this case, the var in the DoneId is the same as the
-- var returned
-subst_id keep_fragile rec_subst subst@(Subst in_scope env) old_id
- = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
+subst_id keep_fragile rec_subst subst@(Subst in_scope env tvs) old_id
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
where
-- id1 is cloned if necessary
id1 = uniqAway in_scope old_id
-- Extend the substitution if the unique has changed
-- See the notes with substTyVar for the delSubstEnv
new_env | new_id /= old_id
- = extendSubstEnv env old_id (DoneId new_id (idOccInfo old_id))
+ = extendVarEnv env old_id (DoneId new_id (idOccInfo old_id))
| otherwise
- = delSubstEnv env old_id
+ = delVarEnv env old_id
\end{code}
Now a variant that unconditionally allocates a new unique.
-> Subst -> (Id, Unique) -- Substitition and Id to transform
-> (Subst, Id) -- Transformed pair
-subst_clone_id rec_subst subst@(Subst in_scope env) (old_id, uniq)
- = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
+subst_clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
where
id1 = setVarUnique old_id uniq
id2 = substIdType subst id1
new_id = maybeModifyIdInfo (substIdInfo False rec_subst) id2
- new_env = extendSubstEnv env old_id (DoneId new_id NoOccInfo)
+ new_env = extendVarEnv env old_id (DoneId new_id NoOccInfo)
substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
substAndCloneIds subst us ids
(ids `zip` uniqsFromSupply us)
substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
-substAndCloneId subst@(Subst in_scope env) us old_id
+substAndCloneId subst us old_id
= subst_clone_id subst subst (old_id, uniqFromSupply us)
\end{code}
------------------
substIdType :: Subst -> Id -> Id
-substIdType subst@(Subst in_scope env) id
- | noTypeSubst env || isEmptyVarSet (tyVarsOfType old_ty) = id
- | otherwise = setIdType id (substTy subst old_ty)
+substIdType subst@(Subst in_scope id_env tv_env) id
+ | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
+ | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
-- The tyVarsOfType is cheaper than it looks
-- because we cache the free tyvars of the type
-- in a Note in the id's type itself
substWorker subst NoWorker
= NoWorker
substWorker subst (HasWorker w a)
- = case lookupIdSubst subst w of
- (DoneId w1 _) -> HasWorker w1 a
- (DoneEx (Var w1)) -> HasWorker w1 a
- (DoneEx other) -> WARN( not (exprIsTrivial other), text "substWorker: DoneEx" <+> ppr w )
- NoWorker -- Worker has got substituted away altogether
+ = case substId subst w of
+ DoneId w1 _ -> HasWorker w1 a
+ DoneEx (Var w1) -> HasWorker w1 a
+ DoneEx other -> WARN( not (exprIsTrivial other), text "substWorker: DoneEx" <+> ppr w )
+ NoWorker -- Worker has got substituted away altogether
-- This can happen if it's trivial,
-- via postInlineUnconditionally
- (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
- NoWorker -- Ditto
+ ContEx se1 e -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
+ NoWorker -- Ditto
------------------
substUnfolding subst NoUnfolding = NoUnfolding
substVarSet subst fvs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
where
- subst_fv subst fv = case lookupIdSubst subst fv of
- DoneId fv' _ -> unitVarSet fv'
- DoneEx expr -> exprFreeVars expr
- DoneTy ty -> tyVarsOfType ty
- ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
+ subst_fv subst fv
+ | isId fv = case substId subst fv of
+ DoneId fv' _ -> unitVarSet fv'
+ DoneEx expr -> exprFreeVars expr
+ ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
+ | otherwise = case lookupTvSubst subst fv of
+ Nothing -> unitVarSet fv
+ Just ty -> substVarSet subst (tyVarsOfType ty)
\end{code}
import HsSyn
import TcHsSyn ( hsPatType )
import TcType ( tcTyConAppTyCon )
-import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
- CanItFail(..), tidyLitPat, tidyNPat,
- )
+import DsUtils ( EquationInfo(..), MatchResult(..),
+ CanItFail(..), firstPat )
+import MatchLit ( tidyLitPat, tidyNPat )
import Id ( Id, idType )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels )
import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc )
Juan Quintela 5 JUL 1998\\
User-friendliness and compiler writers are no friends.
\end{quotation}
-\begin{code}
+\begin{code}
type WarningPat = InPat Name
type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
+type EqnNo = Int
+type EqnSet = UniqSet EqnNo
-check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
-check qs = (untidy_warns, incomplete)
+check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
+ -- Second result is the shadowed equations
+check qs = (untidy_warns, shadowed_eqns)
where
- (warns, incomplete) = check' (simplify_eqns qs)
+ (warns, used_nos) = check' ([1..] `zip` map simplify_eqn qs)
untidy_warns = map untidy_exhaustive warns
+ shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..],
+ not (i `elementOfUniqSet` used_nos)]
untidy_exhaustive :: ExhaustivePat -> ExhaustivePat
untidy_exhaustive ([pat], messages) =
\begin{code}
-check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
-check' [] = ([([],[])],emptyUniqSet)
+check' :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
+check' [] = ([([],[])],emptyUniqSet)
-check' [EqnInfo n ctx ps (MatchResult CanFail _)]
+check' [(n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult CanFail _ })]
| all_vars ps = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)
-check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
+check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult CanFail _}) : rs)
| all_vars ps = (pats, addOneToUniqSet indexs n)
where
(pats,indexs) = check' rs
-check' qs@((EqnInfo n ctx ps result):_)
+check' qs@((n, EqnInfo { eqn_pats = ps }) : _)
| all_vars ps = ([], unitUniqSet n)
--- | nplusk = panic "Check.check': Work in progress: nplusk"
--- | npat = panic "Check.check': Work in progress: npat ?????"
| literals = split_by_literals qs
| constructors = split_by_constructor qs
| only_vars = first_column_only_vars qs
where
-- Note: RecPats will have been simplified to ConPats
-- at this stage.
- first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPat qs
+ first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs
constructors = any is_con first_pats
literals = any is_lit first_pats
only_vars = all is_var first_pats
--- npat = or (map is_npat qs)
--- nplusk = or (map is_nplusk qs)
\end{code}
Here begins the code to deal with literals, we need to split the matrix
rest of values.
\begin{code}
-split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
+split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
split_by_literals qs = process_literals used_lits qs
where
used_lits = get_used_lits qs
in the column of the matrix.
\begin{code}
-process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
where
pats_indexs = map (\x -> construct_literal_matrix x qs) lits
(pats,indexs) = unzip pats_indexs
-
\end{code}
\begin{code}
-process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
process_literals used_lits qs
- | null default_eqns = ([make_row_vars used_lits (head qs)]++pats,indexs)
+ | null default_eqns = ([make_row_vars used_lits (head qs)] ++ pats,indexs)
| otherwise = (pats_default,indexs_default)
where
(pats,indexs) = process_explicit_literals used_lits qs
default_eqns = ASSERT2( okGroup qs, pprGroup qs )
- map remove_var (filter (is_var . firstPat) qs)
+ [remove_var q | q <- qs, is_var (firstPatN q)]
(pats',indexs') = check' default_eqns
pats_default = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
indexs_default = unionUniqSets indexs' indexs
begins for that literal and create a new matrix.
\begin{code}
-construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
construct_literal_matrix lit qs =
(map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
where
new_lit = nlLitPat lit
remove_first_column_lit :: HsLit
- -> [EquationInfo]
- -> [EquationInfo]
+ -> [(EqnNo, EquationInfo)]
+ -> [(EqnNo, EquationInfo)]
remove_first_column_lit lit qs
= ASSERT2( okGroup qs, pprGroup qs )
- map shift_pat (filter (is_var_lit lit . firstPat) qs)
+ [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)]
where
- shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns"
- shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result
-
+ shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }
+ shift_pat eqn@(EqnInfo { eqn_pats = []}) = panic "Check.shift_var: no patterns"
\end{code}
This function splits the equations @qs@ in groups that deal with the
same constructor.
\begin{code}
-
-split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
-
+split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
split_by_constructor qs
| notNull unused_cons = need_default_case used_cons unused_cons qs
| otherwise = no_need_default_case used_cons qs
where
used_cons = get_used_cons qs
unused_cons = get_unused_cons used_cons
-
\end{code}
The first column of the patterns matrix only have vars, then there is
nothing to do.
\begin{code}
-first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
+first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs)
where
- (pats,indexs) = check' (map remove_var qs)
-
+ (pats, indexs) = check' (map remove_var qs)
\end{code}
This equation takes a matrix of patterns and split the equations by
the difference is that here the default case is not always needed.
\begin{code}
-no_need_default_case :: [Pat Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
where
pats_indexs = map (\x -> construct_matrix x qs) cons
(pats,indexs) = unzip pats_indexs
-need_default_case :: [Pat Id] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
need_default_case used_cons unused_cons qs
| null default_eqns = (pats_default_no_eqns,indexs)
| otherwise = (pats_default,indexs_default)
where
(pats,indexs) = no_need_default_case used_cons qs
- default_eqns = ASSERT2( okGroup qs, pprGroup qs ) map remove_var (filter (is_var . firstPat) qs)
+ default_eqns = ASSERT2( okGroup qs, pprGroup qs )
+ [remove_var q | q <- qs, is_var (firstPatN q)]
(pats',indexs') = check' default_eqns
pats_default = [(make_whole_con c:ps,constraints) |
c <- unused_cons, (ps,constraints) <- pats'] ++ pats
pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
indexs_default = unionUniqSets indexs' indexs
-construct_matrix :: Pat Id -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
+construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
construct_matrix con qs =
(map (make_con con) pats,indexs)
where
\begin{code}
remove_first_column :: Pat Id -- Constructor
- -> [EquationInfo]
- -> [EquationInfo]
-remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs
+ -> [(EqnNo, EquationInfo)]
+ -> [(EqnNo, EquationInfo)]
+remove_first_column (ConPatOut con _ _ _ (PrefixCon con_pats) _) qs
= ASSERT2( okGroup qs, pprGroup qs )
- map shift_var (filter (is_var_con con . firstPat) qs)
+ [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)]
where
new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats]
- shift_var (EqnInfo n ctx (ConPatOut _ (PrefixCon ps') _ _ _:ps) result) =
- EqnInfo n ctx (map unLoc ps'++ps) result
- shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
- EqnInfo n ctx (new_wilds ++ ps) result
+ shift_var eqn@(EqnInfo { eqn_pats = ConPatOut _ _ _ _ (PrefixCon ps') _ : ps})
+ = eqn { eqn_pats = map unLoc ps' ++ ps }
+ shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps })
+ = eqn { eqn_pats = new_wilds ++ ps }
shift_var _ = panic "Check.Shift_var:No done"
-make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
-make_row_vars used_lits (EqnInfo _ _ pats _ ) =
- (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)])
- where new_var = hash_x
+make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat
+make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
+ = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)])
+ where
+ new_var = hash_x
hash_x = mkInternalName unboundKey {- doesn't matter much -}
(mkVarOcc FSLIT("#x"))
noSrcLoc
-make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
-make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat nlWildPat)
+make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
+make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
+ = takeList (tail pats) (repeat nlWildPat)
compare_cons :: Pat Id -> Pat Id -> Bool
-compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2
+compare_cons (ConPatOut id1 _ _ _ _ _) (ConPatOut id2 _ _ _ _ _) = id1 == id2
remove_dups :: [Pat Id] -> [Pat Id]
remove_dups [] = []
remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs
| otherwise = x : remove_dups xs
-get_used_cons :: [EquationInfo] -> [Pat Id]
-get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPatOut _ _ _ _ _):_) _) <- qs ]
+get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id]
+get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,
+ isConPatOut pat]
+
+isConPatOut (ConPatOut {}) = True
+isConPatOut other = False
remove_dups' :: [HsLit] -> [HsLit]
remove_dups' [] = []
| otherwise = x : remove_dups' xs
-get_used_lits :: [EquationInfo] -> [HsLit]
+get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]
get_used_lits qs = remove_dups' all_literals
where
all_literals = get_used_lits' qs
-get_used_lits' :: [EquationInfo] -> [HsLit]
+get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
get_used_lits' [] = []
-get_used_lits' ((EqnInfo _ _ ((LitPat lit):_) _):qs) =
- lit : get_used_lits qs
-get_used_lits' ((EqnInfo _ _ ((NPatOut lit _ _):_) _):qs) =
- lit : get_used_lits qs
-get_used_lits' (q:qs) =
- get_used_lits qs
+get_used_lits' (q:qs)
+ | LitPat lit <- first_pat = lit : get_used_lits qs
+ | NPatOut lit _ _ <- first_pat = lit : get_used_lits qs
+ | otherwise = get_used_lits qs
+ where
+ first_pat = firstPatN q
get_unused_cons :: [Pat Id] -> [DataCon]
get_unused_cons used_cons = unused_cons
where
- (ConPatOut _ _ ty _ _) = head used_cons
+ (ConPatOut _ _ _ _ _ ty) = head used_cons
ty_con = tcTyConAppTyCon ty -- Newtype observable
all_cons = tyConDataCons ty_con
- used_cons_as_id = map (\ (ConPatOut d _ _ _ _) -> d) used_cons
+ used_cons_as_id = map (\ (ConPatOut d _ _ _ _ _) -> d) used_cons
unused_cons = uniqSetToList
(mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
all_vars (WildPat _:ps) = all_vars ps
all_vars _ = False
-remove_var :: EquationInfo -> EquationInfo
-remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
-remove_var _ =
- panic "Check.remove_var: equation does not begin with a variable"
+remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo)
+remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps })
+remove_var _ = panic "Check.remove_var: equation does not begin with a variable"
-----------------------
-eqnPats :: EquationInfo -> [Pat Id]
-eqnPats (EqnInfo _ _ ps _) = ps
-
-firstPat :: EquationInfo -> Pat Id
-firstPat eqn_info = head (eqnPats eqn_info)
+eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]
+eqnPats (_, eqn) = eqn_pats eqn
-okGroup :: [EquationInfo] -> Bool
+okGroup :: [(EqnNo, EquationInfo)] -> Bool
-- True if all equations have at least one pattern, and
-- all have the same number of patterns
okGroup [] = True
pprGroup es = vcat (map pprEqnInfo es)
pprEqnInfo e = ppr (eqnPats e)
+
+firstPatN :: (EqnNo, EquationInfo) -> Pat Id
+firstPatN (_, eqn) = firstPat eqn
+
is_con :: Pat Id -> Bool
-is_con (ConPatOut _ _ _ _ _) = True
+is_con (ConPatOut _ _ _ _ _ _) = True
is_con _ = False
is_lit :: Pat Id -> Bool
is_lit (NPatOut _ _ _) = True
is_lit _ = False
-is_npat :: Pat Id -> Bool
-is_npat (NPatOut _ _ _) = True
-is_npat _ = False
-
-is_nplusk :: Pat Id -> Bool
-is_nplusk (NPlusKPatOut _ _ _ _) = True
-is_nplusk _ = False
-
is_var :: Pat Id -> Bool
is_var (WildPat _) = True
is_var _ = False
is_var_con :: DataCon -> Pat Id -> Bool
-is_var_con con (WildPat _) = True
-is_var_con con (ConPatOut id _ _ _ _) | id == con = True
-is_var_con con _ = False
+is_var_con con (WildPat _) = True
+is_var_con con (ConPatOut id _ _ _ _ _) | id == con = True
+is_var_con con _ = False
is_var_lit :: HsLit -> Pat Id -> Bool
is_var_lit lit (WildPat _) = True
make_list _ _ = panic "Check.make_list: Invalid argument"
make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
-make_con (ConPatOut id _ _ _ _) (lp:lq:ps, constraints)
+make_con (ConPatOut id _ _ _ _ _) (lp:lq:ps, constraints)
| return_list id q = (noLoc (make_list lp q) : ps, constraints)
| isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints)
- where p = unLoc lp
- q = unLoc lq
+ where q = unLoc lq
-make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints)
+make_con (ConPatOut id _ _ _ (PrefixCon pats) _) (ps, constraints)
| isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc)) : rest_pats, constraints)
| isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints)
| otherwise = (nlConPat name pats_con : rest_pats, constraints)
\begin{code}
-simplify_eqns :: [EquationInfo] -> [EquationInfo]
-simplify_eqns [] = []
-simplify_eqns ((EqnInfo n ctx pats result):qs) =
- (EqnInfo n ctx pats' result) : simplify_eqns qs
- where
- pats' = map simplify_pat pats
+simplify_eqn :: EquationInfo -> EquationInfo
+simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn) }
simplify_lpat :: LPat Id -> LPat Id
simplify_lpat p = fmap simplify_pat p
simplify_pat :: Pat Id -> Pat Id
simplify_pat pat@(WildPat gt) = pat
simplify_pat (VarPat id) = WildPat (idType id)
+simplify_pat (VarPatOut id _) = WildPat (idType id) -- Ignore the bindings
+simplify_pat (ParPat p) = unLoc (simplify_lpat p)
+simplify_pat (LazyPat p) = unLoc (simplify_lpat p)
+simplify_pat (AsPat id p) = unLoc (simplify_lpat p)
+simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right
-simplify_pat (ParPat p) = unLoc (simplify_lpat p)
-simplify_pat (LazyPat p) = unLoc (simplify_lpat p)
-simplify_pat (AsPat id p) = unLoc (simplify_lpat p)
-simplify_pat (SigPatOut p ty fn) = unLoc (simplify_lpat p) -- I'm not sure this is right
-
-simplify_pat (ConPatOut id ps ty tvs dicts) = ConPatOut id (simplify_con id ps) ty tvs dicts
+simplify_pat (ConPatOut id tvs dicts binds ps ty)
+ = ConPatOut id tvs dicts binds (simplify_con id ps) ty
simplify_pat (ListPat ps ty) =
unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
-- arrays with the existing machinery for constructor pattern
--
simplify_pat (PArrPat ps ty)
- = ConPatOut (parrFakeCon arity)
- (PrefixCon (map simplify_lpat ps))
- (mkPArrTy ty) [] []
- where
- arity = length ps
+ = mk_simple_con_pat (parrFakeCon (length ps))
+ (PrefixCon (map simplify_lpat ps))
+ (mkPArrTy ty)
simplify_pat (TuplePat ps boxity)
- = ConPatOut (tupleCon boxity arity)
- (PrefixCon (map simplify_lpat ps))
- (mkTupleTy boxity arity (map hsPatType ps)) [] []
+ = mk_simple_con_pat (tupleCon boxity arity)
+ (PrefixCon (map simplify_lpat ps))
+ (mkTupleTy boxity arity (map hsPatType ps))
where
arity = length ps
-- unpack string patterns fully, so we can see when they overlap with
-- each other, or even explicit lists of Chars.
simplify_pat pat@(NPatOut (HsString s) _ _) =
- foldr (\c pat -> ConPatOut consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy [] [])
- (ConPatOut nilDataCon (PrefixCon []) stringTy [] []) (unpackFS s)
+ foldr (\c pat -> mk_simple_con_pat consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy)
+ (mk_simple_con_pat nilDataCon (PrefixCon []) stringTy) (unpackFS s)
where
- mk_char_lit c = noLoc $
- ConPatOut charDataCon (PrefixCon [nlLitPat (HsCharPrim c)])
- charTy [] []
+ mk_char_lit c = noLoc (mk_simple_con_pat charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy)
simplify_pat pat@(NPatOut lit lit_ty hsexpr) = unLoc (tidyNPat lit lit_ty (noLoc pat))
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
+mk_simple_con_pat con args ty = ConPatOut con [] [] emptyLHsBinds args ty
+
-----------------
simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps)
simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2]
| otherwise = PrefixCon (map (simplify_lpat.snd) all_pats)
where
-- pad out all the missing fields with WildPats.
- field_pats = map (\ f -> (getName f, nlWildPat))
- (dataConFieldLabels con)
+ field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc)
field_pats fs
import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn )
import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..),
- Dependencies(..), TypeEnv,
- unQualInScope, availsToNameSet )
+ Dependencies(..), TypeEnv, unQualInScope )
import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr,
HsBindGroup(..), LRuleDecl, HsBind(..) )
import TcRnTypes ( TcGblEnv(..), ImportAvails(..) )
import Name ( Name, isExternalName )
import CoreSyn
import PprCore ( pprIdRules, pprCoreExpr )
-import Subst ( substExpr, mkSubst, mkInScopeSet )
+import Subst ( SubstResult(..), substExpr, mkSubst, extendIdSubstList )
import DsMonad
import DsExpr ( dsLExpr )
import DsBinds ( dsHsBinds, AutoScc(..) )
import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
-import Module ( Module, moduleEnvElts, emptyModuleEnv )
+import Module ( Module, moduleEnvElts )
import Id ( Id )
import RdrName ( GlobalRdrEnv )
import NameSet
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
let
- subst_env = mkSubstEnv [id | (id,rhs) <- dict_binds']
- [ContEx subst_env rhs | (id,rhs) <- dict_binds']
+ subst = extendIdSubstList (mkSubst all_vars) pairs
+ pairs = [(id, ContEx subst rhs) | (id,rhs) <- dict_binds']
-- Note recursion here... substitution won't terminate
-- if there is genuine recursion... which there isn't
-
- subst = mkSubst all_vars subst_env
body'' = substExpr subst body'
in
import Match ( matchSimply )
import DsUtils ( mkErrorAppDs,
- mkCoreTupTy, mkCoreTup, selectMatchVarL,
+ mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
mkTupleCase, mkBigCoreTup, mkTupleType,
mkTupleExpr, mkTupleSelector,
dsReboundNames, lookupReboundName )
import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet )
-import TcType ( Type, tcSplitAppTy )
-import Type ( mkTyConApp )
+import TcType ( Type, tcSplitAppTy, mkFunTy )
+import Type ( mkTyConApp, funArgTy )
import CoreSyn
import CoreFVs ( exprFreeVars )
import CoreUtils ( mkIfThenElse, bindNonRec, exprType )
import Util ( mapAccumL )
import Outputable
-import HsPat ( collectPatBinders, collectPatsBinders )
+import HsUtils ( collectPatBinders, collectPatsBinders )
import VarSet ( IdSet, mkVarSet, varSetElems,
intersectVarSet, minusVarSet, extendVarSetList,
unionVarSet, unionVarSets, elemVarSet )
coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair scrut_var var1 var2 body
- = Case (Var scrut_var) scrut_var
+-- gaw 2004
+ = Case (Var scrut_var) scrut_var (exprType body)
[(DataAlt (tupleCon Boxed 2), [var1, var2], body)]
\end{code}
env_ty = mkTupleType env_ids
in
mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr ->
- selectMatchVarL pat `thenDs` \ var ->
+ selectSimpleMatchVarL pat `thenDs` \ var ->
matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
`thenDs` \ match_code ->
let
-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty
- (HsLam (L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ _cmd_ty))))
+ (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ ))] _))
= let
pat_vars = mkVarSet (collectPatsBinders pats)
local_vars' = local_vars `unionVarSet` pat_vars
bodies with |||.
\begin{code}
-dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches)
+dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty))
= dsLExpr exp `thenDs` \ core_exp ->
mappM newSysLocalDs stack `thenDs` \ stack_ids ->
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack
fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars
+
+ pat_ty = funArgTy match_ty
+ match_ty' = mkFunTy pat_ty sum_ty
+ -- Note that we replace the HsCase result type by sum_ty,
+ -- which is the type of matches'
in
- dsExpr (HsCase exp matches') `thenDs` \ core_body ->
+ dsExpr (HsCase exp (MatchGroup matches' match_ty')) `thenDs` \ core_body ->
matchEnvStack env_ids stack_ids core_body
`thenDs` \ core_matches ->
returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
-- projection function
-- \ (p, (xs2)) -> (zs)
- selectMatchVarL pat `thenDs` \ pat_id ->
newSysLocalDs env_ty2 `thenDs` \ env_id ->
newUniqueSupply `thenDs` \ uniqs ->
let
body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids)
in
mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr ->
+ selectSimpleMatchVarL pat `thenDs` \ pat_id ->
matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
`thenDs` \ match_code ->
newSysLocalDs after_c_ty `thenDs` \ pair_id ->
\begin{code}
leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)]
-leavesMatch (L _ (Match pats _ (GRHSs grhss binds _ty)))
+leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
-> LMatch Id -- the matches of a case command
-> ([LHsExpr Id],-- remaining leaf expressions
LMatch Id) -- updated match
-replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds _ty)))
+replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
- (leaves', L loc (Match pat mt (GRHSs grhss' binds res_ty)))
+ (leaves', L loc (Match pat mt (GRHSs grhss' binds)))
replaceLeavesGRHS
:: [LHsExpr Id] -- replacement leaf expressions of that type
lower levels it is preserved with @let@/@letrec@s).
\begin{code}
-module DsBinds ( dsHsBinds, AutoScc(..) ) where
+module DsBinds ( dsHsBinds, dsHsNestedBinds, AutoScc(..) ) where
#include "HsVersions.h"
import {-# SOURCE #-} DsExpr( dsLExpr )
+import {-# SOURCE #-} Match( matchWrapper )
+
import DsMonad
import DsGRHSs ( dsGuarded )
import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import CoreUtils ( exprType, mkInlineMe, mkSCC )
-import Match ( matchWrapper )
import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
import CostCentre ( mkAutoCC, IsCafCC(..) )
import Id ( idType, idName, isExportedId, isSpecPragmaId, Id )
import NameSet
import VarSet
-import TcType ( mkTyVarTy )
-import Subst ( substTyWith )
+import Type ( mkTyVarTy, substTyWith )
import TysWiredIn ( voidTy )
import Outputable
import SrcLoc ( Located(..) )
import Maybe ( isJust )
-import Bag ( Bag, bagToList )
-
+import Bag ( bagToList )
import Monad ( foldM )
\end{code}
%************************************************************************
\begin{code}
+dsHsNestedBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
+dsHsNestedBinds binds = dsHsBinds NoSccs binds []
+
dsHsBinds :: AutoScc -- scc annotation policy (see below)
- -> Bag (LHsBind Id)
+ -> LHsBinds Id
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
-> DsM [(Id,CoreExpr)] -- Result
-dsHsBinds auto_scc binds rest =
- foldM (dsLHsBind auto_scc) rest (bagToList binds)
+dsHsBinds auto_scc binds rest
+ = foldM (dsLHsBind auto_scc) rest (bagToList binds)
dsLHsBind :: AutoScc
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
returnDs ((var, core_expr'') : rest)
dsHsBind auto_scc rest (FunBind (L _ fun) _ matches)
- = matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) ->
- addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
+ = matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) ->
+ addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
returnDs (pair : rest)
-dsHsBind auto_scc rest (PatBind pat grhss)
- = dsGuarded grhss `thenDs` \ body_expr ->
+dsHsBind auto_scc rest (PatBind pat grhss ty)
+ = dsGuarded grhss ty `thenDs` \ body_expr ->
mkSelectorBinds pat body_expr `thenDs` \ sel_binds ->
mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds ->
returnDs (sel_binds ++ rest)
import DsMonad
-import CoreUtils ( exprType, mkCoerce2 )
+import CoreUtils ( exprType, coreAltType, mkCoerce2 )
import Id ( Id, mkWildId )
import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
unboxedSingletonTyCon, unboxedPairTyCon,
trueDataCon, falseDataCon,
trueDataConId, falseDataConId,
- listTyCon, charTyCon,
+ listTyCon, charTyCon, boolTy,
tupleTyCon, tupleCon
)
import BasicTypes ( Boxity(..) )
tc `hasKey` boolTyConKey
= newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
- \ body -> Case (Case arg (mkWildId arg_ty)
+-- gaw 2004
+ \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
- prim_arg
+ prim_arg
+-- gaw 2004
+ (exprType body)
[(DEFAULT,[],body)])
-- Data types with a single constructor, which has a single, primitive-typed arg
newSysLocalDs arg_ty `thenDs` \ case_bndr ->
newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
- \ body -> Case arg case_bndr [(DataAlt data_con,[prim_arg],body)]
+-- gaw 2004
+ \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
)
-- Byte-arrays, both mutable and otherwise; hack warning
= newSysLocalDs arg_ty `thenDs` \ case_bndr ->
newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
returnDs (Var arr_cts_var,
- \ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
+-- gaw 2004
+ \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
+
)
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
Lam state_id $
Case (App the_call (Var state_id))
(mkWildId ccall_res_ty)
+-- gaw 2004
+ (coreAltType the_alt)
[the_alt]
]
in
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
+-- gaw 2004
+ (coreAltType the_alt)
[the_alt]
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= returnDs
(Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+-- gaw 2004
+ boolTy
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
import Match ( matchWrapper, matchSimply )
import MatchLit ( dsLit )
-import DsBinds ( dsHsBinds, AutoScc(..) )
+import DsBinds ( dsHsNestedBinds )
import DsGRHSs ( dsGuarded )
import DsListComp ( dsListComp, dsPArrComp )
-import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr,
- mkCoreTupTy, selectMatchVarL,
+import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
+ mkCoreTupTy, selectSimpleMatchVarL,
dsReboundNames, lookupReboundName )
import DsArrows ( dsProcExpr )
import DsMonad
-- So WATCH OUT; check each use of split*Ty functions.
-- Sigh. This is a pain.
-import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppArgs,
- tcSplitTyConApp, isUnLiftedType, Type,
- mkAppTy )
-import Type ( splitFunTys )
+import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon, tcTyConAppArgs,
+ tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
+import Type ( mkFunTys, funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
-import FieldLabel ( FieldLabel, fieldLabelTyCon )
import CostCentre ( mkUserCC )
-import Id ( Id, idType, idName, recordSelectorFieldLabel )
+import Id ( Id, idType, idName )
import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
-import DataCon ( isExistentialDataCon )
+import DataCon ( isVanillaDataCon )
import Name ( Name )
-import TyCon ( tyConDataCons )
+import TyCon ( FieldLabel, tyConDataCons )
import TysWiredIn ( tupleCon )
import BasicTypes ( RecFlag(..), Boxity(..), ipNameName )
import PrelNames ( toPName,
in
case bagToList binds of
[L loc (FunBind (L _ fun) _ matches)]
- -> putSrcSpanDs loc $
- matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
+ -> putSrcSpanDs loc $
+ matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
ASSERT( null args ) -- Functions aren't lifted
returnDs (bindNonRec fun rhs body_w_exports)
- [L loc (PatBind pat grhss)]
+ [L loc (PatBind pat grhss ty)]
-> putSrcSpanDs loc $
- dsGuarded grhss `thenDs` \ rhs ->
+ dsGuarded grhss ty `thenDs` \ rhs ->
mk_error_app pat `thenDs` \ error_expr ->
matchSimply rhs PatBindRhs pat body_w_exports error_expr
-- Ordinary case for bindings
dsBindGroup body (HsBindGroup binds sigs is_rec)
- = dsHsBinds NoSccs binds [] `thenDs` \ prs ->
+ = dsHsNestedBinds binds `thenDs` \ prs ->
returnDs (Let (Rec prs) body)
-- Use a Rec regardless of is_rec.
-- Why? Because it allows the binds to be all
-- HsOverLit has been gotten rid of by the type checker
dsExpr expr@(HsLam a_Match)
- = matchWrapper LambdaExpr [a_Match] `thenDs` \ (binders, matching_code) ->
+ = matchWrapper LambdaExpr a_Match `thenDs` \ (binders, matching_code) ->
returnDs (mkLams binders matching_code)
dsExpr expr@(HsApp fun arg)
= dsLExpr expr `thenDs` \ core_expr ->
returnDs (Note (CoreNote $ unpackFS fs) core_expr)
--- special case to handle unboxed tuple patterns.
-
-dsExpr (HsCase discrim matches)
- | all ubx_tuple_match matches
+-- Special case to handle unboxed tuple patterns; they can't appear nested
+dsExpr (HsCase discrim matches@(MatchGroup _ ty))
+ | isUnboxedTupleType (funArgTy ty)
= dsLExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
case matching_code of
- Case (Var x) bndr alts | x == discrim_var ->
- returnDs (Case core_discrim bndr alts)
+ Case (Var x) bndr ty alts | x == discrim_var ->
+ returnDs (Case core_discrim bndr ty alts)
_ -> panic ("dsLExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code))
- where
- ubx_tuple_match (L _ (Match [L _ (TuplePat _ Unboxed)] _ _)) = True
- ubx_tuple_match _ = False
dsExpr (HsCase discrim matches)
= dsLExpr discrim `thenDs` \ core_discrim ->
- matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
+ matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
returnDs (bindNonRec discrim_var core_discrim matching_code)
dsExpr (HsLet binds body)
= -- Special case for list comprehensions
dsListComp stmts elt_ty
where
- (_, [elt_ty]) = tcSplitTyConApp result_ty
+ [elt_ty] = tcTyConAppArgs result_ty
dsExpr (HsDo do_or_lc stmts ids result_ty)
| isDoExpr do_or_lc
= -- Special case for array comprehensions
dsPArrComp (map unLoc stmts) elt_ty
where
- (_, [elt_ty]) = tcSplitTyConApp result_ty
+ [elt_ty] = tcTyConAppArgs result_ty
dsExpr (HsIf guard_expr then_expr else_expr)
= dsLExpr guard_expr `thenDs` \ core_guard ->
-- A newtype in the corner should be opaque;
-- hence TcType.tcSplitFunTys
- mk_arg (arg_ty, lbl)
- = case [rhs | (L _ sel_id, rhs) <- rbinds,
- lbl == recordSelectorFieldLabel sel_id] of
+ mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
+ = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of
(rhs:rhss) -> ASSERT( null rhss )
dsLExpr rhs
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
let
in_inst_tys = tcTyConAppArgs record_in_ty -- Newtype opaque
out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque
+ in_out_ty = mkFunTy record_in_ty record_out_ty
mk_val_arg field old_arg_id
- = case [rhs | (L _ sel_id, rhs) <- rbinds,
- field == recordSelectorFieldLabel sel_id] of
+ = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
(rhs:rest) -> ASSERT(null rest) rhs
[] -> nlHsVar old_arg_id
mk_alt con
= newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
-- This call to dataConArgTys won't work for existentials
+ -- but existentials don't have record types anyway
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
out_inst_tys)
val_args
in
- returnDs (mkSimpleMatch [noLoc $ ConPatOut con (PrefixCon (map nlVarPat arg_ids)) record_in_ty [] []]
- rhs
- record_out_ty)
+ returnDs (mkSimpleMatch [noLoc $ ConPatOut con [] [] emptyLHsBinds
+ (PrefixCon (map nlVarPat arg_ids)) record_in_ty]
+ rhs)
in
-- Record stuff doesn't work for existentials
-- The type checker checks for this, but we need
-- worry only about the constructors that are to be updated
- ASSERT2( all (not . isExistentialDataCon) cons_to_upd, ppr expr )
+ ASSERT2( all isVanillaDataCon cons_to_upd, ppr expr )
-- It's important to generate the match with matchWrapper,
-- and the right hand sides with applications of the wrapper Id
-- so that everything works when we are doing fancy unboxing on the
-- constructor aguments.
- mappM mk_alt cons_to_upd `thenDs` \ alts ->
- matchWrapper RecUpd alts `thenDs` \ ([discrim_var], matching_code) ->
+ mappM mk_alt cons_to_upd `thenDs` \ alts ->
+ matchWrapper RecUpd (MatchGroup alts in_out_ty) `thenDs` \ ([discrim_var], matching_code) ->
returnDs (bindNonRec discrim_var record_expr' matching_code)
where
updated_fields :: [FieldLabel]
- updated_fields = [ recordSelectorFieldLabel sel_id
- | (L _ sel_id,_) <- rbinds]
+ updated_fields = [ idName sel_id | (L _ sel_id,_) <- rbinds]
- -- Get the type constructor from the first field label,
+ -- Get the type constructor from the record_in_ty
-- so that we are sure it'll have all its DataCons
-- (In GHCI, it's possible that some TyCons may not have all
-- their constructors, in a module-loop situation.)
- tycon = fieldLabelTyCon (head updated_fields)
+ tycon = tcTyConAppTyCon record_in_ty
data_cons = tyConDataCons tycon
cons_to_upd = filter has_all_fields data_cons
go (BindStmt pat expr : stmts)
= go stmts `thenDs` \ body ->
dsLExpr expr `thenDs` \ rhs ->
- mkStringLit (mk_msg (getLoc pat)) `thenDs` \ core_msg ->
+ mkStringExpr (mk_msg (getLoc pat)) `thenDs` \ core_msg ->
let
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
fail_expr = mkApps fail_id [Type b_ty, core_msg]
a_ty = hsPatType pat
in
- selectMatchVarL pat `thenDs` \ var ->
+ selectSimpleMatchVarL pat `thenDs` \ var ->
matchSimply (Var var) (StmtCtxt do_or_lc) pat
body fail_expr `thenDs` \ match_code ->
returnDs (mkApps bind_id [Type a_ty, Type b_ty, rhs, Lam var match_code])
one_var = null rest
mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg
- mfix_arg = noLoc $ HsLam (mkSimpleMatch [tup_pat] body tup_ty)
+ mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [tup_pat] body]
+ (mkFunTy tup_ty body_ty))
tup_expr | one_var = ret1
| otherwise = noLoc $ ExplicitTuple rets Boxed
- tup_ty = mkCoreTupTy (map idType vars)
- -- Deals with singleton case
+ var_tys = map idType vars
+ tup_ty = mkCoreTupTy var_tys -- Deals with singleton case
tup_pat | one_var = nlVarPat var1
| otherwise = noLoc $ LazyPat (noLoc $ TuplePat (map nlVarPat vars) Boxed)
body = noLoc $ HsDo DoExpr (stmts ++ [return_stmt])
[(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack
- (mkAppTy m_ty tup_ty)
+ body_ty
+ body_ty = mkAppTy m_ty tup_ty
Var return_id = lookupReboundName ds_meths returnMName
Var mfix_id = lookupReboundName ds_meths mfixName
import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..),
HsMatchContext(..), Pat(..) )
import CoreSyn ( CoreExpr )
-import Type ( Type )
import Var ( Id )
+import Type ( Type )
import DsMonad
import DsUtils
necessary. The type argument gives the type of the @ei@.
\begin{code}
-dsGuarded :: GRHSs Id -> DsM CoreExpr
+dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
-dsGuarded grhss
- = dsGRHSs PatBindRhs [] grhss `thenDs` \ (err_ty, match_result) ->
- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
+dsGuarded grhss rhs_ty
+ = dsGRHSs PatBindRhs [] grhss rhs_ty `thenDs` \ match_result ->
+ mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty "" `thenDs` \ error_expr ->
extractMatchResult match_result error_expr
\end{code}
\begin{code}
dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from
-> GRHSs Id -- Guarded RHSs
- -> DsM (Type, MatchResult)
+ -> Type -- Type of RHS
+ -> DsM MatchResult
-dsGRHSs kind pats (GRHSs grhss binds ty)
- = mappM (dsGRHS kind pats) grhss `thenDs` \ match_results ->
+dsGRHSs kind pats (GRHSs grhss binds) rhs_ty
+ = mappM (dsGRHS kind pats rhs_ty) grhss `thenDs` \ match_results ->
let
match_result1 = foldr1 combineMatchResults match_results
match_result2 = adjustMatchResultDs (dsLet binds) match_result1
-- NB: nested dsLet inside matchResult
in
- returnDs (ty, match_result2)
+ returnDs match_result2
-dsGRHS kind pats (L loc (GRHS guard))
- = matchGuard (map unLoc guard) (DsMatchContext kind pats loc)
+dsGRHS kind pats rhs_ty (L loc (GRHS guard))
+ = matchGuard (map unLoc guard) (DsMatchContext kind pats loc) rhs_ty
\end{code}
\begin{code}
matchGuard :: [Stmt Id] -- Guard
- -> DsMatchContext -- Context
+ -> DsMatchContext -- Context
+ -> Type -- Type of RHS of guard
-> DsM MatchResult
-- See comments with HsExpr.Stmt re what an ExprStmt means
-- Here we must be in a guard context (not do-expression, nor list-comp)
-matchGuard [ResultStmt expr] ctx
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (cantFailMatchResult core_expr)
+matchGuard [ResultStmt expr] ctx rhs_ty
+ = do { core_expr <- dsLExpr expr
+ ; return (cantFailMatchResult core_expr) }
-- ExprStmts must be guards
-- Turn an "otherwise" guard is a no-op
-matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx
+matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx rhs_ty
| v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
-- trueDataConId doesn't have the same
-- unique as trueDataCon
- = matchGuard stmts ctx
+ = matchGuard stmts ctx rhs_ty
-matchGuard (ExprStmt expr _ : stmts) ctx
- = matchGuard stmts ctx `thenDs` \ match_result ->
+matchGuard (ExprStmt expr _ : stmts) ctx rhs_ty
+ = matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
dsLExpr expr `thenDs` \ pred_expr ->
returnDs (mkGuardedMatchResult pred_expr match_result)
-matchGuard (LetStmt binds : stmts) ctx
- = matchGuard stmts ctx `thenDs` \ match_result ->
+matchGuard (LetStmt binds : stmts) ctx rhs_ty
+ = matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
returnDs (adjustMatchResultDs (dsLet binds) match_result)
-- NB the dsLet occurs inside the match_result
-
-matchGuard (BindStmt pat rhs : stmts) ctx
- = matchGuard stmts ctx `thenDs` \ match_result ->
- dsLExpr rhs `thenDs` \ core_rhs ->
- matchSinglePat core_rhs ctx pat match_result
+ -- Reason: dsLet takes the body expression as its argument
+ -- so we can't desugar the bindings without the
+ -- body expression in hand
+
+matchGuard (BindStmt pat bind_rhs : stmts) ctx rhs_ty
+ = matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
+ dsLExpr bind_rhs `thenDs` \ core_rhs ->
+ matchSinglePat core_rhs ctx pat rhs_ty match_result
\end{code}
Should {\em fail} if @e@ returns @D@
rest_expr core_fail `thenDs` \ core_match ->
let
rhs = Lam u1 $
- Case (Var u1) u1 [(DataAlt nilDataCon, [], core_list2),
- (DataAlt consDataCon, [u2, u3], core_match)]
+-- gaw 2004
+ Case (Var u1) u1 res_ty
+ [(DataAlt nilDataCon, [], core_list2),
+ (DataAlt consDataCon, [u2, u3], core_match)]
in
returnDs (Let (Rec [(h, rhs)]) letrec_body)
\end{code}
in
returnDs (zip_fn, mkLams ass zip_body)
where
- list_tys = map mkListTy elt_tys
- ret_elt_ty = mkCoreTupTy elt_tys
- zip_fn_ty = mkFunTys list_tys (mkListTy ret_elt_ty)
+ list_tys = map mkListTy elt_tys
+ ret_elt_ty = mkCoreTupTy elt_tys
+ list_ret_ty = mkListTy ret_elt_ty
+ zip_fn_ty = mkFunTys list_tys list_ret_ty
mk_case (as, a', as') rest
- = Case (Var as) as [(DataAlt nilDataCon, [], mkNilExpr ret_elt_ty),
- (DataAlt consDataCon, [a', as'], rest)]
+-- gaw 2004
+ = Case (Var as) as list_ret_ty
+ [(DataAlt nilDataCon, [], mkNilExpr ret_elt_ty),
+ (DataAlt consDataCon, [a', as'], rest)]
-- Helper functions that makes an HsTuple only for non-1-sized tuples
mk_hs_tuple_expr :: [Id] -> LHsExpr Id
dfListComp c_id b quals `thenDs` \ core_rest ->
-- build the pattern match
- matchSimply (Var x) (StmtCtxt ListComp)
+ matchSimply (Var x) (StmtCtxt ListComp)
pat core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
let errTy = exprType ce
errMsg = "DsListComp.deLambda: internal error!"
in
- mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr ->
+ mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr ->
matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr `thenDs` \res ->
returnDs (mkLams [v] res, errTy)
import {-# SOURCE #-} DsExpr ( dsExpr )
import MatchLit ( dsLit )
-import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
+import DsUtils ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
import DsMonad
import qualified Language.Haskell.TH as TH
= do { dsWarn (loc, hang ds_msg 4 (ppr con_decl))
; return (panic "DsMeta:repC") }
where
-
+-- gaw 2004 FIX! Need a case for GadtDecl
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
-repBangTy (L _ (BangType str ty)) = do
+repBangTy (L _ (HsBangTy str ty)) = do
MkC s <- rep2 strName []
MkC t <- repLTy ty
rep2 strictTypeName [s, t]
-- HsOverlit can definitely occur
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l) = do { a <- repLiteral l; repLit a }
-repE (HsLam m) = repLambda m
+repE (HsLam (MatchGroup [m] _)) = repLambda m
repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (OpApp e1 op fix e2) =
repE (HsPar x) = repLE x
repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase e ms) = do { arg <- repLE e
- ; ms2 <- mapM repMatchTup ms
- ; repCaseE arg (nonEmptyCoreList ms2) }
+repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
+ ; ms2 <- mapM repMatchTup ms
+ ; repCaseE arg (nonEmptyCoreList ms2) }
repE (HsIf x y z) = do
a <- repLE x
b <- repLE y
-- Building representations of auxillary structures like Match, Clause, Stmt,
repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
-repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) =
+repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repLP p
; wrapGenSyns (ss1++ss2) match }}}
repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
-repClauseTup (L _ (Match ps ty (GRHSs guards wheres ty2))) =
+repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
ps1 <- repLPs ps
-- 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 [L _ (Match [] ty (GRHSs guards wheres ty2))]))
+rep_bind (L loc (FunBind fn infx (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 ms))
+rep_bind (L loc (FunBind fn infx (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 (GRHSs guards wheres) ty2))
= do { patcore <- repLP pat
; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
-- (\ p1 .. pn -> exp) by causing an error.
repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [] _)))
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [])))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
coreStringLit :: String -> DsM (Core String)
-coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
coreIntLit :: Int -> DsM (Core Int)
coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
import HsSyn ( HsExpr, HsMatchContext, Pat )
import TcIface ( tcIfaceGlobal )
import HscTypes ( TyThing(..), TypeEnv, HscEnv,
- IsBootInterface,
tyThingId, tyThingTyCon, tyThingDataCon )
import Bag ( emptyBag, snocBag, Bag )
import DataCon ( DataCon )
import TyCon ( TyCon )
import DataCon ( DataCon )
import Id ( mkSysLocal, setIdUnique, Id )
-import Module ( Module, ModuleName, ModuleEnv )
+import Module ( Module )
import Var ( TyVar, setTyVarUnique )
import Outputable
import SrcLoc ( noSrcSpan, SrcSpan )
\begin{code}
module DsUtils (
- CanItFail(..), EquationInfo(..), MatchResult(..),
- EqnNo, EqnSet,
-
- tidyLitPat, tidyNPat,
+ EquationInfo(..),
+ firstPat, shiftEqns,
mkDsLet,
- cantFailMatchResult, extractMatchResult,
- combineMatchResults,
- adjustMatchResult, adjustMatchResultDs,
- mkCoLetsMatchResult, mkGuardedMatchResult,
+ MatchResult(..), CanItFail(..),
+ cantFailMatchResult, alwaysFailMatchResult,
+ extractMatchResult, combineMatchResults,
+ adjustMatchResult, adjustMatchResultDs,
+ mkCoLetsMatchResult, mkCoLetMatchResult,
+ mkGuardedMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
+ bindInMatchResult, bindOneInMatchResult,
mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
mkIntExpr, mkCharExpr,
- mkStringLit, mkStringLitFS, mkIntegerExpr,
+ mkStringExpr, mkStringExprFS, mkIntegerExpr,
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
mkTupleType, mkTupleCase, mkBigCoreTup,
dsReboundNames, lookupReboundName,
- selectMatchVarL, selectMatchVar
+ selectSimpleMatchVarL, selectMatchVars
) where
#include "HsVersions.h"
import CoreUtils ( exprType, mkIfThenElse, mkCoerce, bindNonRec )
import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
import Id ( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal )
+import Var ( Var )
import Name ( Name )
-import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
+import Literal ( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT )
import TyCon ( isNewTyCon, tyConDataCons )
-import DataCon ( DataCon, dataConSourceArity )
-import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp )
-import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy )
+import DataCon ( DataCon, dataConSourceArity, dataConTyCon )
+import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy )
+import TcType ( tcTyConAppTyCon, tcEqType )
import TysPrim ( intPrimTy )
import TysWiredIn ( nilDataCon, consDataCon,
tupleCon, mkTupleTy,
unitDataConId, unitTy,
charTy, charDataCon,
intTy, intDataCon,
- floatDataCon,
- doubleDataCon,
- stringTy, isPArrFakeCon )
+ isPArrFakeCon )
import BasicTypes ( Boxity(..) )
-import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
+import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet )
import UniqSupply ( splitUniqSupply, uniqFromSupply, uniqsFromSupply )
import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
plusIntegerName, timesIntegerName, smallIntegerDataConName,
lengthPName, indexPName )
import Outputable
-import UnicodeUtil ( intsToUtf8, stringToUtf8 )
+import UnicodeUtil ( intsToUtf8 )
import SrcLoc ( Located(..), unLoc, noLoc )
import Util ( isSingleton, notNull, zipEqual )
import ListSetOps ( assocDefault )
%************************************************************************
%* *
-\subsection{Tidying lit pats}
-%* *
-%************************************************************************
-
-\begin{code}
-tidyLitPat :: HsLit -> LPat Id -> LPat Id
-tidyLitPat (HsChar c) pat = mkCharLitPat c
-tidyLitPat lit pat = pat
-
-tidyNPat :: HsLit -> Type -> LPat Id -> LPat Id
-tidyNPat (HsString s) _ pat
- | lengthFS s <= 1 -- Short string literals only
- = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
- (mkNilPat stringTy) (unpackFS s)
- -- The stringTy is the type of the whole pattern, not
- -- the type to instantiate (:) or [] with!
- where
-
-tidyNPat lit lit_ty default_pat
- | isIntTy lit_ty = mkPrefixConPat intDataCon [noLoc $ LitPat (mk_int lit)] lit_ty
- | isFloatTy lit_ty = mkPrefixConPat floatDataCon [noLoc $ LitPat (mk_float lit)] lit_ty
- | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [noLoc $ LitPat (mk_double lit)] lit_ty
- | otherwise = default_pat
-
- where
- mk_int (HsInteger i _) = HsIntPrim i
-
- mk_float (HsInteger i _) = HsFloatPrim (fromInteger i)
- mk_float (HsRat f _) = HsFloatPrim f
-
- mk_double (HsInteger i _) = HsDoublePrim (fromInteger i)
- mk_double (HsRat f _) = HsDoublePrim f
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Building lets}
%* *
%************************************************************************
\begin{code}
mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
mkDsLet (NonRec bndr rhs) body
- | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
+ | isUnLiftedType (idType bndr)
+ = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
mkDsLet bind body
= Let bind body
otherwise, make one up.
\begin{code}
-selectMatchVarL :: LPat Id -> DsM Id
-selectMatchVarL pat = selectMatchVar (unLoc pat)
-
-selectMatchVar (VarPat var) = returnDs var
-selectMatchVar (AsPat var pat) = returnDs (unLoc var)
-selectMatchVar (LazyPat pat) = selectMatchVarL pat
-selectMatchVar other_pat = newSysLocalDs (hsPatType (noLoc other_pat))
- -- OK, better make up one...
+selectSimpleMatchVarL :: LPat Id -> DsM Id
+selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) (hsPatType pat)
+
+-- (selectMatchVars ps tys) chooses variables of type tys
+-- to use for matching ps against. If the pattern is a variable,
+-- we try to use that, to save inventing lots of fresh variables.
+-- But even if it is a variable, its type might not match. Consider
+-- data T a where
+-- T1 :: Int -> T Int
+-- T2 :: a -> T a
+--
+-- f :: T a -> a -> Int
+-- f (T1 i) (x::Int) = x
+-- f (T2 i) (y::a) = 0
+-- Then we must not choose (x::Int) as the matching variable!
+
+selectMatchVars :: [Pat Id] -> [Type] -> DsM [Id]
+selectMatchVars [] [] = return []
+selectMatchVars (p:ps) (ty:tys) = do { v <- selectMatchVar p ty
+ ; vs <- selectMatchVars ps tys
+ ; return (v:vs) }
+
+selectMatchVar (LazyPat pat) pat_ty = selectMatchVar (unLoc pat) pat_ty
+selectMatchVar (VarPat var) pat_ty = try_for var pat_ty
+selectMatchVar (AsPat var pat) pat_ty = try_for (unLoc var) pat_ty
+selectMatchVar other_pat pat_ty = newSysLocalDs pat_ty -- OK, better make up one...
+
+try_for var pat_ty
+ | idType var `tcEqType` pat_ty = returnDs var
+ | otherwise = newSysLocalDs pat_ty
\end{code}
worthy of a type synonym and a few handy functions.
\begin{code}
-
-type EqnNo = Int
-type EqnSet = UniqSet EqnNo
-
data EquationInfo
- = EqnInfo
- EqnNo -- The number of the equation
+ = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
+ eqn_rhs :: MatchResult } -- What to do after match
+
+-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
+-- \fail. wrap (case vs of { pats -> rhs fail })
+-- where vs are not in the domain of wrap
- DsMatchContext -- The context info is used when producing warnings
- -- about shadowed patterns. It's the context
- -- of the *first* thing matched in this group.
- -- Should perhaps be a list of them all!
+firstPat :: EquationInfo -> Pat Id
+firstPat eqn = head (eqn_pats eqn)
- [Pat Id] -- The patterns for an eqn
+shiftEqns :: [EquationInfo] -> [EquationInfo]
+-- Drop the outermost layer of the first pattern in each equation
+shiftEqns eqns = [ eqn { eqn_pats = shiftPats (eqn_pats eqn) }
+ | eqn <- eqns ]
- MatchResult -- Encapsulates the guards and bindings
+shiftPats :: [Pat Id] -> [Pat Id]
+shiftPats (ConPatOut _ _ _ _ (PrefixCon arg_pats) _ : pats) = map unLoc arg_pats ++ pats
+shiftPats (pat_with_no_sub_pats : pats) = pats
\end{code}
+
\begin{code}
+-- A MatchResult is an expression with a hole in it
data MatchResult
= MatchResult
CanItFail -- Tells whether the failure expression is used
Functions on MatchResults
\begin{code}
+alwaysFailMatchResult :: MatchResult
+alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
+
cantFailMatchResult :: CoreExpr -> MatchResult
cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
= match_result1
-
adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
= MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
= MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
encl_fn body)
+bindInMatchResult :: [(Var,Var)] -> MatchResult -> MatchResult
+bindInMatchResult binds = adjustMatchResult (\e -> foldr bind e binds)
+ where
+ bind (new,old) body = bindMR new old body
+
+bindOneInMatchResult :: Var -> Var -> MatchResult -> MatchResult
+bindOneInMatchResult new old = adjustMatchResult (bindMR new old)
+
+bindMR :: Var -> Var -> CoreExpr -> CoreExpr
+bindMR new old body
+ | new==old = body
+ | isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
+ | otherwise = Let (NonRec new (Var old)) body
mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
mkCoLetsMatchResult binds match_result
= adjustMatchResult (mkDsLets binds) match_result
+mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
+mkCoLetMatchResult bind match_result
+ = adjustMatchResult (mkDsLet bind) match_result
mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
returnDs (mkIfThenElse pred_expr body fail))
mkCoPrimCaseMatchResult :: Id -- Scrutinee
+ -> Type -- Type of the case
-> [(Literal, MatchResult)] -- Alternatives
-> MatchResult
-mkCoPrimCaseMatchResult var match_alts
+mkCoPrimCaseMatchResult var ty match_alts
= MatchResult CanFail mk_case
where
mk_case fail
= mappM (mk_alt fail) match_alts `thenDs` \ alts ->
- returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts))
+ returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
returnDs (LitAlt lit, [], body)
mkCoAlgCaseMatchResult :: Id -- Scrutinee
+ -> Type -- Type of exp
-> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
-> MatchResult
-
-mkCoAlgCaseMatchResult var match_alts
+mkCoAlgCaseMatchResult var ty match_alts
| isNewTyCon tycon -- Newtype case; use a let
- = ASSERT( null (tail match_alts) && null (tail arg_ids) )
- mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result
+ = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
+ mkCoLetsMatchResult [NonRec arg_id1 newtype_rhs] match_result1
| isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
= MatchResult CanFail mk_parrCase
| otherwise -- Datatype case; use a case
= MatchResult fail_flag mk_case
where
- -- Common stuff
- scrut_ty = idType var
- tycon = tcTyConAppTyCon scrut_ty -- Newtypes must be opaque here
+ tycon = dataConTyCon con1
+ -- [Interesting: becuase of GADTs, we can't rely on the type of
+ -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
-- Stuff for newtype
- (_, arg_ids, match_result) = head match_alts
- arg_id = head arg_ids
- newtype_rhs = mkNewTypeBody tycon (idType arg_id) (Var var)
+ (con1, arg_ids1, match_result1) = head match_alts
+ arg_id1 = head arg_ids1
+ newtype_rhs = mkNewTypeBody tycon (idType arg_id1) (Var var)
-- Stuff for data types
data_cons = tyConDataCons tycon
wild_var = mkWildId (idType var)
mk_case fail = mappM (mk_alt fail) match_alts `thenDs` \ alts ->
- returnDs (Case (Var var) wild_var (mk_default fail ++ alts))
+ returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts))
mk_alt fail (con, args, MatchResult _ body_fn)
= body_fn fail `thenDs` \ body ->
mk_parrCase fail =
dsLookupGlobalId lengthPName `thenDs` \lengthP ->
unboxAlt `thenDs` \alt ->
- returnDs (Case (len lengthP) (mkWildId intTy) [alt])
+ returnDs (Case (len lengthP) (mkWildId intTy) ty [alt])
where
elemTy = case splitTyConApp (idType var) of
(_, [elemTy]) -> elemTy
newSysLocalDs intPrimTy `thenDs` \l ->
dsLookupGlobalId indexPName `thenDs` \indexP ->
mappM (mkAlt indexP) match_alts `thenDs` \alts ->
- returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts)))
+ returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
where
wild = mkWildId intPrimTy
dft = (DEFAULT, [], fail)
= getSrcSpanDs `thenDs` \ src_loc ->
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
- core_msg = Lit (MachStr (mkFastString (stringToUtf8 full_msg)))
+ core_msg = Lit (mkStringLit full_msg)
in
returnDs (mkApps (Var err_id) [Type ty, core_msg])
\end{code}
%************************************************************************
\begin{code}
-mkCharExpr :: Char -> CoreExpr -- Returns C# c :: Int
-mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int
-mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer
-mkStringLit :: String -> DsM CoreExpr -- Result :: String
-mkStringLitFS :: FastString -> DsM CoreExpr -- Result :: String
+mkCharExpr :: Char -> CoreExpr -- Returns C# c :: Int
+mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int
+mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer
+mkStringExpr :: String -> DsM CoreExpr -- Result :: String
+mkStringExprFS :: FastString -> DsM CoreExpr -- Result :: String
mkIntExpr i = mkConApp intDataCon [mkIntLit i]
mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]
-mkStringLit str = mkStringLitFS (mkFastString str)
+mkStringExpr str = mkStringExprFS (mkFastString str)
-mkStringLitFS str
+mkStringExprFS str
| nullFastString str
= returnDs (mkNilExpr charTy)
is_simple_lpat p = is_simple_pat (unLoc p)
- is_simple_pat (TuplePat ps Boxed) = all is_triv_lpat ps
- is_simple_pat (ConPatOut _ ps _ _ _) = all is_triv_lpat (hsConArgs ps)
- is_simple_pat (VarPat _) = True
- is_simple_pat (ParPat p) = is_simple_lpat p
- is_simple_pat other = False
+ is_simple_pat (TuplePat ps Boxed) = all is_triv_lpat ps
+ is_simple_pat (ConPatOut _ _ _ _ ps _) = all is_triv_lpat (hsConArgs ps)
+ is_simple_pat (VarPat _) = True
+ is_simple_pat (ParPat p) = is_simple_lpat p
+ is_simple_pat other = False
is_triv_lpat p = is_triv_pat (unLoc p)
mkSmallTupleCase [var] body _scrut_var scrut
= bindNonRec var scrut body
mkSmallTupleCase vars body scrut_var scrut
- = Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
+-- gaw 2004
+-- One branch no refinement?
+ = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
\end{code}
%************************************************************************
mkCoreSel vars the_var scrut_var scrut
= ASSERT( notNull vars )
- Case scrut scrut_var
+-- gaw 2004
+ Case scrut scrut_var (idType the_var)
[(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
\end{code}
module Match where
match :: [Var.Id]
+ -> TcType.TcType
-> [DsUtils.EquationInfo]
-> DsMonad.DsM DsUtils.MatchResult
-matchExport
- :: [Var.Id]
- -> [DsUtils.EquationInfo]
- -> DsMonad.DsM DsUtils.MatchResult
+matchWrapper
+ :: HsExpr.HsMatchContext Name.Name
+ -> HsExpr.MatchGroup Var.Id
+ -> DsMonad.DsM ([Var.Id], CoreSyn.CoreExpr)
matchSimply
:: CoreSyn.CoreExpr
:: CoreSyn.CoreExpr
-> DsMonad.DsMatchContext
-> HsPat.LPat Var.Id
+ -> TcType.TcType
-> DsUtils.MatchResult
-> DsMonad.DsM DsUtils.MatchResult
\section[Main_match]{The @match@ function}
\begin{code}
-module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) where
+module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr( dsExpr )
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
import TcHsSyn ( hsPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
-import CoreUtils ( bindNonRec )
+import CoreUtils ( bindNonRec, exprType )
import DsMonad
+import DsBinds ( dsHsNestedBinds )
import DsGRHSs ( dsGRHSs )
import DsUtils
-import Id ( idType, recordSelectorFieldLabel, Id )
-import DataCon ( dataConFieldLabels, dataConInstOrigArgTys )
+import Id ( idName, idType, Id )
+import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon )
import MatchCon ( matchConFamily )
-import MatchLit ( matchLiterals )
+import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
import PrelInfo ( pAT_ERROR_ID )
-import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
+import TcType ( Type, tcTyConAppArgs )
+import Type ( splitFunTysN )
import TysWiredIn ( consDataCon, mkTupleTy, mkListTy,
tupleCon, parrFakeCon, mkPArrTy )
import BasicTypes ( Boxity(..) )
-import UniqSet
+import ListSetOps ( runs )
import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) )
-import Util ( lengthExceeds, isSingleton, notNull )
+import Util ( lengthExceeds, notNull )
import Name ( Name )
import Outputable
\end{code}
JJCQ 30-Nov-1997
\begin{code}
-matchExport :: [Id] -- Vars rep'ing the exprs we're matching with
+matchCheck :: DsMatchContext
+ -> [Id] -- Vars rep'ing the exprs we're matching with
+ -> Type -- Type of the case expression
-> [EquationInfo] -- Info about patterns, etc. (type synonym below)
-> DsM MatchResult -- Desugared result!
-
-matchExport vars qs
+matchCheck ctx vars ty qs
= getDOptsDs `thenDs` \ dflags ->
- matchExport_really dflags vars qs
+ matchCheck_really dflags ctx vars ty qs
-matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
+matchCheck_really dflags ctx vars ty qs
| incomplete && shadow =
dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
dsIncompleteWarn ctx pats `thenDs` \ () ->
- match vars qs
+ match vars ty qs
| incomplete =
dsIncompleteWarn ctx pats `thenDs` \ () ->
- match vars qs
+ match vars ty qs
| shadow =
dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
- match vars qs
+ match vars ty qs
| otherwise =
- match vars qs
- where (pats,indexs) = check qs
+ match vars ty qs
+ where (pats, eqns_shadow) = check qs
incomplete = dopt Opt_WarnIncompletePatterns dflags
&& (notNull pats)
shadow = dopt Opt_WarnOverlappingPatterns dflags
- && sizeUniqSet indexs < no_eqns
- no_eqns = length qs
- unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs)
- eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns
+ && not (null eqns_shadow)
\end{code}
This variable shows the maximum number of lines of output generated for warnings.
ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
-ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats)
+ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
\end{code}
So, the full type signature:
\begin{code}
match :: [Id] -- Variables rep'ing the exprs we're matching with
+ -> Type -- Type of the case expression
-> [EquationInfo] -- Info about patterns, etc. (type synonym below)
-> DsM MatchResult -- Desugared result!
\end{code}
And gluing the ``success expressions'' together isn't quite so pretty.
\begin{code}
-match [] eqns_info
- = returnDs (foldr1 combineMatchResults match_results)
+match [] ty eqns_info
+ = ASSERT( not (null eqns_info) )
+ returnDs (foldr1 combineMatchResults match_results)
where
- match_results = [ ASSERT( null pats) mr
- | EqnInfo _ _ pats mr <- eqns_info ]
+ match_results = [ ASSERT( null (eqn_pats eqn) )
+ eqn_rhs eqn
+ | eqn <- eqns_info ]
\end{code}
corresponds roughly to @matchVarCon@.
\begin{code}
-match vars@(v:vs) eqns_info
- = mappM (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
- let
- tidy_eqns_blks = unmix_eqns tidy_eqns_info
- in
- mappM (matchEqnBlock vars) tidy_eqns_blks `thenDs` \ match_results ->
- returnDs (foldr1 combineMatchResults match_results)
+match vars@(v:_) ty eqns_info
+ = do { tidy_eqns <- mappM (tidyEqnInfo v) eqns_info
+ ; let eqns_blks = runs same_family tidy_eqns
+ ; match_results <- mappM match_block eqns_blks
+ ; ASSERT( not (null match_results) )
+ return (foldr1 combineMatchResults match_results) }
where
- unmix_eqns [] = []
- unmix_eqns [eqn] = [ [eqn] ]
- unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
- = if ( (isWildPat p1 && isWildPat p2)
- || (isConPat p1 && isConPat p2)
- || (isLitPat p1 && isLitPat p2) ) then
- eq1 `tack_onto` unmixed_rest
- else
- [ eq1 ] : unmixed_rest
- where
- unmixed_rest = unmix_eqns (eq2:eqs)
-
- x `tack_onto` xss = ( x : head xss) : tail xss
+ same_family eqn1 eqn2
+ = samePatFamily (firstPat eqn1) (firstPat eqn2)
+
+ match_block eqns
+ = case firstPat (head eqns) of
+ WildPat {} -> matchVariables vars ty eqns
+ ConPatOut {} -> matchConFamily vars ty eqns
+ NPlusKPatOut {} -> matchNPlusKPats vars ty eqns
+ NPatOut {} -> matchNPats vars ty eqns
+ LitPat {} -> matchLiterals vars ty eqns
+
+-- After tidying, there are only five kinds of patterns
+samePatFamily (WildPat {}) (WildPat {}) = True
+samePatFamily (ConPatOut {}) (ConPatOut {}) = True
+samePatFamily (NPlusKPatOut {}) (NPlusKPatOut {}) = True
+samePatFamily (NPatOut {}) (NPatOut {}) = True
+samePatFamily (LitPat {}) (LitPat {}) = True
+samePatFamily _ _ = False
+
+matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Real true variables, just like in matchVar, SLPJ p 94
+-- No binding to do: they'll all be wildcards by now (done in tidy)
+matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns)
+\end{code}
+
+
\end{code}
Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
\begin{code}
tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
- -- DsM'd because of internal call to "match".
+ -- DsM'd because of internal call to dsHsNestedBinds
+ -- and mkSelectorBinds.
-- "tidy1" does the interesting stuff, looking at
-- one pattern and fiddling the list of bindings.
--
-- NPat
-- LitPat
-- NPlusKPat
- -- SigPat
-- but no other
-tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
- = tidy1 v pat match_result `thenDs` \ (pat', match_result') ->
- returnDs (EqnInfo n ctx (pat' : pats) match_result')
-
+tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_rhs = rhs })
+ = tidy1 v pat rhs `thenDs` \ (pat', rhs') ->
+ returnDs (eqn { eqn_pats = pat' : pats, eqn_rhs = rhs' })
tidy1 :: Id -- The Id being scrutinised
-> Pat Id -- The pattern against which it is to be matched
- -> MatchResult -- Current thing do do after matching
+ -> MatchResult -- What to do afterwards
-> DsM (Pat Id, -- Equivalent pattern
- MatchResult) -- Augmented thing to do afterwards
- -- The augmentation usually takes the form
- -- of new bindings to be added to the front
+ MatchResult) -- Extra bindings around what to do afterwards
+
+-- The extra bindings etc are all wrapped around the RHS of the match
+-- so they are only available when matching is complete. But that's ok
+-- becuase, for example, in the pattern x@(...), the x can only be
+-- used in the RHS, not in the nested pattern, nor subsquent patterns
+--
+-- However this does have an awkward consequence. The bindings in
+-- a VarPatOut get wrapped around the result in right to left order,
+-- rather than left to right. This only matters if one set of
+-- bindings can mention things used in another, and that can happen
+-- if we allow equality dictionary bindings of form d1=d2.
+-- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart.
+-- (Without this care in bindInstsOfLocalFuns, compiling
+-- Data.Generics.Schemes.hs fails in function everywhereBut.)
-------------------------------------------------------
-- (pat', mr') = tidy1 v pat mr
-- It eliminates many pattern forms (as-patterns, variable patterns,
-- list patterns, etc) yielding one of:
-- WildPat
--- ConPat
+-- ConPatOut
-- LitPat
-- NPat
-- NPlusKPat
---
-tidy1 v (ParPat pat) match_result
- = tidy1 v (unLoc pat) match_result
+tidy1 v (ParPat pat) wrap = tidy1 v (unLoc pat) wrap
+tidy1 v (SigPatOut pat _) wrap = tidy1 v (unLoc pat) wrap
+tidy1 v (WildPat ty) wrap = returnDs (WildPat ty, wrap)
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
-tidy1 v (VarPat var) match_result
- = returnDs (WildPat (idType var), match_result')
- where
- match_result' | v == var = match_result
- | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
+tidy1 v (VarPat var) rhs
+ = returnDs (WildPat (idType var), bindOneInMatchResult var v rhs)
+
+tidy1 v (VarPatOut var binds) rhs
+ = do { prs <- dsHsNestedBinds binds
+ ; return (WildPat (idType var),
+ bindOneInMatchResult var v $
+ mkCoLetMatchResult (Rec prs) rhs) }
-- case v of { x@p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
-tidy1 v (AsPat (L _ var) pat) match_result
- = tidy1 v (unLoc pat) match_result'
- where
- match_result' | v == var = match_result
- | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
+tidy1 v (AsPat (L _ var) pat) rhs
+ = tidy1 v (unLoc pat) (bindOneInMatchResult var v rhs)
-tidy1 v (WildPat ty) match_result
- = returnDs (WildPat ty, match_result)
{- now, here we handle lazy patterns:
tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
-}
-tidy1 v (LazyPat pat) match_result
- = mkSelectorBinds pat (Var v) `thenDs` \ sel_binds ->
- returnDs (WildPat (idType v),
- mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
+tidy1 v (LazyPat pat) rhs
+ = do { v' <- newSysLocalDs (idType v)
+ ; sel_prs <- mkSelectorBinds pat (Var v)
+ ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
+ ; returnDs (WildPat (idType v),
+ bindOneInMatchResult v' v $
+ mkCoLetsMatchResult sel_binds rhs) }
-- re-express <con-something> as (ConPat ...) [directly]
-tidy1 v (ConPatOut con ps pat_ty ex_tvs dicts) match_result
- = returnDs (ConPatOut con tidy_ps pat_ty ex_tvs dicts, match_result)
+tidy1 v (ConPatOut con ex_tvs dicts binds ps pat_ty) rhs
+ = returnDs (ConPatOut con ex_tvs dicts binds tidy_ps pat_ty, rhs)
where
- tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps)
+ tidy_ps = PrefixCon (tidy_con con pat_ty ps)
-tidy1 v (ListPat pats ty) match_result
- = returnDs (unLoc list_ConPat, match_result)
+tidy1 v (ListPat pats ty) rhs
+ = returnDs (unLoc list_ConPat, rhs)
where
list_ty = mkListTy ty
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
(mkNilPat list_ty)
pats
--- introduce fake parallel array constructors to be able to handle parallel
+-- Introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
---
-tidy1 v (PArrPat pats ty) match_result
- = returnDs (unLoc parrConPat, match_result)
+tidy1 v (PArrPat pats ty) rhs
+ = returnDs (unLoc parrConPat, rhs)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
-tidy1 v (TuplePat pats boxity) match_result
- = returnDs (unLoc tuple_ConPat, match_result)
+tidy1 v (TuplePat pats boxity) rhs
+ = returnDs (unLoc tuple_ConPat, rhs)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
(mkTupleTy boxity arity (map hsPatType pats))
-tidy1 v (DictPat dicts methods) match_result
+tidy1 v (DictPat dicts methods) rhs
= case num_of_d_and_ms of
- 0 -> tidy1 v (TuplePat [] Boxed) match_result
- 1 -> tidy1 v (unLoc (head dict_and_method_pats)) match_result
- _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result
+ 0 -> tidy1 v (TuplePat [] Boxed) rhs
+ 1 -> tidy1 v (unLoc (head dict_and_method_pats)) rhs
+ _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) rhs
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map nlVarPat (dicts ++ methods)
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 v pat@(LitPat lit) match_result
- = returnDs (unLoc (tidyLitPat lit (noLoc pat)), match_result)
+tidy1 v pat@(LitPat lit) rhs
+ = returnDs (unLoc (tidyLitPat lit (noLoc pat)), rhs)
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 v pat@(NPatOut lit lit_ty _) match_result
- = returnDs (unLoc (tidyNPat lit lit_ty (noLoc pat)), match_result)
+tidy1 v pat@(NPatOut lit lit_ty _) rhs
+ = returnDs (unLoc (tidyNPat lit lit_ty (noLoc pat)), rhs)
-- and everything else goes through unchanged...
-tidy1 v non_interesting_pat match_result
- = returnDs (non_interesting_pat, match_result)
+tidy1 v non_interesting_pat rhs
+ = returnDs (non_interesting_pat, rhs)
-tidy_con data_con pat_ty ex_tvs (PrefixCon ps) = ps
-tidy_con data_con pat_ty ex_tvs (InfixCon p1 p2) = [p1,p2]
-tidy_con data_con pat_ty ex_tvs (RecCon rpats)
+tidy_con data_con pat_ty (PrefixCon ps) = ps
+tidy_con data_con pat_ty (InfixCon p1 p2) = [p1,p2]
+tidy_con data_con pat_ty (RecCon rpats)
| null rpats
= -- Special case for C {}, which can be used for
-- a constructor that isn't declared to have
-- fields at all
- map (noLoc.WildPat) con_arg_tys'
+ map (noLoc . WildPat) con_arg_tys'
| otherwise
- = map mk_pat tagged_arg_tys
+ = ASSERT( isVanillaDataCon data_con )
+ -- We're in a record case, so the data con must be vanilla
+ -- and hence no existentials to worry about
+ map mk_pat tagged_arg_tys
where
-- Boring stuff to find the arg-tys of the constructor
+
inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque
- con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
- tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
+ con_arg_tys' = dataConInstOrigArgTys data_con inst_tys
+ tagged_arg_tys = con_arg_tys' `zip` dataConFieldLabels data_con
-- mk_pat picks a WildPat of the appropriate type for absent fields,
-- and the specified pattern for present fields
mk_pat (arg_ty, lbl) =
- case [ pat | (sel_id,pat) <- rpats,
- recordSelectorFieldLabel (unLoc sel_id) == lbl
- ] of
- (pat:pats) -> ASSERT( null pats )
- pat
+ case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of
+ (pat:pats) -> ASSERT( null pats ) pat
[] -> noLoc (WildPat arg_ty)
\end{code}
%************************************************************************
%* *
-%* match on an unmixed block: the real business *
-%* *
-%************************************************************************
-\subsection[matchEqnBlock]{@matchEqnBlock@: getting down to business}
-
-The function @matchEqnBlock@ is where the matching stuff sets to
-work a block of equations, to which the mixture rule has been applied.
-Its arguments and results are the same as for the ``top-level'' @match@.
-
-\begin{code}
-matchEqnBlock :: [Id]
- -> [EquationInfo]
- -> DsM MatchResult
-
-matchEqnBlock [] _ = panic "matchEqnBlock: no names"
-
-matchEqnBlock all_vars@(var:vars) eqns_info
- | isWildPat first_pat
- = ASSERT( all isWildPat column_1_pats ) -- Sanity check
- -- Real true variables, just like in matchVar, SLPJ p 94
- -- No binding to do: they'll all be wildcards by now (done in tidy)
- match vars remaining_eqns_info
-
- | isConPat first_pat
- = ASSERT( patsAreAllCons column_1_pats )
- matchConFamily all_vars eqns_info
-
- | isLitPat first_pat
- = ASSERT( patsAreAllLits column_1_pats )
- -- see notes in MatchLiteral
- -- not worried about the same literal more than once in a column
- -- (ToDo: sort this out later)
- matchLiterals all_vars eqns_info
-
- | isSigPat first_pat
- = ASSERT( isSingleton eqns_info )
- matchSigPat all_vars (head eqns_info)
- where
- first_pat = head column_1_pats
- column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
- remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
-\end{code}
-
-A SigPat is a type coercion and must be handled one at at time. We can't
-combine them unless the type of the pattern inside is identical, and we don't
-bother to check for that. For example:
-
- data T = T1 Int | T2 Bool
- f :: (forall a. a -> a) -> T -> t
- f (g::Int->Int) (T1 i) = T1 (g i)
- f (g::Bool->Bool) (T2 b) = T2 (g b)
-
-We desugar this as follows:
-
- f = \ g::(forall a. a->a) t::T ->
- let gi = g Int
- in case t of { T1 i -> T1 (gi i)
- other ->
- let gb = g Bool
- in case t of { T2 b -> T2 (gb b)
- other -> fail }}
-
-Note that we do not treat the first column of patterns as a
-column of variables, because the coerced variables (gi, gb)
-would be of different types. So we get rather grotty code.
-But I don't think this is a common case, and if it was we could
-doubtless improve it.
-
-Meanwhile, the strategy is:
- * treat each SigPat coercion (always non-identity coercions)
- as a separate block
- * deal with the stuff inside, and then wrap a binding round
- the result to bind the new variable (gi, gb, etc)
-
-\begin{code}
-matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult
-matchSigPat (var:vars) (EqnInfo n ctx (SigPatOut pat ty co_fn : pats) result)
- = selectMatchVarL pat `thenDs` \ new_var ->
- dsExpr (HsApp (noLoc co_fn) (nlHsVar var)) `thenDs` \ rhs ->
- match (new_var:vars) [EqnInfo n ctx (unLoc pat:pats) result] `thenDs` \ result' ->
- returnDs (adjustMatchResult (bindNonRec new_var rhs) result')
-\end{code}
-
-%************************************************************************
-%* *
%* matchWrapper: a convenient way to call @match@ *
%* *
%************************************************************************
\begin{code}
matchWrapper :: HsMatchContext Name -- For shadowing warning messages
- -> [LMatch Id] -- Matches being desugared
+ -> MatchGroup Id -- Matches being desugared
-> DsM ([Id], CoreExpr) -- Results
\end{code}
JJQC 30-Nov-1997
\begin{code}
-matchWrapper ctxt matches
- = getDOptsDs `thenDs` \ dflags ->
- flattenMatches ctxt matches `thenDs` \ (result_ty, eqns_info) ->
- let
- EqnInfo _ _ arg_pats _ : _ = eqns_info
- error_string = matchContextErrString ctxt
- in
- mappM selectMatchVar arg_pats `thenDs` \ new_vars ->
- match_fun dflags new_vars eqns_info `thenDs` \ match_result ->
-
- mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
- extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
- returnDs (new_vars, result_expr)
- where match_fun dflags
- = case ctxt of
- LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport
- | otherwise -> match
- _ -> matchExport
+matchWrapper ctxt (MatchGroup matches match_ty)
+ = do { eqns_info <- mapM mk_eqn_info matches
+ ; dflags <- getDOptsDs
+ ; locn <- getSrcSpanDs
+ ; let ds_ctxt = DsMatchContext ctxt arg_pats locn
+ error_string = matchContextErrString ctxt
+
+ ; new_vars <- selectMatchVars arg_pats pat_tys
+ ; match_result <- match_fun dflags ds_ctxt new_vars rhs_ty eqns_info
+
+ ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+ ; result_expr <- extractMatchResult match_result fail_expr
+ ; return (new_vars, result_expr) }
+ where
+ arg_pats = map unLoc (hsLMatchPats (head matches))
+ n_pats = length arg_pats
+ (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty
+
+ mk_eqn_info (L _ (Match pats _ grhss))
+ = do { let upats = map unLoc pats
+ ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
+ ; return (EqnInfo { eqn_pats = upats,
+ eqn_rhs = match_result}) }
+
+ match_fun dflags ds_ctxt
+ = case ctxt of
+ LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
+ | otherwise -> match
+ _ -> matchCheck ds_ctxt
\end{code}
%************************************************************************
let
ctx = DsMatchContext kind [unLoc pat] locn
match_result = cantFailMatchResult result_expr
+ rhs_ty = exprType fail_expr
+ -- Use exprType of fail_expr, because won't refine in the case of failure!
in
- matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' ->
+ matchSinglePat scrut ctx pat rhs_ty match_result `thenDs` \ match_result' ->
extractMatchResult match_result' fail_expr
matchSinglePat :: CoreExpr -> DsMatchContext -> LPat Id
- -> MatchResult -> DsM MatchResult
-
-matchSinglePat (Var var) ctx pat match_result
+ -> Type -> MatchResult -> DsM MatchResult
+matchSinglePat (Var var) ctx pat ty match_result
= getDOptsDs `thenDs` \ dflags ->
- match_fn dflags [var] [EqnInfo 1 ctx [unLoc pat] match_result]
+ match_fn dflags [var] ty [EqnInfo { eqn_pats = [unLoc pat],
+ eqn_rhs = match_result }]
where
match_fn dflags
- | dopt Opt_WarnSimplePatterns dflags = matchExport
+ | dopt Opt_WarnSimplePatterns dflags = matchCheck ctx
| otherwise = match
-matchSinglePat scrut ctx pat match_result
- = selectMatchVarL pat `thenDs` \ var ->
- matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' ->
+matchSinglePat scrut ctx pat ty match_result
+ = selectSimpleMatchVarL pat `thenDs` \ var ->
+ matchSinglePat (Var var) ctx pat ty match_result `thenDs` \ match_result' ->
returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
\end{code}
-%************************************************************************
-%* *
-%* flattenMatches : create a list of EquationInfo *
-%* *
-%************************************************************************
-
-\subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
-
-This is actually local to @matchWrapper@.
-
-\begin{code}
-flattenMatches :: HsMatchContext Name
- -> [LMatch Id]
- -> DsM (Type, [EquationInfo])
-
-flattenMatches kind matches
- = mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) ->
- let
- result_ty = head result_tys
- in
- ASSERT( all (tcEqType result_ty) result_tys )
- returnDs (result_ty, eqn_infos)
- where
- flatten_match (L _ (Match pats _ grhss), n)
- = dsGRHSs kind upats grhss `thenDs` \ (ty, match_result) ->
- getSrcSpanDs `thenDs` \ locn ->
- returnDs (ty, EqnInfo n (DsMatchContext kind upats locn) upats match_result)
- where upats = map unLoc pats
-\end{code}
import {-# SOURCE #-} Match ( match )
-import HsSyn ( Pat(..), HsConDetails(..) )
-
+import HsSyn ( Pat(..), HsConDetails(..), isEmptyLHsBinds )
+import DsBinds ( dsHsNestedBinds )
+import DataCon ( isVanillaDataCon, dataConTyVars, dataConOrigArgTys )
+import TcType ( tcTyConAppArgs )
+import Type ( substTys, zipTopTvSubst, mkTyVarTys )
+import CoreSyn
import DsMonad
import DsUtils
import Id ( Id )
-import Subst ( mkSubst, mkInScopeSet, bindSubst, substExpr )
-import CoreFVs ( exprFreeVars )
-import VarEnv ( emptySubstEnv )
+import Type ( Type )
import ListSetOps ( equivClassesByUniq )
import SrcLoc ( unLoc )
import Unique ( Uniquable(..) )
+import Outputable
\end{code}
We are confronted with the first column of patterns in a set of
@match_cons_used@ does all the real work.
\begin{code}
matchConFamily :: [Id]
+ -> Type
-> [EquationInfo]
-> DsM MatchResult
-
-matchConFamily (var:vars) eqns_info
+matchConFamily (var:vars) ty eqns_info
= let
-- Sort into equivalence classes by the unique on the constructor
-- All the EqnInfos should start with a ConPat
eqn_groups = equivClassesByUniq get_uniq eqns_info
- get_uniq (EqnInfo _ _ (ConPatOut data_con _ _ _ _ : _) _) = getUnique data_con
+ get_uniq (EqnInfo { eqn_pats = ConPatOut data_con _ _ _ _ _ : _}) = getUnique data_con
in
-- Now make a case alternative out of each group
- mappM (match_con vars) eqn_groups `thenDs` \ alts ->
-
- returnDs (mkCoAlgCaseMatchResult var alts)
+ mappM (match_con vars ty) eqn_groups `thenDs` \ alts ->
+ returnDs (mkCoAlgCaseMatchResult var ty alts)
\end{code}
And here is the local function that does all the work. It is
more-or-less the @matchCon@/@matchClause@ functions on page~94 in
-Wadler's chapter in SLPJ.
+Wadler's chapter in SLPJ. The function @shift_con_pats@ does what the
+list comprehension in @matchClause@ (SLPJ, p.~94) does, except things
+are trickier in real life. Works for @ConPats@, and we want it to
+fail catastrophically for anything else (which a list comprehension
+wouldn't). Cf.~@shift_lit_pats@ in @MatchLits@.
\begin{code}
-match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_tvs ex_dicts : _) _)
- : other_eqns)
- = -- Make new vars for the con arguments; avoid new locals where possible
- mappM selectMatchVarL arg_pats `thenDs` \ arg_vars ->
-
- -- Now do the business to make the alt for _this_ ConPat ...
- match (arg_vars ++ vars)
- (map shift_con_pat (eqn1:other_eqns)) `thenDs` \ match_result ->
-
- -- [See "notes on do_subst" below this function]
- -- Make the ex_tvs and ex_dicts line up with those
- -- in the first pattern. Remember, they are all guaranteed to be variables
- let
- match_result' | null ex_tvs = match_result
- | null other_eqns = match_result
- | otherwise = adjustMatchResult do_subst match_result
- in
+match_con vars ty eqns
+ = do { -- Make new vars for the con arguments; avoid new locals where possible
+ arg_vars <- selectMatchVars (map unLoc arg_pats1) arg_tys
+
+ ; match_result <- match (arg_vars ++ vars) ty (shiftEqns eqns)
+
+ ; binds <- mapM ds_binds [ bind | ConPatOut _ _ _ bind _ _ <- pats,
+ not (isEmptyLHsBinds bind) ]
+
+ ; let match_result' = bindInMatchResult (line_up other_pats) $
+ mkCoLetsMatchResult binds match_result
- returnDs (data_con, ex_tvs ++ ex_dicts ++ arg_vars, match_result')
+ ; return (data_con, tvs1 ++ dicts1 ++ arg_vars, match_result') }
where
- shift_con_pat :: EquationInfo -> EquationInfo
- shift_con_pat (EqnInfo n ctx (ConPatOut _ (PrefixCon arg_pats) _ _ _ : pats) match_result)
- = EqnInfo n ctx (map unLoc arg_pats ++ pats) match_result
-
- other_pats = [p | EqnInfo _ _ (p:_) _ <- other_eqns]
-
- var_prs = concat [ (ex_tvs' `zip` ex_tvs) ++
- (ex_dicts' `zip` ex_dicts)
- | ConPatOut _ _ _ ex_tvs' ex_dicts' <- other_pats ]
-
- do_subst e = substExpr subst e
- where
- subst = foldl (\ s (v', v) -> bindSubst s v' v) in_scope var_prs
- in_scope = mkSubst (mkInScopeSet (exprFreeVars e)) emptySubstEnv
- -- We put all the free variables of e into the in-scope
- -- set of the substitution, not because it is necessary,
- -- but to suppress the warning in Subst.lookupInScope
- -- Tiresome, but doing the substitution at all is rare.
+ pats@(pat1 : other_pats) = map firstPat eqns
+ ConPatOut data_con tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = pat1
+
+ ds_binds bind = do { prs <- dsHsNestedBinds bind; return (Rec prs) }
+
+ line_up pats
+ | null tvs1 && null dicts1 = [] -- Common case
+ | otherwise = [ pr | ConPatOut _ ts ds _ _ _ <- pats,
+ pr <- (ts `zip` tvs1) ++ (ds `zip` dicts1)]
+
+ -- Get the arg types, which we use to type the new vars
+ -- to match on, from the "outside"; the types of pats1 may
+ -- be more refined, and hence won't do
+ arg_tys = substTys (zipTopTvSubst (dataConTyVars data_con) inst_tys)
+ (dataConOrigArgTys data_con)
+ inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes opaque!
+ | otherwise = mkTyVarTys tvs1
\end{code}
-Note on @shift_con_pats@ just above: does what the list comprehension in
-@matchClause@ (SLPJ, p.~94) does, except things are trickier in real
-life. Works for @ConPats@, and we want it to fail catastrophically
-for anything else (which a list comprehension wouldn't).
-Cf.~@shift_lit_pats@ in @MatchLits@.
-
-
-Notes on do_subst stuff
-~~~~~~~~~~~~~~~~~~~~~~~
+Note [Existentials in shift_con_pat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = forall a. Ord a => T a (a->Int)
When we put in the tyvars etc we get
f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1...
- f (T b (e::Ord a) (y::a) (g::a->Int)) True = ...expr2...
+ f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2...
After desugaring etc we'll get a single case:
False -> ...expr2...
*** We have to substitute [a/b, d/e] in expr2! **
-That is what do_subst is doing.
+Hence
+ False -> ....((/\b\(e:Ord b).expr2) a d)....
Originally I tried to use
(\b -> let e = d in expr2) a
to do this substitution. While this is "correct" in a way, it fails
Lint, because e::Ord b but d::Ord a.
-So now I simply do the substitution properly using substExpr.
-
\section[MatchLit]{Pattern-matching literal patterns}
\begin{code}
-module MatchLit ( dsLit, matchLiterals ) where
+module MatchLit ( dsLit, tidyLitPat, tidyNPat,
+ matchLiterals, matchNPlusKPats, matchNPats ) where
#include "HsVersions.h"
import Id ( Id )
import CoreSyn
import TyCon ( tyConDataCons )
-import TcType ( tcSplitTyConApp, isIntegerTy )
+import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy, isFloatTy, isDoubleTy )
+import Type ( Type )
import PrelNames ( ratioTyConKey )
+import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
import Unique ( hasKey )
import Literal ( mkMachInt, Literal(..) )
-import Maybes ( catMaybes )
-import SrcLoc ( noLoc, Located(..), unLoc )
-import Panic ( panic, assertPanic )
+import SrcLoc ( noLoc, unLoc )
+import ListSetOps ( equivClasses, runs )
import Ratio ( numerator, denominator )
+import SrcLoc ( Located(..) )
import Outputable
+import FastString ( lengthFS, unpackFS )
\end{code}
%************************************************************************
dsLit :: HsLit -> DsM CoreExpr
dsLit (HsChar c) = returnDs (mkCharExpr c)
dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
-dsLit (HsString str) = mkStringLitFS str
+dsLit (HsString str) = mkStringExprFS str
dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
dsLit (HsInteger i _) = mkIntegerExpr i
dsLit (HsInt i) = returnDs (mkIntExpr i)
%************************************************************************
%* *
- Pattern matching on literals
+ Tidying lit pats
%* *
%************************************************************************
\begin{code}
-matchLiterals :: [Id]
- -> [EquationInfo]
- -> DsM MatchResult
+tidyLitPat :: HsLit -> LPat Id -> LPat Id
+-- Result has only the following HsLits:
+-- HsIntPrim, HsCharPrim, HsFloatPrim
+-- HsDoublePrim, HsStringPrim ?
+-- * HsInteger, HsRat, HsInt can't show up in LitPats,
+-- * HsString has been turned into an NPat in tcPat
+-- and we get rid of HsChar right here
+tidyLitPat (HsChar c) pat = mkCharLitPat c
+tidyLitPat lit pat = pat
+
+tidyNPat :: HsLit -> Type -> LPat Id -> LPat Id
+tidyNPat (HsString s) _ pat
+ | lengthFS s <= 1 -- Short string literals only
+ = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
+ (mkNilPat stringTy) (unpackFS s)
+ -- The stringTy is the type of the whole pattern, not
+ -- the type to instantiate (:) or [] with!
+
+tidyNPat lit lit_ty default_pat
+ | isIntTy lit_ty = mkPrefixConPat intDataCon [noLoc $ LitPat (mk_int lit)] lit_ty
+ | isFloatTy lit_ty = mkPrefixConPat floatDataCon [noLoc $ LitPat (mk_float lit)] lit_ty
+ | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [noLoc $ LitPat (mk_double lit)] lit_ty
+ | otherwise = default_pat
+
+ where
+ mk_int (HsInteger i _) = HsIntPrim i
+
+ mk_float (HsInteger i _) = HsFloatPrim (fromInteger i)
+ mk_float (HsRat f _) = HsFloatPrim f
+
+ mk_double (HsInteger i _) = HsDoublePrim (fromInteger i)
+ mk_double (HsRat f _) = HsDoublePrim f
\end{code}
-This first one is a {\em special case} where the literal patterns are
-unboxed numbers (NB: the fiddling introduced by @tidyEqnInfo@). We
-want to avoid using the ``equality'' stuff provided by the
-typechecker, and do a real ``case'' instead. In that sense, the code
-is much like @matchConFamily@, which uses @match_cons_used@ to create
-the alts---here we use @match_prims_used@.
+
+%************************************************************************
+%* *
+ Pattern matching on LitPat
+%* *
+%************************************************************************
\begin{code}
-matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal : ps1) _ : eqns)
- = -- GENERATE THE ALTS
- match_prims_used vars eqns_info `thenDs` \ prim_alts ->
+matchLiterals :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- All the EquationInfos have LitPats at the front
+
+matchLiterals (var:vars) ty eqns
+ = do { -- GROUP BY LITERAL
+ let groups :: [[(Literal, EquationInfo)]]
+ groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
- -- MAKE THE PRIMITIVE CASE
- returnDs (mkCoPrimCaseMatchResult var prim_alts)
+ -- DO THE MATCHING FOR EACH GROUP
+ ; alts <- mapM match_group groups
+
+ -- MAKE THE PRIMITIVE CASE
+ ; return (mkCoPrimCaseMatchResult var ty alts) }
where
- match_prims_used _ [{-no more eqns-}] = returnDs []
-
- match_prims_used vars eqns_info@(EqnInfo n ctx (pat@(LitPat literal):ps1) _ : eqns)
- = let
- (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
- = partitionEqnsByLit pat eqns_info
- in
- -- recursive call to make other alts...
- match_prims_used vars eqns_not_for_this_lit `thenDs` \ rest_of_alts ->
-
- -- (prim pats have no args; no selectMatchVars as in match_cons_used)
- -- now do the business to make the alt for _this_ LitPat ...
- match vars shifted_eqns_for_this_lit `thenDs` \ match_result ->
- returnDs (
- (mk_core_lit literal, match_result)
- : rest_of_alts
- )
- where
- mk_core_lit :: HsLit -> Literal
-
- mk_core_lit (HsIntPrim i) = mkMachInt i
- mk_core_lit (HsCharPrim c) = MachChar c
- mk_core_lit (HsStringPrim s) = MachStr s
- mk_core_lit (HsFloatPrim f) = MachFloat f
- mk_core_lit (HsDoublePrim d) = MachDouble d
- mk_core_lit other = panic "matchLiterals:mk_core_lit:unhandled"
+ match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult)
+ match_group group
+ = do { let (lits, eqns) = unzip group
+ ; match_result <- match vars ty (shiftEqns eqns)
+ ; return (head lits, match_result) }
\end{code}
+%************************************************************************
+%* *
+ Pattern matching on NPat
+%* *
+%************************************************************************
+
\begin{code}
-matchLiterals all_vars@(var:vars)
- eqns_info@(EqnInfo n ctx (pat@(NPatOut literal lit_ty eq_chk):ps1) _ : eqns)
- = let
- (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
- = partitionEqnsByLit pat eqns_info
- in
- dsExpr (HsApp (noLoc eq_chk) (nlHsVar var)) `thenDs` \ pred_expr ->
- match vars shifted_eqns_for_this_lit `thenDs` \ inner_match_result ->
- let
- match_result1 = mkGuardedMatchResult pred_expr inner_match_result
- in
- if (null eqns_not_for_this_lit)
- then
- returnDs match_result1
- else
- matchLiterals all_vars eqns_not_for_this_lit `thenDs` \ match_result2 ->
- returnDs (combineMatchResults match_result1 match_result2)
+matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- All the EquationInfos have NPatOut at the front
+
+matchNPats (var:vars) ty eqns
+ = do { let groups :: [[(Literal, EquationInfo)]]
+ groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
+
+ ; match_results <- mapM (match_group . map snd) groups
+
+ ; ASSERT( not (null match_results) )
+ return (foldr1 combineMatchResults match_results) }
+ where
+ match_group :: [EquationInfo] -> DsM MatchResult
+ match_group eqns
+ = do { pred_expr <- dsExpr (HsApp (noLoc eq_chk) (nlHsVar var))
+ ; match_result <- match vars ty (shiftEqns eqns)
+ ; return (mkGuardedMatchResult pred_expr match_result) }
+ where
+ NPatOut _ _ eq_chk = firstPat (head eqns)
\end{code}
+
+%************************************************************************
+%* *
+ Pattern matching on n+k patterns
+%* *
+%************************************************************************
+
For an n+k pattern, we use the various magic expressions we've been given.
We generate:
\begin{verbatim}
<try-next-pattern-or-whatever>
\end{verbatim}
+WATCH OUT! Consider
+
+ f (n+1) = ...
+ f (n+2) = ...
+ f (n+1) = ...
+
+We can't group the first and third together, because the second may match
+the same thing as the first. Contrast
+ f 1 = ...
+ f 2 = ...
+ f 1 = ...
+where we can group the first and third. Hence 'runs' rather than 'equivClasses'
\begin{code}
-matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPatOut master_n k ge sub):ps1) _ : eqns)
- = let
- (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
- = partitionEqnsByLit pat eqns_info
- in
- match vars shifted_eqns_for_this_lit `thenDs` \ inner_match_result ->
-
- dsExpr (HsApp (noLoc ge) (nlHsVar var)) `thenDs` \ ge_expr ->
- dsExpr (HsApp (noLoc sub) (nlHsVar var)) `thenDs` \ nminusk_expr ->
-
- let
- match_result1 = mkGuardedMatchResult ge_expr $
- mkCoLetsMatchResult [NonRec (unLoc master_n) nminusk_expr] $
- inner_match_result
- in
- if (null eqns_not_for_this_lit)
- then
- returnDs match_result1
- else
- matchLiterals all_vars eqns_not_for_this_lit `thenDs` \ match_result2 ->
- returnDs (combineMatchResults match_result1 match_result2)
+matchNPlusKPats all_vars@(var:vars) ty eqns
+ = do { let groups :: [[(Literal, EquationInfo)]]
+ groups = runs eqTaggedEqn (tagLitEqns eqns)
+
+ ; match_results <- mapM (match_group . map snd) groups
+
+ ; ASSERT( not (null match_results) )
+ return (foldr1 combineMatchResults match_results) }
+ where
+ match_group :: [EquationInfo] -> DsM MatchResult
+ match_group eqns
+ = do { ge_expr <- dsExpr (HsApp (noLoc ge) (nlHsVar var))
+ ; minusk_expr <- dsExpr (HsApp (noLoc sub) (nlHsVar var))
+ ; match_result <- match vars ty (shiftEqns eqns)
+ ; return (mkGuardedMatchResult ge_expr $
+ mkCoLetsMatchResult [NonRec n1 minusk_expr] $
+ bindInMatchResult (map line_up other_pats) $
+ match_result) }
+ where
+ (NPlusKPatOut (L _ n1) _ ge sub : other_pats) = map firstPat eqns
+ line_up (NPlusKPatOut (L _ n) _ _ _) = (n,n1)
\end{code}
+
+%************************************************************************
+%* *
+ Grouping functions
+%* *
+%************************************************************************
+
Given a blob of @LitPat@s/@NPat@s, we want to split them into those
that are ``same''/different as one we are looking at. We need to know
whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
\begin{code}
-partitionEqnsByLit :: Pat Id
- -> [EquationInfo]
- -> ([EquationInfo], -- These ones are for this lit, AND
- -- they've been "shifted" by stripping
- -- off the first pattern
- [EquationInfo] -- These are not for this lit; they
- -- are exactly as fed in.
- )
-
-partitionEqnsByLit master_pat eqns
- = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys))
- (unzip (map (partition_eqn master_pat) eqns))
+-- Tag equations by the leading literal
+-- NB: we have ordering on Core Literals, but not on HsLits
+cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
+cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
+
+eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
+eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
+
+tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
+tagLitEqns eqns
+ = [(get_lit eqn, eqn) | eqn <- eqns]
where
- partition_eqn :: Pat Id -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo)
-
- partition_eqn (LitPat k1) (EqnInfo n ctx (LitPat k2 : remaining_pats) match_result)
- | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
- -- NB the pattern is stripped off the EquationInfo
-
- partition_eqn (NPatOut k1 _ _) (EqnInfo n ctx (NPatOut k2 _ _ : remaining_pats) match_result)
- | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
- -- NB the pattern is stripped off the EquationInfo
-
- partition_eqn (NPlusKPatOut (L _ master_n) k1 _ _)
- (EqnInfo n ctx (NPlusKPatOut (L _ n') k2 _ _ : remaining_pats) match_result)
- | k1 == k2 = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing)
- -- NB the pattern is stripped off the EquationInfo
- where
- new_match_result | master_n == n' = match_result
- | otherwise = mkCoLetsMatchResult
- [NonRec n' (Var master_n)] match_result
-
- -- Wild-card patterns, which will only show up in the shadows,
- -- go into both groups
- partition_eqn master_pat eqn@(EqnInfo n ctx (WildPat _ : remaining_pats) match_result)
- = (Just (EqnInfo n ctx remaining_pats match_result), Just eqn)
-
- -- Default case; not for this pattern
- partition_eqn master_pat eqn = (Nothing, Just eqn)
+ get_lit eqn = case firstPat eqn of
+ LitPat hs_lit -> mk_core_lit hs_lit
+ NPatOut hs_lit _ _ -> mk_core_lit hs_lit
+ NPlusKPatOut _ i _ _ -> MachInt i
+ other -> panic "tagLitEqns:bad pattern"
+
+mk_core_lit :: HsLit -> Literal
+mk_core_lit (HsIntPrim i) = mkMachInt i
+mk_core_lit (HsCharPrim c) = MachChar c
+mk_core_lit (HsStringPrim s) = MachStr s
+mk_core_lit (HsFloatPrim f) = MachFloat f
+mk_core_lit (HsDoublePrim d) = MachDouble d
+
+ -- These ones are only needed in the NPatOut case,
+ -- and the Literal is only used as a key for grouping,
+ -- so the type doesn't matter. Actually I think HsInt, HsChar
+ -- can't happen, but it does no harm to include them
+mk_core_lit (HsString s) = MachStr s
+mk_core_lit (HsRat r _) = MachFloat r
+mk_core_lit (HsInteger i _) = MachInt i
+mk_core_lit (HsInt i) = MachInt i
+mk_core_lit (HsChar c) = MachChar c
\end{code}
import CoreFVs ( freeVars )
import Type ( isUnLiftedType, splitTyConApp_maybe )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
- isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
+ isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId,
dataConRepArity )
import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons,
isUnboxedTupleTyCon )
schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
- isNullaryDataCon data_con
+ isNullaryRepDataCon data_con
= -- Special case for the worker of a nullary data con.
-- It'll look like this: Nil = /\a -> Nil a
-- If we feed it into schemeR, we'll get
-schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
-- Convert
-- case .... of x { (# VoidArg'd-thing, a #) -> ... }
= --trace "automagic mashing of case alts (# a, VoidArg #)" $
doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
-schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
-- Similarly, convert
-- case .... of x { (# a #) -> ... }
= --trace "automagic mashing of case alts (# a #)" $
doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
-schemeE d s p (AnnCase scrut bndr alts)
+schemeE d s p (AnnCase scrut bndr _ alts)
= doCase d s p scrut bndr alts False{-not an unboxed tuple-}
schemeE d s p (AnnNote note (_, body))
-> BcM BCInstrList
mkConAppCode orig_d s p con [] -- Nullary constructor
- = ASSERT( isNullaryDataCon con )
+ = ASSERT( isNullaryRepDataCon con )
returnBc (unitOL (PUSH_G (getName (dataConWorkId con))))
-- Instead of doing a PACK, which would allocate a fresh
-- copy of this constructor, use the single shared version.
= do_pushes init_d args (map atomRep args)
where
do_pushes d [] reps = do
- ASSERTM( null reps )
+ ASSERT( null reps ) return ()
(push_fn, sz) <- pushAtom d p (AnnVar fn)
- ASSERTM( sz == 1 )
+ ASSERT( sz == 1 ) return ()
returnBc (push_fn `appOL` (
mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
unitOL ENTER))
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.175 2004/08/20 15:02:40 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.176 2004/09/30 10:36:47 simonpj Exp $
--
-- GHC Interactive User Interface
--
= hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
2 (equals <+> ppr mono_ty)
-showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon,
+showDecl want_name (IfaceData {ifName = tycon,
ifTyVars = tyvars, ifCons = condecls})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
2 (add_bars (ppr_trim show_con cs))
where
- show_con (IfaceConDecl con_name is_infix ex_tvs ex_cxt tys strs flds)
+ show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
+ ifConStricts = strs, ifConFields = flds})
| want_name tycon || want_name con_name || any want_name flds
- = Just (pprIfaceForAllPart ex_tvs ex_cxt (show_guts con_name is_infix tys_w_strs flds))
+ = Just (show_guts con_name is_infix tys_w_strs flds)
| otherwise = Nothing
where
tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
+ show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
+ ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
+ | want_name tycon || want_name con_name
+ = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
+ | otherwise = Nothing
+ where
+ tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
+ pp_tau = foldr add pp_res_ty tys_w_strs
+ pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
+ add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
= Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
| otherwise = Nothing
- (pp_nd, cs) = case condecls of
- IfAbstractTyCon -> (ptext SLIT("data"), [])
- IfDataTyCon cs -> (ptext SLIT("data"), cs)
- IfNewTyCon c -> (ptext SLIT("newtype"), [c])
+ (pp_nd, context, cs) = case condecls of
+ IfAbstractTyCon -> (ptext SLIT("data"), [], [])
+ IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs)
+ IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs)
+ IfNewTyCon c -> (ptext SLIT("newtype"), [], [c])
add_bars [] = empty
add_bars [c] = equals <+> c
-> ConDecl (noLoc (cName c)) noExistentials noContext
(InfixCon (mk_arg st1) (mk_arg st2))
where
- mk_arg (IsStrict, ty) = noLoc $ BangType HsStrict (cvtType ty)
- mk_arg (NotStrict, ty) = noLoc $ BangType HsNoBang (cvtType ty)
+ mk_arg (IsStrict, ty) = noLoc $ HsBangTy HsStrict (cvtType ty)
+ mk_arg (NotStrict, ty) = noLoc $ HsBangTy HsNoBang (cvtType ty)
mk_id_arg (i, IsStrict, ty)
- = (noLoc (vName i), noLoc $ BangType HsStrict (cvtType ty))
+ = (noLoc (vName i), noLoc $ HsBangTy HsStrict (cvtType ty))
mk_id_arg (i, NotStrict, ty)
- = (noLoc (vName i), noLoc $ BangType HsNoBang (cvtType ty))
+ = (noLoc (vName i), noLoc $ HsBangTy HsNoBang (cvtType ty))
mk_derivs [] = Nothing
mk_derivs cs = Just [noLoc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
| otherwise = HsLit (cvtLit l)
cvt (AppE x y) = HsApp (cvtl x) (cvtl y)
-cvt (LamE ps e) = HsLam (mkSimpleMatch (map cvtlp ps) (cvtl e) void)
+cvt (LamE ps e) = HsLam (mkMatchGroup [mkSimpleMatch (map cvtlp ps) (cvtl e)])
cvt (TupE [e]) = cvt e
cvt (TupE es) = ExplicitTuple(map cvtl es) Boxed
cvt (CondE x y z) = HsIf (cvtl x) (cvtl y) (cvtl z)
cvt (LetE ds e) = HsLet (cvtdecs ds) (cvtl e)
-cvt (CaseE e ms) = HsCase (cvtl e) (map cvtm ms)
+cvt (CaseE e ms) = HsCase (cvtl e) (mkMatchGroup (map cvtm ms))
cvt (DoE ss) = HsDo DoExpr (cvtstmts ss) [] void
cvt (CompE ss) = HsDo ListComp (cvtstmts ss) [] void
cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd)
-- Used only for declarations in a 'let/where' clause,
-- not for top level decls
cvtd (TH.ValD (TH.VarP s) body ds)
- = noLoc $ FunBind (noLoc (vName s)) False [cvtclause (Clause [] body ds)]
+ = noLoc $ FunBind (noLoc (vName s)) False (mkMatchGroup [cvtclause (Clause [] body ds)])
cvtd (FunD nm cls)
- = noLoc $ FunBind (noLoc (vName nm)) False (map cvtclause cls)
+ = noLoc $ FunBind (noLoc (vName nm)) False (mkMatchGroup (map cvtclause cls))
cvtd (TH.ValD p body ds)
- = noLoc $ PatBind (cvtlp p) (GRHSs (cvtguard body) (cvtdecs ds) void)
+ = noLoc $ PatBind (cvtlp p) (GRHSs (cvtguard body) (cvtdecs ds)) void
cvtd d = cvtPanic "Illegal kind of declaration in where clause"
(text (TH.pprint d))
cvtclause :: TH.Clause -> Hs.LMatch RdrName
cvtclause (Clause ps body wheres)
- = noLoc $ Hs.Match (map cvtlp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)
+ = noLoc $ Hs.Match (map cvtlp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres))
cvtm :: TH.Match -> Hs.LMatch RdrName
cvtm (TH.Match p body wheres)
- = noLoc (Hs.Match [cvtlp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void))
+ = noLoc (Hs.Match [cvtlp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres)))
cvtguard :: TH.Body -> [LGRHS RdrName]
cvtguard (GuardedB pairs) = map cvtpair pairs
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
- LMatch, pprFunBind,
+ MatchGroup, pprFunBind,
GRHSs, pprPatBind )
+import {-# SOURCE #-} HsPat ( LPat )
--- friends:
-import HsPat ( LPat )
-import HsTypes ( LHsType )
-
---others:
+import HsTypes ( LHsType, PostTcType )
import Name ( Name )
import NameSet ( NameSet, elemNameSet, nameSetToList )
import BasicTypes ( IPName, RecFlag(..), Activation(..), Fixity )
import Outputable
import SrcLoc ( Located(..), unLoc )
import Var ( TyVar )
-import Bag ( Bag, bagToList )
+import Bag ( Bag, emptyBag, isEmptyBag, bagToList )
\end{code}
%************************************************************************
-- -----------------------------------------------------------------------------
-type LHsBinds id = Bag (LHsBind id)
-type LHsBind id = Located (HsBind id)
+type LHsBinds id = Bag (LHsBind id)
+type DictBinds id = LHsBinds id -- Used for dictionary or method bindings
+type LHsBind id = Located (HsBind id)
+
+emptyLHsBinds :: LHsBinds id
+emptyLHsBinds = emptyBag
+
+isEmptyLHsBinds :: LHsBinds id -> Bool
+isEmptyLHsBinds = isEmptyBag
pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
-pprLHsBinds binds = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
+pprLHsBinds binds
+ | isEmptyLHsBinds binds = empty
+ | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
data HsBind id
= FunBind (Located id)
-- FunBinds, so if you change this, you'll need to
-- change e.g. rnMethodBinds
Bool -- True => infix declaration
- [LMatch id]
+ (MatchGroup id)
| PatBind (LPat id) -- The pattern is never a simple variable;
-- That case is done by FunBind
(GRHSs id)
+ PostTcType -- Type of the GRHSs
| VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike;
-- located only for consistency
ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
-ppr_monobind (PatBind pat grhss) = pprPatBind pat grhss
+ppr_monobind (PatBind pat grhss ty) = pprPatBind pat grhss
ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs)
ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches
-- ToDo: print infix if appropriate
DefaultDecl(..), LDefaultDecl, HsGroup(..), SpliceDecl(..),
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
- ConDecl(..), LConDecl,
- LBangType, BangType(..), HsBang(..),
- getBangType, getBangStrictness, unbangedType,
+ ConDecl(..), LConDecl,
DeprecDecl(..), LDeprecDecl,
tcdName, tyClDeclNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl,
pp_decl_head context thing tyvars
= hsep [pprHsContext context, ppr thing, interppSP tyvars]
-pp_condecls cs = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
+pp_condecls cs@(L _ (GadtDecl _ _) : _) -- In GADT syntax
+ = hang (ptext SLIT("where")) 2 (vcat (map ppr cs))
+pp_condecls cs -- In H98 syntax
+ = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
pp_tydecl pp_head pp_decl_rhs derivings
= hang pp_head 4 (sep [
[LHsTyVarBndr name] -- Existentially quantified type variables
(LHsContext name) -- ...and context
-- If both are empty then there are no existentials
-
(HsConDetails name (LBangType name))
+
+ | GadtDecl (Located name) -- Constructor name; this is used for the
+ -- DataCon itself, and for the user-callable wrapper Id
+ (LHsType name) -- Constructor type; it may have HsBangs on the
+ -- argument types
\end{code}
\begin{code}
do_one (flds_seen, acc) (ConDecl lname _ _ _)
= (flds_seen, lname:acc)
+-- gaw 2004
+ do_one (flds_seen, acc) (GadtDecl lname _)
+ = (flds_seen, lname:acc)
+
conDetailsTys details = map getBangType (hsConArgs details)
\end{code}
-\begin{code}
-type LBangType name = Located (BangType name)
-
-data BangType name = BangType HsBang (LHsType name)
-
-data HsBang = HsNoBang
- | HsStrict -- !
- | HsUnbox -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
-
-getBangType (BangType _ ty) = ty
-getBangStrictness (BangType s _) = s
-
-unbangedType :: LHsType id -> LBangType id
-unbangedType ty@(L loc _) = L loc (BangType HsNoBang ty)
-\end{code}
\begin{code}
instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr (ConDecl con tvs cxt con_details)
= sep [pprHsForAll Explicit tvs cxt, ppr_con_details con con_details]
+ ppr (GadtDecl con ty)
+ = ppr con <+> dcolon <+> ppr ty
ppr_con_details con (InfixCon ty1 ty2)
- = hsep [ppr ty1, ppr con, ppr ty2]
+ = hsep [ppr ty1, pprHsVar con, ppr ty2]
-- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even
-- if the constructor is an infix one. This is because in an interface file
where
ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty
-instance OutputableBndr name => Outputable (BangType name) where
- ppr (BangType is_strict ty)
- = bang <> pprParendHsType (unLoc ty)
- where
- bang = case is_strict of
- HsNoBang -> empty
- HsStrict -> char '!'
- HsUnbox -> ptext SLIT("!!")
\end{code}
-
%************************************************************************
%* *
\subsection[InstDecl]{An instance declaration
data HsExpr i
data HsSplice i
-data Match a
+data MatchGroup a
data GRHSs a
type LHsExpr a = SrcLoc.Located (HsExpr a)
-type LMatch a = SrcLoc.Located (Match a)
pprExpr :: (Outputable.OutputableBndr i) =>
HsExpr.HsExpr i -> Outputable.SDoc
pprSplice :: (Outputable.OutputableBndr i) =>
HsExpr.HsSplice i -> Outputable.SDoc
-pprPatBind :: (Outputable.OutputableBndr i) =>
- HsPat.LPat i -> HsExpr.GRHSs i -> Outputable.SDoc
+pprPatBind :: (Outputable.OutputableBndr b, Outputable.OutputableBndr i) =>
+ HsPat.LPat b -> HsExpr.GRHSs i -> Outputable.SDoc
pprFunBind :: (Outputable.OutputableBndr i) =>
- i -> [HsExpr.LMatch i] -> Outputable.SDoc
+ i -> HsExpr.MatchGroup i -> Outputable.SDoc
| HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker
| HsLit HsLit -- Simple (non-overloaded) literals
- | HsLam (LMatch id) -- lambda
- | HsApp (LHsExpr id) -- application
+ | HsLam (MatchGroup id) -- Currently always a single match
+
+ | HsApp (LHsExpr id) -- Application
(LHsExpr id)
-- Operator applications:
(LHsExpr id) -- operand
| HsCase (LHsExpr id)
- [LMatch id]
+ (MatchGroup id)
| HsIf (LHsExpr id) -- predicate
(LHsExpr id) -- then part
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
-ppr_expr (HsLam match) = pprMatch LambdaExpr (unLoc match)
-
ppr_expr (HsApp e1 e2)
= let (fun, args) = collect_args e1 [e2] in
(ppr_lexpr fun) <+> (sep (map pprParendExpr args))
pp_infixly v
= parens (sep [ppr v, pp_expr])
+ppr_expr (HsLam matches)
+ = pprMatches LambdaExpr matches
+
ppr_expr (HsCase expr matches)
= sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],
nest 2 (pprMatches CaseAlt matches) ]
patterns in each equation.
\begin{code}
+data MatchGroup id
+ = MatchGroup
+ [LMatch id] -- The alternatives
+ PostTcType -- The type is the type of the entire group
+ -- t1 -> ... -> tn -> tr
+ -- where there are n patterns
+
type LMatch id = Located (Match id)
data Match id
[LPat id] -- The patterns
(Maybe (LHsType id)) -- A type signature for the result of the match
-- Nothing after typechecking
-
(GRHSs id)
+-- gaw 2004
+hsLMatchPats :: LMatch id -> [LPat id]
+hsLMatchPats (L _ (Match pats _ _)) = pats
+
-- GRHSs are used both for pattern bindings and for Matches
data GRHSs id
= GRHSs [LGRHS id] -- Guarded RHSs
[HsBindGroup id] -- The where clause
- PostTcType -- Type of RHS (after type checking)
+-- gaw 2004
+-- PostTcType -- Type of RHS (after type checking)
type LGRHS id = Located (GRHS id)
We know the list must have at least one @Match@ in it.
\begin{code}
-pprMatches :: (OutputableBndr id) => HsMatchContext id -> [LMatch id] -> SDoc
-pprMatches ctxt matches = vcat (map (pprMatch ctxt) (map unLoc matches))
+pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
+pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches))
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (OutputableBndr id) => id -> [LMatch id] -> SDoc
+pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
pprFunBind fun matches = pprMatches (FunRhs fun) matches
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprPatBind :: (OutputableBndr id)
- => LPat id -> GRHSs id -> SDoc
+pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
+ => LPat bndr -> GRHSs id -> SDoc
pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
+-- gaw 2004
pprMatch ctxt (Match pats maybe_ty grhss)
= pp_name ctxt <+> sep [sep (map ppr pats),
- ppr_maybe_ty,
+ ppr_maybe_ty,
nest 2 (pprGRHSs ctxt grhss)]
where
pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will
pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
-pprGRHSs ctxt (GRHSs grhss binds ty)
+-- gaw 2004
+pprGRHSs ctxt (GRHSs grhss binds)
= vcat (map (pprGRHS ctxt . unLoc) grhss)
$$
(if null binds then empty
HsConDetails(..), hsConArgs,
- mkPrefixConPat, mkCharLitPat, mkNilPat,
+ mkPrefixConPat, mkCharLitPat, mkNilPat,
isWildPat,
patsAreAllCons, isConPat, isSigPat,
- patsAreAllLits, isLitPat,
- collectPatBinders, collectPatsBinders,
- collectLocatedPatBinders, collectLocatedPatsBinders,
- collectSigTysFromPat, collectSigTysFromPats
+ patsAreAllLits, isLitPat
) where
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr ( HsExpr )
-- friends:
+import HsBinds ( DictBinds, emptyLHsBinds, pprLHsBinds )
import HsLit ( HsLit(HsCharPrim), HsOverLit )
import HsTypes ( LHsType, SyntaxName, PostTcType )
import BasicTypes ( Boxity, tupleParens )
-- others:
+import PprCore ( {- instance OutputableBndr TyVar -} )
import TysWiredIn ( nilDataCon, charDataCon, charTy )
import Var ( TyVar )
import DataCon ( DataCon )
= ------------ Simple patterns ---------------
WildPat PostTcType -- Wild card
| VarPat id -- Variable
+ | VarPatOut id (DictBinds id) -- Used only for overloaded Ids; the
+ -- bindings give its overloaded instances
| LazyPat (LPat id) -- Lazy pattern
| AsPat (Located id) (LPat id) -- As pattern
| ParPat (LPat id) -- Parenthesised pattern
(HsConDetails id (LPat id))
| ConPatOut DataCon
- (HsConDetails id (LPat id))
- Type -- The type of the pattern
[TyVar] -- Existentially bound type variables
[id] -- Ditto dictionaries
+ (DictBinds id) -- Bindings involving those dictionaries
+ (HsConDetails id (LPat id))
+ Type -- The type of the pattern
------------ Literal and n+k patterns ---------------
| LitPat HsLit -- Used for *non-overloaded* literal patterns:
-- The literal is retained so that the desugarer can readily identify
-- equations with identical literal-patterns
-- Always HsInteger, HsRat or HsString.
- -- Always HsInteger, HsRat or HsString.
-- *Unlike* NPatIn, for negative literals, the
-- literal is acutally negative!
Type -- Type of pattern, t
| SigPatIn (LPat id) -- Pattern with a type signature
(LHsType id)
- | SigPatOut (LPat id) -- Pattern p
- Type -- Type, t, of the whole pattern
- (HsExpr id) -- Coercion function,
- -- of type t -> typeof(p)
+ | SigPatOut (LPat id) -- Pattern with a type signature
+ Type
------------ Dictionary patterns (translation only) ---------------
| DictPat -- Used when destructing Dictionaries with an explicit case
instance (OutputableBndr name) => Outputable (Pat name) where
ppr = pprPat
-pprPat :: (OutputableBndr name) => Pat name -> SDoc
-
-pprPat (VarPat var) -- Print with type info if -dppr-debug is on
+pprPatBndr :: OutputableBndr name => name -> SDoc
+pprPatBndr var -- Print with type info if -dppr-debug is on
= getPprStyle $ \ sty ->
if debugStyle sty then
parens (pprBndr LambdaBind var) -- Could pass the site to pprPat
else
ppr var
+pprPat :: (OutputableBndr name) => Pat name -> SDoc
+
+pprPat (VarPat var) = pprPatBndr var
+pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs))
pprPat (WildPat _) = char '_'
pprPat (LazyPat pat) = char '~' <> ppr pat
pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat])
pprPat (PArrPat pats _) = pabrackets (interpp'SP pats)
pprPat (TuplePat pats bx) = tupleParens bx (interpp'SP pats)
-pprPat (ConPatIn c details) = pprConPat c details
-pprPat (ConPatOut c details _ _ _) = pprConPat c details
+pprPat (ConPatIn con details) = pprUserCon con details
+pprPat (ConPatOut con tvs dicts binds details _)
+ = getPprStyle $ \ sty -> -- Tiresome; in TcBinds.tcRhs we print out a
+ if debugStyle sty then -- typechecked Pat in an error message,
+ -- and we want to make sure it prints nicely
+ ppr con <+> sep [ hsep (map pprPatBndr tvs) <+> hsep (map pprPatBndr dicts),
+ pprLHsBinds binds, pprConArgs details]
+ else pprUserCon con details
pprPat (LitPat s) = ppr s
pprPat (NPatIn l _) = ppr l
pprPat (NPatOut l _ _) = ppr l
pprPat (NPlusKPatIn n k _) = hcat [ppr n, char '+', ppr k]
pprPat (NPlusKPatOut n k _ _) = hcat [ppr n, char '+', integer k]
+pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
+pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
+pprPat (DictPat ds ms) = parens (sep [ptext SLIT("{-dict-}"),
+ brackets (interpp'SP ds),
+ brackets (interpp'SP ms)])
-pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
-
-pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
-pprPat (SigPatOut pat ty _) = ppr pat <+> dcolon <+> ppr ty
+pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2
+pprUserCon c details = ppr c <+> pprConArgs details
-pprPat (DictPat dicts methods)
- = parens (sep [ptext SLIT("{-dict-}"),
- brackets (interpp'SP dicts),
- brackets (interpp'SP methods)])
-
-
-
-pprConPat con (PrefixCon pats) = ppr con <+> interppSP pats -- inner ParPats supply the necessary parens.
-pprConPat con (InfixCon pat1 pat2) = hsep [ppr pat1, ppr con, ppr pat2] -- ParPats put in parens
- -- ToDo: use pprSym to print op (but this involves fiddling various
- -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
-pprConPat con (RecCon rpats)
- = ppr con <+> braces (hsep (punctuate comma (map (pp_rpat) rpats)))
- where
- pp_rpat (v, p) = hsep [ppr v, char '=', ppr p]
+pprConArgs (PrefixCon pats) = interppSP pats
+pprConArgs (InfixCon p1 p2) = interppSP [p1,p2]
+pprConArgs (RecCon rpats) = braces (hsep (punctuate comma (map (pp_rpat) rpats)))
+ where
+ pp_rpat (v, p) = hsep [ppr v, char '=', ppr p]
-- add parallel array brackets around a document
\begin{code}
mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
-- Make a vanilla Prefix constructor pattern
-mkPrefixConPat dc pats ty = noLoc $ ConPatOut dc (PrefixCon pats) ty [] []
+mkPrefixConPat dc pats ty = noLoc $ ConPatOut dc [] [] emptyLHsBinds (PrefixCon pats) ty
mkNilPat :: Type -> OutPat id
mkNilPat ty = mkPrefixConPat nilDataCon [] ty
patsAreAllCons :: [Pat id] -> Bool
patsAreAllCons pat_list = all isConPat pat_list
-isConPat (AsPat _ pat) = isConPat (unLoc pat)
-isConPat (ConPatIn _ _) = True
-isConPat (ConPatOut _ _ _ _ _) = True
-isConPat (ListPat _ _) = True
-isConPat (PArrPat _ _) = True
-isConPat (TuplePat _ _) = True
-isConPat (DictPat ds ms) = (length ds + length ms) > 1
-isConPat other = False
+isConPat (AsPat _ pat) = isConPat (unLoc pat)
+isConPat (ConPatIn _ _) = True
+isConPat (ConPatOut _ _ _ _ _ _) = True
+isConPat (ListPat _ _) = True
+isConPat (PArrPat _ _) = True
+isConPat (TuplePat _ _) = True
+isConPat (DictPat ds ms) = (length ds + length ms) > 1
+isConPat other = False
-isSigPat (SigPatIn _ _) = True
-isSigPat (SigPatOut _ _ _) = True
-isSigPat other = False
+isSigPat (SigPatIn _ _) = True
+isSigPat (SigPatOut _ _) = True
+isSigPat other = False
patsAreAllLits :: [Pat id] -> Bool
patsAreAllLits pat_list = all isLitPat pat_list
isLitPat other = False
\end{code}
-%************************************************************************
-%* *
-%* Gathering stuff out of patterns
-%* *
-%************************************************************************
-
-This function @collectPatBinders@ works with the ``collectBinders''
-functions for @HsBinds@, etc. The order in which the binders are
-collected is important; see @HsBinds.lhs@.
-
-It collects the bounds *value* variables in renamed patterns; type variables
-are *not* collected.
-
-\begin{code}
-collectPatBinders :: LPat a -> [a]
-collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
-
-collectLocatedPatBinders :: LPat a -> [Located a]
-collectLocatedPatBinders pat = collectl pat []
-
-collectPatsBinders :: [LPat a] -> [a]
-collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
-
-collectLocatedPatsBinders :: [LPat a] -> [Located a]
-collectLocatedPatsBinders pats = foldr collectl [] pats
-
-collectl (L l (VarPat var)) bndrs = L l var : bndrs
-collectl pat bndrs = collect (unLoc pat) bndrs
-
-collect (WildPat _) bndrs = bndrs
-collect (LazyPat pat) bndrs = collectl pat bndrs
-collect (AsPat a pat) bndrs = a : collectl pat bndrs
-collect (ParPat pat) bndrs = collectl pat bndrs
-
-collect (ListPat pats _) bndrs = foldr collectl bndrs pats
-collect (PArrPat pats _) bndrs = foldr collectl bndrs pats
-collect (TuplePat pats _) bndrs = foldr collectl bndrs pats
-
-collect (ConPatIn c ps) bndrs = foldr collectl bndrs (hsConArgs ps)
-collect (ConPatOut c ps _ _ ds) bndrs = map noLoc ds
- ++ foldr collectl bndrs (hsConArgs ps)
-
-collect (LitPat _) bndrs = bndrs
-collect (NPatIn _ _) bndrs = bndrs
-collect (NPatOut _ _ _) bndrs = bndrs
-
-collect (NPlusKPatIn n _ _) bndrs = n : bndrs
-collect (NPlusKPatOut n _ _ _) bndrs = n : bndrs
-
-collect (SigPatIn pat _) bndrs = collectl pat bndrs
-collect (SigPatOut pat _ _) bndrs = collectl pat bndrs
-collect (TypePat ty) bndrs = bndrs
-collect (DictPat ids1 ids2) bndrs = map noLoc ids1 ++ map noLoc ids2
- ++ bndrs
-\end{code}
-
-\begin{code}
-collectSigTysFromPats :: [InPat name] -> [LHsType name]
-collectSigTysFromPats pats = foldr collect_lpat [] pats
-
-collectSigTysFromPat :: InPat name -> [LHsType name]
-collectSigTysFromPat pat = collect_lpat pat []
-
-collect_lpat pat acc = collect_pat (unLoc pat) acc
-
-collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc)
-collect_pat (TypePat ty) acc = ty:acc
-
-collect_pat (LazyPat pat) acc = collect_lpat pat acc
-collect_pat (AsPat a pat) acc = collect_lpat pat acc
-collect_pat (ParPat pat) acc = collect_lpat pat acc
-collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
-collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
-collect_pat (TuplePat pats _) acc = foldr collect_lpat acc pats
-collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
-collect_pat other acc = acc -- Literals, vars, wildcard
-\end{code}
HsExplicitForAll(..),
HsContext, LHsContext,
HsPred(..), LHsPred,
+
+ LBangType, BangType, HsBang(..),
+ getBangType, getBangStrictness,
mkExplicitHsForAllTy, mkImplicitHsForAllTy,
hsTyVarName, hsTyVarNames, replaceTyVarName,
noSrcLoc
\end{code}
+%************************************************************************
+%* *
+\subsection{Bang annotations}
+%* *
+%************************************************************************
+
+\begin{code}
+type LBangType name = Located (BangType name)
+type BangType name = HsType name -- Bangs are in the HsType data type
+
+data HsBang = HsNoBang -- Only used as a return value for getBangStrictness,
+ -- never appears on a HsBangTy
+ | HsStrict -- !
+ | HsUnbox -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
+
+instance Outputable HsBang where
+ ppr (HsNoBang) = empty
+ ppr (HsStrict) = char '!'
+ ppr (HsUnbox) = ptext SLIT("!!")
+
+getBangType :: LHsType a -> LHsType a
+getBangType (L _ (HsBangTy _ ty)) = ty
+getBangType ty = ty
+
+getBangStrictness :: LHsType a -> HsBang
+getBangStrictness (L _ (HsBangTy s _)) = s
+getBangStrictness _ = HsNoBang
+\end{code}
+
%************************************************************************
%* *
| HsTyVar name -- Type variable or type constructor
+ | HsBangTy HsBang (LHsType name) -- Bang-style type annotations
+
| HsAppTy (LHsType name)
(LHsType name)
-> ([LHsTyVarBndr name], HsContext name, name, [LHsType name])
-- Split up an instance decl type, returning the pieces
--- In interface files, the instance declaration head is created
--- by HsTypes.toHsType, which does not guarantee to produce a
--- HsForAllTy. For example, if we had the weird decl
--- instance Foo T => Foo [T]
--- then we'd get the instance type
--- Foo T -> Foo [T]
--- So when colleting the instance context, to be on the safe side
--- we gather predicate arguments
---
--- For source code, the parser ensures the type will have the right shape.
--- (e.g. see ParseUtil.checkInstType)
-
splitHsInstDeclTy inst_ty
= case inst_ty of
- HsForAllTy _ tvs cxt1 tau -- The type vars should have been
- -- computed by now, even if they were implicit
- -> (tvs, unLoc cxt1 ++ cxt2, cls, tys)
- where
- (cxt2, cls, tys) = split_tau (unLoc tau)
-
- other -> ([], cxt2, cls, tys)
- where
- (cxt2, cls, tys) = split_tau inst_ty
-
+ HsParTy (L _ ty) -> splitHsInstDeclTy ty
+ HsForAllTy _ tvs cxt (L _ ty) -> split_tau tvs (unLoc cxt) ty
+ other -> split_tau [] [] other
+ -- The type vars should have been computed by now, even if they were implicit
where
- split_tau (HsFunTy (L loc (HsPredTy p)) ty) = (L loc p : ps, cls, tys)
- where
- (ps, cls, tys) = split_tau (unLoc ty)
- split_tau (HsPredTy (HsClassP cls tys)) = ([], cls, tys)
- split_tau other = pprPanic "splitHsInstDeclTy" (ppr inst_ty)
+ split_tau tvs cxt (HsPredTy (HsClassP cls tys)) = (tvs, cxt, cls, tys)
+ split_tau tvs cxt (HsParTy (L _ ty)) = split_tau tvs cxt ty
\end{code}
= maybeParen ctxt_prec pREC_FUN $
sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
+-- gaw 2004
+ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppr b <> ppr ty
ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2
ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
mkHsPar :: LHsExpr id -> LHsExpr id
mkHsPar e = L (getLoc e) (HsPar e)
-mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id
-mkSimpleMatch pats rhs rhs_ty
+-- gaw 2004
+mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
+mkSimpleMatch pats rhs
= L loc $
- Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty)
+ Match pats Nothing (GRHSs (unguardedRHS rhs) [])
where
loc = case pats of
[] -> getLoc rhs
mkHsTyApp expr [] = expr
mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
+mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
mkHsDictApp expr [] = expr
mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
-mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match))
+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
- match = mkSimpleMatch pats body placeHolderType
+ matches = mkMatchGroup [mkSimpleMatch pats body]
+
+mkMatchGroup :: [LMatch id] -> MatchGroup id
+mkMatchGroup matches = MatchGroup matches placeHolderType
mkHsTyLam [] expr = expr
mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
mkHsDictLam [] expr = expr
mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
-mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name
+mkHsLet :: LHsBinds name -> LHsExpr name -> LHsExpr name
mkHsLet binds expr
- | isEmptyBag binds = expr
- | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
+ | isEmptyLHsBinds binds = expr
+ | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
-- Used for constructing dictinoary terms etc, so no locations
mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
mkSimpleHsAlt pat expr
- = mkSimpleMatch [pat] expr placeHolderType
+ = mkSimpleMatch [pat] expr
glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
-glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
- = GRHSs grhss (binds1 : binds2) ty
+-- gaw 2004
+glueBindsOnGRHSs binds1 (GRHSs grhss binds2)
+ = GRHSs grhss (binds1 : binds2)
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
-nlHsLam match = noLoc (HsLam match)
+nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
nlHsPar e = noLoc (HsPar e)
nlHsIf cond true false = noLoc (HsIf cond true false)
-nlHsCase expr matches = noLoc (HsCase expr matches)
+nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
nlTuple exprs box = noLoc (ExplicitTuple exprs box)
nlList exprs = noLoc (ExplicitList placeHolderType exprs)
\begin{code}
mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
-mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs
+mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsBinds RdrName -> LHsExpr RdrName
mk_easy_FunBind loc fun pats binds expr
= L loc (FunBind (L loc fun) False{-not infix-}
- [mk_easy_Match pats binds expr])
+ (mkMatchGroup [mk_easy_Match pats binds expr]))
mk_easy_Match pats binds expr
= mkMatch pats expr [HsBindGroup binds [] Recursive]
mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
mk_FunBind loc fun pats_and_exprs
= L loc (FunBind (L loc fun) False{-not infix-}
- [mkMatch p e [] | (p,e) <-pats_and_exprs])
+ (mkMatchGroup [mkMatch p e [] | (p,e) <-pats_and_exprs]))
mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
mkMatch pats expr binds
= noLoc (Match (map paren pats) Nothing
- (GRHSs (unguardedRHS expr) binds placeHolderType))
+-- gaw 2004
+ (GRHSs (unguardedRHS expr) binds))
where
paren p = case p of
L _ (VarPat _) -> p
collectAcc :: HsBind name -> [Located name] -> [Located name]
-collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc
-collectAcc (FunBind f _ _) acc = f : acc
+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
= [noLoc dp | (_,dp,_) <- dbinds] ++ acc
collectSigTysFromHsBind bind
= go (unLoc bind)
where
- go (PatBind pat _) = collectSigTysFromPat pat
- go (FunBind f _ ms) = go_matches (map unLoc ms)
-
+ 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_matches [] = []
- go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches
- go_matches (match : matches) = go_matches matches
\end{code}
%************************************************************************
collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
collectStmtBinders other = panic "collectStmtBinders"
\end{code}
+
+
+%************************************************************************
+%* *
+%* Gathering stuff out of patterns
+%* *
+%************************************************************************
+
+This function @collectPatBinders@ works with the ``collectBinders''
+functions for @HsBinds@, etc. The order in which the binders are
+collected is important; see @HsBinds.lhs@.
+
+It collects the bounds *value* variables in renamed patterns; type variables
+are *not* collected.
+
+\begin{code}
+collectPatBinders :: LPat a -> [a]
+collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
+
+collectLocatedPatBinders :: LPat a -> [Located a]
+collectLocatedPatBinders pat = collectl pat []
+
+collectPatsBinders :: [LPat a] -> [a]
+collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
+
+collectLocatedPatsBinders :: [LPat a] -> [Located a]
+collectLocatedPatsBinders pats = foldr collectl [] pats
+
+---------------------
+collectl (L l (VarPat var)) bndrs = L l var : bndrs
+collectl (L l (VarPatOut var bs)) bndrs = L l var : collectHsBindLocatedBinders bs
+ ++ bndrs
+collectl (L l pat) bndrs = collect pat bndrs
+
+---------------------
+collect (WildPat _) bndrs = bndrs
+collect (LazyPat pat) bndrs = collectl pat bndrs
+collect (AsPat a pat) bndrs = a : collectl pat bndrs
+collect (ParPat pat) bndrs = collectl pat bndrs
+
+collect (ListPat pats _) bndrs = foldr collectl bndrs pats
+collect (PArrPat pats _) bndrs = foldr collectl bndrs pats
+collect (TuplePat pats _) bndrs = foldr collectl bndrs pats
+
+collect (ConPatIn c ps) bndrs = foldr collectl bndrs (hsConArgs ps)
+collect (ConPatOut c _ ds bs ps _) bndrs = map noLoc ds
+ ++ collectHsBindLocatedBinders bs
+ ++ foldr collectl bndrs (hsConArgs ps)
+collect (LitPat _) bndrs = bndrs
+collect (NPatIn _ _) bndrs = bndrs
+collect (NPatOut _ _ _) bndrs = bndrs
+
+collect (NPlusKPatIn n _ _) bndrs = n : bndrs
+collect (NPlusKPatOut n _ _ _) bndrs = n : bndrs
+
+collect (SigPatIn pat _) bndrs = collectl pat bndrs
+collect (SigPatOut pat _) bndrs = collectl pat bndrs
+collect (TypePat ty) bndrs = bndrs
+collect (DictPat ids1 ids2) bndrs = map noLoc ids1 ++ map noLoc ids2
+ ++ bndrs
+\end{code}
+
+\begin{code}
+collectSigTysFromPats :: [InPat name] -> [LHsType name]
+collectSigTysFromPats pats = foldr collect_lpat [] pats
+
+collectSigTysFromPat :: InPat name -> [LHsType name]
+collectSigTysFromPat pat = collect_lpat pat []
+
+collect_lpat pat acc = collect_pat (unLoc pat) acc
+
+collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc)
+collect_pat (TypePat ty) acc = ty:acc
+
+collect_pat (LazyPat pat) acc = collect_lpat pat acc
+collect_pat (AsPat a pat) acc = collect_lpat pat acc
+collect_pat (ParPat pat) acc = collect_lpat pat acc
+collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
+collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
+collect_pat (TuplePat pats _) acc = foldr collect_lpat acc pats
+collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
+collect_pat other acc = acc -- Literals, vars, wildcard
+\end{code}
putByte bh 4
put_ bh ag
put_ bh ah
- put_ bh (IfaceCase ai aj ak) = do
+-- gaw 2004
+ put_ bh (IfaceCase ai aj al ak) = do
putByte bh 5
put_ bh ai
put_ bh aj
+-- gaw 2004
+ put_ bh al
put_ bh ak
put_ bh (IfaceLet al am) = do
putByte bh 6
return (IfaceApp ag ah)
5 -> do ai <- get bh
aj <- get bh
+-- gaw 2004
+ al <- get bh
ak <- get bh
- return (IfaceCase ai aj ak)
+-- gaw 2004
+ return (IfaceCase ai aj al ak)
6 -> do al <- get bh
am <- get bh
return (IfaceLet al am)
put_ bh idinfo
put_ bh (IfaceForeign ae af) =
error "Binary.put_(IfaceDecl): IfaceForeign"
- put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
+ put_ bh (IfaceData a1 a2 a3 a4 a5 a6) = do
putByte bh 2
put_ bh a1
put_ bh a2
put_ bh a4
put_ bh a5
put_ bh a6
- put_ bh a7
put_ bh (IfaceSyn aq ar as at) = do
putByte bh 3
a4 <- get bh
a5 <- get bh
a6 <- get bh
- a7 <- get bh
- return (IfaceData a1 a2 a3 a4 a5 a6 a7)
+ return (IfaceData a1 a2 a3 a4 a5 a6)
3 -> do
aq <- get bh
ar <- get bh
instance Binary IfaceConDecls where
put_ bh IfAbstractTyCon = putByte bh 0
- put_ bh (IfDataTyCon cs) = do { putByte bh 1
- ; put_ bh cs }
+ put_ bh (IfDataTyCon st cs) = do { putByte bh 1
+ ; put_ bh st
+ ; put_ bh cs }
put_ bh (IfNewTyCon c) = do { putByte bh 2
; put_ bh c }
get bh = do
h <- getByte bh
case h of
0 -> return IfAbstractTyCon
- 1 -> do aa <- get bh
- return (IfDataTyCon aa)
+ 1 -> do st <- get bh
+ cs <- get bh
+ return (IfDataTyCon st cs)
_ -> do aa <- get bh
return (IfNewTyCon aa)
instance Binary IfaceConDecl where
- put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6 a7) = do
+ put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
+ putByte bh 0
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
+ putByte bh 1
put_ bh a1
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh a5
put_ bh a6
- put_ bh a7
get bh = do
- a1 <- get bh
- a2 <- get bh
- a3 <- get bh
- a4 <- get bh
- a5 <- get bh
- a6 <- get bh
- a7 <- get bh
- return (IfaceConDecl a1 a2 a3 a4 a5 a6 a7)
+ h <- getByte bh
+ case h of
+ 0 -> do a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ return (IfVanillaCon a1 a2 a3 a4 a5)
+ _ -> do a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ return (IfGadtCon a1 a2 a3 a4 a5 a6)
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
import IfaceEnv ( newImplicitBinder )
import TcRnMonad
-import Subst ( substTyWith )
import Util ( zipLazy )
-import FieldLabel ( allFieldLabelTags, mkFieldLabel, fieldLabelName )
-import VarSet
-import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels )
+import DataCon ( DataCon, isNullarySrcDataCon,
+ mkDataCon, dataConFieldLabels, dataConOrigArgTys )
import Var ( tyVarKind, TyVar, Id )
+import VarSet ( isEmptyVarSet, intersectVarSet )
import TysWiredIn ( unitTy )
import BasicTypes ( RecFlag, StrictnessMark(..) )
import Name ( Name )
mkClassDataConOcc, mkSuperDictSelOcc )
import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId )
import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
-import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons,
+import TyCon ( FieldLabel, mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta,
tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
ArgVrcs, AlgTyConRhs(..), newTyConRhs, visibleDataCons )
-import Type ( mkArrowKinds, liftedTypeKind, tyVarsOfTypes, typeKind,
- tyVarsOfPred, splitTyConApp_maybe, mkPredTys, ThetaType, Type )
+import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfTypes, tyVarsOfPred,
+ splitTyConApp_maybe, mkPredTys, mkTyVarTys, ThetaType, Type,
+ substTyWith, zipTopTvSubst, substTheta )
import Outputable
import List ( nubBy )
------------------------------------------------------
-buildAlgTyCon :: Name -> [TyVar] -> ThetaType
+buildAlgTyCon :: Name -> [TyVar]
-> AlgTyConRhs
-> ArgVrcs -> RecFlag
-> Bool -- True <=> want generics functions
-> TcRnIf m n TyCon
-buildAlgTyCon tc_name tvs ctxt rhs arg_vrcs is_rec want_generics
- = do { let { tycon = mkAlgTyCon tc_name kind tvs ctxt arg_vrcs
- rhs sel_ids is_rec want_generics
+buildAlgTyCon tc_name tvs rhs arg_vrcs is_rec want_generics
+ = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs
+ rhs fields is_rec want_generics
; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
- ; sel_ids = mkRecordSelectors tycon rhs
+ ; fields = mkTyConFields tycon rhs
}
; return tycon }
mkAbstractTyConRhs :: AlgTyConRhs
mkAbstractTyConRhs = AbstractTyCon
-mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
-mkDataTyConRhs cons
- = DataTyCon cons (all is_nullary cons)
+mkDataTyConRhs :: Maybe ThetaType -> [DataCon] -> AlgTyConRhs
+mkDataTyConRhs mb_theta cons
+ = DataTyCon mb_theta cons (all isNullarySrcDataCon cons)
+
+mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs
+mkNewTyConRhs tycon con
+ = NewTyCon con rhs_ty (mkNewTyConRep tycon)
where
- is_nullary con = null (dataConOrigArgTys con)
- -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
- -- but that looks at the *representation* arity, and isEnumerationType
- -- refers to the *source* code definition
-
-mkNewTyConRhs :: DataCon -> AlgTyConRhs
-mkNewTyConRhs con
- = NewTyCon con -- The constructor
- (head (dataConOrigArgTys con)) -- The RHS type
- (mkNewTyConRep (dataConTyCon con)) -- The ultimate rep type
+ rhs_ty = head (dataConOrigArgTys con)
+ -- Newtypes are guaranteed vanilla, so OrigArgTys will do
+mkNewTyConRep :: TyCon -- The original type constructor
+ -> Type -- Chosen representation type
+ -- (guaranteed not to be another newtype)
+
+-- Find the representation type for this newtype TyCon
+-- Remember that the representation type is the *ultimate* representation
+-- type, looking through other newtypes.
+--
+-- The non-recursive newtypes are easy, because they look transparent
+-- to splitTyConApp_maybe, but recursive ones really are represented as
+-- TyConApps (see TypeRep).
+--
+-- The trick is to to deal correctly with recursive newtypes
+-- such as newtype T = MkT T
+
+mkNewTyConRep tc
+ | null (tyConDataCons tc) = unitTy
+ -- External Core programs can have newtypes with no data constructors
+ | otherwise = go [] tc
+ where
+ -- Invariant: tc is a NewTyCon
+ -- tcs have been seen before
+ go tcs tc
+ | tc `elem` tcs = unitTy
+ | otherwise
+ = case splitTyConApp_maybe rhs_ty of
+ Just (tc', tys) | isNewTyCon tc'
+ -> substTyWith tc_tvs tys (go (tc:tcs) tc')
+ other -> rhs_ty
+ where
+ (tc_tvs, rhs_ty) = newTyConRhs tc
+
------------------------------------------------------
-buildDataCon :: Name -> Bool
+buildDataCon :: Name -> Bool -> Bool
-> [StrictnessMark]
-> [Name] -- Field labels
-> [TyVar] -> ThetaType
- -> [TyVar] -> ThetaType
- -> [Type] -> TyCon
+ -> [Type] -> TyCon -> [Type]
-> TcRnIf m n DataCon
-- A wrapper for DataCon.mkDataCon that
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
-buildDataCon src_name declared_infix arg_stricts field_lbl_names
- tyvars ctxt ex_tyvars ex_ctxt
- arg_tys tycon
+buildDataCon src_name declared_infix vanilla arg_stricts field_lbls
+ tyvars ctxt arg_tys tycon res_tys
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
-- This last one takes the name of the data constructor in the source
-- space, and makes it into a "real data constructor name"
; let
- -- Make the FieldLabels
- -- The zipLazy avoids forcing the arg_tys too early
- final_lbls = [ mkFieldLabel name tycon ty tag
- | ((name, tag), ty) <- (field_lbl_names `zip` allFieldLabelTags)
- `zipLazy` arg_tys
- ]
-
- ctxt' = thinContext arg_tys ctxt
- data_con = mkDataCon src_name declared_infix
- arg_stricts final_lbls
- tyvars ctxt'
- ex_tyvars ex_ctxt
- arg_tys tycon dc_ids
+ stupid_ctxt = mkDataConStupidTheta tycon arg_tys res_tys
+ data_con = mkDataCon src_name declared_infix vanilla
+ arg_stricts field_lbls
+ tyvars stupid_ctxt ctxt
+ arg_tys tycon res_tys dc_ids
dc_ids = mkDataConIds wrap_name work_name data_con
; returnM data_con }
--- The context for a data constructor should be limited to
+
+-- The stupid context for a data constructor should be limited to
-- the type variables mentioned in the arg_tys
-thinContext arg_tys ctxt
- = filter in_arg_tys ctxt
+mkDataConStupidTheta tycon arg_tys res_tys
+ | null stupid_theta = [] -- The common case
+ | otherwise = filter in_arg_tys stupid_theta
where
- arg_tyvars = tyVarsOfTypes arg_tys
- in_arg_tys pred = not $ isEmptyVarSet $
+ tc_subst = zipTopTvSubst (tyConTyVars tycon) res_tys
+ stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
+ arg_tyvars = tyVarsOfTypes arg_tys
+ in_arg_tys pred = not $ isEmptyVarSet $
tyVarsOfPred pred `intersectVarSet` arg_tyvars
------------------------------------------------------
-mkRecordSelectors :: TyCon -> AlgTyConRhs -> [Id]
-mkRecordSelectors tycon data_cons
+mkTyConFields :: TyCon -> AlgTyConRhs -> [(FieldLabel,Type,Id)]
+mkTyConFields tycon rhs
= -- We'll check later that fields with the same name
-- from different constructors have the same type.
- [ mkRecordSelId tycon field
- | field <- nubBy eq_name fields ]
+ [ (fld, ty, mkRecordSelId tycon fld ty)
+ | (fld, ty) <- nubBy eq_fld all_fld_tys ]
where
- fields = [ field | con <- visibleDataCons data_cons,
- field <- dataConFieldLabels con ]
- eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
+ all_fld_tys = concatMap fld_tys_of (visibleDataCons rhs)
+ fld_tys_of con = dataConFieldLabels con `zipLazy`
+ dataConOrigArgTys con
+ -- The laziness means that the type isn't sucked in prematurely
+ -- Only vanilla datacons have fields at all, and they
+ -- share the tycon's type variables => datConOrigArgTys will do
+
+ eq_fld (f1,_) (f2,_) = f1 == f2
\end{code}
| (op_name, dm_info, _) <- sig_stuff ] }
-- Build the selector id and default method id
- ; dict_con <- buildDataCon datacon_name False {- Not declared infix -}
+ ; dict_con <- buildDataCon datacon_name
+ False -- Not declared infix
+ True -- Is vanilla; tyvars same as tycon
(map (const NotMarkedStrict) dict_component_tys)
[{- No labelled fields -}]
- tvs [{-No context-}]
- [{-No existential tyvars-}] [{-Or context-}]
- dict_component_tys
- (classTyCon clas)
+ tvs [{-No context-}] dict_component_tys
+ (classTyCon clas) (mkTyVarTys tvs)
; let { clas = mkClass class_name tvs fds
sc_theta sc_sel_ids op_items
; clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
; rhs = case dict_component_tys of
- [rep_ty] -> mkNewTyConRhs dict_con
- other -> mkDataTyConRhs [dict_con]
+ [rep_ty] -> mkNewTyConRhs tycon dict_con
+ other -> mkDataTyConRhs Nothing [dict_con]
}
; return clas
})}
\end{code}
-------------------------------------------------------
-\begin{code}
-mkNewTyConRep :: TyCon -- The original type constructor
- -> Type -- Chosen representation type
- -- (guaranteed not to be another newtype)
-
--- Find the representation type for this newtype TyCon
--- Remember that the representation type is the *ultimate* representation
--- type, looking through other newtypes.
---
--- The non-recursive newtypes are easy, because they look transparent
--- to splitTyConApp_maybe, but recursive ones really are represented as
--- TyConApps (see TypeRep).
---
--- The trick is to to deal correctly with recursive newtypes
--- such as newtype T = MkT T
-
-mkNewTyConRep tc
- | null (tyConDataCons tc) = unitTy
- -- External Core programs can have newtypes with no data constructors
- | otherwise = go [] tc
- where
- -- Invariant: tc is a NewTyCon
- -- tcs have been seen before
- go tcs tc
- | tc `elem` tcs = unitTy
- | otherwise
- = case splitTyConApp_maybe rep_ty of
- Nothing -> rep_ty
- Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
- | otherwise -> go1 (tc:tcs) tc' tys
- where
- (_,rep_ty) = newTyConRhs tc
-
- go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
-\end{code}
import TcRnMonad
import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
import TysWiredIn ( tupleTyCon, tupleCon )
-import HscTypes ( NameCache(..), HscEnv(..),
- TyThing, ExternalPackageState(..), OrigNameCache )
+import HscTypes ( NameCache(..), HscEnv(..), OrigNameCache )
import TyCon ( TyCon, tyConName )
-import Class ( Class )
import DataCon ( dataConWorkId, dataConName )
import Var ( TyVar, Id, varName )
import Name ( Name, nameUnique, nameModule,
getOccName, nameParent_maybe,
isWiredInName, mkIPName,
mkExternalName, mkInternalName )
-import NameEnv
import OccName ( OccName, isTupleOcc_maybe, tcName, dataName,
lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
import PrelNames ( gHC_PRIM_Name, pREL_TUP_Name )
-import HscTypes ( ExternalPackageState, NameCache, TyThing(..) )
import Module ( Module, ModuleName, moduleName, mkPackageModule,
emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
import FunDeps ( pprFundeps )
import NewDemand ( StrictSig, pprIfaceStrictSig )
-import TcType ( deNoteType, mkSigmaTy, tcSplitDFunTy, mkClassPred )
-import Type ( TyThing(..), mkForAllTys, mkFunTys, splitForAllTys, funResultTy,
- mkTyVarTys, mkTyConApp, mkTyVarTys, mkPredTy, tidyTopType )
+import TcType ( deNoteType, tcSplitDFunTy, mkClassPred )
+import Type ( TyThing(..), mkForAllTys, splitForAllTys, funResultTy,
+ mkPredTy, tidyTopType )
import InstEnv ( DFunId )
import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe )
import NewDemand ( isTopSig )
arityInfo, cafInfo, newStrictnessInfo,
workerInfo, unfoldingInfo, inlinePragInfo )
import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
- isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
+ isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
isTupleTyCon, tupleTyConBoxity,
- tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn,
- tyConArity, tyConTyVars, algTyConRhs, tyConExtName )
+ tyConHasGenerics, tyConArgVrcs, getSynTyConDefn,
+ tyConArity, tyConTyVars, algTcRhs, tyConExtName )
import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
- dataConTyCon, dataConIsInfix )
+ dataConTyCon, dataConIsInfix, isVanillaDataCon )
import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv,
lookupOccEnv, extendOccEnv, emptyOccEnv,
ifType :: IfaceType,
ifIdInfo :: IfaceIdInfo }
- | IfaceData { ifCtxt :: IfaceContext, -- Context
- ifName :: OccName, -- Type constructor
+ | IfaceData { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifCons :: IfaceConDecls, -- Includes new/data info
ifRec :: RecFlag, -- Recursive or not?
ifSynRhs :: IfaceType -- synonym expansion
}
- | IfaceClass { ifCtxt :: IfaceContext, -- Context...
- ifName :: OccName, -- Name of the class
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifFDs :: [FunDep OccName], -- Functional dependencies
- ifSigs :: [IfaceClassOp], -- Method signatures
- ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive?
- ifVrcs :: ArgVrcs -- ... and what are its argument variances ...
+ | IfaceClass { ifCtxt :: IfaceContext, -- Context...
+ ifName :: OccName, -- Name of the class
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifFDs :: [FunDep OccName], -- Functional dependencies
+ ifSigs :: [IfaceClassOp], -- Method signatures
+ ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive?
+ ifVrcs :: ArgVrcs -- ... and what are its argument variances ...
}
- | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET
+ | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET
ifExtName :: Maybe FastString }
data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
data IfaceConDecls
= IfAbstractTyCon -- No info
- | IfDataTyCon [IfaceConDecl] -- data type decls
+ | IfDataTyCon -- data type decls
+ (Maybe IfaceContext) -- See TyCon.AlgTyConRhs; H98 or GADT
+ [IfaceConDecl]
| IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
-visibleIfConDecls IfAbstractTyCon = []
-visibleIfConDecls (IfDataTyCon cs) = cs
-visibleIfConDecls (IfNewTyCon c) = [c]
+visibleIfConDecls IfAbstractTyCon = []
+visibleIfConDecls (IfDataTyCon _ cs) = cs
+visibleIfConDecls (IfNewTyCon c) = [c]
data IfaceConDecl
- = IfaceConDecl OccName -- Constructor name
- Bool -- True <=> declared infix
- [IfaceTvBndr] -- Existental tyvars
- IfaceContext -- Existential context
- [IfaceType] -- Arg types
- [StrictnessMark] -- Empty (meaning all lazy), or 1-1 corresp with arg types
- [OccName] -- ...ditto... (field labels)
+ = IfVanillaCon {
+ ifConOcc :: OccName, -- Constructor name
+ ifConInfix :: Bool, -- True <=> declared infix
+ ifConArgTys :: [IfaceType], -- Arg types
+ ifConStricts :: [StrictnessMark], -- Empty (meaning all lazy), or 1-1 corresp with arg types
+ ifConFields :: [OccName] } -- ...ditto... (field labels)
+ | IfGadtCon {
+ ifConOcc :: OccName, -- Constructor name
+ ifConTyVars :: [IfaceTvBndr], -- All tyvars
+ ifConCtxt :: IfaceContext, -- Non-stupid context
+ ifConArgTys :: [IfaceType], -- Arg types
+ ifConResTys :: [IfaceType], -- Result type args
+ ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types
data IfaceInst = IfaceInst { ifInstHead :: IfaceType, -- Just the instance head type, quantified
-- so that it'll compare alpha-wise
| IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
- | IfaceCase IfaceExpr OccName [IfaceAlt]
+-- gaw 2004
+ | IfaceCase IfaceExpr OccName IfaceType [IfaceAlt]
| IfaceLet IfaceBinding IfaceExpr
| IfaceNote IfaceNote IfaceExpr
| IfaceLit Literal
4 (vcat [equals <+> ppr mono_ty,
pprVrcs vrcs])
-pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen,
- ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs})
+pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen,
+ ifTyVars = tyvars, ifCons = condecls,
+ ifRec = isrec, ifVrcs = vrcs})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
- 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls])
+ 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls])
where
- pp_nd = case condecls of
- IfAbstractTyCon -> ptext SLIT("data")
- IfDataTyCon _ -> ptext SLIT("data")
- IfNewTyCon _ -> ptext SLIT("newtype")
+ (context, pp_nd)
+ = case condecls of
+ IfAbstractTyCon -> ([], ptext SLIT("data"))
+ IfDataTyCon Nothing _ -> ([], ptext SLIT("data"))
+ IfDataTyCon (Just c) _ -> (c, ptext SLIT("data"))
+ IfNewTyCon _ -> ([], ptext SLIT("newtype"))
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
pprIfaceDeclHead context thing tyvars
= hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars]
-pp_condecls IfAbstractTyCon = ptext SLIT("{- abstract -}")
-pp_condecls (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
-pp_condecls (IfNewTyCon c) = equals <+> ppr c
+pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
+pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
+pp_condecls tc (IfDataTyCon _ cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
+ (map (pprIfaceConDecl tc) cs))
-instance Outputable IfaceConDecl where
- ppr (IfaceConDecl name is_infix ex_tvs ex_ctxt arg_tys strs fields)
- = pprIfaceForAllPart ex_tvs ex_ctxt $
- sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
+pprIfaceConDecl tc (IfVanillaCon {
+ ifConOcc = name, ifConInfix = is_infix,
+ ifConArgTys = arg_tys,
+ ifConStricts = strs, ifConFields = fields })
+ = sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
if is_infix then ptext SLIT("Infix") else empty,
if null strs then empty
else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
if null fields then empty
else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
+pprIfaceConDecl tc (IfGadtCon {
+ ifConOcc = name,
+ ifConTyVars = tvs, ifConCtxt = ctxt,
+ ifConArgTys = arg_tys, ifConResTys = res_tys,
+ ifConStricts = strs })
+ = sep [ppr name <+> dcolon <+> pprIfaceForAllPart tvs ctxt (ppr con_tau),
+ if null strs then empty
+ else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs))]
+ where
+ con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app])
+ tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) res_tys
+ -- Gruesome, but jsut for debug print
+
instance Outputable IfaceRule where
ppr (IfaceRule name act bndrs fn args rhs)
= sep [hsep [doubleQuotes (ftext name), ppr act,
collect bs (IfaceLam b e) = collect (b:bs) e
collect bs e = (reverse bs, e)
-pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
- = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
+-- gaw 2004
+pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
+-- gaw 2004
+ = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
<+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
pprIfaceExpr noParens rhs <+> char '}'])
-pprIfaceExpr add_par (IfaceCase scrut bndr alts)
- = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
+-- gaw 2004
+pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
+-- gaw 2004
+ = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
<+> ppr bndr <+> char '{',
nest 2 (sep (map ppr_alt alts)) <+> char '}'])
ifSynRhs = toIfaceType ext syn_ty }
| isAlgTyCon tycon
- = IfaceData { ifCtxt = toIfaceContext ext (tyConTheta tycon),
- ifName = getOccName tycon,
+ = IfaceData { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
- ifCons = ifaceConDecls (algTyConRhs tycon),
+ ifCons = ifaceConDecls (algTcRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifVrcs = tyConArgVrcs tycon,
ifGeneric = tyConHasGenerics tycon }
| isPrimTyCon tycon || isFunTyCon tycon
-- Needed in GHCi for ':info Int#', for example
- = IfaceData { ifCtxt = [],
- ifName = getOccName tycon,
+ = IfaceData { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
ifCons = IfAbstractTyCon,
ifGeneric = False,
ifaceConDecls _ | abstract = IfAbstractTyCon
ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con)
- ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons)
+ ifaceConDecls (DataTyCon mb_theta cons _) = IfDataTyCon (ifaceDataCtxt mb_theta)
+ (map ifaceConDecl cons)
ifaceConDecls AbstractTyCon = IfAbstractTyCon
-- The last case should never happen when we are generating an
-- interface file (we're exporting this thing, so it's locally defined
-- in TcRnDriver for GHCi, when browsing a module, in which case the
-- AbstractTyCon case is perfectly sensible.
+ ifaceDataCtxt Nothing = Nothing
+ ifaceDataCtxt (Just theta) = Just (toIfaceContext ext theta)
+
ifaceConDecl data_con
- = IfaceConDecl (getOccName (dataConName data_con))
- (dataConIsInfix data_con)
- (toIfaceTvBndrs ex_tyvars)
- (toIfaceContext ext ex_theta)
- (map (toIfaceType ext) arg_tys)
- strict_marks
- (map getOccName field_labels)
+ | isVanillaDataCon data_con
+ = IfVanillaCon {ifConOcc = getOccName (dataConName data_con),
+ ifConInfix = dataConIsInfix data_con,
+ ifConArgTys = map (toIfaceType ext) arg_tys,
+ ifConStricts = strict_marks,
+ ifConFields = map getOccName field_labels }
+ | otherwise
+ = IfGadtCon { ifConOcc = getOccName (dataConName data_con),
+ ifConTyVars = toIfaceTvBndrs tyvars,
+ ifConCtxt = toIfaceContext ext theta,
+ ifConArgTys = map (toIfaceType ext) arg_tys,
+ ifConResTys = map (toIfaceType ext) res_tys,
+ ifConStricts = strict_marks }
where
- (_, _, ex_tyvars, ex_theta, arg_tys, _) = dataConSig data_con
+ (tyvars, theta, arg_tys, _, res_tys) = dataConSig data_con
field_labels = dataConFieldLabels data_con
strict_marks = dataConStrictMarks data_con
toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty)
toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
toIfaceExpr ext (App f a) = toIfaceApp ext f [a]
-toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as)
+-- gaw 2004
+toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as)
toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
ifVrcs d1 == ifVrcs d2 &&
ifGeneric d1 == ifGeneric d2) &&&
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
- eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
- eq_hsCD env (ifCons d1) (ifCons d2)
+ eq_hsCD env (ifCons d1) (ifCons d2)
)
+ -- The type variables of the data type do not scope
+ -- over the constructors (any more), but they do scope
+ -- over the stupid context in the IfaceConDecls
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
eq_ifaceExpr env rhs1 rhs2)
eqIfRule _ _ = NotEqual
-eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) = eqListBy (eq_ConDecl env) c1 c2
+eq_hsCD env (IfDataTyCon st1 c1) (IfDataTyCon st2 c2)
+ = eqMaybeBy (eq_ifContext env) st1 st2 &&&
+ eqListBy (eq_ConDecl env) c1 c2
+
eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
eq_hsCD env d1 d2 = NotEqual
-eq_ConDecl env (IfaceConDecl n1 inf1 tvs1 cxt1 args1 ss1 lbls1)
- (IfaceConDecl n2 inf2 tvs2 cxt2 args2 ss2 lbls2)
- = bool (n1 == n2 && inf1 == inf2 && ss1 == ss2 && lbls1 == lbls2) &&&
- eq_ifTvBndrs env tvs1 tvs2 (\ env ->
- eq_ifContext env cxt1 cxt2 &&&
- eq_ifTypes env args1 args2)
+eq_ConDecl env c1@(IfVanillaCon {}) c2@(IfVanillaCon {})
+ = bool (ifConOcc c1 == ifConOcc c2 &&
+ ifConInfix c1 == ifConInfix c2 &&
+ ifConStricts c1 == ifConStricts c2 &&
+ ifConFields c1 == ifConFields c2) &&&
+ eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)
+
+eq_ConDecl env c1@(IfGadtCon {}) c2@(IfGadtCon {})
+ = bool (ifConOcc c1 == ifConOcc c2 &&
+ ifConStricts c1 == ifConStricts c2) &&&
+ eq_ifTvBndrs env (ifConTyVars c1) (ifConTyVars c2) (\ env ->
+ eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
+ eq_ifTypes env (ifConResTys c1) (ifConResTys c2) &&&
+ eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2))
+
+eq_ConDecl env c1 c2 = NotEqual
eq_hsFD env (ns1,ms1) (ns2,ms2)
= eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
-eq_ifaceExpr env (IfaceCase s1 b1 as1) (IfaceCase s2 b2 as2)
+eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
= eq_ifaceExpr env s1 s2 &&&
+ eq_ifType env ty1 ty2 &&&
eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
where
eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
import Var ( isId, tyVarKind, idType )
import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
import OccName ( OccName )
-import Name ( Name, getName, getOccName, nameModuleName, nameOccName, isInternalName )
+import Name ( Name, getName, getOccName, nameModuleName, nameOccName )
import Module ( ModuleName )
import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity )
import Outputable
opt_InPackage )
import Parser ( parseIface )
-import IfaceSyn ( IfaceDecl(..), IfaceConDecls(..), IfaceConDecl(..), IfaceClassOp(..),
+import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceConDecls(..),
IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
- IfaceType(..), IfacePredType(..), IfaceExtName, visibleIfConDecls, mkIfaceExtName )
+ IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName )
import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc )
-import HscTypes ( HscEnv(..), ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats,
+import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats,
ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv,
lookupIfaceByModName, emptyPackageIfaceTable,
- IsBootInterface, mkIfaceFixCache, mkTypeEnv,
- Gated, implicitTyThings,
+ IsBootInterface, mkIfaceFixCache, Gated, implicitTyThings,
addRulesToPool, addInstsToPool
)
import TcRnMonad
import PrelNames ( gHC_PRIM_Name )
-import PrelInfo ( ghcPrimExports, wiredInThings )
+import PrelInfo ( ghcPrimExports )
import PrelRules ( builtinRules )
import Rules ( emptyRuleBase )
import InstEnv ( emptyInstEnv )
import MkId ( seqId )
import Packages ( basePackage )
import Module ( Module, ModuleName, ModLocation(ml_hi_file),
- moduleName, isHomeModule, emptyModuleEnv, moduleEnvElts,
+ moduleName, isHomeModule, emptyModuleEnv,
extendModuleEnv, lookupModuleEnvByName, moduleUserString
)
import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc,
ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon})
= []
-ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfaceConDecl con_occ _ _ _ _ _ fields)})
+-- Newtype
+ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con_occ,
+ ifConFields = fields})})
= fields ++ [con_occ, mkDataConWrapperOcc con_occ]
-- Wrapper, no worker; see MkId.mkDataConIds
-ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons})
+ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon _ cons})
= nub (concatMap fld_occs cons) -- Eliminate duplicate fields
++ concatMap dc_occs cons
where
- fld_occs (IfaceConDecl _ _ _ _ _ _ fields) = fields
- dc_occs (IfaceConDecl con_occ _ _ _ _ strs _)
+ fld_occs (IfVanillaCon { ifConFields = fields }) = fields
+ fld_occs (IfGadtCon {}) = []
+ dc_occs con_decl
| has_wrapper = [con_occ, work_occ, wrap_occ]
| otherwise = [con_occ, work_occ]
where
+ con_occ = ifConOcc con_decl
+ strs = ifConStricts con_decl
wrap_occ = mkDataConWrapperOcc con_occ
work_occ = mkDataConWorkerOcc con_occ
has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
-- ToDo: may miss strictness in existential dicts
-ifaceDeclSubBndrs _other = []
-
+ifaceDeclSubBndrs _other = []
-----------------------------------------------------
-- Loading instance decls
Dependencies(..), FixItem(..),
mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
typeEnvElts,
- Avails, AvailInfo, GenAvailInfo(..), availName,
+ GenAvailInfo(..), availName,
ExternalPackageState(..),
Usage(..), IsBootInterface,
Deprecs(..), IfaceDeprecs, Deprecations,
extendOccSet, extendOccSetList,
isEmptyOccSet, intersectOccSet, intersectsOccSet,
occNameFS, isTcOcc )
-import TyCon ( visibleDataCons, tyConDataCons, isNewTyCon, newTyConRep )
+import TyCon ( tyConDataCons, isNewTyCon, newTyConRep )
import Class ( classSelIds )
import DataCon ( dataConName, dataConFieldLabels )
-import FieldLabel ( fieldLabelName )
import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
ModLocation(..), mkSysModuleNameFS, moduleUserString,
ModuleEnv, emptyModuleEnv, lookupModuleEnv,
-- can only do that if it can "see" the newtype representation
where
exported_data_con con
- = any (`elemNameSet` exports) (dataConName con : field_names)
- where
- field_names = map fieldLabelName (dataConFieldLabels con)
+ = any (`elemNameSet` exports) (dataConName con : dataConFieldLabels con)
mustExposeThing exports (AClass cls)
= any exported_class_op (classSelIds cls)
eq_ind_occs [op | IfaceClassOp op _ _ <- sigs]
eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons})
= same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too
- eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ _ <- visibleIfConDecls cons]
+ eq_ind_occs (map ifConOcc (visibleIfConDecls cons))
eq_indirects other = Equal -- Synonyms and foreign declarations
eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules
(unitFM avail_fs avail)
where
occ = nameOccName name
- occ_fs = occNameFS occ
mod_fs = moduleNameFS (nameModuleName name)
avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ]
| isTcOcc occ = AvailTC occ [occ]
import TyCon ( TyCon, tyConName )
import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon,
- ModIface(..), ModDetails(..), InstPool, ModGuts,
- TypeEnv, mkTypeEnv, extendTypeEnv, extendTypeEnvList,
- lookupTypeEnv, lookupType, typeEnvIds,
- RulePool )
+ ModIface(..), ModDetails(..), ModGuts,
+ mkTypeEnv, extendTypeEnv,
+ lookupTypeEnv, lookupType, typeEnvIds )
import InstEnv ( extendInstEnv )
import CoreSyn
import PprCore ( pprIdRules )
setArityInfo, setInlinePragInfo, setCafInfo,
vanillaIdInfo, newStrictnessInfo )
import Class ( Class )
-import TyCon ( tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon )
-import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys )
-import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon,
- tupleTyCon, tupleCon )
+import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
+import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon )
+import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
import Var ( TyVar, mkTyVar, tyVarKind )
-import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName, nameIsLocalOrFrom,
- isWiredInName, wiredInNameTyThing_maybe, nameParent, nameParent_maybe )
+import Name ( Name, nameModuleName, nameModule, nameIsLocalOrFrom,
+ isWiredInName, wiredInNameTyThing_maybe, nameParent )
import NameEnv
import OccName ( OccName )
import Module ( Module, ModuleName, moduleName )
import Outputable
import SrcLoc ( noSrcLoc )
import Util ( zipWithEqual, dropList, equalLength, zipLazy )
-import Maybes ( expectJust )
import CmdLineOpts ( DynFlag(..) )
-
-import UniqFM (sizeUFM)
-
\end{code}
This module takes
; return (AnId (mkVanillaGlobal name ty info)) }
tcIfaceDecl (IfaceData {ifName = occ_name,
- ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt,
+ ifTyVars = tv_bndrs,
ifCons = rdr_cons,
ifVrcs = arg_vrcs, ifRec = is_rec,
ifGeneric = want_generic })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
- { traceIf (text "tcIfaceDecl" <+> ppr rdr_ctxt)
-
- ; ctxt <- forkM (ptext SLIT("Ctxt of data decl") <+> ppr tc_name) $
- tcIfaceCtxt rdr_ctxt
- -- The reason for laziness here is to postpone
- -- looking at the context, because the class may not
- -- be in the type envt yet. E.g.
- -- class Real a where { toRat :: a -> Ratio Integer }
- -- data (Real a) => Ratio a = ...
- -- We suck in the decl for Real, and type check it, which sucks
- -- in the data type Ratio; but we must postpone typechecking the
- -- context
-
- ; tycon <- fixM ( \ tycon -> do
- { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons
- ; tycon <- buildAlgTyCon tc_name tyvars ctxt cons
+ { tycon <- fixM ( \ tycon -> do
+ { cons <- tcIfaceDataCons tycon tyvars rdr_cons
+ ; tycon <- buildAlgTyCon tc_name tyvars cons
arg_vrcs is_rec want_generic
; return tycon
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon)
- } }
+ }}
tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0 [])) }
-tcIfaceDataCons tycon tyvars ctxt if_cons
+tcIfaceDataCons tycon tc_tyvars if_cons
= case if_cons of
- IfAbstractTyCon -> return mkAbstractTyConRhs
- IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
- ; return (mkDataTyConRhs data_cons) }
- IfNewTyCon con -> do { data_con <- tc_con_decl con
- ; return (mkNewTyConRhs data_con) }
+ IfAbstractTyCon -> return mkAbstractTyConRhs
+ IfDataTyCon mb_ctxt cons -> do { mb_theta <- tc_ctxt mb_ctxt
+ ; data_cons <- mappM tc_con_decl cons
+ ; return (mkDataTyConRhs mb_theta data_cons) }
+ IfNewTyCon con -> do { data_con <- tc_con_decl con
+ ; return (mkNewTyConRhs tycon data_con) }
where
- tc_con_decl (IfaceConDecl occ is_infix ex_tvs ex_ctxt args stricts field_lbls)
- = bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
- { name <- lookupIfaceTop occ
- ; ex_theta <- tcIfaceCtxt ex_ctxt -- Laziness seems not worth the bother here
+ tc_ctxt Nothing = return Nothing
+ tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) }
+
+ tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args,
+ ifConStricts = stricts, ifConFields = field_lbls})
+ = do { name <- lookupIfaceTop occ
+ -- Read the argument types, but lazily to avoid faulting in
+ -- the component types unless they are really needed
+ ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
+ ; lbl_names <- mappM lookupIfaceTop field_lbls
+ ; buildDataCon name is_infix True {- Vanilla -}
+ stricts lbl_names
+ tc_tyvars [] arg_tys tycon
+ (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys
+ }
+
+ tc_con_decl (IfGadtCon { ifConTyVars = con_tvs,
+ ifConOcc = occ, ifConCtxt = ctxt,
+ ifConArgTys = args, ifConResTys = ress,
+ ifConStricts = stricts})
+ = bindIfaceTyVars con_tvs $ \ con_tyvars -> do
+ { name <- lookupIfaceTop occ
+ ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
+ -- At one stage I thought that this context checking *had*
+ -- to be lazy, because of possible mutual recursion between the
+ -- type and the classe:
+ -- E.g.
+ -- class Real a where { toRat :: a -> Ratio Integer }
+ -- data (Real a) => Ratio a = ...
+ -- But now I think that the laziness in checking class ops breaks
+ -- the loop, so no laziness needed
-- Read the argument types, but lazily to avoid faulting in
-- the component types unless they are really needed
- ; arg_tys <- forkM (mk_doc name args) (mappM tcIfaceType args) ;
-
- ; lbl_names <- mappM lookupIfaceTop field_lbls
+ ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
+ ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress)
- ; buildDataCon name is_infix stricts lbl_names
- tyvars ctxt ex_tyvars ex_theta
- arg_tys tycon
+ ; buildDataCon name False {- Not infix -} False {- Not vanilla -}
+ stricts [{- No fields -}]
+ con_tyvars theta
+ arg_tys tycon res_tys
}
- mk_doc con_name args = ptext SLIT("Constructor") <+> sep [ppr con_name, ppr args]
+ mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
\end{code}
tcIfaceExpr arg `thenM` \ arg' ->
returnM (App fun' arg')
-tcIfaceExpr (IfaceCase scrut case_bndr alts)
+-- gaw 2004
+tcIfaceExpr (IfaceCase scrut case_bndr ty alts)
= tcIfaceExpr scrut `thenM` \ scrut' ->
newIfaceName case_bndr `thenM` \ case_bndr_name ->
let
in
extendIfaceIdEnv [case_bndr'] $
mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' ->
- returnM (Case scrut' case_bndr' alts')
+ tcIfaceType ty `thenM` \ ty' ->
+ returnM (Case scrut' case_bndr' ty' alts')
tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
= tcIfaceExpr rhs `thenM` \ rhs' ->
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
- = let
- tycon_mod = nameModuleName (tyConName tycon)
- in
- tcIfaceDataCon (ExtPkg tycon_mod data_occ) `thenM` \ con ->
- newIfaceNames arg_occs `thenM` \ arg_names ->
- let
- ex_tyvars = dataConExistentialTyVars con
- main_tyvars = tyConTyVars tycon
- ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` ex_tyvars]
- ex_tys' = mkTyVarTys ex_tyvars'
- arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
- id_names = dropList ex_tyvars arg_names
- arg_ids
-#ifdef DEBUG
- | not (equalLength id_names arg_tys)
- = pprPanic "tcIfaceAlts" (ppr (con, arg_names, rhs) $$
- (ppr main_tyvars <+> ppr ex_tyvars) $$
- ppr arg_tys)
- | otherwise
-#endif
- = zipWithEqual "tcIfaceAlts" mkLocalId id_names arg_tys
- in
- ASSERT2( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars,
- ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) $$ ppr arg_tys $$ ppr main_tyvars )
- extendIfaceTyVarEnv ex_tyvars' $
- extendIfaceIdEnv arg_ids $
- tcIfaceExpr rhs `thenM` \ rhs' ->
- returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
+ = do { let tycon_mod = nameModuleName (tyConName tycon)
+ ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
+ ; ASSERT2( con `elem` tyConDataCons tycon,
+ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
+
+ if isVanillaDataCon con then
+ tcVanillaAlt con inst_tys arg_occs rhs
+ else
+ do { -- General case
+ arg_names <- newIfaceNames arg_occs
+ ; let tyvars = [ mkTyVar name (tyVarKind tv)
+ | (name,tv) <- arg_names `zip` dataConTyVars con]
+ arg_tys = dataConArgTys con (mkTyVarTys tyvars)
+ id_names = dropList tyvars arg_names
+ arg_ids = ASSERT2( equalLength id_names arg_tys,
+ ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
+ zipWith mkLocalId id_names arg_tys
+
+ ; rhs' <- extendIfaceTyVarEnv tyvars $
+ extendIfaceIdEnv arg_ids $
+ tcIfaceExpr rhs
+ ; return (DataAlt con, tyvars ++ arg_ids, rhs') }}
tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
- = newIfaceNames arg_occs `thenM` \ arg_names ->
- let
- [con] = tyConDataCons tycon
- arg_ids = zipWithEqual "tcIfaceAlts" mkLocalId arg_names inst_tys
- in
- ASSERT( isTupleTyCon tycon )
- extendIfaceIdEnv arg_ids $
- tcIfaceExpr rhs `thenM` \ rhs' ->
- returnM (DataAlt con, arg_ids, rhs')
+ = ASSERT( isTupleTyCon tycon )
+ do { let [data_con] = tyConDataCons tycon
+ ; tcVanillaAlt data_con inst_tys arg_occs rhs }
+
+tcVanillaAlt data_con inst_tys arg_occs rhs
+ = do { arg_names <- newIfaceNames arg_occs
+ ; let arg_tys = dataConArgTys data_con inst_tys
+ ; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
+ ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs )
+ zipWith mkLocalId arg_names arg_tys
+ ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
+ ; returnM (DataAlt data_con, arg_ids, rhs') }
\end{code}
import Maybes ( firstJust )
import Directory ( doesFileExist )
-import Data.List ( intersperse )
import Monad ( when )
import IO
\end{code}
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.32 2004/06/24 09:41:11 simonmar Exp $
+-- $Id: DriverMkDepend.hs,v 1.33 2004/09/30 10:37:10 simonpj Exp $
--
-- GHC Driver
--
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.29 2004/08/13 13:06:57 simonmar Exp $
+-- $Id: DriverPhases.hs,v 1.30 2004/09/30 10:37:11 simonpj Exp $
--
-- GHC Driver
--
-----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.43 2004/08/13 13:07:02 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.44 2004/09/30 10:37:11 simonpj Exp $
--
-- Utils for the driver
--
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import BasicTypes ( Fixity )
+import SrcLoc ( SrcLoc, noSrcLoc )
#endif
import RdrName ( RdrName )
import HsSyn ( HsModule )
-import SrcLoc ( SrcLoc, noSrcLoc, Located(..) )
+import SrcLoc ( Located(..) )
import StringBuffer ( hGetStringBuffer )
import Parser
import Lexer ( P(..), ParseResult(..), mkPState )
(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 (L _ (VarPat n)) r _) = (1,0)
+ count_bind (PatBind p r _) = (0,1)
+ count_bind (FunBind f _ m) = (0,1)
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
import NameEnv
import NameSet
import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv,
- extendOccEnv, foldOccEnv )
+ extendOccEnv )
import Module
import InstEnv ( InstEnv, DFunId )
import Rules ( RuleBase )
import Type ( TyThing(..) )
import Class ( Class, classSelIds, classTyCon )
-import TyCon ( TyCon, isClassTyCon, tyConSelIds, tyConDataCons )
+import TyCon ( TyCon, tyConSelIds, tyConDataCons )
import DataCon ( dataConImplicitIds )
import Packages ( PackageName )
import CmdLineOpts ( DynFlags )
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.138 2004/08/13 13:07:05 simonmar Exp $
+-- $Id: Main.hs,v 1.139 2004/09/30 10:37:17 simonpj Exp $
--
-- GHC Driver program
--
cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
cafRefs p (Lam x e) = cafRefs p e
cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
-cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
+-- gaw 2004
+cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
cafRefs p (Note n e) = cafRefs p e
cafRefs p (Type t) = fastBool False
(vbody, vbodyTy) <- vectorise body
return ((Let vbind vbody), vbodyTy)
-vectorise (Case expr b alts) =
+-- gaw 2004
+vectorise (Case expr b ty alts) =
do
(vexpr, vexprTy) <- vectorise expr
valts <- mapM vectorise' alts
- return (Case vexpr (setIdType b vexprTy) (map fst valts), snd (head valts))
+ let res_ty = snd (head valts)
+ return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)
where vectorise' (con, bs, expr) =
do
(vexpr, vexprTy) <- vectorise expr
-- otherwise (a) compute index vector for simpleAlts (for def permute
-- later on
-- (b)
-lift cExpr@(Case expr b alts) =
+-- gaw 2004 FIX?
+lift cExpr@(Case expr b _ alts) =
do
(lExpr, _) <- lift expr
lb <- liftBinderType b -- lift alt-expression
where showBinds (NonRec b e) = showBind (b,e)
showBinds (Rec bnds) = concat (map showBind bnds)
showBind (b,e) = " b = " ++ (showCoreExpr e)++ "\n"
-showCoreExpr (Case ex b alts) =
+-- gaw 2004 FIX?
+showCoreExpr (Case ex b ty alts) =
"Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
where showAlts _ = ""
showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
newExpr = substIdEnv newEnv expr
substBnd (b,e) = (b, substIdEnv newEnv e)
in Let (Rec (map substBnd bnds)) newExpr
-substIdEnv env (Case expr b alts) =
- Case (substIdEnv newEnv expr) b (map substAlt alts)
+-- gaw 2004
+substIdEnv env (Case expr b ty alts) =
+ Case (substIdEnv newEnv expr) b ty (map substAlt alts)
where
newEnv = delVarEnv env b
substAlt (c, bnds, expr) =
(c, bnds, substIdEnv (delVarEnvList env bnds) expr)
substIdEnv env (Note n expr) =
Note n (substIdEnv env expr)
-substIdEnv env e@(Type t) = e
\ No newline at end of file
+substIdEnv env e@(Type t) = e
t2 = arrUsage expr
in if isArrayUsage t1 then Array else t2
-arrUsage (Case expr b alts) =
+-- gaw 2004
+arrUsage (Case expr b _ alts) =
let
t1 = arrUsage expr
t2 = scanType (map (arrUsage . (\ (_,_,x) -> x)) alts)
{ let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4) }
| 'data' tycl_hdr constrs -- No deriving in hi-boot
{ TyClD (mkTyData DataType (unLoc $2) (reverse (unLoc $3)) Nothing) }
+ | 'data' tycl_hdr 'where' gadt_constrlist
+ { TyClD (mkTyData DataType (unLoc $2) (reverse (unLoc $4)) Nothing) }
| 'newtype' tycl_hdr -- Constructor is optional
{ TyClD (mkTyData NewType (unLoc $2) [] Nothing) }
| 'newtype' tycl_hdr '=' newconstr
{ L (comb4 $1 $2 $3 $4)
(mkTyData DataType (unLoc $2) (reverse (unLoc $3)) (unLoc $4)) }
+ | 'data' tycl_hdr 'where' gadt_constrlist -- No deriving for GADTs
+ { L (comb4 $1 $2 $3 $4)
+ (mkTyData DataType (unLoc $2) (reverse (unLoc $4)) Nothing) }
+
| 'newtype' tycl_hdr '=' newconstr deriving
{ L (comb3 $1 $4 $5)
(mkTyData NewType (unLoc $2) [$4] (unLoc $5)) }
-----------------------------------------------------------------------------
-- Types
+strict_mark :: { Located HsBang }
+ : '!' { L1 HsStrict }
+ | '{-# UNPACK' '#-}' '!' { LL HsUnbox }
+
-- A ctype is a for-all type
ctype :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
atype :: { LHsType RdrName }
: 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) }
| '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 }
| '[' type ']' { LL $ HsListTy $2 }
-- It's kept as a single type, with a MonoDictTy at the right
-- hand corner, for convenience.
inst_type :: { LHsType RdrName }
- : ctype {% checkInstType $1 }
+ : sigtype {% checkInstType $1 }
inst_types1 :: { [LHsType RdrName] }
: inst_type { [$1] }
-- Datatype declarations
newconstr :: { LConDecl RdrName }
- : conid atype { LL $ ConDecl $1 [] (noLoc [])
- (PrefixCon [(unbangedType $2)]) }
+ : conid atype { LL $ ConDecl $1 [] (noLoc []) (PrefixCon [$2]) }
| conid '{' var '::' ctype '}'
- { LL $ ConDecl $1 [] (noLoc [])
- (RecCon [($3, (unbangedType $5))]) }
+ { LL $ ConDecl $1 [] (noLoc []) (RecCon [($3, $5)]) }
+
+gadt_constrlist :: { Located [LConDecl RdrName] }
+ : '{' gadt_constrs '}' { LL (unLoc $2) }
+ | vocurly gadt_constrs close { $2 }
+
+gadt_constrs :: { Located [LConDecl RdrName] }
+ : gadt_constrs ';' gadt_constr { LL ($3 : unLoc $1) }
+ | gadt_constr { L1 [$1] }
+
+gadt_constr :: { LConDecl RdrName }
+ : qcon '::' sigtype
+ { LL (GadtDecl $1 $3) }
constrs :: { Located [LConDecl RdrName] }
: {- empty; a GHC extension -} { noLoc [] }
| {- empty -} { noLoc [] }
constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
+-- We parse the constructor declaration
+-- C t1 t2
+-- as a btype (treating C as a type constructor) and then convert C to be
+-- a data constructor. Reason: it might continue like this:
+-- C t1 t2 %: D Int
+-- in which case C really would be a type constructor. We can't resolve this
+-- ambiguity till we come across the constructor oprerator :% (or not, more usually)
: btype {% mkPrefixCon $1 [] >>= return.LL }
- | btype bang_atype satypes {% do { r <- mkPrefixCon $1 ($2 : unLoc $3);
- return (L (comb3 $1 $2 $3) r) } }
| oqtycon '{' '}' {% mkRecCon $1 [] >>= return.LL }
| oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL }
- | sbtype conop sbtype { LL ($2, InfixCon $1 $3) }
-
-bang_atype :: { LBangType RdrName }
- : strict_mark atype { LL (BangType (unLoc $1) $2) }
-
-satypes :: { Located [LBangType RdrName] }
- : atype satypes { LL (unbangedType $1 : unLoc $2) }
- | bang_atype satypes { LL ($1 : unLoc $2) }
- | {- empty -} { noLoc [] }
-
-sbtype :: { LBangType RdrName }
- : btype { unbangedType $1 }
- | strict_mark atype { LL (BangType (unLoc $1) $2) }
+ | btype conop btype { LL ($2, InfixCon $1 $3) }
fielddecls :: { [([Located RdrName], LBangType RdrName)] }
: fielddecl ',' fielddecls { unLoc $1 : $3 }
| fielddecl { [unLoc $1] }
fielddecl :: { Located ([Located RdrName], LBangType RdrName) }
- : sig_vars '::' stype { LL (reverse (unLoc $1), $3) }
-
-stype :: { LBangType RdrName }
- : ctype { unbangedType $1 }
- | strict_mark atype { LL (BangType (unLoc $1) $2) }
-
-strict_mark :: { Located HsBang }
- : '!' { L1 HsStrict }
- | '{-# UNPACK' '#-}' '!' { LL HsUnbox }
+ : sig_vars '::' ctype { LL (reverse (unLoc $1), $3) }
-- We allow the odd-looking 'inst_type' in a deriving clause, so that
-- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
return (LL $ unitOL (LL $ ValD r)) } }
rhs :: { Located (GRHSs RdrName) }
- : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) placeHolderType }
- | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) placeHolderType }
+ : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
+ | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) }
gdrhs :: { Located [LGRHS RdrName] }
: gdrhs gdrh { LL ($2 : unLoc $1) }
exp10 :: { LHsExpr RdrName }
: '\\' aexp aexps opt_asig '->' exp
{% checkPatterns ($2 : reverse $3) >>= \ ps ->
- return (LL $ HsLam (LL $ Match ps $4
+ return (LL $ HsLam (mkMatchGroup [LL $ Match ps $4
(GRHSs (unguardedRHS $6) []
- placeHolderType))) }
+ )])) }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
| 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 }
- | 'case' exp 'of' altslist { LL $ HsCase $2 (unLoc $4) }
+ | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
| '-' fexp { LL $ mkHsNegApp $2 }
| 'do' stmtlist {% let loc = comb2 $1 $2 in
return (LL (Match [p] $2 (unLoc $3))) }
alt_rhs :: { Located (GRHSs RdrName) }
- : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2)
- placeHolderType) }
+ : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2)) }
ralt :: { Located [LGRHS RdrName] }
: '->' exp { LL (unguardedRHS $2) }
-----------------------------------------------------------------------------
-- Data constructors
-qconid :: { Located RdrName } -- Qualified or unqualifiedb
+qconid :: { Located RdrName } -- Qualified or unqualified
: conid { $1 }
| QCONID { L1 $ mkQual dataName (getQCONID $1) }
import ParserCoreUtils
import LexCore
import Literal
-import BasicTypes
import SrcLoc
import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon,
floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
trep :: { OccName -> [LConDecl RdrName] }
: {- empty -} { (\ tc_occ -> []) }
| '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
- con_info = PrefixCon [unbangedType (toHsType $2)] }
+ con_info = PrefixCon [toHsType $2] }
in [noLoc $ ConDecl (noLoc dc_name) []
(noLoc []) con_info]) }
con :: { LConDecl RdrName }
: d_pat_occ attv_bndrs hs_atys
- { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon (map unbangedType $3))}
+ { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3)}
+ | d_pat_occ '::' ty
+ { noLoc $ GadtDecl (noLoc (mkRdrUnqual $1)) (toHsType $3) }
attv_bndrs :: { [LHsTyVarBndr RdrName] }
: {- empty -} { [] }
: fexp { $1 }
| '\\' bndrs '->' exp { foldr IfaceLam $4 $2 }
| '%let' let_bind '%in' exp { IfaceLet $2 $4 }
- | '%case' aexp '%of' id_bndr
- '{' alts1 '}' { IfaceCase $2 (fst $4) $6 }
+-- gaw 2004
+ | '%case' '(' ty ')' aexp '%of' id_bndr
+ '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 }
| '%coerce' aty exp { IfaceNote (IfaceCoerce $2) $3 }
| '%note' STRING exp
{ case $2 of
| otherwise = acc
extract_lty ty acc = extract_ty (unLoc ty) acc
+extract_ty (HsBangTy _ ty) acc = extract_lty ty acc
extract_ty (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
extract_ty (HsListTy ty) acc = extract_lty ty acc
extract_ty (HsPArrTy ty) acc = extract_lty ty acc
extractGenericPatTyVars binds
= nubBy eqLocated (foldrBag get [] binds)
where
- get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms
- get other acc = acc
+ get (L _ (FunBind _ _ (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
%* *
%************************************************************************
-mkBootIface, and its boring helper functions, have two purposes:
+mkBootIface, and its deeply boring helper functions, have two purposes:
+
a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
an hi-boot file, and interfaces consist of the latter
+
b) Convert unqualifed names from the "current module" to qualified Orig
names. E.g.
module This where
becomes
This.foo :: GHC.Base.Int -> GHC.Base.Int
-It assumes that everything is well kinded, of course.
+It assumes that everything is well kinded, of course. Failure causes a
+fatal error using pgmError, rather than a monadic error. You're supposed
+to get hi-boot files right!
+
\begin{code}
mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
ifType = hsIfaceLType ty,
ifIdInfo = NoInfo }
+hsIfaceDecl (TyClD decl@(ClassDecl {}))
+ = IfaceClass { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
+ ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
+ ifSigs = [], -- Is this right??
+ ifRec = NonRecursive, ifVrcs = [] }
+
hsIfaceDecl (TyClD decl@(TySynonym {}))
= IfaceSyn { ifName = rdrNameOcc (tcdName decl),
ifTyVars = hsIfaceTvs (tcdTyVars decl),
hsIfaceDecl (TyClD decl@(TyData {}))
= IfaceData { ifName = rdrNameOcc (tcdName decl),
- ifTyVars = hsIfaceTvs (tcdTyVars decl),
- ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
- ifCons = hsIfaceCons (tcdND decl) (tcdCons decl),
+ ifTyVars = tvs,
+ ifCons = hsIfaceCons tvs decl,
ifRec = NonRecursive,
ifVrcs = [], ifGeneric = False }
-- I'm not sure that [] is right for ifVrcs, but
-- since we don't use them I'm not going to fiddle
-
-hsIfaceDecl (TyClD decl@(ClassDecl {}))
- = IfaceClass { ifName = rdrNameOcc (tcdName decl),
- ifTyVars = hsIfaceTvs (tcdTyVars decl),
- ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
- ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
- ifSigs = [], -- Is this right??
- ifRec = NonRecursive, ifVrcs = [] }
-
-hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
-
-hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls
-hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified",
- = IfAbstractTyCon -- not "no constructors"
-
-hsIfaceCons DataType cons -- data type
- = IfDataTyCon (map (hsIfaceCon . unLoc) cons)
-
-hsIfaceCons NewType [con] -- newtype
- = IfNewTyCon (hsIfaceCon (unLoc con))
-
-
-hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
-hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
- = IfaceConDecl (get_occ lname) is_infix
- (hsIfaceTvs ex_tvs)
- (hsIfaceCtxt (unLoc ex_ctxt))
- (map (hsIfaceLType . getBangType . unLoc) args)
- (map (hsStrictMark . getBangStrictness . unLoc) args)
- flds
+ where
+ tvs = hsIfaceTvs (tcdTyVars decl)
+
+hsIfaceDecl decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
+
+hsIfaceCons :: [IfaceTvBndr] -> TyClDecl RdrName -> IfaceConDecls
+hsIfaceCons tvs decl@(TyData {tcdCtxt = L _ stupid_ctxt})
+ | not (null stupid_ctxt) -- Keep it simple: no data type contexts
+ -- Else we'll have to do "thinning"; sigh
+ = pprPgmError "Can't do data type contexts in hi-boot file:" (ppr decl)
+
+hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = []})
+ = -- data T a, meaning "constructors unspecified",
+ IfAbstractTyCon -- not "no constructors"
+
+hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = cons})
+ = IfDataTyCon Nothing (map (hsIfaceCon tvs . unLoc) cons)
+
+hsIfaceCons tvs (TyData {tcdND = NewType, tcdCons = [con]})
+ = IfNewTyCon (hsIfaceCon tvs (unLoc con))
+
+hsIfaceCons tvs decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
+
+
+hsIfaceCon :: [IfaceTvBndr] -> ConDecl RdrName -> IfaceConDecl
+hsIfaceCon tvs (ConDecl lname ex_tvs ex_ctxt details)
+ | null ex_tvs && null (unLoc ex_ctxt)
+ = IfVanillaCon { ifConOcc = get_occ lname,
+ ifConInfix = is_infix,
+ ifConArgTys = map hsIfaceLType args,
+ ifConStricts = map (hsStrictMark . getBangStrictness) args,
+ ifConFields = flds }
+ | null flds
+ = IfGadtCon { ifConOcc = get_occ lname,
+ ifConTyVars = tvs ++ hsIfaceTvs ex_tvs,
+ ifConCtxt = hsIfaceCtxt (unLoc ex_ctxt),
+ ifConArgTys = map hsIfaceLType args,
+ ifConResTys = map (IfaceTyVar . fst) tvs,
+ ifConStricts = map (hsStrictMark . getBangStrictness) args }
+ | otherwise = pprPgmError "Fields illegal in existential" (ppr (unLoc lname))
where
(is_infix, args, flds) = case details of
PrefixCon args -> (False, args, [])
RecCon fs -> (False, map snd fs, map (get_occ . fst) fs)
get_occ lname = rdrNameOcc (unLoc lname)
+hsIfaceCon _tvs (GadtDecl lname con_ty) -- Not yet
+ = pprPgmError "Can't use GADTs in hi-boot files (yet)" (ppr (unLoc lname))
+
hsStrictMark :: HsBang -> StrictnessMark
-- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
-- but in an hi-boot file it's interpreted as the Truth!
hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
hsIfaceType (HsParTy t) = hsIfaceLType t
+hsIfaceType (HsBangTy _ t) = hsIfaceLType t
hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
hsIfaceType (HsKindSig t _) = hsIfaceLType t
-hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
-hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy"
+hsIfaceType ty = pprPanic "hsIfaceType" (ppr ty)
+ -- HsNumTy, HsSpliceTy
-----------
hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
-----------
+hsIfaceTvs :: [LHsTyVarBndr RdrName] -> [IfaceTvBndr]
hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
-----------
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
+-- gaw 2004
+getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds
| has_args mtchs
= go mtchs loc binds
where
- go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
+ go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds)
| f == unLoc f2 = go (mtchs2++mtchs1) loc binds
where loc = combineSrcSpans loc1 loc2
go mtchs1 loc binds
- = (L loc (FunBind lf inf (reverse mtchs1)), binds)
+ = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds)
-- reverse the final matches, to get it back in the right order
getMonoBind bind binds = (bind, binds)
mkPrefixCon ty tys
= split ty tys
where
- split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
+ split (L _ (HsAppTy t u)) ts = split t (u : ts)
split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc
return (data_con, PrefixCon ts)
split (L l _) _ = parseError l "parse error in data/newtype declaration"
showRdrName (unLoc f))
else do ps <- checkPatterns es
let match_span = combineSrcSpans (getLoc lhs) rhs_span
- return (FunBind f inf [L match_span (Match ps opt_sig grhss)])
- -- the span of the match covers the entire equation. That isn't
- -- quite right, but it'll do for now.
+ return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)]))
+ -- The span of the match covers the entire equation.
+ -- That isn't quite right, but it'll do for now.
| otherwise = do
lhs <- checkPattern lhs
- return (PatBind lhs grhss)
-
+ return (PatBind lhs grhss placeHolderType)
checkValSig
:: LHsExpr RdrName
, float2DoubleLit, double2FloatLit
)
import PrimOp ( PrimOp(..), primOpOcc )
-import TysWiredIn ( trueDataConId, falseDataConId )
+-- gaw 2004
+import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
import CoreUtils ( cheapEqExpr, exprIsConApp_maybe )
litEq is_eq other = Nothing
do_lit_eq is_eq lit expr
- = Just (Case expr (mkWildId (literalType lit))
+-- gaw 2004
+ = Just (Case expr (mkWildId (literalType lit)) boolTy
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
where
mkTupleTyCon, mkAlgTyCon, tyConName
)
-import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..),
- Fixity(..), FixityDirection(..), defaultFixity )
+import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) )
-import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys,
- ThetaType, TyThing(..) )
+import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, TyThing(..) )
import Kind ( mkArrowKinds, liftedTypeKind, ubxTupleKind )
import Unique ( incrUnique, mkTupleTyConUnique,
mkTupleDataConUnique, mkPArrDataConUnique )
tycon = mkAlgTyCon name
(mkArrowKinds (map tyVarKind tyvars) liftedTypeKind)
tyvars
- [] -- No context
argvrcs
- (DataTyCon cons is_enum)
- [] -- No record selectors
+ (DataTyCon (Just []) cons is_enum)
+ [] -- No record selectors
is_rec
True -- All the wired-in tycons have generics
pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon
= data_con
where
- data_con = mkDataCon dc_name declared_infix
+ data_con = mkDataCon dc_name declared_infix True {- Vanilla -}
(map (const NotMarkedStrict) arg_tys)
[{- No labelled fields -}]
- tyvars [] [] [] arg_tys tycon
+ tyvars [] [] arg_tys tycon (mkTyVarTys tyvars)
(mkDataConIds bogus_wrap_name wrk_name data_con)
+
mod = nameModule dc_name
wrk_occ = mkDataConWorkerOcc (nameOccName dc_name)
import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, rnLPat )
-import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch )
+import RnExpr ( rnMatchGroup, rnMatch, rnGRHSs, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn,
lookupLocatedInstDeclBndr,
lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV,
import SrcLoc ( mkSrcSpan, Located(..), unLoc )
import Bag
import Outputable
-
import Monad ( foldM )
-
-import SrcLoc (getLoc) -- tmp
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
contains bindings for the binders of this particular binding.
\begin{code}
-rnTopBinds :: Bag (LHsBind RdrName)
+rnTopBinds :: LHsBinds RdrName
-> [LSig RdrName]
-> RnM ([HsBindGroup Name], DefUses)
\begin{code}
rnBinds :: TopLevelFlag
- -> Bag (LHsBind RdrName)
+ -> LHsBinds RdrName
-> [LSig RdrName]
-> RnM ([HsBindGroup Name], DefUses)
\begin{code}
mkBindVertices :: [LSig Name] -- Signatures
- -> Bag (LHsBind RdrName)
+ -> LHsBinds RdrName
-> RnM [BindVertex]
mkBindVertices sigs = mapM (mkBindVertex sigs) . bagToList
mkBindVertex :: [LSig Name] -> LHsBind RdrName -> RnM BindVertex
-mkBindVertex sigs (L loc (PatBind pat grhss))
- = addSrcSpan loc $
+mkBindVertex sigs (L loc (PatBind pat grhss ty))
+ = setSrcSpan loc $
rnLPat pat `thenM` \ (pat', pat_fvs) ->
-- Find which things are bound in this group
rnGRHSs PatBindRhs grhss `thenM` \ (grhss', fvs) ->
returnM
(names_bound_here, fvs `plusFV` pat_fvs,
- L loc (PatBind pat' grhss'), sigs_for_me
+ L loc (PatBind pat' grhss' ty), sigs_for_me
)
mkBindVertex sigs (L loc (FunBind name inf matches))
- = addSrcSpan loc $
+ = setSrcSpan loc $
lookupLocatedBndrRn name `thenM` \ new_name ->
let
plain_name = unLoc new_name
names_bound_here = unitNameSet plain_name
in
sigsForMe names_bound_here sigs `thenM` \ sigs_for_me ->
- mapFvRn (rnMatch (FunRhs plain_name)) matches `thenM` \ (new_matches, fvs) ->
- mappM_ (checkPrecMatch inf plain_name) new_matches `thenM_`
+ rnMatchGroup (FunRhs plain_name) matches `thenM` \ (new_matches, fvs) ->
+ checkPrecMatch inf plain_name new_matches `thenM_`
returnM
(unitNameSet plain_name, fvs,
L loc (FunBind new_name inf new_matches), sigs_for_me
\begin{code}
rnMethodBinds :: Name -- Class name
-> [Name] -- Names for generic type variables
- -> (LHsBinds RdrName)
+ -> LHsBinds RdrName
-> RnM (LHsBinds Name, FreeVars)
rnMethodBinds cls gen_tyvars binds
(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 matches))
- = addSrcSpan loc $
+rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _)))
+ = setSrcSpan loc $
lookupLocatedInstDeclBndr cls name `thenM` \ sel_name ->
let plain_name = unLoc sel_name in
-- We use the selector name as the binder
mapFvRn (rn_match plain_name) matches `thenM` \ (new_matches, fvs) ->
- mappM_ (checkPrecMatch inf plain_name) new_matches `thenM_`
- returnM (unitBag (L loc (FunBind sel_name inf new_matches)), fvs `addOneFV` plain_name)
+ let
+ 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 `addOneFV` plain_name)
where
- -- Gruesome; bring into scope the correct members of the generic type variables
- -- See comments in RnSource.rnSourceDecl(ClassDecl)
+ -- Truly gruesome; bring into scope the correct members of the generic
+ -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl)
rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _))
= extendTyVarEnvFVRn gen_tvs $
rnMatch (FunRhs sel_name) match
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _))
+rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _ _))
= addLocErr mbind methodBindErr `thenM_`
returnM (emptyBag, emptyFVs)
\end{code}
isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv,
Provenance(..), pprNameProvenance, ImportSpec(..)
)
-import HsTypes ( hsTyVarName, replaceTyVarName )
+import HsTypes ( replaceTyVarName )
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity )
import TcRnMonad
import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName,
nameSrcLoc, nameOccName, nameModuleName, nameParent )
import NameSet
-import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused,
- isVarOcc )
+import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused )
import Module ( Module, ModuleName, moduleName, mkHomeModule )
import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE, consDataConKey, hasKey )
import UniqSupply
lookupLocatedBndrRn = wrapLocM lookupBndrRn
lookupBndrRn :: RdrName -> RnM Name
--- NOTE: assumes that the SrcSpan of the binder has already been addSrcSpan'd
+-- NOTE: assumes that the SrcSpan of the binder has already been setSrcSpan'd
lookupBndrRn rdr_name
= getLocalRdrEnv `thenM` \ local_env ->
case lookupLocalRdrEnv local_env rdr_name of
-> RnM a
bindTyVarsRn doc_str tyvar_names enclosed_scope
= let
- located_tyvars = [L loc (hsTyVarName tv) | L loc tv <- tyvar_names]
+ located_tyvars = hsLTyVarLocNames tyvar_names
in
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
enclosed_scope (zipWith replace tyvar_names names)
check_shadow (L loc rdr_name)
| rdr_name `elemLocalRdrEnv` local_env
|| not (null (lookupGRE_RdrName rdr_name global_env ))
- = addSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name)
+ = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name)
| otherwise = returnM ()
in
mappM_ check_shadow loc_rdr_names
warnUnusedModules mods
= ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
where
- bleat (mod,loc) = addSrcSpan loc $ addWarn (mk_warn mod)
+ bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod)
mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
text "is imported, but nothing from it is used",
parens (ptext SLIT("except perhaps instances visible in") <+>
-- The rdrNameOcc is because we don't want to print Prelude.(,)
dupNamesErr descriptor (L loc name : dup_things)
- = addSrcSpan loc $
+ = setSrcSpan loc $
addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
$$
descriptor)
\begin{code}
module RnExpr (
- rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
+ rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
checkPrecMatch, checkTH
) where
************************************************************************
\begin{code}
+rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
+rnMatchGroup ctxt (MatchGroup ms _)
+ = mapFvRn (rnMatch ctxt) ms `thenM` \ (new_ms, ms_fvs) ->
+ returnM (MatchGroup new_ms placeHolderType, ms_fvs)
+
rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
rnMatch ctxt = wrapLocFstM (rnMatch' ctxt)
\begin{code}
rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
-rnGRHSs ctxt (GRHSs grhss binds _)
+-- gaw 2004
+rnGRHSs ctxt (GRHSs grhss binds)
= rnBindGroupsAndThen binds $ \ binds' ->
mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
- returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
+ returnM (GRHSs grhss' binds', fvGRHSs)
rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
= rnOverLit lit `thenM` \ (lit', fvs) ->
returnM (HsOverLit lit', fvs)
-rnExpr (HsLam match)
- = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) ->
- returnM (HsLam match', fvMatch)
-
rnExpr (HsApp fun arg)
= rnLExpr fun `thenM` \ (fun',fvFun) ->
rnLExpr arg `thenM` \ (arg',fvArg) ->
= rnLExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsSCC lbl expr', fvs_expr)
-rnExpr (HsCase expr ms)
+rnExpr (HsLam matches)
+ = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
+ returnM (HsLam matches', fvMatch)
+
+rnExpr (HsCase expr matches)
= rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
- mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
- returnM (HsCase new_expr new_ms, e_fvs `plusFV` ms_fvs)
+ rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
+ returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
rnExpr (HsLet binds expr)
= rnBindGroupsAndThen binds $ \ binds' ->
convertOpFormsCmd :: HsCmd id -> HsCmd id
convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
-
convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
-
convertOpFormsCmd (OpApp c1 op fixity c2)
= let
arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
+-- gaw 2004
convertOpFormsCmd (HsCase exp matches)
- = HsCase exp (map convertOpFormsMatch matches)
+ = HsCase exp (convertOpFormsMatch matches)
convertOpFormsCmd (HsIf exp c1 c2)
= HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
= RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es
convertOpFormsStmt stmt = stmt
-convertOpFormsMatch = fmap convert
+convertOpFormsMatch (MatchGroup ms ty)
+ = MatchGroup (map (fmap convert) ms) ty
where convert (Match pat mty grhss)
= Match pat mty (convertOpFormsGRHSs grhss)
-convertOpFormsGRHSs (GRHSs grhss binds ty)
- = GRHSs (map convertOpFormsGRHS grhss) binds ty
+convertOpFormsGRHSs (GRHSs grhss binds)
+ = GRHSs (map convertOpFormsGRHS grhss) binds
convertOpFormsGRHS = fmap convert
where convert (GRHS stmts)
methodNamesCmd (HsLam match) = methodNamesMatch match
methodNamesCmd (HsCase scrut matches)
- = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
+ = methodNamesMatch matches `addOneFV` choiceAName
methodNamesCmd other = emptyFVs
-- Other forms can't occur in commands, but it's not convenient
-- The type checker will complain later
---------------------------------------------------
-methodNamesMatch (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
+methodNamesMatch (MatchGroup ms ty)
+ = plusFVs (map do_one ms)
+ where
+ do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
-------------------------------------------------
-methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
+-- gaw 2004
+methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss)
-------------------------------------------------
methodNamesGRHS (L _ (GRHS stmts)) = methodNamesLStmt (last stmts)
\end{code}
\begin{code}
-checkPrecMatch :: Bool -> Name -> LMatch Name -> RnM ()
+checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
+ -- True indicates an infix lhs
+ -- See comments with rnExpr (OpApp ...) about "deriving"
-checkPrecMatch False fn match
+checkPrecMatch False fn match
= returnM ()
+checkPrecMatch True op (MatchGroup ms _)
+ = mapM_ check ms
+ where
+ check (L _ (Match (p1:p2:_) _ _))
+ = checkPrec op (unLoc p1) False `thenM_`
+ checkPrec op (unLoc p2) True
-checkPrecMatch True op (L _ (Match (p1:p2:_) _ _))
- -- True indicates an infix lhs
- = -- See comments with rnExpr (OpApp ...) about "deriving"
- checkPrec op (unLoc p1) False `thenM_`
- checkPrec op (unLoc p2) True
-
-checkPrecMatch True op _ = panic "checkPrecMatch"
+ check _ = panic "checkPrecMatch"
checkPrec op (ConPatIn op1 (InfixCon _ _)) right
= lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
+-- gaw 2004
import SrcLoc ( Located(..), unLoc )
\end{code}
get (HsPredTy p) = extractHsPredTyNames p
get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
get (HsParTy ty) = getl ty
+ get (HsBangTy _ ty) = getl ty
get (HsNumTy n) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsSpliceTy _) = emptyNameSet -- Type splices mention no type variables
= delFVs (map hsLTyVarName tyvars) $
extractHsCtxtTyNames context `plusFV`
conDetailsFVs details
+-- gaw 2004
+conDeclFVs (L _ (GadtDecl _ ty))
+ = extractHsTyNames ty
-conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys)
+conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys)
conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2
conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds]
-bangTyFVs bty = extractHsTyNames (getBangType (unLoc bty))
+bangTyFVs bty = extractHsTyNames (getBangType bty)
\end{code}
nameParent, nameParent_maybe, isExternalName, nameModule,
isBuiltInSyntax )
import NameSet
-import NameEnv
import OccName ( srcDataName, isTcOcc, occNameFlavour, OccEnv,
mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv )
import HscTypes ( GenAvailInfo(..), AvailInfo, Avails, GhciMode(..),
Provenance(..), ImportSpec(..),
isLocalGRE, pprNameProvenance )
import Outputable
-import Maybes ( isJust, isNothing, catMaybes, mapCatMaybes, seqMaybe )
+import Maybes ( isNothing, catMaybes, mapCatMaybes, seqMaybe )
import SrcLoc ( noSrcLoc, Located(..), mkGeneralSrcSpan,
unLoc, noLoc, srcLocSpan, SrcSpan )
import BasicTypes ( DeprecTxt )
importsFromImportDecl this_mod
(L loc (ImportDecl loc_imp_mod_name want_boot qual_only as_mod imp_details))
=
- addSrcSpan loc $
+ setSrcSpan loc $
-- If there's an error in loadInterface, (e.g. interface
-- file not found) we get lots of spurious errors from 'filterImports'
check hpt pit (GRE {gre_name = name, gre_prov = Imported (imp_spec:_) _})
| name `elemNameSet` used_names
, Just deprec_txt <- lookupDeprec hpt pit name
- = addSrcSpan (is_loc imp_spec) $
+ = setSrcSpan (is_loc imp_spec) $
addWarn (sep [ptext SLIT("Deprecated use of") <+>
occNameFlavour (nameOccName name) <+>
quotes (ppr name),
import NameSet
import NameEnv
import Outputable
-import SrcLoc ( Located(..), unLoc, getLoc )
+import SrcLoc ( Located(..), unLoc, getLoc, noLoc )
import CmdLineOpts ( DynFlag(..) )
-- Warn of unused for-all'd tyvars
import Maybes ( seqMaybe )
rnFixityDecl :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity))
- = addSrcSpan loc $
+ = setSrcSpan loc $
-- GHC extension: look up both the tycon and data con
-- for con-like things
-- If neither are in scope, report an error; otherwise
emptyFVs)
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
- tcdTyVars = tyvars, tcdCons = condecls,
- tcdDerivs = derivs})
- = lookupLocatedTopBndrRn tycon `thenM` \ tycon' ->
- bindTyVarsRn data_doc tyvars $ \ tyvars' ->
- rnContext data_doc context `thenM` \ context' ->
- rn_derivs derivs `thenM` \ (derivs', deriv_fvs) ->
- checkDupNames data_doc con_names `thenM_`
- rnConDecls (unLoc tycon') condecls `thenM` \ condecls' ->
- returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
- tcdTyVars = tyvars', tcdCons = condecls',
- tcdDerivs = derivs'},
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context' `plusFV`
- plusFVs (map conDeclFVs condecls') `plusFV`
- deriv_fvs)
+ tcdTyVars = tyvars, tcdCons = condecls,
+ tcdDerivs = derivs})
+ | is_vanilla -- Normal Haskell data type decl
+ = bindTyVarsRn data_doc tyvars $ \ tyvars' ->
+ do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; context' <- rnContext data_doc context
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
+ ; checkDupNames data_doc con_names
+ ; condecls' <- rnConDecls (unLoc tycon') condecls
+ ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
+ tcdTyVars = tyvars', tcdCons = condecls',
+ tcdDerivs = derivs'},
+ delFVs (map hsLTyVarName tyvars') $
+ extractHsCtxtTyNames context' `plusFV`
+ plusFVs (map conDeclFVs condecls') `plusFV`
+ deriv_fvs) }
+
+ | otherwise -- GADT
+ = ASSERT( null (unLoc context) )
+ do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; tyvars' <- bindTyVarsRn data_doc tyvars
+ (\ tyvars' -> return tyvars')
+ -- For GADTs, the type variables in the declaration
+ -- do not scope over the constructor signatures
+ -- data T a where { T1 :: forall b. b-> b }
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
+ ; checkDupNames data_doc con_names
+ ; condecls' <- rnConDecls (unLoc tycon') condecls
+ ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
+ tcdTyVars = tyvars', tcdCons = condecls',
+ tcdDerivs = derivs'},
+ plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
+
where
+ is_vanilla = case condecls of -- Yuk
+ [] -> True
+ L _ (ConDecl {}) : _ -> True
+ other -> False
+
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
- con_names = [ n | L _ (ConDecl n _ _ _) <- condecls ]
+ con_names = map con_names_helper condecls
+
+ con_names_helper (L _ (ConDecl n _ _ _)) = n
+ con_names_helper (L _ (GadtDecl n _)) = n
rn_derivs Nothing = returnM (Nothing, emptyFVs)
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
+rnConDecl (GadtDecl name ty)
+ = addLocM checkConName name `thenM_`
+ lookupLocatedTopBndrRn name `thenM` \ new_name ->
+ rnHsSigType doc ty `thenM` \ new_ty ->
+ returnM (GadtDecl new_name new_ty)
+ where
+ doc = text "In the definition of data constructor" <+> quotes (ppr name)
+
rnConDetails doc (PrefixCon tys)
- = mappM (rnLBangTy doc) tys `thenM` \ new_tys ->
+ = mappM (rnLHsType doc) tys `thenM` \ new_tys ->
returnM (PrefixCon new_tys)
rnConDetails doc (InfixCon ty1 ty2)
- = rnLBangTy doc ty1 `thenM` \ new_ty1 ->
- rnLBangTy doc ty2 `thenM` \ new_ty2 ->
+ = rnLHsType doc ty1 `thenM` \ new_ty1 ->
+ rnLHsType doc ty2 `thenM` \ new_ty2 ->
returnM (InfixCon new_ty1 new_ty2)
rnConDetails doc (RecCon fields)
rnField doc (name, ty)
= lookupLocatedTopBndrRn name `thenM` \ new_name ->
- rnLBangTy doc ty `thenM` \ new_ty ->
+ rnLHsType doc ty `thenM` \ new_ty ->
returnM (new_name, new_ty)
-rnLBangTy doc = wrapLocM (rnBangTy doc)
-
-rnBangTy doc (BangType s ty)
- = rnLHsType doc ty `thenM` \ new_ty ->
- returnM (BangType s new_ty)
-
-- This data decl will parse OK
-- data T = a Int
-- treating "a" as the constructor.
newLocalsRn [L loc n] `thenM` \ [n'] ->
rnLExpr expr `thenM` \ (expr', fvs) ->
returnM (HsSplice n' expr', fvs)
-\end{code}
\ No newline at end of file
+\end{code}
returnM (HsTyVar tyvar')
rnHsType doc (HsOpTy ty1 (L loc op) ty2)
- = addSrcSpan loc (
+ = setSrcSpan loc (
lookupOccRn op `thenM` \ op' ->
lookupTyFixityRn (L loc op') `thenM` \ fix ->
rnLHsType doc ty1 `thenM` \ ty1' ->
= rnLHsType doc ty `thenM` \ ty' ->
returnM (HsParTy ty')
+rnHsType doc (HsBangTy b ty)
+ = rnLHsType doc ty `thenM` \ ty' ->
+ returnM (HsBangTy b ty')
+
rnHsType doc (HsNumTy i)
| i == 1 = returnM (HsNumTy i)
| otherwise = addErr err_msg `thenM_` returnM (HsNumTy i)
\begin{code}
-rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] -> LHsContext RdrName
- -> LHsType RdrName -> RnM (HsType Name)
+rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
+ -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty
-- One reason for this case is that a type like Int#
lookupTyFixityRn (L loc n)
= doptM Opt_GlasgowExts `thenM` \ glaExts ->
when (not glaExts)
- (addSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_`
+ (setSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_`
lookupFixityRn n
-- Building (ty1 `op1` (ty21 `op2` ty22))
forAllWarn doc ty (L loc tyvar)
= ifOptM Opt_WarnUnusedMatches $
- addSrcSpan loc $
+ setSrcSpan loc $
addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
$$
import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
import DataCon ( isUnboxedTupleCon )
import Type ( tyConAppArgs )
-import Subst ( InScopeSet, uniqAway, emptyInScopeSet,
- extendInScopeSet, elemInScopeSet )
import CoreSyn
import VarEnv
import CoreLint ( showPass, endPass )
in Lam b' (cseExpr env' e)
cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
in Let bind' (cseExpr env' e)
-cseExpr env (Case scrut bndr alts) = Case scrut' bndr' (cseAlts env' scrut' bndr bndr' alts)
+-- gaw 2004
+cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts)
where
scrut' = tryForCSE env scrut
(env', bndr') = addBinder env bndr
alternatives/default [default FVs always {\em first}!].
\begin{code}
-fiExpr to_drop (_, AnnCase scrut case_bndr alts)
+-- gaw 2004
+fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
= mkCoLets' drop_here1 $
mkCoLets' drop_here2 $
- Case (fiExpr scrut_drops scrut) case_bndr
+ Case (fiExpr scrut_drops scrut) case_bndr ty
(zipWith fi_alt alts_drops_s alts)
where
-- Float into the scrut and alts-considered-together just like App
where
bind_lvl = getBindLevel bind
-floatExpr lvl (Case scrut (TB case_bndr case_lvl) alts)
+-- gaw 2004
+floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts)
= case floatExpr lvl scrut of { (fse, fde, scrut') ->
case floatList float_alt alts of { (fsa, fda, alts') ->
- (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr alts')
+ (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr ty alts')
}}
where
-- Use floatRhs for the alternatives, so that we
where
(env_body, bind') = libCaseBind env bind
-libCase env (Case scrut bndr alts)
- = Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts)
+-- gaw 2004
+libCase env (Case scrut bndr ty alts)
+ = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)
where
env_alts = addBinders env_with_scrut [bndr]
env_with_scrut = case scrut of
env2 = env1 `addNewCands` binders -- Add in-scope binders
env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext
-occAnal env (Case scrut bndr alts)
+-- gaw 2004
+occAnal env (Case scrut bndr ty alts)
= case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') ->
-- No need for rhsCtxt
(alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
total_usage = scrut_usage `combineUsageDetails` alts_usage1
in
- total_usage `seq` (total_usage, Case scrut' tagged_bndr alts') }}
+-- gaw 2004
+ total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
where
alt_env = env `addNewCand` bndr
lvlMFE False ctxt_lvl env arg `thenLvl` \ arg' ->
returnLvl (App fun' arg')
where
- lvl_fun (_, AnnCase _ _ _) = lvlMFE True ctxt_lvl env fun
+-- gaw 2004
+ lvl_fun (_, AnnCase _ _ _ _) = lvlMFE True ctxt_lvl env fun
lvl_fun other = lvlExpr ctxt_lvl env fun
-- We don't do MFE on partial applications generally,
-- but we do if the function is big and hairy, like a case
lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
returnLvl (Let bind' body')
-lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
+-- gaw 2004
+lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts)
= lvlMFE True ctxt_lvl env expr `thenLvl` \ expr' ->
let
alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl
in
mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' ->
- returnLvl (Case expr' (TB case_bndr incd_lvl) alts')
+ returnLvl (Case expr' (TB case_bndr incd_lvl) ty alts')
where
incd_lvl = incMinorLvl ctxt_lvl
extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl
= (float_lams,
extendVarEnv lvl_env case_bndr lvl,
- extendSubst subst case_bndr (DoneEx (Var scrut_var)),
+ extendIdSubst subst case_bndr (DoneEx (Var scrut_var)),
extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var))
extendCaseBndrLvlEnv env scrut case_bndr lvl
foldl add_id id_env bndr_pairs)
where
add_lvl env (v,v') = extendVarEnv env v' dest_lvl
- add_subst env (v,v') = extendSubst env v (DoneEx (mkVarApps (Var v') abs_vars))
+ add_subst env (v,v') = extendIdSubst env v (DoneEx (mkVarApps (Var v') abs_vars))
add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs
import SimplMonad
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
import CoreLint ( endPass )
-import Subst ( mkInScopeSet )
+import VarEnv ( mkInScopeSet )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import Id ( idIsFrom, idSpecialisation, setIdSpecialisation )
getEnclosingCC, setEnclosingCC,
-- Environments
- SimplEnv, emptySimplEnv, getSubst, setSubst,
- getSubstEnv, extendSubst, extendSubstList,
+ SimplEnv, emptySimplEnv, getSubst, setSubst, extendIdSubst, extendTvSubst,
+ zapSubstEnv, setSubstEnv, getTvSubst, setTvSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
- setSubstEnv, zapSubstEnv,
-- Floats
Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
import CostCentre ( CostCentreStack, subsumedCCS )
import Var
import VarEnv
-import VarSet
import OrdList
import qualified Subst
-import Subst ( Subst, emptySubst, substEnv,
- InScopeSet, mkInScopeSet, substInScope,
- isInScope
- )
-import Type ( Type, isUnLiftedType )
+import Subst ( Subst, SubstResult, emptySubst, substInScope, isInScope )
+import Type ( Type, TvSubst, TvSubstEnv, isUnLiftedType )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
UniqSupply
)
unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
-- A single non-rec float; extend the in-scope set
unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
- (Subst.extendInScopeSet (getInScope env) var)
+ (extendInScopeSet (getInScope env) var)
(not (isUnLiftedType (idType var)))
addFloats :: SimplEnv -> Floats
getSubst :: SimplEnv -> Subst
getSubst env = seSubst env
+getTvSubst :: SimplEnv -> TvSubst
+getTvSubst env = Subst.getTvSubst (seSubst env)
+
+setTvSubstEnv :: SimplEnv -> TvSubstEnv -> SimplEnv
+setTvSubstEnv env@(SimplEnv {seSubst = subst}) tv_subst_env
+ = env {seSubst = Subst.setTvSubstEnv subst tv_subst_env}
+
setSubst :: SimplEnv -> Subst -> SimplEnv
setSubst env subst = env {seSubst = subst}
-extendSubst :: SimplEnv -> CoreBndr -> SubstResult -> SimplEnv
-extendSubst env@(SimplEnv {seSubst = subst}) var res
- = env {seSubst = Subst.extendSubst subst var res}
+extendIdSubst :: SimplEnv -> Id -> SubstResult -> SimplEnv
+extendIdSubst env@(SimplEnv {seSubst = subst}) var res
+ = env {seSubst = Subst.extendIdSubst subst var res}
-extendSubstList :: SimplEnv -> [CoreBndr] -> [SubstResult] -> SimplEnv
-extendSubstList env@(SimplEnv {seSubst = subst}) vars ress
- = env {seSubst = Subst.extendSubstList subst vars ress}
+extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
+extendTvSubst env@(SimplEnv {seSubst = subst}) var res
+ = env {seSubst = Subst.extendTvSubst subst var res}
---------------------
getInScope :: SimplEnv -> InScopeSet
setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope
- = env {seSubst = Subst.setInScope subst in_scope}
+ = env {seSubst = Subst.setInScopeSet subst in_scope}
addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
-- The new Ids are guaranteed to be freshly allocated
addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs
- = env {seSubst = Subst.extendNewInScopeList subst vs}
+ = env {seSubst = Subst.extendInScopeIds subst vs}
modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
modifyInScope env@(SimplEnv {seSubst = subst}) v v'
= env {seSubst = Subst.modifyInScope subst v v'}
---------------------
-getSubstEnv :: SimplEnv -> SubstEnv
-getSubstEnv env = substEnv (seSubst env)
-
-setSubstEnv :: SimplEnv -> SubstEnv -> SimplEnv
-setSubstEnv env@(SimplEnv {seSubst = subst}) senv
- = env {seSubst = Subst.setSubstEnv subst senv}
-
zapSubstEnv :: SimplEnv -> SimplEnv
zapSubstEnv env@(SimplEnv {seSubst = subst})
= env {seSubst = Subst.zapSubstEnv subst}
+
+setSubstEnv :: SimplEnv -> Subst -> SimplEnv
+setSubstEnv env@(SimplEnv {seSubst = subst}) subst_with_env
+ = env {seSubst = Subst.setSubstEnv subst subst_with_env}
\end{code}
SimplCont(..), DupFlag(..), LetRhsFlag(..),
contIsDupable, contResultType,
countValArgs, countArgs, pushContArgs,
- mkBoringStop, mkStop, contIsRhs, contIsRhsOrArg,
+ mkBoringStop, mkRhsStop, contIsRhs, contIsRhsOrArg,
getContArgs, interestingCallContext, interestingArg, isStrictType
) where
import Name ( mkSysTvName )
import OccName ( EncodedFS )
import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
-import DataCon ( dataConRepArity, dataConExistentialTyVars, dataConArgTys )
+import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon )
import Var ( tyVarKind, mkTyVar )
import VarSet
import Util ( lengthExceeds, mapAccumL )
-------------------
-mkBoringStop :: OutType -> SimplCont
+mkBoringStop, mkRhsStop :: OutType -> SimplCont
mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
-
-mkStop :: OutType -> LetRhsFlag -> SimplCont
-mkStop ty is_rhs = Stop ty is_rhs (canUpdateInPlace ty)
+mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
contIsRhs :: SimplCont -> Bool
contIsRhs (Stop _ AnRhs _) = True
contIsDupable (ApplyTo OkToDup _ _ _) = True
contIsDupable (Select OkToDup _ _ _ _) = True
contIsDupable (CoerceIt _ cont) = contIsDupable cont
-contIsDupable (InlinePlease cont) = contIsDupable cont
-contIsDupable other = False
+contIsDupable (InlinePlease cont) = contIsDupable cont
+contIsDupable other = False
-------------------
discardableCont :: SimplCont -> Bool
interestingCallContext some_args some_val_args cont
= interesting cont
where
- interesting (InlinePlease _) = True
- interesting (Select _ _ _ _ _) = some_args
- interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
+ interesting (InlinePlease _) = True
+ interesting (Select _ _ _ _ _) = some_args
+ interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
-- Perhaps True is a bit over-keen, but I've
-- seen (coerce f) x, where f has an INLINE prag,
-- So we have to give some motivaiton for inlining it
= returnSmpl []
mk_args missing_con inst_tys
- = getUniquesSmpl `thenSmpl` \ tv_uniqs ->
- getUniquesSmpl `thenSmpl` \ id_uniqs ->
- let
- ex_tyvars = dataConExistentialTyVars missing_con
- ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
- mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
- arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
- arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
- in
- returnSmpl (ex_tyvars' ++ arg_ids)
+ = mk_tv_bndrs missing_con inst_tys `thenSmpl` \ (tv_bndrs, inst_tys') ->
+ getUniquesSmpl `thenSmpl` \ id_uniqs ->
+ let arg_tys = dataConArgTys missing_con inst_tys'
+ arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
+ in
+ returnSmpl (tv_bndrs ++ arg_ids)
+
+mk_tv_bndrs missing_con inst_tys
+ | isVanillaDataCon missing_con
+ = returnSmpl ([], inst_tys)
+ | otherwise
+ = getUniquesSmpl `thenSmpl` \ tv_uniqs ->
+ let new_tvs = zipWith mk tv_uniqs (dataConTyVars missing_con)
+ mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
+ in
+ returnSmpl (new_tvs, mkTyVarTys new_tvs)
\end{code}
mkCase puts a case expression back together, trying various transformations first.
\begin{code}
-mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
+mkCase :: OutExpr -> OutId -> OutType -> [OutAlt] -> SimplM OutExpr
-mkCase scrut case_bndr alts
+mkCase scrut case_bndr ty alts
= mkAlts scrut case_bndr alts `thenSmpl` \ better_alts ->
- mkCase1 scrut case_bndr better_alts
+ mkCase1 scrut case_bndr ty better_alts
\end{code}
mkAlts' dflags scrut outer_bndr outer_alts
| dopt Opt_CaseMerge dflags,
(outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
- Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
+-- gaw 2004
+ Just (Case (Var scrut_var) inner_bndr _ inner_alts) <- maybe_outer_deflt,
scruting_same_var scrut_var
= let -- Eliminate any inner alts which are shadowed by the outer ones
--------------------------------------------------
#ifdef DEBUG
-mkCase1 scrut case_bndr []
+mkCase1 scrut case_bndr ty []
= pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
returnSmpl scrut
#endif
-- 1. Eliminate the case altogether if poss
--------------------------------------------------
-mkCase1 scrut case_bndr [(con,bndrs,rhs)]
+mkCase1 scrut case_bndr ty [(con,bndrs,rhs)]
-- See if we can get rid of the case altogether
-- See the extensive notes on case-elimination above
-- mkCase made sure that if all the alternatives are equal,
-- 2. Identity case
--------------------------------------------------
-mkCase1 scrut case_bndr alts -- Identity case
+mkCase1 scrut case_bndr ty alts -- Identity case
| all identity_alt alts
= tick (CaseIdentity case_bndr) `thenSmpl_`
returnSmpl (re_note scrut)
--------------------------------------------------
-- Catch-all
--------------------------------------------------
-mkCase1 scrut bndr alts = returnSmpl (Case scrut bndr alts)
+-- gaw 2004
+mkCase1 scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
\end{code}
import SimplUtils ( mkCase, mkLam, newId, prepareAlts,
simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
- mkStop, mkBoringStop, pushContArgs,
+ mkRhsStop, mkBoringStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg,
getContArgs, interestingCallContext, interestingArg, isStrictType
)
-import Var ( mustHaveLocalBinding )
-import VarEnv
import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
- idNewDemandInfo, setIdInfo,
+ idNewDemandInfo, setIdInfo,
setIdOccInfo, zapLamIdInfo, setOneShotLambda,
)
+import MkId ( eRROR_ID )
+import Literal ( mkStringLit )
import OccName ( encodeFS )
import IdInfo ( OccInfo(..), isLoopBreaker,
setArityInfo, zapDemandInfo,
occInfo
)
import NewDemand ( isStrictDmd )
-import DataCon ( dataConNumInstArgs, dataConRepStrictness )
+import Unify ( coreRefineTys )
+import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon )
+import TyCon ( tyConArity )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline )
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsValue,
exprOkForSpeculation, exprArity,
- mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
+ mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy,
- splitFunTy_maybe, splitFunTy, eqType
- )
-import Subst ( mkSubst, substTy, substExpr,
- isInScope, lookupIdSubst, simplIdInfo
+ splitFunTy_maybe, splitFunTy, eqType, substTy
)
+import Subst ( SubstResult(..), emptySubst, substExpr,
+ substId, simplIdInfo )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
| preInlineUnconditionally env NotTopLevel bndr
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
- thing_inside (extendSubst env bndr (ContEx (getSubstEnv rhs_se) rhs))
+ thing_inside (extendIdSubst env bndr (ContEx (getSubst rhs_se) rhs))
| isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
-- because quotInt# can fail.
= simplBinder env bndr `thenSmpl` \ (env, bndr') ->
thing_inside env `thenSmpl` \ (floats, body) ->
- returnSmpl (emptyFloats env, Case new_rhs bndr' [(DEFAULT, [], wrapFloats floats body)])
+-- gaw 2004
+ let body' = wrapFloats floats body in
+ returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')])
| preInlineUnconditionally env NotTopLevel bndr
-- This happens; for example, the case_bndr during case of
-- Similarly, single occurrences can be inlined vigourously
-- e.g. case (f x, g y) of (a,b) -> ....
-- If a,b occur once we can avoid constructing the let binding for them.
- = thing_inside (extendSubst env bndr (ContEx emptySubstEnv new_rhs))
+ = thing_inside (extendIdSubst env bndr (ContEx emptySubst new_rhs))
| otherwise
= simplBinder env bndr `thenSmpl` \ (env, bndr') ->
simplRecOrTopPair env top_lvl bndr bndr' rhs
| preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
- returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs))
+ returnSmpl (emptyFloats env, extendIdSubst env bndr (ContEx (getSubst env) rhs))
| otherwise
= simplLazyBind env top_lvl Recursive bndr bndr' rhs env
rhs_env = setInScope rhs_se env1
is_top_level = isTopLevel top_lvl
ok_float_unlifted = not is_top_level && isNonRec is_rec
- rhs_cont = mkStop (idType bndr1) AnRhs
+ rhs_cont = mkRhsStop (idType bndr1)
in
- -- Simplify the RHS; note the mkStop, which tells
+ -- Simplify the RHS; note the mkRhsStop, which tells
-- the simplifier that this is the RHS of a let.
simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) ->
| postInlineUnconditionally env new_bndr occ_info new_rhs
= -- Drop the binding
tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
- returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs))
+ returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs))
-- Use the substitution to make quite, quite sure that the substitution
-- will happen, since we are going to discard the binding
\begin{code}
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-simplExpr env expr = simplExprC env expr (mkStop expr_ty' AnArg)
+simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
where
- expr_ty' = substTy (getSubst env) (exprType expr)
+ expr_ty' = substTy (getTvSubst env) (exprType expr)
-- The type in the Stop continuation, expr_ty', is usually not used
-- It's only needed when discarding continuations after finding
-- a function that returns bottom.
simplType env ty `thenSmpl` \ ty' ->
rebuild env (Type ty') cont
-simplExprF env (Case scrut bndr alts) cont
+-- gaw 2004
+simplExprF env (Case scrut bndr case_ty alts) cont
| not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
= -- Simplify the scrutinee with a Select continuation
simplExprF env scrut (Select NoDup bndr alts env cont)
simplExprC env scrut case_cont `thenSmpl` \ case_expr' ->
rebuild env case_expr' cont
where
- case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
+ case_cont = Select NoDup bndr alts env (mkBoringStop case_ty')
+ case_ty' = substTy (getTvSubst env) case_ty -- c.f. defn of simplExpr
simplExprF env (Let (Rec pairs) body) cont
= simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
simplType env ty
= seqType new_ty `seq` returnSmpl new_ty
where
- new_ty = substTy (getSubst env) ty
+ new_ty = substTy (getTvSubst env) ty
\end{code}
= ASSERT( isTyVar bndr )
tick (BetaReduction bndr) `thenSmpl_`
simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' ->
- go (extendSubst env bndr (DoneTy ty_arg')) body body_cont
+ go (extendTvSubst env bndr ty_arg') body body_cont
-- Ordinary beta reduction
go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
\begin{code}
simplNote env (Coerce to from) body cont
= let
- in_scope = getInScope env
-
addCoerce s1 k1 (CoerceIt t1 cont)
-- coerce T1 S1 (coerce S1 K1 e)
-- ==>
-- But it isn't a common case.
= let
(t1,t2) = splitFunTy t1t2
- new_arg = mkCoerce2 s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
+ new_arg = mkCoerce2 s1 t1 (substExpr subst arg)
+ subst = getSubst (setInScope arg_se env)
in
ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
\begin{code}
simplVar env var cont
- = case lookupIdSubst (getSubst env) var of
+ = case substId (getSubst env) var of
DoneEx e -> simplExprF (zapSubstEnv env) e cont
ContEx se e -> simplExprF (setSubstEnv env se) e cont
- DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1,
- text "simplVar:" <+> ppr var )
- completeCall (zapSubstEnv env) var1 occ cont
+ DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont
+ -- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
-- let x = e in
go env (Lam bndr body) (Type ty_arg : args)
= ASSERT( isTyVar bndr )
tick (BetaReduction bndr) `thenSmpl_`
- go (extendSubst env bndr (DoneTy ty_arg)) body args
+ go (extendTvSubst env bndr ty_arg) body args
-- Ordinary beta reduction
go env (Lam bndr body) (arg : args)
-- have to be very careful about bogus strictness through
-- floating a demanded let.
= simplExprC (setInScope arg_se env) val_arg
- (mkStop arg_ty AnArg) `thenSmpl` \ arg1 ->
+ (mkBoringStop arg_ty) `thenSmpl` \ arg1 ->
thing_inside env arg1
where
arg_ty = funArgTy fn_ty
| needsCaseBinding (idType v) r
= addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) ->
WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
- returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)])
+ (let body = wrapFloats floats expr in
+ returnSmpl (emptyFloats env, Case r v (exprType body) [(DEFAULT,[],body)]))
| otherwise
= addAuxiliaryBind env (NonRec v r) $ \ env ->
prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
addFloats env floats $ \ env ->
+ let
+ -- The case expression is annotated with the result type of the continuation
+ -- This may differ from the type originally on the case. For example
+ -- case(T) (case(Int#) a of { True -> 1#; False -> 0# }) of
+ -- a# -> <blob>
+ -- ===>
+ -- let j a# = <blob>
+ -- in case(T) a of { True -> j 1#; False -> j 0# }
+ -- Note that the case that scrutinises a now returns a T not an Int#
+ res_ty' = contResultType dup_cont
+ in
+
-- Deal with variable scrutinee
simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
-- Deal with the case alternatives
simplAlts alt_env zap_occ_info handled_cons
- case_bndr' better_alts dup_cont `thenSmpl` \ alts' ->
+ case_bndr' better_alts dup_cont res_ty' `thenSmpl` \ alts' ->
-- Put the case back together
- mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr ->
+ mkCase scrut case_bndr' res_ty' alts' `thenSmpl` \ case_expr ->
-- Notice that rebuildDone returns the in-scope set from env, not alt_env
-- The case binder *not* scope over the whole returned case-expression
-- in the default case
-> OutId -- Case binder
-> [InAlt] -> SimplCont
+ -> OutType -- Result type
-> SimplM [OutAlt] -- Includes the continuation
-simplAlts env zap_occ_info handled_cons case_bndr' alts cont'
+simplAlts env zap_occ_info handled_cons case_bndr' alts cont' res_ty'
= mapSmpl simpl_alt alts
where
- inst_tys' = tyConAppArgs (idType case_bndr')
+ mk_rhs_env env case_bndr_unf
+ = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf)
simpl_alt (DEFAULT, _, rhs)
- = let
- -- In the default case we record the constructors that the
- -- case-binder *can't* be.
- -- We take advantage of any OtherCon info in the case scrutinee
- case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons
- env_with_unf = modifyInScope env case_bndr' case_bndr_w_unf
- in
- simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
+ = let unf = mkOtherCon handled_cons in
+ -- Record the constructors that the case-binder *can't* be.
+ simplExprC (mk_rhs_env env unf) rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (DEFAULT, [], rhs')
- simpl_alt (con, vs, rhs)
+ simpl_alt (LitAlt lit, _, rhs)
+ = let unf = mkUnfolding False (Lit lit) in
+ simplExprC (mk_rhs_env env unf) rhs cont' `thenSmpl` \ rhs' ->
+ returnSmpl (LitAlt lit, [], rhs')
+
+ simpl_alt (DataAlt con, vs, rhs)
+ | isVanillaDataCon con
= -- Deal with the pattern-bound variables
-- Mark the ones that are in ! positions in the data constructor
-- as certainly-evaluated.
simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
-- Bind the case-binder to (con args)
- let
- unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
- env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding)
+ let unf = mkUnfolding False (mkConApp con con_args)
+ inst_tys' = tyConAppArgs (idType case_bndr')
+ con_args = map Type inst_tys' ++ map varToCoreExpr vs'
in
- simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
- returnSmpl (con, vs', rhs')
-
+ simplExprC (mk_rhs_env env unf) rhs cont' `thenSmpl` \ rhs' ->
+ returnSmpl (DataAlt con, vs', rhs')
+
+
+ | otherwise -- GADT case
+ = simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
+ let unf = mkUnfolding False con_app
+ con_app = mkConApp con con_args
+ con_args = map varToCoreExpr vs' -- NB: no inst_tys'
+ pat_res_ty = exprType con_app
+ env_w_unf = mk_rhs_env env unf
+ tv_subst = getTvSubst env
+ in
+ case coreRefineTys vs' tv_subst pat_res_ty (idType case_bndr') of
+ Just tv_subst_env ->
+ simplExprC (setTvSubstEnv env_w_unf tv_subst_env) rhs cont' `thenSmpl` \ rhs' ->
+ returnSmpl (DataAlt con, vs', rhs')
+ Nothing -> -- Dead code; for now, I'm just going to put in an
+ -- error case so I can see them
+ let rhs' = mkApps (Var eRROR_ID)
+ [Type (substTy tv_subst (exprType rhs)),
+ Lit (mkStringLit "Impossible alternative (GADT)")]
+ in
+ returnSmpl (DataAlt con, vs', rhs')
-- add_evals records the evaluated-ness of the bound variables of
-- a case pattern. This is *important*. Consider
-- We really must record that b is already evaluated so that we don't
-- go and re-evaluate it when constructing the result.
- add_evals (DataAlt dc) vs = cat_evals dc vs (dataConRepStrictness dc)
- add_evals other_con vs = vs
+ add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc)
cat_evals dc vs strs
= go vs strs
where
go [] [] = []
+ go (v:vs) strs | isTyVar v = v : go vs strs
go (v:vs) (str:strs)
- | isTyVar v = v : go vs (str:strs)
| isMarkedStrict str = evald_v : go vs strs
| otherwise = zapped_v : go vs strs
where
simplNonRecX env bndr (Lit lit) $ \ env ->
simplExprF env rhs cont
- (DataAlt dc, bs, rhs) -> ASSERT( length bs + n_tys == length args )
- bind_args env bs (drop n_tys args) $ \ env ->
- let
- con_app = mkConApp dc (take n_tys args ++ con_args)
- con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
+ (DataAlt dc, bs, rhs)
+ -> ASSERT( n_drop_tys + length bs == length args )
+ bind_args env bs (drop n_drop_tys args) $ \ env ->
+ let
+ con_app = mkConApp dc (take n_drop_tys args ++ con_args)
+ con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
-- args are aready OutExprs, but bs are InIds
- in
- simplNonRecX env bndr con_app $ \ env ->
- simplExprF env rhs cont
- where
- n_tys = dataConNumInstArgs dc -- Non-existential type args
+ in
+ simplNonRecX env bndr con_app $ \ env ->
+ simplExprF env rhs cont
+ where
+ n_drop_tys | isVanillaDataCon dc = tyConArity (dataConTyCon dc)
+ | otherwise = 0
+ -- Vanilla data constructors lack type arguments in the pattern
+
-- Ugh!
bind_args env [] _ thing_inside = thing_inside env
bind_args env (b:bs) (Type ty : args) thing_inside
- = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside
+ = ASSERT( isTyVar b )
+ bind_args (extendTvSubst env b ty) bs args thing_inside
bind_args env (b:bs) (arg : args) thing_inside
- = simplNonRecX env b arg $ \ env ->
+ = ASSERT( isId b )
+ simplNonRecX env b arg $ \ env ->
bind_args env bs args thing_inside
\end{code}
-- This has been this way for a long time, so I'll leave it,
-- but I can't convince myself that it's right.
-
+-- gaw 2004
mkDupableCont env (Select _ case_bndr alts se cont)
= -- e.g. (case [...hole...] of { pi -> ei })
-- ===>
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
import CoreUtils ( eqExpr )
import CoreTidy ( pprTidyIdRules )
-import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
- substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
- bindSubstList, unBindSubstList, substInScope, uniqAway
+import Subst ( Subst, SubstResult(..), extendIdSubst,
+ getTvSubstEnv, setTvSubstEnv,
+ emptySubst, isInScope, lookupIdSubst, lookupTvSubst,
+ bindSubstList, unBindSubstList, substInScope
)
import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
-import Var ( isId )
+import Var ( Var, isId )
import VarSet
import VarEnv
import TcType ( mkTyVarTy )
-import qualified TcType ( match )
+import qualified Unify ( matchTyX )
import BasicTypes ( Activation, CompilerPhase, isActive )
import Outputable
-----------------------
app_match subst fn vs = foldl go fn vs
- where
- senv = substEnv subst
- go fn v = case lookupSubstEnv senv v of
- Just (DoneEx ex) -> fn `App` ex
- Just (DoneTy ty) -> fn `App` Type ty
- -- Substitution should bind them all!
-
+ where
+ go fn v = case lookupVar subst v of
+ Just e -> fn `App` e
+ Nothing -> pprPanic "app_match: unbound tpl" (ppr v)
+
+lookupVar :: Subst -> Var -> Maybe CoreExpr
+lookupVar subst v
+ | isId v = case lookupIdSubst subst v of
+ Just (DoneEx ex) -> Just ex
+ other -> Nothing
+ | otherwise = case lookupTvSubst subst v of
+ Just ty -> Just (Type ty)
+ Nothing -> Nothing
-----------------------
{- The code below tries to match even if there are more
-> Subst -> Maybe result -- Substitution so far -> result
-- The *SubstEnv* in these Substs apply to the TEMPLATE only
--- The *InScopeSet* in these Substs gives variables bound so far in the
+-- The *InScopeSet* in these Substs is HIJACKED,
+-- to give the set of variables bound so far in the
-- target term. So when matching forall a. (\x. a x) against (\y. y y)
-- while processing the body of the lambdas, the in-scope set will be {y}.
-- That lets us do the occurs-check when matching 'a' against 'y'
+--
+-- It starts off empty
match :: CoreExpr -- Template
-> CoreExpr -- Target
match_fail = Nothing
-match (Var v1) e2 tpl_vars kont subst
- = case lookupSubst subst v1 of
+-- ToDo: remove this debugging junk
+-- match e1 e2 tpls kont subst = pprTrace "match" (ppr e1 <+> ppr e2 <+> ppr subst) $ match_ e1 e2 tpls kont subst
+match = match_
+
+match_ (Var v1) e2 tpl_vars kont subst
+ = case lookupIdSubst subst v1 of
Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable
-> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then
match_fail -- Occurs check failure
-- e.g. match forall a. (\x-> a x) against (\y. y y)
else
- kont (extendSubst subst v1 (DoneEx e2))
+ kont (extendIdSubst subst v1 (DoneEx e2))
| eqExpr (Var v1) e2 -> kont subst
other -> match_fail
-match (Lit lit1) (Lit lit2) tpl_vars kont subst
+match_ (Lit lit1) (Lit lit2) tpl_vars kont subst
| lit1 == lit2
= kont subst
-match (App f1 a1) (App f2 a2) tpl_vars kont subst
+match_ (App f1 a1) (App f2 a2) tpl_vars kont subst
= match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
-match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
+match_ (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
= bind [x1] [x2] (match e1 e2) tpl_vars kont subst
-- This rule does eta expansion
-- (\x.M) ~ N iff M ~ N x
-- See assumption A3
-match (Lam x1 e1) e2 tpl_vars kont subst
+match_ (Lam x1 e1) e2 tpl_vars kont subst
= bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
-- Eta expansion the other way
-- M ~ (\y.N) iff \y.M y ~ \y.N
-- iff M y ~ N
-- Remembering that by (A), y can't be free in M, we get this
-match e1 (Lam x2 e2) tpl_vars kont subst
+match_ e1 (Lam x2 e2) tpl_vars kont subst
+ | new_id == x2 -- If the two are equal, don't bind, else we get
+ -- a substitution looking like x->x, and that sends
+ -- Unify.matchTy into a loop
+ = match (App e1 (mkVarArg new_id)) e2 tpl_vars kont subst
+ | otherwise
= bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst
where
new_id = uniqAway (substInScope subst) x2
-- The first \x is ok, but when we inline k, hoping it might
-- match (:) we find a second \x.
-match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
- = match e1 e2 tpl_vars case_kont subst
+-- gaw 2004
+match_ (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) tpl_vars kont subst
+ = (match_ty ty1 ty2 tpl_vars $
+ match e1 e2 tpl_vars case_kont) subst
where
case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLe le_alt alts2))
tpl_vars kont subst
-match (Type ty1) (Type ty2) tpl_vars kont subst
+match_ (Type ty1) (Type ty2) tpl_vars kont subst
= match_ty ty1 ty2 tpl_vars kont subst
-match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
+match_ (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
tpl_vars kont subst
= (match_ty to1 to2 tpl_vars $
match_ty from1 from2 tpl_vars $
-- variable, we expand it so long as its unfolding is a WHNF
-- (Its occurrence information is not necessarily up to date,
-- so we don't use it.)
-match e1 (Var v2) tpl_vars kont subst
+match_ e1 (Var v2) tpl_vars kont subst
| isCheapUnfolding unfolding
= match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
where
-- We can't cope with lets in the template
-match e1 e2 tpl_vars kont subst = match_fail
+match_ e1 e2 tpl_vars kont subst = match_fail
------------------------------------------
subst' = bindSubstList subst vs1 vs2
-- The unBindSubst relies on no shadowing in the template
- not_in_subst v = isNothing (lookupSubst subst v)
+ not_in_subst v = isNothing (lookupVar subst v)
bug_msg = sep [ppr vs1, ppr vs2]
----------------------------------------
\begin{code}
----------------------------------------
match_ty ty1 ty2 tpl_vars kont subst
- = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst)
- where
- kont' senv = kont (setSubstEnv subst senv)
+ = case Unify.matchTyX tpl_vars (getTvSubstEnv subst) ty1 ty2 of
+ Just tv_env' -> kont (setTvSubstEnv subst tv_env')
+ Nothing -> match_fail
\end{code}
ruleCheck env (Note n e) = ruleCheck env e
ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
ruleCheck env (Lam b e) = ruleCheck env e
-ruleCheck env (Case e _ as) = ruleCheck env e `unionBags`
- unionManyBags [ruleCheck env r | (_,_,r) <- as]
+-- gaw 2004
+ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
+ unionManyBags [ruleCheck env r | (_,_,r) <- as]
ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
ruleCheckApp env (Var f) as = ruleCheckFun env f as
scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
returnUs (usg, Lam b e')
-scExpr env (Case scrut b alts)
+-- gaw 2004
+scExpr env (Case scrut b ty alts)
= sc_scrut scrut `thenUs` \ (scrut_usg, scrut') ->
mapAndUnzipUs sc_alt alts `thenUs` \ (alts_usgs, alts') ->
+-- gaw 2004
returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
- Case scrut' b alts')
+ Case scrut' b ty alts')
where
sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
sc_scrut e = scExpr env e
tyVarsOfTypes, tyVarsOfTheta, isClassPred,
mkForAllTys, tcCmpType
)
-import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
- simplBndr, simplBndrs,
+import Subst ( Subst, SubstResult(..), mkSubst, mkSubst, extendTvSubstList,
+ simplBndr, simplBndrs, substTy,
substAndCloneId, substAndCloneIds, substAndCloneRecIds,
- lookupIdSubst, substInScope
+ substId, substInScope
)
import Var ( zapSpecPragmaId )
import VarSet
-- accidentally re-use a unique that's already in use
-- Easiest thing is to do it all at once, as if all the top-level
-- decls were mutually recursive
- top_subst = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) emptySubstEnv
+ top_subst = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds)))
go [] = returnSM ([], emptyUDs)
go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
\begin{code}
specVar :: Subst -> Id -> CoreExpr
-specVar subst v = case lookupIdSubst subst v of
+specVar subst v = case substId subst v of
DoneEx e -> e
DoneId v _ -> Var v
-- More efficient to collect a group of binders together all at once
-- and we don't want to split a lambda group with dumped bindings
-specExpr subst (Case scrut case_bndr alts)
+-- gaw 2004
+specExpr subst (Case scrut case_bndr ty alts)
= specExpr subst scrut `thenSM` \ (scrut', uds_scrut) ->
mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) ->
- returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
+ returnSM (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts)
where
(subst_alt, case_bndr') = simplBndr subst case_bndr
-- No need to clone case binder; it can't float like a let(rec)
where
mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar)
mk_ty_arg rhs_tyvar (Just ty) = Type ty
- rhs_subst = extendSubstList subst spec_tyvars [DoneTy ty | Just ty <- call_ts]
+ rhs_subst = extendTvSubstList subst (spec_tyvars `zip` [ty | Just ty <- call_ts])
in
cloneBinders rhs_subst rhs_dicts `thenSM` \ (rhs_subst', rhs_dicts') ->
let
-- Cases require a little more real work.
-coreToStgExpr (Case scrut bndr alts)
+-- gaw 2004
+coreToStgExpr (Case scrut bndr _ alts)
= extendVarEnvLne [(bndr, LambdaBound)] (
mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
returnLne ( alts2,
Just (_,_,info) -> info
allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
-allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
+allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id]
-- Non-top-level things only, both type variables and ids
-- (type variables only if opt_RuntimeTypes)
getFVs :: FreeVarsInfo -> [Var]
-getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
+getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
not (topLevelBound how_bound) ]
getFVSet :: FreeVarsInfo -> VarSet
in
(deferType lam_ty, Lam var' body')
-dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)])
+-- gaw 2004
+dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
| let tycon = dataConTyCon dc,
isProductTyCon tycon,
not (isRecursiveTyCon tycon)
(scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
in
- (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' [alt'])
+-- gaw 2004
+ (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt'])
-dmdAnal sigs dmd (Case scrut case_bndr alts)
+-- gaw 2004
+dmdAnal sigs dmd (Case scrut case_bndr ty alts)
= let
(alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts
(scrut_ty, scrut') = dmdAnal sigs evalDmd scrut
(alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr
in
-- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys)
- (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' alts')
+-- gaw 2004
+ (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts')
dmdAnal sigs dmd (Let (NonRec id rhs) body)
= let
wwExpr expr `thenUs` \ new_expr ->
returnUs (mkLets intermediate_bind new_expr)
-wwExpr (Case expr binder alts)
+-- gaw 2004
+wwExpr (Case expr binder ty alts)
= wwExpr expr `thenUs` \ new_expr ->
mapUs ww_alt alts `thenUs` \ new_alts ->
- returnUs (Case new_expr binder new_alts)
+-- gaw 2004
+ returnUs (Case new_expr binder ty new_alts)
where
ww_alt (con, binders, rhs)
= wwExpr rhs `thenUs` \ new_rhs ->
arg = mk_ww_local arg_uniq con_arg_ty1
con_app = mkConApp data_con (map Type tycon_arg_tys ++ [Var arg])
in
- returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], con_app)],
- \ body -> workerCase body work_wild [(DataAlt data_con, [arg], Var arg)],
+-- gaw 2004
+ returnUs (\ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)],
+ \ body -> workerCase body work_wild con_arg_ty1 [(DataAlt data_con, [arg], Var arg)],
con_arg_ty1)
| otherwise -- The general case
ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars)
con_app = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars)
in
- returnUs (\ wkr_call -> Case wkr_call wrap_wild [(DataAlt ubx_tup_con, args, con_app)],
- \ body -> workerCase body work_wild [(DataAlt data_con, args, ubx_tup_app)],
+-- gaw 2004
+ returnUs (\ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)],
+ \ body -> workerCase body work_wild ubx_tup_ty [(DataAlt data_con, args, ubx_tup_app)],
ubx_tup_ty)
where
(_, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty
-- This transform doesn't move work or allocation
-- from one cost centre to another
-workerCase (Note (SCC cc) e) arg alts = Note (SCC cc) (Case e arg alts)
-workerCase e arg alts = Case e arg alts
+-- gaw 2004
+workerCase (Note (SCC cc) e) arg ty alts = Note (SCC cc) (Case e arg ty alts)
+-- gaw 2004
+workerCase e arg ty alts = Case e arg ty alts
\end{code}
-- A data type
= Case (Var arg)
(sanitiseCaseBndr arg)
+-- gaw 2004
+ (exprType body)
[(DataAlt boxing_con, unpk_args, body)]
-mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) [(DEFAULT, [], body)]
+-- gaw 2004
+mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
sanitiseCaseBndr :: Id -> Id
-- The argument we are scrutinising has the right type to be
tidyInsts, tidyMoreInsts,
- newDictsFromOld, newDicts, cloneDict,
+ newDictsFromOld, newDicts, newDictsAtLoc, cloneDict,
newOverloadedLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
- tcInstClassOp, tcInstCall, tcInstDataCon,
+ tcInstClassOp, tcInstCall, tcInstStupidTheta,
tcSyntaxName, tcStdSyntaxName,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
)
-import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
- PredType(..), TyVarDetails(VanillaTv), typeKind,
- tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
+import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar,
+ PredType(..), typeKind,
+ tcSplitForAllTys, tcSplitForAllTys,
tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
isClassPred, isTyVarClassPred, isLinearPred,
getClassPredTys, getClassPredTys_maybe, mkPredName,
- isInheritablePred, isIPPred, matchTys,
+ isInheritablePred, isIPPred,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
)
+import Type ( substTy, substTys, substTyWith, substTheta, zipTopTvSubst )
+import Unify ( matchTys )
import Kind ( isSubKind )
import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
-import DataCon ( DataCon,dataConSig )
+import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
import PrelInfo ( isStandardClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
import NameSet ( addOneToNameSet )
-import Subst ( substTy, substTyWith, substTheta, mkTopTyVarSubst )
import Literal ( inIntRange )
import Var ( TyVar, tyVarKind )
-import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
+import VarEnv ( TidyEnv, emptyTidyEnv, lookupVarEnv )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
-import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt )
+import CmdLineOpts( DynFlags )
import Maybes ( isJust )
import Outputable
\end{code}
\begin{code}
-tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, TcType)
+tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
- = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
- newDicts orig theta `thenM` \ dicts ->
- extendLIEs dicts `thenM_`
- let
- inst_fn e = DictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars)) (map instToId dicts)
- in
- returnM (mkCoercion inst_fn, tau)
-
-tcInstDataCon :: InstOrigin
- -> TyVarDetails -- Use this for the existential tyvars
- -- ExistTv when pattern-matching,
- -- VanillaTv at a call of the constructor
- -> DataCon
- -> TcM ([TcType], -- Types to instantiate at
- [Inst], -- Existential dictionaries to apply to
- [TcType], -- Argument types of constructor
- TcType, -- Result type
- [TyVar]) -- Existential tyvars
-tcInstDataCon orig ex_tv_details data_con
- = let
- (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
- -- We generate constraints for the stupid theta even when
- -- pattern matching (as the Report requires)
- in
- mappM (tcInstTyVar VanillaTv) tvs `thenM` \ tvs' ->
- mappM (tcInstTyVar ex_tv_details) ex_tvs `thenM` \ ex_tvs' ->
- let
- tv_tys' = mkTyVarTys tvs'
- ex_tv_tys' = mkTyVarTys ex_tvs'
- all_tys' = tv_tys' ++ ex_tv_tys'
-
- tenv = mkTopTyVarSubst (tvs ++ ex_tvs) all_tys'
- stupid_theta' = substTheta tenv stupid_theta
- ex_theta' = substTheta tenv ex_theta
- arg_tys' = map (substTy tenv) arg_tys
- result_ty' = mkTyConApp tycon tv_tys'
- in
- newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
- newDicts orig ex_theta' `thenM` \ ex_dicts ->
-
- -- Note that we return the stupid theta *only* in the LIE;
- -- we don't otherwise use it at all
- extendLIEs stupid_dicts `thenM_`
-
- returnM (all_tys', ex_dicts, arg_tys', result_ty', ex_tvs')
+ = 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
+tcInstStupidTheta data_con inst_tys
+ | null stupid_theta
+ = return ()
+ | otherwise
+ = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
+ (substTheta tenv stupid_theta)
+ ; extendLIEs stupid_dicts }
+ where
+ stupid_theta = dataConStupidTheta data_con
+ tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
newMethodFromName origin ty name
then return ()
else do
{ traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
- ; tv1 <- tcInstTyVar VanillaTv tv
+ ; tv1 <- tcInstTyVar tv
; unifyTauTy (mkTyVarTy tv1) ty1 }}
, let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
-- Print without the for-all, which the programmer doesn't write
-show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
-
tidyInst :: TidyEnv -> Inst -> Inst
tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
addInst dflags home_ie dfun
= do { -- Load imported instances, so that we report
-- duplicates correctly
- pkg_ie <- loadImportedInsts cls tys
+ let (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
+ ; pkg_ie <- loadImportedInsts cls tys
-- Check functional dependencies
; case checkFunDeps (pkg_ie, home_ie) dfun of
Nothing -> return ()
-- Check for duplicate instance decls
- ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
+ -- We instantiate the dfun type because the instance lookup
+ -- requires nice fresh types in the thing to be looked up
+ ; (tvs', _, tenv) <- tcInstTyVars tvs
+ ; let { tys' = substTys tenv tys
+ ; (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
- isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
+ isJust (matchTys (mkVarSet tvs) tys' dup_tys)] }
-- Find memebers of the match list which
-- dfun itself matches. If the match is 2-way, it's a duplicate
; case dup_dfuns of
-- OK, now extend the envt
; return (extendInstEnv home_ie dfun) }
- where
- (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
+
traceDFuns dfuns
= traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
2 (pprDFuns [dfun, dup_dfun]))
addDictLoc dfun thing_inside
- = addSrcSpan (mkSrcSpan loc loc) thing_inside
+ = setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc dfun
\end{code}
-----------------
instantiate_dfun tenv dfun_id pred loc
- = traceTc (text "lookupInst success" <+>
+ = -- tenv is a substitution that instantiates the dfun_id
+ -- to match the requested result type. However, the dfun
+ -- might have some tyvars that only appear in arguments
+ -- dfun :: forall a b. C a b, Ord b => D [a]
+ -- We instantiate b to a flexi type variable -- it'll presumably
+ -- become fixed later via functional dependencies
+ traceTc (text "lookupInst success" <+>
vcat [text "dict" <+> ppr pred,
text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_`
-- Record that this dfun is needed
(topIdLvl dfun_id) use_stage `thenM_`
let
(tyvars, rho) = tcSplitForAllTys (idType dfun_id)
- mk_ty_arg tv = case lookupSubstEnv tenv tv of
- Just (DoneTy ty) -> returnM ty
- Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
- returnM (mkTyVarTy tc_tv)
+ mk_ty_arg tv = case lookupVarEnv tenv tv of
+ Just ty -> returnM ty
+ Nothing -> tcInstTyVar tv `thenM` \ tc_tv ->
+ returnM (mkTyVarTy tc_tv)
in
mappM mk_ty_arg tyvars `thenM` \ ty_args ->
let
- dfun_rho = substTy (mkTopTyVarSubst tyvars ty_args) rho
+ dfun_rho = substTy (zipTopTvSubst tyvars ty_args) rho
-- Since the tyvars are freshly made,
-- they cannot possibly be captured by
- -- any existing for-alls. Hence mkTopTyVarSubst
+ -- any existing for-alls. Hence zipTopTyVarSubst
(theta, _) = tcSplitPhiTy dfun_rho
ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args
in
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcCheckRho )
+import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho )
import HsSyn
import TcHsSyn ( mkHsLet )
TcMatchCtxt(..), tcMatchesCase )
import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
- mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType )
-import TcMType ( newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType )
+ mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType,
+ SkolemInfo(..) )
+import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVar, zonkTcType )
import TcBinds ( tcBindsAndThen )
import TcSimplify ( tcSimplifyCheck )
import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
import Name ( Name )
import TysWiredIn ( boolTy, pairTyCon )
import VarSet
+import TysPrim ( alphaTyVar )
import Type ( Kind, mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes )
import SrcLoc ( Located(..) )
-> TcM (OutPat TcId, LHsCmdTop TcId)
tcProc pat cmd exp_ty
- = do { arr_ty <- newTyVarTy arrowTyConKind
- ; [arg_ty, res_ty] <- newTyVarTys 2 liftedTypeKind
+-- gaw 2004 FIX?
+ = do { arr_ty <- newTyFlexiVarTy arrowTyConKind
+ ; [arg_ty, res_ty] <- newTyFlexiVarTys 2 liftedTypeKind
; zapExpectedTo exp_ty (mkAppTys arr_ty [arg_ty,res_ty])
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
- ; ([pat'], cmd', ex_binds) <- incProcLevel $
- tcMatchPats [(pat, Check arg_ty)] (Check res_ty) $
- tcCmdTop cmd_env cmd ([], res_ty)
-
- ; return (pat', glueBindsOnCmd ex_binds cmd') }
+ ; ([pat'], cmd') <- incProcLevel $
+ 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!
+
+ ; return (pat', cmd') }
\end{code}
-> TcM (LHsCmdTop TcId)
tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) (cmd_stk, res_ty)
- = addSrcSpan loc $
+ = setSrcSpan loc $
do { cmd' <- tcCmd env cmd (cmd_stk, res_ty)
; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
-- The main recursive function
tcCmd env (L loc expr) res_ty
- = addSrcSpan loc $ do
+ = setSrcSpan loc $ do
{ expr' <- tc_cmd env expr res_ty
; return (L loc expr') }
tc_cmd env (HsLet binds (L body_loc body)) res_ty
= tcBindsAndThen glue binds $
- addSrcSpan body_loc $
+ setSrcSpan body_loc $
tc_cmd env body res_ty
where
glue binds expr = HsLet [binds] (L body_loc expr)
tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
= addErrCtxt (cmdCtxt in_cmd) $
- tcMatchesCase match_ctxt matches (Check res_ty)
- `thenM` \ (scrut_ty, matches') ->
addErrCtxt (caseScrutCtxt scrut) (
- tcCheckRho scrut scrut_ty
- ) `thenM` \ scrut' ->
+ tcInferRho scrut
+ ) `thenM` \ (scrut', scrut_ty) ->
+ tcMatchesCase match_ctxt scrut_ty matches (Check res_ty) `thenM` \ matches' ->
returnM (HsCase scrut' matches')
where
match_ctxt = MC { mc_what = CaseAlt,
tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
- do { arg_ty <- newTyVarTy openTypeKind
+ do { arg_ty <- newTyFlexiVarTy openTypeKind
; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
; fun' <- pop_arrow_binders (tcCheckRho fun fun_ty)
tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
- do { arg_ty <- newTyVarTy openTypeKind
+-- gaw 2004 FIX?
+ do { arg_ty <- newTyFlexiVarTy openTypeKind
; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty)
-------------------------------------------
-- Lambda
-tc_cmd env cmd@(HsLam (L mtch_loc match@(Match pats maybe_rhs_sig grhss))) (cmd_stk, res_ty)
+-- gaw 2004
+tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig grhss))] _))
+ (cmd_stk, res_ty)
= addErrCtxt (matchCtxt match_ctxt match) $
do { -- Check the cmd stack is big enough
; checkTc (lengthAtLeast cmd_stk n_pats)
(kappaUnderflow cmd)
- ; let pats_w_tys = zip pats (map Check cmd_stk)
-- Check the patterns, and the GRHSs inside
- ; (pats', grhss', ex_binds) <- addSrcSpan mtch_loc $
- tcMatchPats pats_w_tys (Check res_ty) $
- tc_grhss grhss
+ ; (pats', grhss') <- setSrcSpan mtch_loc $
+ tcMatchPats pats (map Check cmd_stk) (Check res_ty) $
+ tc_grhss grhss
- ; return (HsLam (L mtch_loc (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))))
+ ; let match' = L mtch_loc (Match pats' Nothing grhss')
+ ; return (HsLam (MatchGroup [match'] res_ty))
}
where
stk' = drop n_pats cmd_stk
match_ctxt = LambdaExpr -- Maybe KappaExpr?
- tc_grhss (GRHSs grhss binds _)
+ tc_grhss (GRHSs grhss binds)
= tcBindsAndThen glueBindsOnGRHSs binds $
do { grhss' <- mappM (wrapLocM tc_grhs) grhss
- ; return (GRHSs grhss' [] res_ty) }
+ ; return (GRHSs grhss' []) }
stmt_ctxt = SC { sc_what = PatGuard match_ctxt,
- sc_rhs = tcCheckRho,
+ sc_rhs = tcInferRho,
sc_body = \ body -> tcCmd env body (stk', res_ty),
sc_ty = res_ty } -- ToDo: Is this right?
tc_grhs (GRHS guarded)
sc_body = tc_ret,
sc_ty = res_ty }
- tc_rhs rhs ty = tcCmd env rhs ([], ty)
- tc_ret body = tcCmd env body ([], res_ty)
+ tc_rhs rhs = do { ty <- newTyFlexiVarTy liftedTypeKind
+ ; rhs' <- tcCmd env rhs ([], ty)
+ ; return (rhs', ty) }
+ tc_ret body = tcCmd env body ([], res_ty)
-----------------------------------------------------------------
tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
- ; w_tv <- newSigTyVar liftedTypeKind
- ; let w_ty = mkTyVarTy w_tv
+ ; span <- getSrcSpanM
+ ; w_tv <- tcSkolTyVar (ArrowSkol span) alphaTyVar
+ ; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point
-- a ((w,t1) .. tn) t
; let e_res_ty = mkCmdArrTy env (foldl mkPairTy w_ty cmd_stk) res_ty
-- Check that the polymorphic variable hasn't been unified with anything
-- and is not free in res_ty or the cmd_stk (i.e. t, t1..tn)
- ; [w_tv'] <- checkSigTyVarsWrt (tyVarsOfTypes (res_ty:cmd_stk))
- [w_tv]
+ ; checkSigTyVarsWrt (tyVarsOfTypes (res_ty:cmd_stk)) [w_tv]
-- OK, now we are in a position to unscramble
-- the s1..sm and check each cmd
- ; cmds' <- mapM (tc_cmd w_tv') cmds_w_tys
+ ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
- ; returnM (HsArrForm (mkHsTyLam [w_tv'] (mkHsLet inst_binds expr')) fixity cmds')
+ ; returnM (HsArrForm (mkHsTyLam [w_tv] (mkHsLet inst_binds expr')) fixity cmds')
}
where
-- Make the types
new_cmd_ty :: LHsCmdTop Name -> Int
-> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
new_cmd_ty cmd i
- = do { b_ty <- newTyVarTy arrowTyConKind
- ; tup_ty <- newTyVarTy liftedTypeKind
+-- gaw 2004 FIX?
+ = do { b_ty <- newTyFlexiVarTy arrowTyConKind
+ ; tup_ty <- newTyFlexiVarTy liftedTypeKind
-- We actually make a type variable for the tuple
-- because we don't know how deeply nested it is yet
- ; s_ty <- newTyVarTy liftedTypeKind
+ ; s_ty <- newTyFlexiVarTy liftedTypeKind
; return (cmd, i, b_ty, tup_ty, s_ty)
}
\begin{code}
-glueBindsOnCmd binds (L loc (HsCmdTop cmd stk res_ty names))
- = L loc (HsCmdTop (L loc (HsLet [binds] cmd)) stk res_ty names)
- -- Existential bindings become local bindings in the command
-
-
mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
arrowTyConKind :: Kind -- *->*->*
import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho )
import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) )
-import HsSyn ( HsExpr(..), HsBind(..), LHsBind, LHsBinds, Sig(..),
+import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
LSig, Match(..), HsBindGroup(..), IPBind(..),
- collectSigTysFromHsBinds, collectHsBindBinders,
+ LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
+ collectHsBindBinders, collectPatBinders, pprPatBind
)
-import TcHsSyn ( TcId, zonkId, mkHsLet )
+import TcHsSyn ( TcId, TcDictBinds, zonkId, mkHsLet )
import TcRnMonad
-import Inst ( InstOrigin(..), newDicts, newIPDict, instToId )
-import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName )
-import TcUnify ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sigCtxt )
+import Inst ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
+import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, newLocalName, tcLookupLocalIds )
+import TcUnify ( Expected(..), tcInfer, checkSigTyVars, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs )
-import TcHsType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..),
- tcTySig, maybeSig, tcAddScopedTyVars
+import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
+ TcSigInfo(..), TcSigFun, mkTcSig, lookupSig
)
-import TcPat ( tcPat, tcSubPat, tcMonoPatBndr )
+import TcPat ( tcPat, PatCtxt(..) )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcMType ( newTyVar, newTyVarTy, zonkTcTyVarToTyVar )
-import TcType ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
- mkPredTy, mkForAllTy, isUnLiftedType )
-import Kind ( liftedTypeKind, argTypeKind, isUnliftedTypeKind )
-
-import CoreFVs ( idFreeTyVars )
+import TcMType ( newTyFlexiVarTy, tcSkolType, zonkQuantifiedTyVar )
+import TcType ( TcTyVar, SkolemInfo(SigSkol),
+ TcTauType, TcSigmaType,
+ TvSubstEnv, mkTvSubst, substTheta, substTy,
+ mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
+ mkForAllTy, isUnLiftedType, tcGetTyVar_maybe,
+ mkTyVarTys )
+import Unify ( tcMatchPreds )
+import Kind ( argTypeKind, isUnliftedTypeKind )
+import VarEnv ( lookupVarEnv )
+import TysPrim ( alphaTyVar )
import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma )
import Var ( idType, idName )
-import Name ( Name, getSrcLoc )
+import Name ( Name )
import NameSet
import Var ( tyVarKind )
import VarSet
-import SrcLoc ( Located(..), srcLocSpan, unLoc, noLoc, getLoc )
+import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
import Bag
-import Util ( isIn, equalLength )
+import Util ( isIn )
import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec,
isNotTopLevel, isAlwaysActive )
import FiniteMap ( listToFM, lookupFM )
tcTopBinds binds
= tc_binds_and_then TopLevel glue binds $
getLclEnv `thenM` \ env ->
- returnM (emptyBag, env)
+ returnM (emptyLHsBinds, env)
where
-- The top level bindings are flattened into a giant
-- implicitly-mutually-recursive MonoBinds
-- Consider ?x = 4
-- ?y = ?x + 1
tc_ip_bind (IPBind ip expr)
- = newTyVarTy argTypeKind `thenM` \ ty ->
+ = newTyFlexiVarTy argTypeKind `thenM` \ ty ->
newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) ->
tcCheckRho expr ty `thenM` \ expr' ->
returnM (ip_inst, (IPBind ip' expr'))
tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next
- | isEmptyBag binds
+ | isEmptyLHsBinds binds
= do_next
| otherwise
= -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
-- a) the type signatures in the binding group
-- b) the bindings in the group
-- c) the scope of the binding group (the "in" part)
- tcAddScopedTyVars (collectSigTysFromHsBinds (bagToList binds)) $
+ tcAddLetBoundTyVars binds $
case top_lvl of
TopLevel -- For the top level don't bother will all this
where
tc_body poly_ids -- Type check the pragmas and "thing inside"
= -- Extend the environment to bind the new polymorphic Ids
- tcExtendLocalValEnv poly_ids $
+ tcExtendIdEnv poly_ids $
-- Build bindings and IdInfos corresponding to user pragmas
tcSpecSigs sigs `thenM` \ prag_binds ->
-> RecFlag
-> TcM (LHsBinds TcId, [TcId])
-tcBindWithSigs top_lvl mbind sigs is_rec
- = -- TYPECHECK THE SIGNATURES
- recoverM (returnM []) (
- mappM tcTySig [sig | sig@(L _(Sig name _)) <- sigs]
- ) `thenM` \ tc_ty_sigs ->
+tcBindWithSigs top_lvl mbind sigs is_rec = do
+ { -- TYPECHECK THE SIGNATURES
+ tc_ty_sigs <- recoverM (returnM []) $
+ tcTySigs [sig | sig@(L _(Sig name _)) <- sigs]
+ ; let lookup_sig = lookupSig tc_ty_sigs
-- SET UP THE MAIN RECOVERY; take advantage of any type sigs
- recoverM (
- -- If typechecking the binds fails, then return with each
- -- signature-less binder given type (forall a.a), to minimise subsequent
- -- error messages
- newTyVar liftedTypeKind `thenM` \ alpha_tv ->
- let
- forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
- binder_names = collectHsBindBinders mbind
- poly_ids = map mk_dummy binder_names
- mk_dummy name = case maybeSig tc_ty_sigs name of
- Just sig -> sig_poly_id sig -- Signature
- Nothing -> mkLocalId name forall_a_a -- No signature
- in
- traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) `thenM_`
- returnM (emptyBag, poly_ids)
- ) $
-
- -- TYPECHECK THE BINDINGS
- traceTc (ptext SLIT("--------------------------------------------------------")) `thenM_`
- traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind)) `thenM_`
- getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', bndr_names_w_ids), lie_req) ->
- let
- (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids)
- tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids
- in
+ ; recoverM (recoveryCode mbind lookup_sig) $ do
+
+ { traceTc (ptext SLIT("--------------------------------------------------------"))
+ ; traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind))
+
+ -- TYPECHECK THE BINDINGS
+ ; ((mbind', mono_bind_infos), lie_req)
+ <- getLIE (tcMonoBinds mbind lookup_sig is_rec)
-- GENERALISE
- -- (it seems a bit crude to have to do getLIE twice,
- -- but I can't see a better way just now)
- addSrcSpan (getLoc (head (bagToList mbind))) $
- -- TODO: location a bit awkward, but the mbinds have been
- -- dependency analysed and may no longer be adjacent
-
- addErrCtxt (genCtxt binder_names) $
- getLIE (generalise binder_names mbind tau_tvs lie_req tc_ty_sigs)
- `thenM` \ ((tc_tyvars_to_gen, dict_binds, dict_ids), lie_free) ->
-
-
- -- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars
- -- This commits any unbound kind variables to boxed kind, by unification
- -- It's important that the final quanfified type variables
- -- are fully zonked, *including boxity*, because they'll be
- -- included in the forall types of the polymorphic Ids.
- -- At calls of these Ids we'll instantiate fresh type variables from
- -- them, and we use their boxity then.
- mappM zonkTcTyVarToTyVar tc_tyvars_to_gen `thenM` \ real_tyvars_to_gen ->
-
- -- ZONK THE Ids
- -- It's important that the dict Ids are zonked, including the boxity set
- -- in the previous step, because they are later used to form the type of
- -- the polymorphic thing, and forall-types must be zonked so far as
- -- their bound variables are concerned
- mappM zonkId dict_ids `thenM` \ zonked_dict_ids ->
- mappM zonkId mono_ids `thenM` \ zonked_mono_ids ->
+ ; is_unres <- isUnRestrictedGroup mbind tc_ty_sigs
+ ; (tyvars_to_gen, dict_binds, dict_ids)
+ <- setSrcSpan (getLoc (head (bagToList mbind))) $
+ -- TODO: location a bit awkward, but the mbinds have been
+ -- dependency analysed and may no longer be adjacent
+ addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
+ generalise is_unres mono_bind_infos tc_ty_sigs lie_req
+
+ -- FINALISE THE QUANTIFIED TYPE VARIABLES
+ -- The quantified type variables often include meta type variables
+ -- we want to freeze them into ordinary type variables, and
+ -- default their kind (e.g. from OpenTypeKind to TypeKind)
+ ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
-- BUILD THE POLYMORPHIC RESULT IDs
- let
- exports = zipWith mk_export binder_names zonked_mono_ids
+ ; let
+ exports = map mk_export mono_bind_infos
poly_ids = [poly_id | (_, poly_id, _) <- exports]
- dict_tys = map idType zonked_dict_ids
+ dict_tys = map idType dict_ids
- inlines = mkNameSet [ name
- | L _ (InlineSig True (L _ name) _) <- sigs]
+ inlines = mkNameSet [ name
+ | L _ (InlineSig True (L _ name) _) <- sigs]
-- Any INLINE sig (regardless of phase control)
-- makes the RHS look small
-
inline_phases = listToFM [ (name, phase)
| L _ (InlineSig _ (L _ name) phase) <- sigs,
not (isAlwaysActive phase)]
-- Set the IdInfo field to control the inline phase
-- AlwaysActive is the default, so don't bother with them
+ add_inlines id = attachInlinePhase inline_phases id
- mk_export binder_name zonked_mono_id
- = (tyvars,
- attachInlinePhase inline_phases poly_id,
- zonked_mono_id)
+ mk_export (binder_name, mb_sig, mono_id)
+ = case mb_sig of
+ Just sig -> (sig_tvs sig, add_inlines (sig_id sig), mono_id)
+ Nothing -> (tyvars_to_gen', add_inlines new_poly_id, mono_id)
where
- (tyvars, poly_id) =
- case maybeSig tc_ty_sigs binder_name of
- Just sig -> (sig_tvs sig, sig_poly_id sig)
- Nothing -> (real_tyvars_to_gen, new_poly_id)
-
new_poly_id = mkLocalId binder_name poly_ty
- poly_ty = mkForAllTys real_tyvars_to_gen
+ poly_ty = mkForAllTys tyvars_to_gen'
$ mkFunTys dict_tys
- $ idType zonked_mono_id
- -- It's important to build a fully-zonked poly_ty, because
- -- we'll slurp out its free type variables when extending the
- -- local environment (tcExtendLocalValEnv); if it's not zonked
- -- it appears to have free tyvars that aren't actually free
- -- at all.
- in
+ $ idType mono_id
- traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
- exports, map idType poly_ids)) `thenM_`
+ -- ZONK THE poly_ids, because they are used to extend the type
+ -- environment; see the invariant on TcEnv.tcExtendIdEnv
+ ; zonked_poly_ids <- mappM zonkId poly_ids
+
+ ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds),
+ exports, map idType zonked_poly_ids))
-- Check for an unlifted, non-overloaded group
-- In that case we must make extra checks
- if any (isUnLiftedType . idType) zonked_mono_ids && null zonked_dict_ids
+ ; if any (isUnLiftedType . idType) zonked_poly_ids
then -- Some bindings are unlifted
- checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind `thenM_`
-
- extendLIEs lie_req `thenM_`
- returnM (
- unitBag $ noLoc $
- AbsBinds [] [] exports inlines mbind',
- -- Do not generate even any x=y bindings
- poly_ids
- )
+ do { checkUnliftedBinds top_lvl is_rec tyvars_to_gen' mbind
+ ; return (
+ unitBag $ noLoc $
+ AbsBinds [] [] exports inlines mbind',
+ -- Do not generate even any x=y bindings
+ zonked_poly_ids )}
else -- The normal case
- extendLIEs lie_free `thenM_`
- returnM (
+ return (
unitBag $ noLoc $
- AbsBinds real_tyvars_to_gen
- zonked_dict_ids
+ AbsBinds tyvars_to_gen'
+ dict_ids
exports
inlines
(dict_binds `unionBags` mbind'),
- poly_ids
+ zonked_poly_ids
)
+ } }
+
+-- If typechecking the binds fails, then return with each
+-- signature-less binder given type (forall a.a), to minimise
+-- subsequent error messages
+recoveryCode mbind lookup_sig
+ = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
+ ; return (emptyLHsBinds, poly_ids) }
+ where
+ forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
+ binder_names = collectHsBindBinders mbind
+ poly_ids = map mk_dummy binder_names
+ mk_dummy name = case lookup_sig name of
+ Just sig -> sig_id sig -- Signature
+ Nothing -> mkLocalId name forall_a_a -- No signature
attachInlinePhase inline_phases bndr
= case lookupFM inline_phases (idName bndr) of
-- c) non-polymorphic
-- d) not a multiple-binding group (more or less implied by (a))
-checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind
- = ASSERT( not (any (isUnliftedTypeKind . tyVarKind) real_tyvars_to_gen) )
+checkUnliftedBinds top_lvl is_rec tyvars_to_gen mbind
+ = ASSERT( not (any (isUnliftedTypeKind . tyVarKind) tyvars_to_gen) )
-- The instCantBeGeneralised stuff in tcSimplify should have
-- already raised an error if we're trying to generalise an
-- unboxed tyvar (NB: unboxed tyvars are always introduced
(unliftedBindErr "Recursive" mbind) `thenM_`
checkTc (isSingletonBag mbind)
(unliftedBindErr "Multiple" mbind) `thenM_`
- checkTc (null real_tyvars_to_gen)
+ checkTc (null tyvars_to_gen)
(unliftedBindErr "Polymorphic" mbind)
\end{code}
%************************************************************************
%* *
-\subsection{getTyVarsToGen}
+\subsection{tcMonoBind}
%* *
%************************************************************************
+@tcMonoBinds@ deals with a single @MonoBind@.
+The signatures have been dealt with already.
+
\begin{code}
-generalise binder_names mbind tau_tvs lie_req sigs =
+tcMonoBinds :: LHsBinds Name
+ -> TcSigFun -> RecFlag
+ -> TcM (LHsBinds TcId, [MonoBindInfo])
+
+type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
+ -- Type signature (if any), and
+ -- the monomorphic bound things
+
+bndrNames :: [MonoBindInfo] -> [Name]
+bndrNames mbi = [n | (n,_,_) <- mbi]
+
+getMonoType :: MonoBindInfo -> TcTauType
+getMonoType (_,_,mono_id) = idType mono_id
+
+tcMonoBinds binds lookup_sig is_rec
+ = do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds
+ ; let mono_info = getMonoBindInfo tc_binds
+ ; binds' <- tcExtendIdEnv2 (rhsEnvExtension mono_info) $
+ mapBagM (wrapLocM tcRhs) tc_binds
+ ; return (binds', mono_info) }
+
+------------------------
+-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
+-- we typecheck the RHSs. Basically what we are doing is this: for each binder:
+-- if there's a signature for it, use the instantiated signature type
+-- otherwise invent a type variable
+-- You see that quite directly in the FunBind case.
+--
+-- But there's a complication for pattern bindings:
+-- data T = MkT (forall a. a->a)
+-- MkT f = e
+-- Here we can guess a type variable for the entire LHS (which will be refined to T)
+-- but we want to get (f::forall a. a->a) as the RHS environment.
+-- The simplest way to do this is to typecheck the pattern, and then look up the
+-- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing
+-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
+
+data TcMonoBind -- Half completed; LHS done, RHS not done
+ = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name)
+ | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
+
+tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
+tcLhs lookup_sig (FunBind (L nm_loc name) inf matches)
+ = do { let mb_sig = lookup_sig 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
- -- check for -fno-monomorphism-restriction
- doptM Opt_NoMonomorphismRestriction `thenM` \ no_MR ->
- let is_unrestricted | no_MR = True
- | otherwise = isUnRestrictedGroup tysig_names mbind
- in
+tcLhs lookup_sig bind@(PatBind pat grhss _)
+ = do { let tc_pat exp_ty = tcPat (LetPat lookup_sig) pat exp_ty lookup_infos
+ ; ((pat', ex_tvs, infos), pat_ty)
+ <- addErrCtxt (patMonoBindsCtxt pat grhss)
+ (tcInfer tc_pat)
+
+ -- Don't know how to deal with pattern-bound existentials yet
+ ; checkTc (null ex_tvs) (existentialExplode bind)
- if not is_unrestricted then -- RESTRICTED CASE
- -- Check signature contexts are empty
- checkTc (all is_mono_sig sigs)
- (restrictedBindCtxtErr binder_names) `thenM_`
+ ; 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, lookup_sig name, mono_id)
+ | (name, mono_id) <- names `zip` mono_ids] }
+
+-------------------
+tcRhs :: TcMonoBind -> TcM (HsBind TcId)
+tcRhs (TcFunBind _ fun'@(L _ mono_id) inf matches)
+ = do { matches' <- tcMatchesFun (idName mono_id) matches
+ (Check (idType mono_id))
+ ; return (FunBind fun' inf matches') }
+
+tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
+ = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
+ tcGRHSsPat grhss (Check pat_ty)
+ ; return (PatBind pat' grhss' pat_ty) }
+
+
+---------------------
+getMonoBindInfo :: Bag (Located TcMonoBind) -> [MonoBindInfo]
+getMonoBindInfo tc_binds
+ = foldrBag (get_info . unLoc) [] tc_binds
+ where
+ get_info (TcFunBind info _ _ _) rest = info : rest
+ get_info (TcPatBind infos _ _ _) rest = infos ++ rest
+
+---------------------
+rhsEnvExtension :: [MonoBindInfo] -> [(Name, TcId)]
+-- Environment for RHS of definitions: use type sig if there is one
+rhsEnvExtension mono_info
+ = map mk mono_info
+ where
+ mk (name, Just sig, _) = (name, sig_id sig)
+ mk (name, Nothing, mono_id) = (name, mono_id)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{getTyVarsToGen}
+%* *
+%************************************************************************
+
+\begin{code}
+tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
+-- 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
+tcTySigs [] = return []
+tcTySigs (L span (Sig (L _ name) ty) : sigs)
+ = do { -- Typecheck the first signature
+ ; sigma1 <- setSrcSpan span $
+ tcHsSigType (FunSigCtxt name) ty
+ ; let id1 = mkLocalId name sigma1
+ ; tc_sig1 <- mkTcSig id1
+
+ ; tc_sigs <- mapM (tcTySig tc_sig1) sigs
+ ; return (tc_sig1 : tc_sigs) }
+
+tcTySig sig1 (L span (Sig (L _ name) ty))
+ = setSrcSpan span $
+ do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+ ; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty
+ ; let poly_id = mkLocalId name sigma_ty
+ bale_out = failWithTc $
+ sigContextsErr (sig_id sig1) name sigma_ty
+
+ -- Try to match the context of this signature with
+ -- that of the first signature
+ ; case tcMatchPreds tvs (sig_theta sig1) theta of {
+ Nothing -> bale_out
+ ; Just tenv -> do
+ ; case check_tvs tenv tvs of
+ Nothing -> bale_out
+ Just tvs' -> do
+
+ { let subst = mkTvSubst tenv
+ theta' = substTheta subst theta
+ tau' = substTy subst tau
+ ; loc <- getInstLoc (SigOrigin rigid_info)
+ ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs',
+ sig_theta = theta', sig_tau = tau',
+ sig_loc = loc }) }}}
+ where
+ rigid_info = SigSkol name
+
+ -- Rather tedious check that the type variables
+ -- have been matched only with another type variable,
+ -- and that two type variables have not been matched
+ -- with the same one
+ -- A return of Nothing indicates that one of the bad
+ -- things has happened
+ check_tvs :: TvSubstEnv -> [TcTyVar] -> Maybe [TcTyVar]
+ check_tvs tenv [] = Just []
+ check_tvs tenv (tv:tvs)
+ | Just ty <- lookupVarEnv tenv tv
+ = do { tv' <- tcGetTyVar_maybe ty
+ ; tvs' <- check_tvs tenv tvs
+ ; if tv' `elem` tvs'
+ then Nothing
+ else Just (tv':tvs') }
+ | otherwise
+ = do { tvs' <- check_tvs tenv tvs
+ ; Just (tv:tvs') }
+\end{code}
+
+\begin{code}
+generalise :: Bool -> [MonoBindInfo] -> [TcSigInfo] -> [Inst]
+ -> TcM ([TcTyVar], TcDictBinds, [TcId])
+generalise is_unrestricted mono_infos sigs lie_req
+ | not is_unrestricted -- RESTRICTED CASE
+ = -- Check signature contexts are empty
+ do { checkTc (all is_mono_sig sigs)
+ (restrictedBindCtxtErr bndr_names)
-- Now simplify with exactly that set of tyvars
-- We have to squash those Methods
- tcSimplifyRestricted doc tau_tvs lie_req `thenM` \ (qtvs, binds) ->
+ ; (qtvs, binds) <- tcSimplifyRestricted doc tau_tvs lie_req
-- Check that signature type variables are OK
- checkSigsTyVars qtvs sigs `thenM` \ final_qtvs ->
+ ; final_qtvs <- checkSigsTyVars qtvs sigs
- returnM (final_qtvs, binds, [])
+ ; return (final_qtvs, binds, []) }
- else if null sigs then -- UNRESTRICTED CASE, NO TYPE SIGS
- tcSimplifyInfer doc tau_tvs lie_req
+ | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS
+ = tcSimplifyInfer doc tau_tvs lie_req
+
+ | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS
+ = do { let sig1 = head sigs
+ ; sig_lie <- newDictsAtLoc (sig_loc sig1) (sig_theta sig1)
+ ; let -- The "sig_avails" is the stuff available. We get that from
+ -- the context of the type signature, BUT ALSO the lie_avail
+ -- so that polymorphic recursion works right (see comments at end of fn)
+ local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
+ sig_avails = sig_lie ++ local_meths
- else -- UNRESTRICTED CASE, WITH TYPE SIGS
- -- CHECKING CASE: Unrestricted group, there are type signatures
- -- Check signature contexts are identical
- checkSigsCtxts sigs `thenM` \ (sig_avails, sig_dicts) ->
-
-- Check that the needed dicts can be
-- expressed in terms of the signature ones
- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenM` \ (forall_tvs, dict_binds) ->
+ ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req
-- Check that signature type variables are OK
- checkSigsTyVars forall_tvs sigs `thenM` \ final_qtvs ->
+ ; final_qtvs <- checkSigsTyVars forall_tvs sigs
- returnM (final_qtvs, dict_binds, sig_dicts)
+ ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
where
- tysig_names = map (idName . sig_poly_id) sigs
+ bndr_names = bndrNames mono_infos
+ tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos
is_mono_sig sig = null (sig_theta sig)
+ doc = ptext SLIT("type signature(s) for") <+> pprBinders bndr_names
- doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
-
------------------------
- -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
- -- The type signatures on a mutually-recursive group of definitions
- -- must all have the same context (or none).
- --
- -- We unify them because, with polymorphic recursion, their types
- -- might not otherwise be related. This is a rather subtle issue.
- -- ToDo: amplify
-checkSigsCtxts sigs@(TySigInfo { sig_poly_id = id1, sig_tvs = sig_tvs, sig_theta = theta1, sig_loc = span}
- : other_sigs)
- = addSrcSpan span $
- mappM_ check_one other_sigs `thenM_`
- if null theta1 then
- returnM ([], []) -- Non-overloaded type signatures
- else
- newDicts SignatureOrigin theta1 `thenM` \ sig_dicts ->
- let
- -- The "sig_avails" is the stuff available. We get that from
- -- the context of the type signature, BUT ALSO the lie_avail
- -- so that polymorphic recursion works right (see comments at end of fn)
- sig_avails = sig_dicts ++ sig_meths
- in
- returnM (sig_avails, map instToId sig_dicts)
- where
- sig1_dict_tys = map mkPredTy theta1
- sig_meths = concatMap sig_insts sigs
-
- check_one (TySigInfo {sig_poly_id = id, sig_theta = theta})
- = addErrCtxt (sigContextsCtxt id1 id) $
- checkTc (equalLength theta theta1) sigContextsErr `thenM_`
- unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
+mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
+ sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id
+ = Method mono_id poly_id (mkTyVarTys tvs) theta tau loc
checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
checkSigsTyVars qtvs sigs
in
returnM (varSetElems all_tvs)
where
- check_one (TySigInfo {sig_poly_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau})
+ check_one (TcSigInfo {sig_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau})
= addErrCtxt (ptext SLIT("In the type signature for")
<+> quotes (ppr id)) $
addErrCtxtM (sigCtxt id tvs theta tau) $
- checkSigTyVarsWrt (idFreeTyVars id) tvs
+ do { checkSigTyVars tvs; return tvs }
\end{code}
@getTyVarsToGen@ decides what type variables to generalise over.
find which tyvars are constrained.
\begin{code}
-isUnRestrictedGroup :: [Name] -- Signatures given for these
- -> LHsBinds Name
- -> Bool
-isUnRestrictedGroup sigs binds = all (unrestricted . unLoc) (bagToList binds)
+isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool
+isUnRestrictedGroup binds sigs
+ = do { no_MR <- doptM Opt_NoMonomorphismRestriction
+ ; return (no_MR || all_unrestricted) }
where
- unrestricted (PatBind other _) = False
- unrestricted (VarBind v _) = v `is_elem` sigs
- unrestricted (FunBind v _ matches) = unrestricted_match matches
- || unLoc v `is_elem` sigs
+ all_unrestricted = all (unrestricted . unLoc) (bagToList binds)
+ tysig_names = map (idName . sig_id) sigs
+
+ unrestricted (PatBind other _ _) = False
+ unrestricted (VarBind v _) = v `is_elem` tysig_names
+ unrestricted (FunBind v _ matches) = unrestricted_match matches
+ || unLoc v `is_elem` tysig_names
- unrestricted_match (L _ (Match [] _ _) : _) = False
+ unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
-- No args => like a pattern binding
unrestricted_match other = True
-- Some args => a function binding
%************************************************************************
%* *
-\subsection{tcMonoBind}
-%* *
-%************************************************************************
-
-@tcMonoBinds@ deals with a single @MonoBind@.
-The signatures have been dealt with already.
-
-\begin{code}
-tcMonoBinds :: LHsBinds Name
- -> [TcSigInfo] -> RecFlag
- -> TcM (LHsBinds TcId,
- Bag (Name, -- Bound names
- TcId)) -- Corresponding monomorphic bound things
-
-tcMonoBinds mbinds tc_ty_sigs is_rec
- -- Three stages:
- -- 1. Check the patterns, building up an environment binding
- -- the variables in this group (in the recursive case)
- -- 2. Extend the environment
- -- 3. Check the RHSs
- = mapBagM tc_lbind_pats mbinds `thenM` \ bag_of_pairs ->
- let
- (complete_it, xve)
- = foldrBag combine
- (returnM (emptyBag, emptyBag), emptyBag)
- bag_of_pairs
- combine (complete_it1, xve1) (complete_it2, xve2)
- = (complete_it, xve1 `unionBags` xve2)
- where
- complete_it = complete_it1 `thenM` \ (b1, bs1) ->
- complete_it2 `thenM` \ (b2, bs2) ->
- returnM (b1 `consBag` b2, bs1 `unionBags` bs2)
- in
- tcExtendLocalValEnv2 (bagToList xve) complete_it
- where
- tc_lbind_pats :: LHsBind Name
- -> TcM (TcM (LHsBind TcId, Bag (Name,TcId)), -- Completer
- Bag (Name,TcId))
- -- wrapper for tc_bind_pats to deal with the location stuff
- tc_lbind_pats (L loc bind)
- = addSrcSpan loc $ do
- (tc, bag) <- tc_bind_pats bind
- return (wrap tc, bag)
- where
- wrap tc = addSrcSpan loc $ do
- (bind, stuff) <- tc
- return (L loc bind, stuff)
-
-
- tc_bind_pats :: HsBind Name
- -> TcM (TcM (HsBind TcId, Bag (Name,TcId)), -- Completer
- Bag (Name,TcId))
- tc_bind_pats (FunBind (L nm_loc name) inf matches)
- -- Three cases:
- -- a) Type sig supplied
- -- b) No type sig and recursive
- -- c) No type sig and non-recursive
-
- | Just sig <- maybeSig tc_ty_sigs name
- = let -- (a) There is a type signature
- -- Use it for the environment extension, and check
- -- the RHS has the appropriate type (with outer for-alls stripped off)
- mono_id = sig_mono_id sig
- mono_ty = idType mono_id
- complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' ->
- returnM (FunBind (L nm_loc mono_id) inf matches',
- unitBag (name, mono_id))
- in
- returnM (complete_it, if isRec is_rec then unitBag (name, sig_poly_id sig)
- else emptyBag)
-
- | isRec is_rec
- = -- (b) No type signature, and recursive
- -- So we must use an ordinary H-M type variable
- -- which means the variable gets an inferred tau-type
- newLocalName name `thenM` \ mono_name ->
- newTyVarTy argTypeKind `thenM` \ mono_ty ->
- let
- mono_id = mkLocalId mono_name mono_ty
- complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' ->
- returnM (FunBind (L nm_loc mono_id) inf matches',
- unitBag (name, mono_id))
- in
- returnM (complete_it, unitBag (name, mono_id))
-
- | otherwise -- (c) No type signature, and non-recursive
- = let -- So we can use a 'hole' type to infer a higher-rank type
- complete_it
- = newHole `thenM` \ hole ->
- tcMatchesFun name matches (Infer hole) `thenM` \ matches' ->
- readMutVar hole `thenM` \ fun_ty ->
- newLocalName name `thenM` \ mono_name ->
- let
- mono_id = mkLocalId mono_name fun_ty
- in
- returnM (FunBind (L nm_loc mono_id) inf matches',
- unitBag (name, mono_id))
- in
- returnM (complete_it, emptyBag)
-
- tc_bind_pats bind@(PatBind pat grhss)
- = -- Now typecheck the pattern
- -- We do now support binding fresh (not-already-in-scope) scoped
- -- type variables in the pattern of a pattern binding.
- -- For example, this is now legal:
- -- (x::a, y::b) = e
- -- The type variables are brought into scope in tc_binds_and_then,
- -- so we don't have to do anything here.
- newHole `thenM` \ hole ->
- tcPat tc_pat_bndr pat (Infer hole) `thenM` \ (pat', tvs, ids, lie_avail) ->
- readMutVar hole `thenM` \ pat_ty ->
-
- -- Don't know how to deal with pattern-bound existentials yet
- checkTc (isEmptyBag tvs && null lie_avail)
- (existentialExplode bind) `thenM_`
-
- let
- complete_it = addErrCtxt (patMonoBindsCtxt bind) $
- tcGRHSsPat grhss (Check pat_ty) `thenM` \ grhss' ->
- returnM (PatBind pat' grhss', ids)
- in
- returnM (complete_it, if isRec is_rec then ids else emptyBag)
-
- -- tc_pat_bndr is used when dealing with a LHS binder in a pattern.
- -- If there was a type sig for that Id, we want to make it much
- -- as if that type signature had been on the binder as a SigPatIn.
- -- We check for a type signature; if there is one, we use the mono_id
- -- from the signature. This is how we make sure the tau part of the
- -- signature actually matches the type of the LHS; then tc_bind_pats
- -- ensures the LHS and RHS have the same type
-
- tc_pat_bndr name pat_ty
- = case maybeSig tc_ty_sigs name of
- Nothing -> newLocalName name `thenM` \ bndr_name ->
- tcMonoPatBndr bndr_name pat_ty
-
- Just sig -> addSrcSpan (srcLocSpan (getSrcLoc name)) $
- -- TODO: location wrong
- tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn ->
- returnM (co_fn, mono_id)
- where
- mono_id = sig_mono_id sig
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{SPECIALIZE pragmas}
%* *
%************************************************************************
tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId)
tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs)
= -- SPECIALISE f :: forall b. theta => tau = g
- addSrcSpan loc $
+ setSrcSpan loc $
addErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
returnM (binds_rest `snocBag` L loc spec_bind)
tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
-tcSpecSigs [] = returnM emptyBag
+tcSpecSigs [] = returnM emptyLHsBinds
\end{code}
%************************************************************************
\begin{code}
-patMonoBindsCtxt bind
- = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
+-- This one is called on LHS, when pat and grhss are both Name
+-- and on RHS, when pat is TcId and grhss is still Name
+patMonoBindsCtxt pat grhss
+ = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss)
-----------------------------------------------
valSpecSigCtxt v ty
nest 4 (ppr v <+> dcolon <+> ppr ty)]
-----------------------------------------------
-sigContextsErr = ptext SLIT("Mismatched contexts")
-
-sigContextsCtxt s1 s2
- = vcat [ptext SLIT("When matching the contexts of the signatures for"),
- nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1),
- ppr s2 <+> dcolon <+> ppr (idType s2)]),
+sigContextsErr id1 name ty
+ = vcat [ptext SLIT("Mis-match between the contexts of the signatures for"),
+ nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
+ ppr name <+> dcolon <+> ppr ty]),
ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
+
-----------------------------------------------
unliftedBindErr flavour mbind
= hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
import RnExpr ( rnLExpr )
import RnEnv ( lookupTopBndrRn, lookupImportedName )
-import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
-import TcEnv ( tcLookupLocatedClass, tcExtendLocalValEnv2,
+import Inst ( Inst, InstOrigin(..), instToId, newDicts, newDictsAtLoc, newMethod )
+import TcEnv ( tcLookupLocatedClass, tcExtendIdEnv2,
tcExtendTyVarEnv2,
InstInfo(..), pprInstInfoDetails,
simpleInstInfoTyCon, simpleInstInfoTy,
import TcHsType ( TcSigInfo(..), mkTcSig, tcHsKindedType, tcHsSigType )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcUnify ( checkSigTyVars, sigCtxt )
-import TcMType ( tcInstTyVars, UserTypeCtxt( GenPatCtxt ) )
-import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar,
+import TcMType ( tcSkolTyVars, UserTypeCtxt( GenPatCtxt ) )
+import TcType ( Type, SkolemInfo(ClsSkol, InstSkol),
+ TcType, TcThetaType, TcTyVar, mkTyVarTys,
mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
getClassPredTys_maybe, mkPhiTy, mkTyVarTy
import Class ( classTyVars, classBigSig,
Class, ClassOpItem, DefMeth (..) )
import TyCon ( TyCon, tyConName, tyConHasGenerics )
-import Subst ( substTyWith )
+import Type ( substTyWith )
import MkId ( mkDefaultMethodId, mkDictFunId )
import Id ( Id, idType, idName, mkUserLocal, setInlinePragma )
import Name ( Name, NamedThing(..) )
= do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
return (mkNameEnv dm_infos)
-checkDefaultBind clas ops (FunBind (L _ op) _ matches)
+checkDefaultBind clas ops (FunBind (L _ op) _ (MatchGroup matches _))
= do { -- Check that the op is from this class
checkTc (op `elem` ops) (badMethodErr clas op)
-> TcM TcMethInfo
tcClassSig dm_env (L loc (Sig (L _ op_name) op_hs_ty))
- = addSrcSpan loc $ do
+ = setSrcSpan loc $ do
{ op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
; let dm = case lookupNameEnv dm_env op_name of
Nothing -> NoDefMeth
tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
- = recoverM (returnM (emptyBag, [])) $
- addSrcSpan loc $
+ = recoverM (returnM (emptyLHsBinds, [])) $
+ setSrcSpan loc $
tcLookupLocatedClass class_name `thenM` \ clas ->
-- We make a separate binding for each default method.
returnM (listToBag defm_binds, concat dm_ids_s)
tcDefMeth clas tyvars binds_in prags sel_id
- = lookupTopBndrRn (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
- tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) ->
- let
- dm_ty = idType sel_id -- Same as dict selector!
- theta = [mkClassPred clas inst_tys]
- local_dm_id = mkDefaultMethodId dm_name dm_ty
- xtve = tyvars `zip` clas_tyvars
- origin = ClassDeclOrigin
- in
- mkMethodBind origin clas inst_tys
- binds_in (sel_id, DefMeth) `thenM` \ (_, meth_info) ->
- newDicts origin theta `thenM` \ [this_dict] ->
- getLIE (tcMethodBind xtve clas_tyvars theta
- [this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) ->
+ = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
+ ; let rigid_info = ClsSkol clas
+ ; clas_tyvars <- tcSkolTyVars rigid_info tyvars
+ ; let
+ inst_tys = mkTyVarTys clas_tyvars
+ dm_ty = idType sel_id -- Same as dict selector!
+ theta = [mkClassPred clas inst_tys]
+ local_dm_id = mkDefaultMethodId dm_name dm_ty
+ xtve = tyvars `zip` clas_tyvars
+ origin = SigOrigin rigid_info
+
+ ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
+ ; [this_dict] <- newDicts origin theta
+ ; (defm_bind, insts_needed) <- getLIE (tcMethodBind xtve clas_tyvars theta
+ [this_dict] prags meth_info)
- addErrCtxt (defltMethCtxt clas) $
+ ; addErrCtxt (defltMethCtxt clas) $ do
-- Check the context
- tcSimplifyCheck
- (ptext SLIT("class") <+> ppr clas)
- clas_tyvars
- [this_dict]
- insts_needed `thenM` \ dict_binds ->
+ { dict_binds <- tcSimplifyCheck
+ (ptext SLIT("class") <+> ppr clas)
+ clas_tyvars
+ [this_dict]
+ insts_needed
-- Simplification can do unification
- checkSigTyVars clas_tyvars `thenM` \ clas_tyvars' ->
+ ; checkSigTyVars clas_tyvars
- let
- (_,dm_inst_id,_) = meth_info
- full_bind = AbsBinds
- clas_tyvars'
- [instToId this_dict]
- [(clas_tyvars', local_dm_id, dm_inst_id)]
- emptyNameSet -- No inlines (yet)
- (dict_binds `unionBags` defm_bind)
- in
- returnM (noLoc full_bind, [local_dm_id])
+ ; let
+ (_,dm_inst_id,_) = meth_info
+ full_bind = AbsBinds
+ clas_tyvars
+ [instToId this_dict]
+ [(clas_tyvars, local_dm_id, dm_inst_id)]
+ emptyNameSet -- No inlines (yet)
+ (dict_binds `unionBags` defm_bind)
+ ; returnM (noLoc full_bind, [local_dm_id]) }}
mkDefMethRdrName :: Id -> RdrName
mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
(sel_id, meth_id, meth_bind)
- = recoverM (returnM emptyBag) $
+ = recoverM (returnM emptyLHsBinds) $
-- If anything fails, recover returning no bindings.
-- This is particularly useful when checking the default-method binding of
-- a class decl. If we don't recover, we don't add the default method to
-- Check the bindings; first adding inst_tyvars to the envt
-- so that we don't quantify over them in nested places
mkTcSig meth_id `thenM` \ meth_sig ->
-
+ let lookup_sig name = ASSERT( name == idName meth_id )
+ Just meth_sig
+ in
tcExtendTyVarEnv2 xtve (
addErrCtxt (methodCtxt sel_id) $
getLIE $
- tcMonoBinds (unitBag meth_bind) [meth_sig] NonRecursive
- ) `thenM` \ ((meth_bind,_), meth_lie) ->
+ tcMonoBinds (unitBag meth_bind) lookup_sig NonRecursive
+ ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
-- Now do context reduction. We simplify wrt both the local tyvars
-- and the ones of the class/instance decl, so that there is
--
-- We do this for each method independently to localise error messages
- let
- TySigInfo { sig_poly_id = meth_id, sig_tvs = meth_tvs,
- sig_theta = meth_theta, sig_mono_id = local_meth_id } = meth_sig
- in
addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
- newDicts SignatureOrigin meth_theta `thenM` \ meth_dicts ->
+ newDictsAtLoc (sig_loc meth_sig) (sig_theta meth_sig) `thenM` \ meth_dicts ->
let
+ meth_tvs = sig_tvs meth_sig
all_tyvars = meth_tvs ++ inst_tyvars
all_insts = avail_insts ++ meth_dicts
in
(ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
- checkSigTyVars all_tyvars `thenM` \ all_tyvars' ->
+ checkSigTyVars all_tyvars `thenM_`
let
sel_name = idName sel_id
| otherwise
= (meth_id, emptyNameSet)
- meth_tvs' = take (length meth_tvs) all_tyvars'
- poly_meth_bind = noLoc $ AbsBinds meth_tvs'
+ [(_,_,local_meth_id)] = mono_bind_infos
+ poly_meth_bind = noLoc $ AbsBinds meth_tvs
(map instToId meth_dicts)
- [(meth_tvs', final_meth_id, local_meth_id)]
+ [(meth_tvs, final_meth_id, local_meth_id)]
inlines
(lie_binds `unionBags` meth_bind)
in
-- Deal with specialisation pragmas
-- The sel_name is what appears in the pragma
- tcExtendLocalValEnv2 [(sel_name, final_meth_id)] (
+ tcExtendIdEnv2 [(sel_name, final_meth_id)] (
getLIE (tcSpecSigs spec_prags) `thenM` \ (spec_binds1, prag_lie) ->
-- The prag_lie for a SPECIALISE pragma will mention the function itself,
mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
-- Not infix decl
returnM (noLoc $ FunBind (noLoc meth_name) False
- [mkSimpleMatch [] rhs placeHolderType])
+ (mkMatchGroup [mkSimpleMatch [] rhs]))
) `thenM` \ meth_bind ->
returnM (mb_inst, (sel_id, meth_id, meth_bind))
(omittedMethodWarn sel_id) `thenM_`
returnM error_rhs
where
- error_rhs = noLoc $ HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType)
+ error_rhs = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
(nlHsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
other -> Nothing
other -> Nothing
-isInstDecl InstanceDeclOrigin = True
-isInstDecl ClassDeclOrigin = False
+isInstDecl (SigOrigin (InstSkol _)) = True
+isInstDecl (SigOrigin (ClsSkol _)) = False
\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 matches))
+getGenericBind (L loc (FunBind id infixop (MatchGroup matches ty)))
= groupWith wrap (mapCatMaybes maybeGenericMatch matches)
where
- wrap ms = L loc (FunBind id infixop ms)
+ wrap ms = L loc (FunBind id infixop (MatchGroup ms ty))
getGenericBind _
= []
= returnM (Just []) -- Default declaration specifying no types
tcDefaults [L locn (DefaultDecl mono_tys)]
- = addSrcSpan locn $
+ = setSrcSpan locn $
addErrCtxt defaultDeclCtxt $
tcLookupClass numClassName `thenM` \ num_class ->
mappM tc_default_ty mono_tys `thenM` \ tau_tys ->
returnM (Just tau_tys)
tcDefaults decls@(L locn (DefaultDecl _) : _) =
- addSrcSpan locn $
+ setSrcSpan locn $
failWithTc (dupDefaultDeclErr decls)
import HscTypes ( DFunId, FixityEnv )
import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Subst ( mkTyVarSubst, substTheta )
+import Type ( zipTvSubst, substTheta )
import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
-import DataCon ( isNullaryDataCon, isExistentialDataCon, dataConOrigArgTys )
+import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
import Maybes ( catMaybes )
import RdrName ( RdrName )
import Name ( Name, getSrcLoc )
import NameSet ( NameSet, emptyNameSet, duDefs )
import Kind ( splitKindFunTys )
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
- tyConTheta, isProductTyCon, isDataTyCon, newTyConRhs,
+ tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
-----------------------------------------
deriveOrdinaryStuff [] -- Short cut
- = returnM ([], emptyBag)
+ = returnM ([], emptyLHsBinds)
deriveOrdinaryStuff eqns
= do { -- Take the equation list and solve it, to deliver a list of
mk_eqn (new_or_data, tycon_name, hs_deriv_ty)
= tcLookupTyCon tycon_name `thenM` \ tycon ->
- addSrcSpan (srcLocSpan (getSrcLoc tycon)) $
+ setSrcSpan (srcLocSpan (getSrcLoc tycon)) $
addErrCtxt (derivCtxt Nothing tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
-- There's no 'corece' needed because after the type checker newtypes
-- are transparent.
- sc_theta = substTheta (mkTyVarSubst clas_tyvars inst_tys)
+ sc_theta = substTheta (zipTvSubst clas_tyvars inst_tys)
(classSCTheta clas)
-- If there are no tyvars, there's no need
where
tyvars = tyConTyVars tycon
constraints = extra_constraints ++ ordinary_constraints
- extra_constraints = tyConTheta tycon
+ extra_constraints = tyConStupidTheta tycon
-- "extra_constraints": see note [Data decl contexts] above
ordinary_constraints
= [ mkClassPred clas [arg_ty]
| data_con <- tyConDataCons tycon,
arg_ty <- dataConOrigArgTys data_con,
- -- Use the same type variables
- -- as the type constructor,
- -- hence no need to instantiate
not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
]
cond_std :: Condition
cond_std (gla_exts, tycon)
- | any isExistentialDataCon data_cons = Just existential_why
- | null data_cons = Just no_cons_why
- | otherwise = Nothing
+ | any (not . isVanillaDataCon) data_cons = Just existential_why
+ | null data_cons = Just no_cons_why
+ | otherwise = Nothing
where
data_cons = tyConDataCons tycon
no_cons_why = quotes (ppr tycon) <+> ptext SLIT("has no data constructors")
------------------------------------------------------------------
gen_soln (_, clas, tc,tyvars,deriv_rhs)
- = addSrcSpan (srcLocSpan (getSrcLoc tc)) $
+ = setSrcSpan (srcLocSpan (getSrcLoc tc)) $
addErrCtxt (derivCtxt (Just clas) tc) $
tcSimplifyDeriv tyvars deriv_rhs `thenM` \ theta ->
returnM (sortLe (<=) theta) -- Canonicalise before returning the soluction
genDerivBinds clas fix_env tycon
| className clas `elem` typeableClassNames
- = (gen_Typeable_binds tycon, emptyBag)
+ = (gen_Typeable_binds tycon, emptyLHsBinds)
| otherwise
= case assocMaybe gen_list (getUnique clas) of
-- no_aux_binds is used for generators that don't
-- need to produce any auxiliary bindings
- no_aux_binds f fix_env tc = (f fix_env tc, emptyBag)
+ no_aux_binds f fix_env tc = (f fix_env tc, emptyLHsBinds)
ignore_fix_env f fix_env tc = f tc
\end{code}
do_con2tag acc_Names tycon
| isDataTyCon tycon &&
((we_are_deriving eqClassKey tycon
- && any isNullaryDataCon (tyConDataCons tycon))
+ && any isNullarySrcDataCon (tyConDataCons tycon))
|| (we_are_deriving ordClassKey tycon
&& not (isProductTyCon tycon))
|| (we_are_deriving enumClassKey tycon)
tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
- tcLookupLocatedClass, tcLookupLocatedDataCon,
+ tcLookupLocatedClass,
-- Local environment
tcExtendKindEnv,
- tcExtendTyVarEnv, tcExtendTyVarEnv2,
- tcExtendLocalValEnv, tcExtendLocalValEnv2,
+ tcExtendTyVarEnv, tcExtendTyVarEnv2,
+ tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar,
lclEnvElts, getInLocalScope, findGlobals,
import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
import TcType ( Type, TcKind, TcTyVar, TcTyVarSet,
tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
- getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo,
+ getDFunTyKey, tcTyConAppTyCon,
tidyOpenType, tidyOpenTyVar
)
import qualified Type ( getTyVar_maybe )
import SrcLoc ( SrcLoc, Located(..) )
import Outputable
-import Maybe ( isJust )
\end{code}
then -- It's defined in this module
case lookupNameEnv (tcg_type_env env) name of
Just thing -> return thing
- Nothing -> notFound "tcLookupGlobal" name
+ Nothing -> notFound name -- Panic!
else do -- It's imported
{ (eps,hpt) <- getEpsAndHpt
tcLookupLocatedGlobalId :: Located Name -> TcM Id
tcLookupLocatedGlobalId = addLocM tcLookupId
-tcLookupLocatedDataCon :: Located Name -> TcM DataCon
-tcLookupLocatedDataCon = addLocM tcLookupDataCon
-
tcLookupLocatedClass :: Located Name -> TcM Class
tcLookupLocatedClass = addLocM tcLookupClass
\begin{code}
-tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a
-tcExtendLocalValEnv ids thing_inside
- = getLclEnv `thenM` \ env ->
- let
- extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
- th_lvl = thLevel (tcl_th_ctxt env)
- proc_lvl = proc_level (tcl_arrow_ctxt env)
- extra_env = [(idName id, ATcId id th_lvl proc_lvl) | id <- ids]
- le' = extendNameEnvList (tcl_env env) extra_env
- rdr_env' = extendLocalRdrEnv (tcl_rdr env) (map idName ids)
- in
- 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
-
-tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
-tcExtendLocalValEnv2 names_w_ids thing_inside
+tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
+-- Invariant: the TcIds are fully zonked. Reasons:
+-- (a) The kinds of the forall'd type variables are defaulted
+-- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
+-- (b) There are no via-Indirect occurrences of the bound variables
+-- in the types, because instantiation does not look through such things
+-- (c) The call to tyVarsOfTypes is ok without looking through refs
+tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
+
+tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
+tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
+
+tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
+-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
+tcExtendIdEnv2 names_w_ids thing_inside
= getLclEnv `thenM` \ env ->
let
extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
tv == tv' = empty
| otherwise = equals <+> ppr tidy_ty
-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
-
- bound_at = tyVarBindingInfo tv
+ bound_at = ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
in
returnM (tidy_env2, Just msg)
\end{code}
%************************************************************************
\begin{code}
-notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
- ptext SLIT("is not in scope"))
+notFound name
+ = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
+ ptext SLIT("is not in scope"))
wrongThingErr expected thing name
= failWithTc (pp_thing thing <+> quotes (ppr name) <+>
-> TcType.TcType
-> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id)
+tcInferRho ::
+ HsExpr.LHsExpr Name.Name
+ -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id, TcType.TcType)
+
tcMonoExpr ::
HsExpr.LHsExpr Name.Name
-> TcUnify.Expected TcType.TcType
import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields,
HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar )
-import TcHsSyn ( hsLitType, mkHsDictApp, mkHsTyApp, (<$>) )
+import TcHsSyn ( hsLitType, (<$>) )
import TcRnMonad
-import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedTo, tcSubExp, tcGen,
- unifyFunTy, zapToListTy, zapToPArrTy, zapToTupleTy )
+import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen,
+ unifyFunTys, zapToListTy, zapToTyConApp, readExpectedType )
import BasicTypes ( isMarkedStrict )
import Inst ( InstOrigin(..),
newOverloadedLit, newMethodFromName, newIPDict,
- newDicts, newMethodWithGivenTy,
- instToId, tcInstCall, tcInstDataCon
- )
+ newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookup, tcLookupId, checkProcLevel,
tcLookupDataCon, tcLookupGlobalId
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) )
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( badFieldCon )
-import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, zonkTcType )
-import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
+import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType, readMetaTyVar )
+import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, MetaDetails(..),
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
- isSigmaTy, mkFunTy, mkFunTys,
- mkTyConApp, tyVarsOfTypes, isLinearPred,
+ isSigmaTy, mkFunTy, mkTyConApp, tyVarsOfTypes, isLinearPred,
tcSplitSigmaTy, tidyOpenType
)
import Kind ( openTypeKind, liftedTypeKind, argTypeKind )
-import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
import Id ( idType, recordSelectorFieldLabel, isRecordSelector )
import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId )
import Name ( Name )
-import TyCon ( TyCon, tyConTyVars, tyConTheta, tyConDataCons )
-import Subst ( mkTopTyVarSubst, substTheta, substTy )
+import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta,
+ tyConDataCons, tyConFields )
+import Type ( zipTopTvSubst, mkTopTvSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
-import TysWiredIn ( boolTy )
+import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
import PrelNames ( enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName
import HscTypes ( TyThing(..) )
import SrcLoc ( Located(..), unLoc, getLoc )
import Util
+import Maybes ( catMaybes )
import Outputable
import FastString
tcCheckRho expr rho_ty = tcMonoExpr expr (Check rho_ty)
tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
-tcInferRho (L loc (HsVar name)) = addSrcSpan loc $
- do { (e,ty) <- tcId name; return (L loc e, ty)}
-tcInferRho expr = newHole `thenM` \ hole ->
- tcMonoExpr expr (Infer hole) `thenM` \ expr' ->
- readMutVar hole `thenM` \ rho_ty ->
- returnM (expr', rho_ty)
+tcInferRho (L loc (HsVar name)) = setSrcSpan loc $ do
+ { (e,_,ty) <- tcId name; return (L loc e, ty)}
+tcInferRho expr = tcInfer (tcMonoExpr expr)
\end{code}
-> TcM (LHsExpr TcId)
tcMonoExpr (L loc expr) res_ty
- = addSrcSpan loc (do { expr' <- tc_expr expr res_ty
+ = setSrcSpan loc (do { expr' <- tc_expr expr res_ty
; return (L loc expr') })
tc_expr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId)
tc_expr (HsVar name) res_ty
- = tcId name `thenM` \ (expr', id_ty) ->
- tcSubExp res_ty id_ty `thenM` \ co_fn ->
- returnM (co_fn <$> expr')
+ = do { (expr', _, id_ty) <- tcId name
+ ; co_fn <- tcSubExp res_ty id_ty
+ ; returnM (co_fn <$> expr') }
tc_expr (HsIPVar ip) res_ty
= -- Implicit parameters must have a *tau-type* not a
-- type scheme. We enforce this by creating a fresh
-- type variable as its type. (Because res_ty may not
-- be a tau-type.)
- newTyVarTy argTypeKind `thenM` \ ip_ty ->
+ 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_`
tc_expr in_expr@(SectionL arg1 op) res_ty
= tcInferRho op `thenM` \ (op', op_ty) ->
- split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ unifyFunTys 2 op_ty {- two args -} `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 ->
tc_expr in_expr@(SectionR op arg2) res_ty
= tcInferRho op `thenM` \ (op', op_ty) ->
- split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ unifyFunTys 2 op_ty {- two args -} `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 ->
tc_expr in_expr@(OpApp arg1 op fix arg2) res_ty
= tcInferRho op `thenM` \ (op', op_ty) ->
- split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ unifyFunTys 2 op_ty {- two args -} `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) $
= tcBindsAndThen
glue
binds -- Bindings to check
- (tc_expr expr res_ty)
+ (setSrcSpan loc $ tc_expr expr res_ty)
where
glue bind expr = HsLet [bind] (L loc expr)
-tc_expr in_expr@(HsCase scrut matches) res_ty
- = addErrCtxt (caseCtxt in_expr) $
-
- -- Typecheck the case alternatives first.
+tc_expr 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
-
- tcMatchesCase match_ctxt matches res_ty `thenM` \ (scrut_ty, matches') ->
-
- addErrCtxt (caseScrutCtxt scrut) (
- tcCheckRho scrut scrut_ty
- ) `thenM` \ scrut' ->
-
- returnM (HsCase scrut' matches')
- where
+ --
+ -- 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')
+ where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = tcMonoExpr }
tcCheckRho expr elt_ty
tc_expr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
- = zapToPArrTy res_ty `thenM` \ elt_ty ->
- mappM (tc_elt elt_ty) exprs `thenM` \ exprs' ->
- returnM (ExplicitPArr elt_ty exprs')
+ = do { [elt_ty] <- zapToTyConApp parrTyCon res_ty
+ ; exprs' <- mappM (tc_elt elt_ty) exprs
+ ; return (ExplicitPArr elt_ty exprs') }
where
tc_elt elt_ty expr
- = addErrCtxt (parrCtxt expr) $
- tcCheckRho expr elt_ty
+ = addErrCtxt (parrCtxt expr) (tcCheckRho expr elt_ty)
tc_expr (ExplicitTuple exprs boxity) res_ty
- = zapToTupleTy boxity (length exprs) res_ty `thenM` \ arg_tys ->
- tcCheckRhos exprs arg_tys `thenM` \ exprs' ->
- returnM (ExplicitTuple exprs' boxity)
+ = do { arg_tys <- zapToTyConApp (tupleTyCon boxity (length exprs)) res_ty
+ ; exprs' <- tcCheckRhos exprs arg_tys
+ ; return (ExplicitTuple exprs' boxity) }
tc_expr (HsProc pat cmd) res_ty
= tcProc pat cmd res_ty `thenM` \ (pat', cmd') ->
%************************************************************************
\begin{code}
-tc_expr expr@(RecordCon con@(L _ con_name) rbinds) res_ty
+tc_expr expr@(RecordCon con@(L loc con_name) rbinds) res_ty
= addErrCtxt (recordConCtxt expr) $
- addLocM tcId con `thenM` \ (con_expr, con_tau) ->
+ addLocM tcId con `thenM` \ (con_expr, _, con_tau) ->
let
(_, record_ty) = tcSplitFunTys con_tau
(tycon, ty_args) = tcSplitTyConApp record_ty
-- The renamer has already checked that they
-- are all in scope
let
- bad_guys = [ addSrcSpan loc $ addErrTc (notSelector field_name)
+ bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
| (L loc field_name, sel_id) <- field_names `zip` sel_ids,
not (isRecordSelector sel_id) -- Excludes class ops
]
let
-- It's OK to use the non-tc splitters here (for a selector)
sel_id : _ = sel_ids
- field_lbl = recordSelectorFieldLabel sel_id -- We've failed already if
- tycon = fieldLabelTyCon field_lbl -- it's not a field label
- data_cons = tyConDataCons tycon
+ (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
+ data_cons = tyConDataCons tycon -- it's not a field label
tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars
in
- tcInstTyVars VanillaTv tycon_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
+ tcInstTyVars tycon_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
-- STEP 2
-- Check that at least one constructor has all the named fields
-- i.e. has an empty set of bad fields returned by badFields
checkTc (any (null . badFields rbinds) data_cons)
- (badFieldsUpd rbinds) `thenM_`
+ (badFieldsUpd rbinds) `thenM_`
-- STEP 3
-- Typecheck the update bindings.
-- WARNING: this code assumes that all data_cons in a common tycon
-- have FieldLabels abstracted over the same tyvars.
let
- upd_field_lbls = map recordSelectorFieldLabel (recBindFields rbinds')
+ upd_field_lbls = recBindFields rbinds
con_field_lbls_s = map dataConFieldLabels data_cons
-- A constructor is only relevant to this process if
is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls
- common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
+ common_tyvars = tyVarsOfTypes [ty | (fld,ty,_) <- tyConFields tycon,
+ fld `elem` non_upd_field_lbls]
mk_inst_ty tyvar result_inst_ty
| tyvar `elemVarSet` common_tyvars = returnM result_inst_ty -- Same as result type
- | otherwise = newTyVarTy liftedTypeKind -- Fresh type
+-- gaw 2004 FIX?
+ | otherwise = newTyFlexiVarTy liftedTypeKind -- Fresh type
in
zipWithM mk_inst_ty tycon_tyvars result_inst_tys `thenM` \ inst_tys ->
-- What dictionaries do we need?
-- We just take the context of the type constructor
let
- theta' = substTheta inst_env (tyConTheta tycon)
+ theta' = substTheta inst_env (tyConStupidTheta tycon)
in
newDicts RecordUpdOrigin theta' `thenM` \ dicts ->
extendLIEs dicts `thenM_`
tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty
= addErrCtxt (parrSeqCtxt in_expr) $
- zapToPArrTy res_ty `thenM` \ elt_ty ->
+ zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] ->
tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
tcCheckRho expr2 elt_ty `thenM` \ expr2' ->
newMethodFromName (PArrSeqOrigin seq)
tc_expr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
= addErrCtxt (parrSeqCtxt in_expr) $
- zapToPArrTy res_ty `thenM` \ elt_ty ->
+ 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' ->
tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
-> Expected TcRhoType -- Expected result type of application
- -> TcM (HsExpr TcId) -- Translated fun and args
+ -> 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
- = -- First type-check the function
- tcInferRho fun `thenM` \ (fun', fun_ty) ->
-
- addErrCtxt (wrongArgsCtxt "too many" fun args) (
- traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_ty)) `thenM_`
- split_fun_ty fun_ty (length args)
- ) `thenM` \ (expected_arg_tys, actual_result_ty) ->
-
- -- Unify with expected result before (was: after) type-checking the args
- -- so that the info from res_ty (was: args) percolates to args (was actual_result_ty).
- -- This is when we might detect a too-few args situation.
- -- (One can think of cases when the opposite order would give
- -- a better error message.)
- -- [March 2003: I'm experimenting with putting this first. Here's an
- -- example where it actually makes a real difference
- -- class C t a b | t a -> b
- -- instance C Char a Bool
- --
- -- data P t a = forall b. (C t a b) => MkP b
- -- data Q t = MkQ (forall a. P t a)
-
- -- f1, f2 :: Q Char;
- -- f1 = MkQ (MkP True)
- -- f2 = MkQ (MkP True :: forall a. P Char a)
- --
- -- With the change, f1 will type-check, because the 'Char' info from
- -- the signature is propagated into MkQ's argument. With the check
- -- in the other order, the extra signature in f2 is reqd.]
-
- addErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
- (tcSubExp res_ty actual_result_ty) `thenM` \ co_fn ->
+ = do { (fun', fun_tvs, fun_tau) <- tcFun fun -- Type-check the function
+
+ -- Extract its argument types
+ ; (expected_arg_tys, actual_res_ty)
+ <- addErrCtxt (wrongArgsCtxt "too many" fun args) $ do
+ { traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_tau))
+ ; unifyFunTys (length 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
+ ; actual_res_ty' <- refineResultTy fun_tvs 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 [Push result type in]
+--
+-- Unify with expected result before (was: after) type-checking the args
+-- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
+-- This is when we might detect a too-few args situation.
+-- (One can think of cases when the opposite order would give
+-- a better error message.)
+-- [March 2003: I'm experimenting with putting this first. Here's an
+-- example where it actually makes a real difference
+-- class C t a b | t a -> b
+-- instance C Char a Bool
+--
+-- data P t a = forall b. (C t a b) => MkP b
+-- data Q t = MkQ (forall a. P t a)
- -- Now typecheck the args
- mappM (tcArg fun)
- (zip3 args expected_arg_tys [1..]) `thenM` \ args' ->
+-- f1, f2 :: Q Char;
+-- f1 = MkQ (MkP True)
+-- f2 = MkQ (MkP True :: forall a. P Char a)
+--
+-- With the change, f1 will type-check, because the 'Char' info from
+-- 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 f
+ ; return (L loc fun', tvs, fun_tau) }
+tcFun fun = do { (fun', fun_tau) <- tcInfer (tcMonoExpr fun)
+ ; return (fun', [], fun_tau) }
+
+----------------
+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
+
+tcArgs fun fun' args expected_arg_tys
+ = do { args' <- mappM (tcArg fun) (zip3 args expected_arg_tys [1..])
+ ; return (unLoc (foldl mkHsApp fun' args')) }
- returnM (co_fn <$> unLoc (foldl mkHsApp fun' args'))
+tcArg :: LHsExpr Name -- The function (for error messages)
+ -> (LHsExpr Name, TcSigmaType, 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)
+----------------
+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.
in
returnM (env2, message)
-
-split_fun_ty :: TcRhoType -- The type of the function
- -> Int -- Number of arguments
- -> TcM ([TcType], -- Function argument types
- TcType) -- Function result types
-
-split_fun_ty fun_ty 0
- = returnM ([], fun_ty)
-
-split_fun_ty fun_ty n
- = -- Expect the function to have type A->B
- unifyFunTy fun_ty `thenM` \ (arg_ty, res_ty) ->
- split_fun_ty res_ty (n-1) `thenM` \ (arg_tys, final_res_ty) ->
- returnM (arg_ty:arg_tys, final_res_ty)
-\end{code}
-
-\begin{code}
-tcArg :: LHsExpr Name -- The function (for error messages)
- -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type
- -> TcM (LHsExpr TcId) -- Resulting argument
-
-tcArg the_fun (arg, expected_arg_ty, arg_no)
- = addErrCtxt (funAppCtxt the_fun arg arg_no) $
- tcCheckSigma arg expected_arg_ty
+----------------
+refineResultTy :: [TcTyVar] -- Newly instantiated meta-tyvars of the function
+ -> TcType -- Result type, instantiated with those tyvars
+ -> TcM TcType -- Refined result type
+-- De-wobblify the result type, by taking account what we learned
+-- from type-checking the arguments. Just one level of de-wobblification
+-- though. What a hack!
+refineResultTy tvs res_ty
+ = do { mb_prs <- mapM mk_pr tvs
+ ; let subst = mkTopTvSubst (catMaybes mb_prs)
+ ; return (substTy subst res_ty) }
+ where
+ mk_pr tv = do { details <- readMetaTyVar tv
+ ; case details of
+ Indirect ty -> return (Just (tv,ty))
+ other -> return Nothing
+ }
\end{code}
b) perhaps fewer separated lambdas
\begin{code}
-tcId :: Name -> TcM (HsExpr TcId, TcRhoType)
+tcId :: 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 name -- Look up the Id and instantiate its type
- = -- First check whether it's a DataCon
- -- Reason: we must not forget to chuck in the
- -- constraints from their "silly context"
- tcLookup name `thenM` \ thing ->
+ = tcLookup name `thenM` \ thing ->
case thing of {
- AGlobal (ADataCon data_con) -> inst_data_con data_con
- ; AGlobal (AnId id) -> loop (HsVar id) (idType id)
+ AGlobal (AnId id) -> instantiate id
-- A global cannot possibly be ill-staged
-- nor does it need the 'lifting' treatment
- ; ATcId id th_level proc_level -> tc_local_id id th_level proc_level
- ; other -> pprPanic "tcId" (ppr name $$ ppr thing)
+ ; 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) }
+
+ ; ATcId id th_level proc_level
+ -> do { checkProcLevel id proc_level
+ ; tc_local_id id th_level }
+
+ ; other -> pprPanic "tcId" (ppr name $$ ppr thing)
}
where
#ifndef GHCI
- tc_local_id id th_bind_lvl proc_lvl -- Non-TH case
- = checkProcLevel id proc_lvl `thenM_`
- loop (HsVar id) (idType id)
+ 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 proc_lvl -- TH case
- = checkProcLevel id proc_lvl `thenM_`
-
- -- Check for cross-stage lifting
+ 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
-> -- 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.
readMutVar ps_var `thenM` \ ps ->
writeMutVar ps_var ((name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) `thenM_`
- returnM (HsVar id, id_ty))
+ returnM (HsVar id, [], id_ty))
other ->
checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_`
- loop (HsVar id) (idType id)
+ instantiate id
#endif /* GHCI */
- loop (HsVar fun_id) fun_ty
+ instantiate :: TcId -> TcM (HsExpr TcId, [TcTyVar], TcRhoType)
+ instantiate fun_id = loop (HsVar fun_id) [] (idType fun_id)
+
+ loop (HsVar fun_id) tvs fun_ty
| want_method_inst fun_ty
- = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
+ = tcInstType fun_ty `thenM` \ (tyvars, theta, tau) ->
newMethodWithGivenTy orig fun_id
(mkTyVarTys tyvars) theta tau `thenM` \ meth_id ->
- loop (HsVar meth_id) tau
+ loop (HsVar meth_id) (tvs ++ tyvars) tau
- loop fun fun_ty
+ loop fun tvs fun_ty
| isSigmaTy fun_ty
- = tcInstCall orig fun_ty `thenM` \ (inst_fn, tau) ->
- loop (inst_fn <$> fun) tau
+ = tcInstCall orig fun_ty `thenM` \ (inst_fn, new_tvs, tau) ->
+ loop (inst_fn <$> fun) (tvs ++ new_tvs) tau
| otherwise
- = returnM (fun, fun_ty)
+ = returnM (fun, tvs, fun_ty)
-- Hack Alert (want_method_inst)!
-- If f :: (%x :: T) => Int -> Int
(_,[],_) -> False -- Not overloaded
(_,theta,_) -> not (any isLinearPred theta)
-
- -- We treat data constructors differently, because we have to generate
- -- constraints for their silly theta, which no longer appears in
- -- the type of dataConWrapId (see note on "stupid context" in DataCon.lhs
- -- It's dual to TcPat.tcConstructor
- inst_data_con data_con
- = tcInstDataCon orig VanillaTv data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) ->
- extendLIEs ex_dicts `thenM_`
- getSrcSpanM `thenM` \ loc ->
- returnM (unLoc (mkHsDictApp (mkHsTyApp (L loc (HsVar (dataConWrapId data_con))) ty_args)
- (map instToId ex_dicts)),
- mkFunTys arg_tys result_ty)
- -- ToDo: nasty loc/unloc stuff here
-
orig = OccurrenceOf name
\end{code}
tcRecordBinds tycon ty_args rbinds
= mappM do_bind rbinds
where
- tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
+ tenv = zipTopTvSubst (tyConTyVars tycon) ty_args
- do_bind (L loc field_lbl_name, rhs)
- = addErrCtxt (fieldCtxt field_lbl_name) $
- tcLookupId field_lbl_name `thenM` \ sel_id ->
+ do_bind (L loc field_lbl, rhs)
+ = addErrCtxt (fieldCtxt field_lbl) $
let
- field_lbl = recordSelectorFieldLabel sel_id
- field_ty = substTy tenv (fieldLabelType field_lbl)
+ field_ty = tyConFieldType tycon field_lbl
+ field_ty' = substTy tenv field_ty
in
+ tcCheckSigma rhs field_ty' `thenM` \ rhs' ->
+ tcLookupId field_lbl `thenM` \ sel_id ->
ASSERT( isRecordSelector sel_id )
+ returnM (L loc sel_id, rhs')
+
+tyConFieldType :: TyCon -> FieldLabel -> Type
+tyConFieldType tycon field_lbl
+ = case [ty | (f,ty,_) <- tyConFields tycon, f == field_lbl] of
+ (ty:other) -> ASSERT( null other) ty
-- This lookup and assertion will surely succeed, because
-- we check that the fields are indeed record selectors
-- before calling tcRecordBinds
- ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
- -- The caller of tcRecordBinds has already checked
- -- that all the fields come from the same type
-
- tcCheckSigma rhs field_ty `thenM` \ rhs' ->
-
- returnM (L loc sel_id, rhs')
badFields rbinds data_con
= filter (not . (`elem` field_names)) (recBindFields rbinds)
where
- field_names = map fieldLabelName (dataConFieldLabels data_con)
+ field_names = dataConFieldLabels data_con
checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
checkMissingFields data_con rbinds
missing_s_fields
= [ fl | (fl, str) <- field_info,
isMarkedStrict str,
- not (fieldLabelName fl `elem` field_names_used)
+ not (fl `elem` field_names_used)
]
missing_ns_fields
= [ fl | (fl, str) <- field_info,
not (isMarkedStrict str),
- not (fieldLabelName fl `elem` field_names_used)
+ not (fl `elem` field_names_used)
]
field_names_used = recBindFields rbinds
import ForeignCall ( CExportSpec(..), CCallTarget(..),
CLabelString, isCLabelString,
isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
-import MachOp ( machRepByteWidth )
import PrelNames ( hasKey, ioTyConKey )
import CmdLineOpts ( dopt_HscLang, HscLang(..) )
import Outputable
import SrcLoc ( Located(..), srcSpanStart )
-import Bag ( emptyBag, consBag )
+import Bag ( consBag )
+#if alpha_TARGET_ARCH
+import MachOp ( machRepByteWidth )
+#endif
\end{code}
\begin{code}
tcForeignExports :: [LForeignDecl Name]
-> TcM (LHsBinds TcId, [LForeignDecl TcId])
tcForeignExports decls
- = foldlM combine (emptyBag, []) (filter isForeignExport decls)
+ = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
where
combine (binds, fs) fe =
wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
import RdrName ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual,
mkDerivedRdrName )
import BasicTypes ( Fixity(..), maxPrecedence, Boxity(..) )
-import FieldLabel ( fieldLabelName )
-import DataCon ( isNullaryDataCon, dataConTag,
+import DataCon ( isNullarySrcDataCon, dataConTag,
dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
DataCon, dataConName, dataConIsInfix,
dataConFieldLabels )
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
- | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
+ | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
rest
= if (null nullary_cons) then
in
listToBag [
mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
- mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyBag (
+ mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyLHsBinds (
nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
]
where
single_con_type = isSingleton tycon_data_cons
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
- | otherwise = partition isNullaryDataCon tycon_data_cons
+ | otherwise = partition isNullarySrcDataCon tycon_data_cons
cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
cmp_eq_match
occ_nm = getOccString tycon
succ_enum
- = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
nlHsVarApps intDataCon_RDR [ah_RDR]])
nlHsIntLit 1]))
pred_enum
- = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
nlHsVarApps intDataCon_RDR [ah_RDR]])
nlHsLit (HsInt (-1))]))
to_enum
- = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyLHsBinds $
nlHsIf (nlHsApps and_RDR
[nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
(illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
enum_from
- = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsApps map_RDR
[nlHsVar (tag2con_RDR tycon),
(nlHsVar (maxtag_RDR tycon)))]
enum_from_then
- = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
nlHsPar (enum_from_then_to_Expr
))
from_enum
- = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR])
\end{code}
enum_range
= mk_easy_FunBind tycon_loc range_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag $
+ [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
= mk_easy_FunBind tycon_loc index_RDR
[noLoc (AsPat (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
- d_Pat] emptyBag (
+ d_Pat] emptyLHsBinds (
nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
enum_inRange
= mk_easy_FunBind tycon_loc inRange_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyBag (
+ [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] (
--------------------------------------------------------------
single_con_range
= mk_easy_FunBind tycon_loc range_RDR
- [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyBag $
+ [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyLHsBinds $
nlHsDo ListComp stmts
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
range_size
= mk_easy_FunBind tycon_loc rangeSize_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag (
+ [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds (
genOpApp (
(nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed,
b_Expr])
= mk_easy_FunBind tycon_loc inRange_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed]
- emptyBag (
+ emptyLHsBinds (
foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
where
in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
loc = getSrcSpan tycon
data_cons = tyConDataCons tycon
- (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
+ (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
read_prec = mkVarBind loc readPrec_RDR
(nlHsApp (nlHsVar parens_RDR) read_cons)
bindLex (symbol_pat lbl_lit),
read_punc ")"]
where
- lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
+ lbl_str = occNameUserString (getOccName lbl)
lbl_lit = mkHsString lbl_str
is_id_start c = isAlpha c || c == '_'
\end{code}
-- lexeme. Only the space after the '=' is necessary, but
-- it seems tidier to have them both sides.
where
- occ_nm = getOccName (fieldLabelName l)
+ occ_nm = getOccName l
nm = occNameUserString_with_parens occ_nm
show_args = zipWith show_arg bs_needed arg_tys
= unitBag $
mk_easy_FunBind tycon_loc
(mk_typeOf_RDR tycon) -- Name of appropriate type0f function
- [nlWildPat] emptyBag
+ [nlWildPat] emptyLHsBinds
(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
where
tycon_loc = getSrcSpan tycon
tycon_loc
dataTypeOf_RDR
[nlWildPat]
- emptyBag
+ emptyLHsBinds
(nlHsVar data_type_name)
------------ $dT
nlList labels, -- Field labels
nlHsVar fixity] -- Fixity
where
- labels = map (nlHsLit . mkHsString . getOccString . fieldLabelName)
+ labels = map (nlHsLit . mkHsString . getOccString)
(dataConFieldLabels dc)
dc_occ = getOccName dc
is_infix = isDataSymOcc dc_occ
where
eq_op
| not (isUnLiftedType ty) = eq_RDR
- | otherwise =
+ | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
-- we have to do something special for primitive things...
- primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
\end{code}
\begin{code}
\begin{code}
module TcHsSyn (
- TcDictBinds,
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet, mkHsApp,
hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
idCoercion, isIdCoercion,
-- re-exported from TcMonad
- TcId, TcIdSet,
+ TcId, TcIdSet, TcDictBinds,
zonkTopDecls, zonkTopExpr, zonkTopLExpr,
zonkId, zonkTopBndrs
import TcRnMonad
import Type ( Type )
-import TcType ( TcType, TcTyVar, mkTyVarTy, tcGetTyVar, mkTyConApp )
+import TcType ( TcType, TcTyVar, mkTyVarTy, tcGetTyVar, mkTyConApp, isImmutableTyVar )
import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
import qualified Type
-import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars,
- putTcTyVar )
+import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, zonkTcTyVars,
+ putMetaTyVar )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
\end{code}
-\begin{code}
-type TcDictBinds = LHsBinds TcId -- Bag of dictionary bindings
-\end{code}
-
-
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
hsPatType :: OutPat Id -> Type
hsPatType pat = pat_type (unLoc pat)
-pat_type (ParPat pat) = hsPatType pat
-pat_type (WildPat ty) = ty
-pat_type (VarPat var) = idType var
-pat_type (LazyPat pat) = hsPatType pat
-pat_type (LitPat lit) = hsLitType lit
-pat_type (AsPat var pat) = idType (unLoc var)
-pat_type (ListPat _ ty) = mkListTy ty
-pat_type (PArrPat _ ty) = mkPArrTy ty
-pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
-pat_type (ConPatOut _ _ ty _ _) = ty
-pat_type (SigPatOut _ ty _) = ty
-pat_type (NPatOut lit ty _) = ty
-pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id)
-pat_type (DictPat ds ms) = case (ds ++ ms) of
+pat_type (ParPat pat) = hsPatType pat
+pat_type (WildPat ty) = ty
+pat_type (VarPat var) = idType var
+pat_type (VarPatOut var _) = idType var
+pat_type (LazyPat pat) = hsPatType pat
+pat_type (LitPat lit) = hsLitType lit
+pat_type (AsPat var pat) = idType (unLoc var)
+pat_type (ListPat _ ty) = mkListTy ty
+pat_type (PArrPat _ ty) = mkPArrTy ty
+pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
+pat_type (ConPatOut _ _ _ _ _ ty) = ty
+pat_type (SigPatOut pat ty) = ty
+pat_type (NPatOut lit ty _) = ty
+pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id)
+pat_type (DictPat ds ms) = case (ds ++ ms) of
[] -> unitTy
[d] -> idType d
ds -> mkTupleTy Boxed (length ds) (map idType ds)
extendZonkEnv (ZonkEnv zonk_ty env) ids
= ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
+extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
+extendZonkEnv1 (ZonkEnv zonk_ty env) id
+ = ZonkEnv zonk_ty (extendVarEnv env id id)
+
setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
-mkZonkEnv :: [Id] -> ZonkEnv
-mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
+zonkEnvIds :: ZonkEnv -> [Id]
+zonkEnvIds (ZonkEnv _ env) = varEnvElts env
zonkIdOcc :: ZonkEnv -> TcId -> Id
-- Ids defined in this module should be in the envt;
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e
-zonkTopDecls :: Bag (LHsBind TcId) -> [LRuleDecl TcId] -> [LForeignDecl TcId]
+zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
-> TcM ([Id],
Bag (LHsBind Id),
[LForeignDecl Id],
[LRuleDecl Id])
-zonkTopDecls binds rules fords -- Top level is implicitly recursive
- = fixM (\ ~(new_ids, _, _, _) ->
- let
- zonk_env = mkZonkEnv new_ids
- in
- zonkMonoBinds zonk_env binds `thenM` \ binds' ->
- zonkRules zonk_env rules `thenM` \ rules' ->
- zonkForeignExports zonk_env fords `thenM` \ fords' ->
-
- returnM (collectHsBindBinders binds', binds', fords', rules')
- )
+zonkTopDecls binds rules fords
+ = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
+ -- Top level is implicitly recursive
+ ; rules' <- zonkRules env rules
+ ; fords' <- zonkForeignExports env fords
+ ; return (zonkEnvIds env, binds', fords', rules') }
---------------------------------------------
zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id)
zonkGroup env (HsBindGroup bs sigs is_rec)
= ASSERT( null sigs )
- do { (env1, bs') <- fixM (\ ~(_, new_binds) -> do
- { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
- ; bs' <- zonkMonoBinds env1 bs
- ; return (env1, bs') })
- ; return (env1, HsBindGroup bs' [] is_rec) }
+ do { (env1, bs') <- zonkRecMonoBinds env bs
+ ; return (env1, HsBindGroup bs' [] is_rec) }
-
zonkGroup env (HsIPBinds binds)
= mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
let
; return (env2, b':bs') }
---------------------------------------------
-zonkMonoBinds :: ZonkEnv -> Bag (LHsBind TcId) -> TcM (Bag (LHsBind Id))
+zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
+zonkRecMonoBinds env binds
+ = fixM (\ ~(_, new_binds) -> do
+ { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
+ ; binds' <- zonkMonoBinds env1 binds
+ ; return (env1, binds') })
+
+zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
-zonk_bind env (PatBind pat grhss)
- = zonkPat env pat `thenM` \ (new_pat, _) ->
- zonkGRHSs env grhss `thenM` \ new_grhss ->
- returnM (PatBind new_pat new_grhss)
+zonk_bind env (PatBind pat grhss 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) }
zonk_bind env (VarBind var expr)
= zonkIdBndr env var `thenM` \ new_var ->
zonk_bind env (FunBind var inf ms)
= wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
- mappM (zonkMatch env) ms `thenM` \ new_ms ->
+ zonkMatchGroup env ms `thenM` \ new_ms ->
returnM (FunBind new_var inf new_ms)
zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds)
- = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
- -- No need to extend tyvar env: the effects are
- -- propagated through binding the tyvars themselves
-
+ = ASSERT( all isImmutableTyVar tyvars )
zonkIdBndrs env dicts `thenM` \ new_dicts ->
fixM (\ ~(new_val_binds, _) ->
let
- env1 = extendZonkEnv (extendZonkEnv env new_dicts)
+ env1 = extendZonkEnv (extendZonkEnv env new_dicts)
(collectHsBindBinders new_val_binds)
in
zonkMonoBinds env1 val_binds `thenM` \ new_val_binds ->
mappM (zonkExport env1) exports `thenM` \ new_exports ->
returnM (new_val_binds, new_exports)
) `thenM` \ (new_val_bind, new_exports) ->
- returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind)
+ returnM (AbsBinds tyvars new_dicts new_exports inlines new_val_bind)
where
zonkExport env (tyvars, global, local)
- = 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
+ = ASSERT( all isImmutableTyVar tyvars )
zonkIdBndr env global `thenM` \ new_global ->
- returnM (new_tyvars, new_global, zonkIdOcc env local)
+ returnM (tyvars, new_global, zonkIdOcc env local)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
+zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
+zonkMatchGroup env (MatchGroup ms ty)
+ = do { ms' <- mapM (zonkMatch env) ms
+ ; ty' <- zonkTcTypeToType env ty
+ ; return (MatchGroup ms' ty') }
+zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
zonkMatch env (L loc (Match pats _ grhss))
- = zonkPats env pats `thenM` \ (new_pats, new_ids) ->
- zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss ->
- returnM (L loc (Match new_pats Nothing new_grhss))
+ = do { (env1, new_pats) <- zonkPats env pats
+ ; new_grhss <- zonkGRHSs env1 grhss
+ ; return (L loc (Match new_pats Nothing new_grhss)) }
-------------------------------------------------------------------------
zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
-zonkGRHSs env (GRHSs grhss binds ty)
+zonkGRHSs env (GRHSs grhss binds)
= zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
let
zonk_grhs (GRHS guarded)
returnM (GRHS new_guarded)
in
mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (GRHSs new_grhss new_binds new_ty)
+ returnM (GRHSs new_grhss new_binds)
\end{code}
%************************************************************************
zonkExpr env (HsLit lit)
= returnM (HsLit lit)
-
-- HsOverLit doesn't appear in typechecker output
-zonkExpr env (HsLam match)
- = zonkMatch env match `thenM` \ new_match ->
- returnM (HsLam new_match)
+zonkExpr env (HsLam matches)
+ = zonkMatchGroup env matches `thenM` \ new_matches ->
+ returnM (HsLam new_matches)
zonkExpr env (HsApp e1 e2)
= zonkLExpr env e1 `thenM` \ new_e1 ->
zonkLExpr env expr `thenM` \ new_expr ->
returnM (SectionR new_op new_expr)
+-- gaw 2004
zonkExpr env (HsCase expr ms)
= zonkLExpr env expr `thenM` \ new_expr ->
- mappM (zonkMatch env) ms `thenM` \ new_ms ->
+ zonkMatchGroup env ms `thenM` \ new_ms ->
returnM (HsCase new_expr new_ms)
zonkExpr env (HsIf e1 e2 e3)
returnM (HsCoreAnn lbl new_expr)
zonkExpr env (TyLam tyvars expr)
- = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
- -- No need to extend tyvar env; see AbsBinds
-
+ = ASSERT( all isImmutableTyVar tyvars )
zonkLExpr env expr `thenM` \ new_expr ->
- returnM (TyLam new_tyvars new_expr)
+ returnM (TyLam tyvars new_expr)
zonkExpr env (TyApp expr tys)
= zonkLExpr env expr `thenM` \ new_expr ->
-- arrow notation extensions
zonkExpr env (HsProc pat body)
- = zonkPat env pat `thenM` \ (new_pat, new_ids) ->
- let
- env1 = extendZonkEnv env (bagToList new_ids)
- in
- zonkCmdTop env1 body `thenM` \ new_body ->
- returnM (HsProc new_pat new_body)
+ = do { (env1, new_pat) <- zonkPat env pat
+ ; new_body <- zonkCmdTop env1 body
+ ; return (HsProc new_pat new_body) }
zonkExpr env (HsArrApp e1 e2 ty ho rl)
= zonkLExpr env e1 `thenM` \ new_e1 ->
returnM (env1, LetStmt new_binds)
zonkStmt env (BindStmt pat expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkPat env pat `thenM` \ (new_pat, new_ids) ->
- let
- env1 = extendZonkEnv env (bagToList new_ids)
- in
- returnM (env1, BindStmt new_pat new_expr)
-
+ = do { new_expr <- zonkLExpr env expr
+ ; (env1, new_pat) <- zonkPat env pat
+ ; return (env1, BindStmt new_pat new_expr) }
-------------------------------------------------------------------------
%************************************************************************
\begin{code}
-zonkPat :: ZonkEnv -> OutPat TcId -> TcM (OutPat Id, Bag Id)
-zonkPat env pat = wrapLocFstM (zonk_pat env) pat
+zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
+-- Extend the environment as we go, because it's possible for one
+-- pattern to bind something that is used in another (inside or
+-- to the right)
+zonkPat env pat = wrapLocSndM (zonk_pat env) pat
zonk_pat env (ParPat p)
- = zonkPat env p `thenM` \ (new_p, ids) ->
- returnM (ParPat new_p, ids)
+ = do { (env', p') <- zonkPat env p
+ ; return (env', ParPat p') }
zonk_pat env (WildPat ty)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (WildPat new_ty, emptyBag)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; return (env, WildPat ty') }
zonk_pat env (VarPat v)
- = zonkIdBndr env v `thenM` \ new_v ->
- returnM (VarPat new_v, unitBag new_v)
+ = do { v' <- zonkIdBndr env v
+ ; return (extendZonkEnv1 env v', VarPat v') }
+
+zonk_pat env (VarPatOut v binds)
+ = do { v' <- zonkIdBndr env v
+ ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
+ ; returnM (env', VarPatOut v' binds') }
zonk_pat env (LazyPat pat)
- = zonkPat env pat `thenM` \ (new_pat, ids) ->
- returnM (LazyPat new_pat, ids)
+ = do { (env', pat') <- zonkPat env pat
+ ; return (env', LazyPat pat') }
-zonk_pat env (AsPat n pat)
- = wrapLocM (zonkIdBndr env) n `thenM` \ new_n ->
- zonkPat env pat `thenM` \ (new_pat, ids) ->
- returnM (AsPat new_n new_pat, unLoc new_n `consBag` ids)
+zonk_pat env (AsPat (L loc v) pat)
+ = do { v' <- zonkIdBndr env v
+ ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
+ ; return (env', AsPat (L loc v') pat') }
zonk_pat env (ListPat pats ty)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkPats env pats `thenM` \ (new_pats, ids) ->
- returnM (ListPat new_pats new_ty, ids)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', ListPat pats' ty') }
zonk_pat env (PArrPat pats ty)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkPats env pats `thenM` \ (new_pats, ids) ->
- returnM (PArrPat new_pats new_ty, ids)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', PArrPat pats' ty') }
zonk_pat env (TuplePat pats boxed)
- = zonkPats env pats `thenM` \ (new_pats, ids) ->
- returnM (TuplePat new_pats boxed, ids)
+ = do { (env', pats') <- zonkPats env pats
+ ; return (env', TuplePat pats' boxed) }
-zonk_pat env (ConPatOut n stuff ty tvs dicts)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
- zonkIdBndrs env dicts `thenM` \ new_dicts ->
- let
- env1 = extendZonkEnv env new_dicts
- in
- zonkConStuff env1 stuff `thenM` \ (new_stuff, ids) ->
- returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
- listToBag new_dicts `unionBags` ids)
+zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
+ = ASSERT( all isImmutableTyVar tvs )
+ do { new_ty <- zonkTcTypeToType env ty
+ ; new_dicts <- zonkIdBndrs env dicts
+ ; let env1 = extendZonkEnv env new_dicts
+ ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
+ ; (env', new_stuff) <- zonkConStuff env2 stuff
+ ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
-zonk_pat env (LitPat lit) = returnM (LitPat lit, emptyBag)
+zonk_pat env (LitPat lit) = return (env, LitPat lit)
-zonk_pat env (SigPatOut pat ty expr)
- = zonkPat env pat `thenM` \ (new_pat, ids) ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkExpr env expr `thenM` \ new_expr ->
- returnM (SigPatOut new_pat new_ty new_expr, ids)
+zonk_pat env (SigPatOut pat ty)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pat') <- zonkPat env pat
+ ; return (env', SigPatOut pat' ty') }
zonk_pat env (NPatOut lit ty expr)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkExpr env expr `thenM` \ new_expr ->
- returnM (NPatOut lit new_ty new_expr, emptyBag)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; expr' <- zonkExpr env expr
+ ; return (env, NPatOut lit ty' expr') }
-zonk_pat env (NPlusKPatOut n k e1 e2)
- = wrapLocM (zonkIdBndr env) n `thenM` \ new_n ->
- zonkExpr env e1 `thenM` \ new_e1 ->
- zonkExpr env e2 `thenM` \ new_e2 ->
- returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag (unLoc new_n))
+zonk_pat env (NPlusKPatOut (L loc n) k e1 e2)
+ = do { n' <- zonkIdBndr env n
+ ; e1' <- zonkExpr env e1
+ ; e2' <- zonkExpr env e2
+ ; return (extendZonkEnv1 env n', NPlusKPatOut (L loc n') k e1' e2') }
zonk_pat env (DictPat ds ms)
- = zonkIdBndrs env ds `thenM` \ new_ds ->
- zonkIdBndrs env ms `thenM` \ new_ms ->
- returnM (DictPat new_ds new_ms,
- listToBag new_ds `unionBags` listToBag new_ms)
+ = do { ds' <- zonkIdBndrs env ds
+ ; ms' <- zonkIdBndrs env ms
+ ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
---------------------------
zonkConStuff env (PrefixCon pats)
- = zonkPats env pats `thenM` \ (new_pats, ids) ->
- returnM (PrefixCon new_pats, ids)
+ = do { (env', pats') <- zonkPats env pats
+ ; return (env', PrefixCon pats') }
zonkConStuff env (InfixCon p1 p2)
- = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
- zonkPat env p2 `thenM` \ (new_p2, ids2) ->
- returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
+ = do { (env1, p1') <- zonkPat env p1
+ ; (env', p2') <- zonkPat env1 p2
+ ; return (env', InfixCon p1' p2') }
zonkConStuff env (RecCon rpats)
- = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
- returnM (RecCon new_rpats, unionManyBags ids_s)
+ = do { (env', pats') <- zonkPats env pats
+ ; returnM (env', RecCon (fields `zip` pats')) }
where
- zonk_rpat (f, pat)
- = zonkPat env pat `thenM` \ (new_pat, ids) ->
- returnM ((f, new_pat), ids)
+ (fields, pats) = unzip rpats
---------------------------
-zonkPats env []
- = returnM ([], emptyBag)
-
-zonkPats env (pat:pats)
- = zonkPat env pat `thenM` \ (pat', ids1) ->
- zonkPats env pats `thenM` \ (pats', ids2) ->
- returnM (pat':pats', ids1 `unionBags` ids2)
+zonkPats env [] = return (env, [])
+zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
+ ; (env', pats') <- zonkPats env1 pats
+ ; return (env', pat':pats') }
\end{code}
%************************************************************************
where
zonk_bndr (RuleBndr v)
| isId (unLoc v) = wrapLocM (zonkIdBndr env) v
- | otherwise = wrapLocM zonkTcTyVarToTyVar v
+ | otherwise = ASSERT( isImmutableTyVar (unLoc v) )
+ return v
\end{code}
zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
-- This variant collects unbound type variables in a mutable variable
zonkTypeCollecting unbound_tv_set
- = zonkType zonk_unbound_tyvar
+ = zonkType zonk_unbound_tyvar True
where
zonk_unbound_tyvar tv
- = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
+ = zonkQuantifiedTyVar tv `thenM` \ tv' ->
readMutVar unbound_tv_set `thenM` \ tv_set ->
writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
return (mkTyVarTy 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 ty
+ = zonkType zonk_unbound_tyvar True 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 = putTcTyVar tv (mkArbitraryType tv)
+ zonk_unbound_tyvar tv = do { putMetaTyVar tv ty; return ty }
+ where
+ ty = mkArbitraryType tv
-- When the type checker finds a type variable with no binding,
-- Kind checking
kcHsTyVars, kcHsSigType, kcHsLiftedSigType,
- kcCheckHsType, kcHsContext, kcHsType,
+ kcCheckHsType, kcHsContext, kcHsType,
-- Typechecking kinded types
- tcHsKindedContext, tcHsKindedType, tcTyVarBndrs, dsHsType,
+ tcHsKindedContext, tcHsKindedType, tcHsBangType,
+ tcTyVarBndrs, dsHsType, tcLHsConSig,
- tcAddScopedTyVars,
+ tcHsPatSigType, tcAddLetBoundTyVars,
- TcSigInfo(..), tcTySig, mkTcSig, maybeSig
+ TcSigInfo(..), mkTcSig,
+ TcSigFun, lookupSig
) where
#include "HsVersions.h"
-import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr,
- LHsContext, Sig(..), LSig, HsPred(..), LHsPred )
+import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, HsBang,
+ LHsContext, HsPred(..), LHsPred, LHsBinds,
+ getBangStrictness, collectSigTysFromHsBinds )
import RnHsSyn ( extractHsTyVars )
import TcHsSyn ( TcId )
TyThing(..), TcTyThing(..),
getInLocalScope, wrongThingErr
)
-import TcMType ( newKindVar, tcInstType, newMutTyVar,
+import TcMType ( newKindVar, tcSkolType, newMetaTyVar,
zonkTcKindToKind,
checkValidType, UserTypeCtxt(..), pprHsSigCtxt
)
import TcUnify ( unifyFunKind, checkExpectedKind )
-import TcType ( Type, PredType(..), ThetaType, TyVarDetails(..),
- TcTyVar, TcKind, TcThetaType, TcTauType,
- mkTyVarTy, mkTyVarTys, mkFunTy,
+import TcType ( Type, PredType(..), ThetaType,
+ SkolemInfo(SigSkol), MetaDetails(Flexi),
+ TcType, TcTyVar, TcKind, TcThetaType, TcTauType,
+ mkTyVarTy, mkFunTy,
mkForAllTys, mkFunTys, tcEqType, isPredTy,
mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
tcSplitFunTy_maybe, tcSplitForAllTys )
import Kind ( liftedTypeKind, ubxTupleKind, openTypeKind, argTypeKind )
-import Inst ( Inst, InstOrigin(..), newMethod, instToId )
+import Inst ( InstOrigin(..) )
-import Id ( mkLocalId, idName, idType )
+import Id ( idName, idType )
import Var ( TyVar, mkTyVar, tyVarKind )
import TyCon ( TyCon, tyConKind )
import Class ( Class, classTyCon )
import Name ( Name )
import NameSet
import PrelNames ( genUnitTyConName )
-import Subst ( deShadowTy )
+import Type ( deShadowTy )
import TysWiredIn ( mkListTy, mkPArrTy, mkTupleTy )
+import Bag ( bagToList )
import BasicTypes ( Boxity(..) )
-import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc )
+import SrcLoc ( Located(..), unLoc, noLoc )
import Outputable
import List ( nubBy )
\end{code}
= do { ty <- dsHsType hs_ty
; return (hoistForAllTys ty) }
+tcHsBangType :: LHsType Name -> TcM Type
+-- Permit a bang, but discard it
+tcHsBangType (L span (HsBangTy b ty)) = tcHsKindedType ty
+tcHsBangType ty = tcHsKindedType ty
+
tcHsKindedContext :: LHsContext Name -> TcM ThetaType
-- Used when we are expecting a ClassContext (i.e. no implicit params)
-- Does not do validity checking, like tcHsKindedType
-- Be sure to use checkExpectedKind, rather than simply unifying
-- with OpenTypeKind, because it gives better error messages
kcCheckHsType (L span ty) exp_kind
- = addSrcSpan span $
+ = setSrcSpan span $
kc_hs_type ty `thenM` \ (ty', act_kind) ->
checkExpectedKind ty act_kind exp_kind `thenM_`
returnM (L span ty')
= kcHsType ty `thenM` \ (ty', kind) ->
returnM (HsParTy ty', kind)
--- kcHsType (HsSpliceTy s)
--- = kcSpliceType s)
-
kc_hs_type (HsTyVar name)
= kcTyVar name `thenM` \ kind ->
returnM (HsTyVar name, kind)
-- kind-checked, so we only allow liftedTypeKind here
returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind)
+kc_hs_type (HsBangTy b ty)
+ = do { (ty', kind) <- kcHsType ty
+ ; return (HsBangTy b ty', kind) }
+
+kc_hs_type ty@(HsSpliceTy _)
+ = failWithTc (ptext SLIT("Unexpected type splice:") <+> ppr ty)
+
+
---------------------------
kcApps :: TcKind -- Function kind
-> SDoc -- Function
* Transforms from HsType to Type
* Zonks any kinds
-It cannot fail, and does no validity checking
+It cannot fail, and does no validity checking, except for
+structural matters, such as spurious ! annotations.
\begin{code}
dsHsType :: LHsType Name -> TcM Type
ds_type (HsParTy ty) -- Remove the parentheses markers
= dsHsType ty
+ds_type ty@(HsBangTy _ _) -- No bangs should be here
+ = failWithTc (ptext SLIT("Unexpected strictness annotation:") <+> ppr ty)
+
ds_type (HsKindSig ty k)
= dsHsType ty -- Kind checking done already
ds_type (HsOpTy ty1 (L span op) ty2)
= dsHsType ty1 `thenM` \ tau_ty1 ->
dsHsType ty2 `thenM` \ tau_ty2 ->
- addSrcSpan span (ds_var_app op [tau_ty1,tau_ty2])
+ setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2])
ds_type (HsNumTy n)
= ASSERT(n==1)
case thing of
ATyVar tv -> returnM (mkAppTys (mkTyVarTy tv) arg_tys)
AGlobal (ATyCon tc) -> returnM (mkGenTyConApp tc arg_tys)
- AThing _ -> tcLookupTyCon name `thenM` \ tc ->
- returnM (mkGenTyConApp tc arg_tys)
+-- AThing _ -> tcLookupTyCon name `thenM` \ tc ->
+-- returnM (mkGenTyConApp tc arg_tys)
other -> pprPanic "ds_app_type" (ppr name <+> ppr arg_tys)
\end{code}
Contexts
~~~~~~~~
+
\begin{code}
dsHsLPred :: LHsPred Name -> TcM PredType
dsHsLPred pred = dsHsPred (unLoc pred)
returnM (IParam name arg_ty)
\end{code}
+GADT constructor signatures
+
+\begin{code}
+tcLHsConSig :: LHsType Name
+ -> TcM ([TcTyVar], TcThetaType,
+ [HsBang], [TcType],
+ TyCon, [TcType])
+-- Take apart the type signature for a data constructor
+-- The difference is that there can be bangs at the top of
+-- the argument types, and kind-checking is the right place to check
+tcLHsConSig sig@(L span (HsForAllTy exp tv_names ctxt ty))
+ = setSrcSpan span $
+ addErrCtxt (gadtSigCtxt sig) $
+ tcTyVarBndrs tv_names $ \ tyvars ->
+ do { theta <- mappM dsHsLPred (unLoc ctxt)
+ ; (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty
+ ; return (tyvars, theta, bangs, arg_tys, tc, res_tys) }
+tcLHsConSig ty
+ = do { (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty
+ ; return ([], [], bangs, arg_tys, tc, res_tys) }
+
+--------
+tc_con_sig_tau (L _ (HsFunTy arg ty))
+ = do { (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty
+ ; arg_ty <- tcHsBangType arg
+ ; return (getBangStrictness arg : bangs,
+ arg_ty : arg_tys, tc, res_tys) }
+
+tc_con_sig_tau ty
+ = do { (tc, res_tys) <- tc_con_res ty []
+ ; return ([], [], tc, res_tys) }
+
+--------
+tc_con_res (L _ (HsAppTy fun res_ty)) res_tys
+ = do { res_ty' <- dsHsType res_ty
+ ; tc_con_res fun (res_ty' : res_tys) }
+
+tc_con_res ty@(L _ (HsTyVar name)) res_tys
+ = do { thing <- tcLookup name
+ ; case thing of
+ AGlobal (ATyCon tc) -> return (tc, res_tys)
+ other -> failWithTc (badGadtDecl ty)
+ }
+
+tc_con_res ty _ = failWithTc (badGadtDecl ty)
+
+gadtSigCtxt ty
+ = hang (ptext SLIT("In the signature of a data constructor:"))
+ 2 (ppr ty)
+badGadtDecl ty
+ = hang (ptext SLIT("Malformed constructor signature:"))
+ 2 (ppr ty)
+\end{code}
%************************************************************************
%* *
where
zonk (KindedTyVar name kind) = zonkTcKindToKind kind `thenM` \ kind' ->
returnM (mkTyVar name kind')
- zonk (UserTyVar name) = pprTrace "BAD: Un-kinded tyvar" (ppr name) $
+ zonk (UserTyVar name) = pprTrace "Un-kinded tyvar" (ppr name) $
returnM (mkTyVar name liftedTypeKind)
\end{code}
it with expected_ty afterwards
\begin{code}
-tcAddScopedTyVars :: [LHsType Name] -> TcM a -> TcM a
-tcAddScopedTyVars [] thing_inside
- = thing_inside -- Quick get-out for the empty case
-
-tcAddScopedTyVars sig_tys thing_inside
- = getInLocalScope `thenM` \ in_scope ->
- getSrcSpanM `thenM` \ span ->
- let
- sig_tvs = [ L span (UserTyVar n)
- | ty <- sig_tys,
- n <- nameSetToList (extractHsTyVars ty),
- not (in_scope n) ]
- -- The tyvars we want are the free type variables of
- -- the type that are not already in scope
- in
+tcPatSigBndrs :: LHsType Name
+ -> TcM ([TcTyVar], -- Brought into scope
+ LHsType Name) -- Kinded, but not yet desugared
+
+tcPatSigBndrs hs_ty
+ = do { in_scope <- getInLocalScope
+ ; span <- getSrcSpanM
+ ; let 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
- kcHsTyVars sig_tvs (\ kinded_tvs -> do
- { mappM kcTypeType sig_tys
- ; return kinded_tvs }) `thenM` \ kinded_tvs ->
+ ; (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
- -- Rather like tcTyVarBndrs, except that it brings *mutable*
- -- tyvars into scope, not immutable ones
+ -- 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
- mapM (zonk . unLoc) kinded_tvs `thenM` \ tyvars ->
- tcExtendTyVarEnv tyvars thing_inside
-
+ ; tyvars <- mapM (zonk . unLoc) kinded_tvs
+ ; return (tyvars, kinded_ty) }
where
zonk (KindedTyVar name kind) = zonkTcKindToKind kind `thenM` \ kind' ->
- newMutTyVar name kind' PatSigTv
- zonk (UserTyVar name) = pprTrace "BAD: Un-kinded tyvar" (ppr name) $
+ 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
+
+ -- 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) }
+ }
+
+tcAddLetBoundTyVars :: LHsBinds Name -> TcM a -> TcM a
+-- Turgid funciton, used for type variables bound by the patterns of a let binding
+
+tcAddLetBoundTyVars binds thing_inside
+ = go (collectSigTysFromHsBinds (bagToList 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) }
\end{code}
\begin{code}
data TcSigInfo
- = TySigInfo {
- sig_poly_id :: TcId, -- *Polymorphic* binder for this value...
- -- Has name = N
-
- sig_tvs :: [TcTyVar], -- tyvars
- sig_theta :: TcThetaType, -- theta
- sig_tau :: TcTauType, -- tau
-
- sig_mono_id :: TcId, -- *Monomorphic* binder for this value
- -- Does *not* have name = N
- -- Has type tau
-
- sig_insts :: [Inst], -- Empty if theta is null, or
- -- (method mono_id) otherwise
-
- sig_loc :: SrcSpan -- The location of the signature
+ = TcSigInfo {
+ sig_id :: TcId, -- *Polymorphic* binder for this value...
+ sig_tvs :: [TcTyVar], -- tyvars
+ sig_theta :: TcThetaType, -- theta
+ sig_tau :: TcTauType, -- tau
+ sig_loc :: InstLoc -- The location of the signature
}
+type TcSigFun = Name -> Maybe TcSigInfo
instance Outputable TcSigInfo where
- ppr (TySigInfo id tyvars theta tau _ inst _) =
- ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
-
-maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo)
- -- Search for a particular signature
-maybeSig [] name = Nothing
-maybeSig (sig@(TySigInfo sig_id _ _ _ _ _ _) : sigs) name
- | name == idName sig_id = Just sig
- | otherwise = maybeSig sigs name
-\end{code}
+ 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
-
-\begin{code}
-tcTySig :: LSig Name -> TcM TcSigInfo
-
-tcTySig (L span (Sig (L _ v) ty))
- = addSrcSpan span $
- tcHsSigType (FunSigCtxt v) ty `thenM` \ sigma_tc_ty ->
- mkTcSig (mkLocalId v sigma_tc_ty) `thenM` \ sig ->
- returnM sig
+lookupSig :: [TcSigInfo] -> TcSigFun -- Search for a particular signature
+lookupSig [] name = Nothing
+lookupSig (sig : sigs) name
+ | name == idName (sig_id sig) = Just sig
+ | otherwise = lookupSig sigs name
mkTcSig :: TcId -> TcM TcSigInfo
mkTcSig poly_id
-- the tyvars *do* get unified with something, we want to carry on
-- typechecking the rest of the program with the function bound
-- to a pristine type, namely sigma_tc_ty
- tcInstType SigTv (idType poly_id) `thenM` \ (tyvars', theta', tau') ->
-
- getInstLoc SignatureOrigin `thenM` \ inst_loc ->
- newMethod inst_loc poly_id
- (mkTyVarTys tyvars')
- theta' tau' `thenM` \ inst ->
- -- We make a Method even if it's not overloaded; no harm
- -- But do not extend the LIE! We're just making an Id.
-
- getSrcSpanM `thenM` \ src_loc ->
- returnM (TySigInfo { sig_poly_id = poly_id, sig_tvs = tyvars',
- sig_theta = theta', sig_tau = tau',
- sig_mono_id = instToId inst,
- sig_insts = [inst], sig_loc = src_loc })
+ do { let rigid_info = SigSkol (idName poly_id)
+ ; (tyvars', theta', tau') <- tcSkolType rigid_info (idType poly_id)
+ ; loc <- getInstLoc (SigOrigin rigid_info)
+ ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tyvars',
+ sig_theta = theta', sig_tau = tau', sig_loc = loc }) }
\end{code}
import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr,
tcClassDecl2, getGenericInstances )
import TcRnMonad
-import TcMType ( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr,
+import TcMType ( tcSkolType, checkValidTheta, checkValidInstHead, instTypeErr,
checkAmbiguity, SourceTyCtxt(..) )
-import TcType ( mkClassPred, tcSplitForAllTys, tyVarsOfType,
+import TcType ( mkClassPred, tcSplitForAllTys, tyVarsOfType,
tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
- TyVarDetails(..), tcSplitDFunTy, pprClassPred )
+ SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred )
import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv )
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv2,
InstInfo(..), InstBindings(..),
- newDFunName, tcExtendLocalValEnv
+ newDFunName, tcExtendIdEnv
)
import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck, tcSimplifyTop )
-import Subst ( mkTyVarSubst, substTheta, substTy )
+import Type ( zipTvSubst, substTheta, substTys )
import DataCon ( classDataCon )
import Class ( classBigSig )
import Var ( Id, idName, idType )
import MkId ( mkDictFunId, rUNTIME_ERROR_ID )
import FunDeps ( checkInstFDs )
import Name ( Name, getSrcLoc )
-import NameSet ( unitNameSet, emptyNameSet, nameSetToList, unionNameSets )
+import NameSet ( unitNameSet, emptyNameSet, unionNameSets )
import UnicodeUtil ( stringToUtf8 )
import Maybe ( catMaybes )
import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
= -- Prime error recovery, set source location
recoverM (returnM Nothing) $
- addSrcSpan loc $
+ setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
-- Typecheck the instance type itself. We can't use
= do { -- (a) Default methods from class decls
(dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
filter (isClassDecl.unLoc) tycl_decls
- ; tcExtendLocalValEnv (concat dm_ids_s) $ do
+ ; tcExtendIdEnv (concat dm_ids_s) $ do
-- (b) instance declarations
; inst_binds_s <- mappM tcInstDecl2 inst_decls
tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
= -- Prime error recovery
- recoverM (returnM emptyBag) $
- addSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $
+ recoverM (returnM emptyLHsBinds) $
+ setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
let
+ rigid_info = InstSkol dfun_id
inst_ty = idType dfun_id
(inst_tyvars, _) = tcSplitForAllTys inst_ty
-- The tyvars of the instance decl scope over the 'where' part
in
-- Instantiate the instance decl with tc-style type variables
- tcInstType InstTv inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
+ tcSkolType rigid_info inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
let
Just pred = tcSplitPredTy_maybe inst_head'
(clas, inst_tys') = getClassPredTys pred
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
-- Instantiate the super-class context with inst_tys
- sc_theta' = substTheta (mkTyVarSubst class_tyvars inst_tys') sc_theta
- origin = InstanceDeclOrigin
+ sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys') sc_theta
+ origin = SigOrigin rigid_info
in
-- Create dictionary Ids from the specified instance contexts.
- newDicts origin sc_theta' `thenM` \ sc_dicts ->
+ newDicts InstScOrigin sc_theta' `thenM` \ sc_dicts ->
newDicts origin dfun_theta' `thenM` \ dfun_arg_dicts ->
newDicts origin [pred] `thenM` \ [this_dict] ->
-- Default-method Ids may be mentioned in synthesised RHSs,
let -- These insts are in scope; quite a few, eh?
avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
in
- tcMethods clas inst_tyvars inst_tyvars'
+ tcMethods origin clas inst_tyvars inst_tyvars'
dfun_theta' inst_tys' avail_insts
op_items binds `thenM` \ (meth_ids, meth_binds) ->
-- Figure out bindings for the superclass context
tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
- `thenM` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) ->
+ `thenM` \ (sc_binds_inner, sc_binds_outer) ->
+
+ -- It's possible that the superclass stuff might have done unification
+ checkSigTyVars inst_tyvars' `thenM_`
-- Deal with 'SPECIALISE instance' pragmas by making them
-- look like SPECIALISE pragmas for the dfun
all_binds = dict_bind `consBag` (sc_binds_inner `unionBags` meth_binds)
main_bind = noLoc $ AbsBinds
- zonked_inst_tyvars
- (map instToId dfun_arg_dicts)
- [(inst_tyvars', dfun_id, this_dict_id)]
- inlines all_binds
+ inst_tyvars'
+ (map instToId dfun_arg_dicts)
+ [(inst_tyvars', dfun_id, this_dict_id)]
+ inlines all_binds
in
showLIE (text "instance") `thenM_`
returnM (unitBag main_bind `unionBags`
sc_binds_outer)
-tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
+tcMethods origin clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
avail_insts op_items (VanillaInst monobinds uprags)
= -- Check that all the method bindings come from this class
let
-- Make the method bindings
let
- mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds
+ mk_method_bind = mkMethodBind origin clas inst_tys' monobinds
in
mapAndUnzipM mk_method_bind op_items `thenM` \ (meth_insts, meth_infos) ->
all_insts = avail_insts ++ catMaybes meth_insts
xtve = inst_tyvars `zip` inst_tyvars'
tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags
+ meth_ids = [meth_id | (_,meth_id,_) <- meth_infos]
in
+
mapM tc_method_bind meth_infos `thenM` \ meth_binds_s ->
- returnM ([meth_id | (_,meth_id,_) <- meth_infos],
- unionManyBags meth_binds_s)
+ returnM (meth_ids, unionManyBags meth_binds_s)
-- Derived newtype instances
-tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
+tcMethods origin clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
avail_insts op_items (NewTypeDerived rep_tys)
- = getInstLoc InstanceDeclOrigin `thenM` \ inst_loc ->
+ = getInstLoc origin `thenM` \ inst_loc ->
mapAndUnzip3M (do_one inst_loc) op_items `thenM` \ (meth_ids, meth_binds, rhs_insts) ->
tcSimplifyCheck
return (meth_id, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst)
-- Instantiate rep_tys with the relevant type variables
- rep_tys' = map (substTy subst) rep_tys
- subst = mkTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')
+ rep_tys' = substTys subst rep_tys
+ subst = zipTvSubst inst_tyvars (mkTyVarTys inst_tyvars')
\end{code}
Note: [Superclass loops]
dfun_arg_dicts
sc_dicts) `thenM` \ (sc_binds1, sc_lie) ->
- -- It's possible that the superclass stuff might have done unification
- checkSigTyVars inst_tyvars' `thenM` \ zonked_inst_tyvars ->
-
-- We must simplify this all the way down
-- lest we build superclass loops
-- See Note [Superclass loops] above
tcSimplifyTop sc_lie `thenM` \ sc_binds2 ->
- returnM (zonked_inst_tyvars, sc_binds1, sc_binds2)
+ returnM (sc_binds1, sc_binds2)
where
doc = ptext SLIT("instance declaration superclass context")
--------------------------------
-- Creating new mutable type variables
- newTyVar, newSigTyVar,
- newTyVarTy, -- Kind -> TcM TcType
- newTyVarTys, -- Int -> Kind -> TcM [TcType]
+ newFlexiTyVar,
+ newTyFlexiVarTy, -- Kind -> TcM TcType
+ newTyFlexiVarTys, -- Int -> Kind -> TcM [TcType]
newKindVar, newKindVars,
- putTcTyVar, getTcTyVar,
- newMutTyVar, readMutTyVar, writeMutTyVar,
+ lookupTcTyVar, condLookupTcTyVar, LookupTyVarResult(..),
+ newMetaTyVar, readMetaTyVar, writeMetaTyVar, putMetaTyVar,
--------------------------------
-- Instantiation
tcInstTyVar, tcInstTyVars, tcInstType,
+ tcSkolTyVar, tcSkolTyVars, tcSkolType,
--------------------------------
-- Checking type validity
Rank, UserTypeCtxt(..), checkValidType, pprHsSigCtxt,
SourceTyCtxt(..), checkValidTheta, checkFreeness,
checkValidInstHead, instTypeErr, checkAmbiguity,
- arityErr,
+ arityErr, isRigidType,
--------------------------------
-- Zonking
- zonkType,
- zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV,
+ zonkType, zonkTcPredType,
+ zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkQuantifiedTyVar,
zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
- zonkTcPredType, zonkTcTyVarToTyVar,
zonkTcKindToKind, zonkTcKind,
readKindVar, writeKindVar
Kind, ThetaType
)
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
- TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..),
+ TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..),
+ MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef,
tcEqType, tcCmpPred, isClassPred,
tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
tcSplitTyConApp_maybe, tcSplitForAllTys,
tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy,
- isUnLiftedType, isIPPred,
- typeKind,
+ isUnLiftedType, isIPPred, isImmutableTyVar,
+ typeKind, isFlexi, isSkolemTyVar,
mkAppTy, mkTyVarTy, mkTyVarTys,
tyVarsOfPred, getClassPredTys_maybe,
tyVarsOfType, tyVarsOfTypes,
pprPred, pprTheta, pprClassPred )
-import Kind ( Kind(..), KindVar(..), mkKindVar,
+import Kind ( Kind(..), KindVar(..), mkKindVar, isSubKind,
isLiftedTypeKind, isArgTypeKind, isOpenTypeKind,
- liftedTypeKind
+ liftedTypeKind, defaultKind
)
-import Subst ( Subst, mkTopTyVarSubst, substTy )
+import Type ( TvSubst, zipTopTvSubst, substTy )
import Class ( Class, classArity, className )
import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
tyConArity, tyConName )
import Var ( TyVar, tyVarKind, tyVarName, isTyVar,
- mkTyVar, mkTcTyVar, tcTyVarRef, isTcTyVar )
+ mkTyVar, mkTcTyVar, tcTyVarDetails, isTcTyVar )
-- others:
import TcRnMonad -- TcType, amongst others
import FunDeps ( grow )
import Name ( Name, setNameUnique, mkSysTvName )
import VarSet
+import VarEnv
import CmdLineOpts ( dopt, DynFlag(..) )
import Util ( nOfThem, isSingleton, equalLength, notNull )
import ListSetOps ( removeDups )
%************************************************************************
\begin{code}
-newMutTyVar :: Name -> Kind -> TyVarDetails -> TcM TyVar
-newMutTyVar name kind details
- = do { ref <- newMutVar Nothing ;
- return (mkTcTyVar name kind details ref) }
+newMetaTyVar :: Name -> Kind -> MetaDetails -> TcM TyVar
+newMetaTyVar name kind details
+ = do { ref <- newMutVar details ;
+ return (mkTcTyVar name kind (MetaTv ref)) }
-readMutTyVar :: TyVar -> TcM (Maybe Type)
-readMutTyVar tyvar = readMutVar (tcTyVarRef tyvar)
+readMetaTyVar :: TyVar -> TcM MetaDetails
+readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
+ readMutVar (metaTvRef tyvar)
-writeMutTyVar :: TyVar -> Maybe Type -> TcM ()
-writeMutTyVar tyvar val = writeMutVar (tcTyVarRef tyvar) val
+writeMetaTyVar :: TyVar -> MetaDetails -> TcM ()
+writeMetaTyVar tyvar val = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
+ writeMutVar (metaTvRef tyvar) val
-newTyVar :: Kind -> TcM TcTyVar
-newTyVar kind
+newFlexiTyVar :: Kind -> TcM TcTyVar
+newFlexiTyVar kind
= newUnique `thenM` \ uniq ->
- newMutTyVar (mkSysTvName uniq FSLIT("t")) kind VanillaTv
+ newMetaTyVar (mkSysTvName uniq FSLIT("t")) kind Flexi
-newSigTyVar :: Kind -> TcM TcTyVar
-newSigTyVar kind
- = newUnique `thenM` \ uniq ->
- newMutTyVar (mkSysTvName uniq FSLIT("s")) kind SigTv
-
-newTyVarTy :: Kind -> TcM TcType
-newTyVarTy kind
- = newTyVar kind `thenM` \ tc_tyvar ->
+newTyFlexiVarTy :: Kind -> TcM TcType
+newTyFlexiVarTy kind
+ = newFlexiTyVar kind `thenM` \ tc_tyvar ->
returnM (TyVarTy tc_tyvar)
-newTyVarTys :: Int -> Kind -> TcM [TcType]
-newTyVarTys n kind = mappM newTyVarTy (nOfThem n kind)
+newTyFlexiVarTys :: Int -> Kind -> TcM [TcType]
+newTyFlexiVarTys n kind = mappM newTyFlexiVarTy (nOfThem n kind)
+
+isRigidType :: TcType -> TcM Bool
+-- Check that the type is rigid, *taking the type refinement into account*
+-- In other words if a rigid type variable tv is refined to a wobbly type,
+-- the answer should be False
+-- ToDo: can this happen?
+isRigidType ty
+ = do { rigids <- mapM is_rigid (varSetElems (tyVarsOfType ty))
+ ; return (and rigids) }
+ where
+ is_rigid tv = do { details <- lookupTcTyVar tv
+ ; case details of
+ RigidTv -> return True
+ IndirectTv True ty -> isRigidType ty
+ other -> return False
+ }
newKindVar :: TcM TcKind
newKindVar = do { uniq <- newUnique
Instantiating a bunch of type variables
-\begin{code}
-tcInstTyVars :: TyVarDetails -> [TyVar]
- -> TcM ([TcTyVar], [TcType], Subst)
+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.
-tcInstTyVars tv_details tyvars
- = mappM (tcInstTyVar tv_details) tyvars `thenM` \ tc_tyvars ->
- let
- tys = mkTyVarTys tc_tyvars
- in
- returnM (tc_tyvars, tys, mkTopTyVarSubst tyvars tys)
+
+\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 mkTopTyVarSubst
-
-tcInstTyVar tv_details tyvar
- = newUnique `thenM` \ uniq ->
- let
- name = setNameUnique (tyVarName tyvar) uniq
- -- 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.
- in
- newMutTyVar name (tyVarKind tyvar) tv_details
+ -- any existing for-alls. Hence zipTopTvSubst
+
+tcInstTyVar tyvar
+ = do { uniq <- newUnique
+ ; let name = setNameUnique (tyVarName tyvar) uniq
+ -- See Note [TyVarName]
+ ; newMetaTyVar name (tyVarKind tyvar) Flexi }
-tcInstType :: TyVarDetails -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
+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 tv_details ty
+tcInstType ty
= case tcSplitForAllTys ty of
([], rho) -> -- There may be overloading despite no type variables;
-- (?x :: Int) => Int -> Int
in
returnM ([], theta, tau)
- (tyvars, rho) -> tcInstTyVars tv_details tyvars `thenM` \ (tyvars', _, tenv) ->
+ (tyvars, rho) -> tcInstTyVars tyvars `thenM` \ (tyvars', _, tenv) ->
let
(theta, tau) = tcSplitPhiTy (substTy tenv rho)
in
returnM (tyvars', theta, tau)
+
+---------------------------------------------
+-- Similar functions but for skolem constants
+
+tcSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
+tcSkolTyVars info tyvars = mappM (tcSkolTyVar info) tyvars
+
+tcSkolTyVar :: SkolemInfo -> TyVar -> TcM TcTyVar
+tcSkolTyVar info tyvar
+ = do { uniq <- newUnique
+ ; let name = setNameUnique (tyVarName tyvar) uniq
+ -- See Note [TyVarName]
+ ; return (mkTcTyVar name (tyVarKind tyvar)
+ (SkolemTv info)) }
+
+tcSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
+tcSkolType info ty
+ = case tcSplitForAllTys ty of
+ ([], rho) -> let
+ (theta, tau) = tcSplitPhiTy rho
+ in
+ returnM ([], theta, tau)
+
+ (tyvars, rho) -> tcSkolTyVars info tyvars `thenM` \ tyvars' ->
+ let
+ tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars')
+ (theta, tau) = tcSplitPhiTy (substTy tenv rho)
+ in
+ returnM (tyvars', theta, tau)
\end{code}
%************************************************************************
\begin{code}
-putTcTyVar :: TcTyVar -> TcType -> TcM TcType
-getTcTyVar :: TcTyVar -> TcM (Maybe TcType)
-\end{code}
-
-Putting is easy:
-
-\begin{code}
-putTcTyVar tyvar ty
- | not (isTcTyVar tyvar)
+putMetaTyVar :: TcTyVar -> TcType -> TcM ()
+#ifndef DEBUG
+putMetaTyVar tyvar ty = writeMetaTyVar tyvar (Indirect ty)
+#else
+putMetaTyVar tyvar ty
+ | not (isMetaTyVar tyvar)
= pprTrace "putTcTyVar" (ppr tyvar) $
- returnM ty
+ returnM ()
| otherwise
- = ASSERT( isTcTyVar tyvar )
- writeMutTyVar tyvar (Just ty) `thenM_`
- returnM ty
+ = 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) }
+ where
+ k1 = tyVarKind tyvar
+ k2 = typeKind ty
+#endif
\end{code}
-Getting is more interesting. The easy thing to do is just to read, thus:
-
-\begin{verbatim}
-getTcTyVar tyvar = readMutTyVar tyvar
-\end{verbatim}
-
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.
We return Nothing iff the original box was unbound.
\begin{code}
+data LookupTyVarResult -- The result of a lookupTcTyVar call
+ = FlexiTv
+ | RigidTv
+ | 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
+
+lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult
+-- This function is the ONLY PLACE that we consult the
+-- type refinement carried by the monad
+--
+-- The boolean returned with Indirect
+lookupTcTyVar tyvar
+ = case tcTyVarDetails tyvar of
+ SkolemTv _ -> do { type_reft <- getTypeRefinement
+ ; case lookupVarEnv type_reft tyvar of
+ Just ty -> return (IndirectTv True ty)
+ Nothing -> return RigidTv
+ }
+ MetaTv ref -> do { details <- readMutVar ref
+ ; case details of
+ Indirect ty -> return (IndirectTv False ty)
+ Flexi -> return FlexiTv
+ }
+
+-- 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 tcTyVarDetails tyvar of
+ SkolemTv _ -> return RigidTv
+ MetaTv ref -> do { details <- readMutVar ref
+ ; case details of
+ Indirect ty -> return (IndirectTv False ty)
+ Flexi -> return FlexiTv
+ }
+
+{-
+-- gaw 2004 We aren't shorting anything out anymore, at least for now
getTcTyVar tyvar
| not (isTcTyVar tyvar)
= pprTrace "getTcTyVar" (ppr tyvar) $
| otherwise
= ASSERT2( isTcTyVar tyvar, ppr tyvar )
- readMutTyVar tyvar `thenM` \ maybe_ty ->
+ readMetaTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
Just ty -> short_out ty `thenM` \ ty' ->
- writeMutTyVar tyvar (Just ty') `thenM_`
+ writeMetaTyVar tyvar (Just ty') `thenM_`
returnM (Just ty')
Nothing -> returnM Nothing
= returnM ty
| otherwise
- = readMutTyVar tyvar `thenM` \ maybe_ty ->
+ = readMetaTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
Just ty' -> short_out ty' `thenM` \ ty' ->
- writeMutTyVar tyvar (Just ty') `thenM_`
+ writeMetaTyVar tyvar (Just ty') `thenM_`
returnM ty'
other -> returnM ty
short_out other_ty = returnM other_ty
+-}
\end{code}
returnM (tyVarsOfTypes tys)
zonkTcTyVar :: TcTyVar -> TcM TcType
-zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnM (TyVarTy tv)) tyvar
+zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnM (TyVarTy tv)) True tyvar
\end{code}
----------------- Types
\begin{code}
zonkTcType :: TcType -> TcM TcType
-zonkTcType ty = zonkType (\ tv -> returnM (TyVarTy tv)) ty
+zonkTcType ty = zonkType (\ tv -> returnM (TyVarTy tv)) True ty
zonkTcTypes :: [TcType] -> TcM [TcType]
zonkTcTypes tys = mappM zonkTcType tys
are used at the end of type checking
\begin{code}
--- zonkTcTyVarToTyVar is applied to the *binding* occurrence
--- of a type variable, at the *end* of type checking. It changes
--- the *mutable* type variable into an *immutable* one.
---
--- It does this by making an immutable version of tv and binds tv to it.
--- Now any bound occurences of the original type variable will get
--- zonked to the immutable version.
-
-zonkTcTyVarToTyVar :: TcTyVar -> TcM TyVar
-zonkTcTyVarToTyVar tv
- = let
- -- Make an immutable version, defaulting
- -- the kind to lifted if necessary
- immut_tv = mkTyVar (tyVarName tv) (tyVarKind tv)
- -- was: defaultKind (tyVarKind tv), but I don't
- immut_tv_ty = mkTyVarTy immut_tv
-
- zap tv = putTcTyVar tv immut_tv_ty
- -- Bind the mutable version to the immutable one
- in
- -- If the type variable is mutable, then bind it to immut_tv_ty
- -- so that all other occurrences of the tyvar will get zapped too
- zonkTyVar zap tv `thenM` \ ty2 ->
-
- -- This warning shows up if the allegedly-unbound tyvar is
- -- already bound to something. It can actually happen, and
- -- in a harmless way (see [Silly Type Synonyms] below) so
- -- it's only a warning
- WARN( not (immut_tv_ty `tcEqType` ty2), ppr tv $$ ppr immut_tv $$ ppr ty2 )
-
- returnM immut_tv
+zonkQuantifiedTyVar :: TcTyVar -> TcM TyVar
+-- zonkQuantifiedTyVar is applied to the a TcTyVar when quantifying over it.
+-- It might be a meta TyVar, in which case we freeze it inot ano ordinary TyVar.
+-- When we do this, we also default the kind -- see notes with Kind.defaultKind
+-- The meta tyvar is updated to point to the new regular TyVar. Now any
+-- bound occurences of the original type variable will get zonked to
+-- the immutable version.
+--
+-- We leave skolem TyVars alone; they are imutable.
+zonkQuantifiedTyVar tv
+ | isSkolemTyVar tv = return tv
+ -- It might be a skolem type variable,
+ -- for example from a user type signature
+
+ | otherwise -- It's a meta-type-variable
+ = do { details <- readMetaTyVar tv
+
+ -- Create the new, frozen, regular type variable
+ ; let final_kind = defaultKind (tyVarKind tv)
+ final_tv = mkTyVar (tyVarName tv) final_kind
+
+ -- Bind the meta tyvar to the new tyvar
+ ; case details of
+ Indirect ty -> WARN( True, ppr tv $$ ppr ty )
+ return ()
+ -- [Sept 04] I don't think this should happen
+ -- See note [Silly Type Synonym]
+
+ other -> writeMetaTyVar tv (Indirect (mkTyVarTy final_tv))
+
+ -- Return the new tyvar
+ ; return final_tv }
\end{code}
[Silly Type Synonyms]
* So we get a dict binding for Num (C d a), which is zonked to give
a = ()
+ [Note Sept 04: now that we are zonking quantified type variables
+ on construction, the 'a' will be frozen as a regular tyvar on
+ quantification, so the floated dict will still have type (C d a).
+ Which renders this whole note moot; happily!]
* Then the /\a abstraction has a zonked 'a' in it.
-All very silly. I think its harmless to ignore the problem.
+All very silly. I think its harmless to ignore the problem. We'll end up with
+a /\a in the final result but all the occurrences of a will be zonked to ()
%************************************************************************
zonkType :: (TcTyVar -> TcM Type) -- What to do with unbound mutable type variables
-- see zonkTcType, and zonkTcTypeToType
- -> TcType
+ -> Bool -- Should we consult the current type refinement?
+ -> TcType
-> TcM Type
-zonkType unbound_var_fn ty
+zonkType unbound_var_fn rflag ty
= go ty
where
go (TyConApp tycon tys) = mappM go tys `thenM` \ tys' ->
-- to pull the TyConApp to the top.
-- The two interesting cases!
- go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar
+ go (TyVarTy tyvar) = zonkTyVar unbound_var_fn rflag tyvar
- go (ForAllTy tyvar ty) = zonkTcTyVarToTyVar tyvar `thenM` \ tyvar' ->
- go ty `thenM` \ ty' ->
- returnM (ForAllTy tyvar' ty')
+ go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar )
+ go ty `thenM` \ ty' ->
+ returnM (ForAllTy tyvar ty')
go_pred (ClassP c tys) = mappM go tys `thenM` \ tys' ->
returnM (ClassP c tys')
returnM (IParam n ty')
zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable variable
- -> TcTyVar -> TcM TcType
-zonkTyVar unbound_var_fn tyvar
- | not (isTcTyVar tyvar) -- Not a mutable tyvar. This can happen when
+ -> Bool -- Consult the type refinement?
+ -> TcTyVar -> TcM TcType
+zonkTyVar unbound_var_fn rflag tyvar
+ | not (isTcTyVar tyvar) -- This can happen when
-- zonking a forall type, when the bound type variable
-- needn't be mutable
- = ASSERT( isTyVar tyvar ) -- Should not be any immutable kind vars
- returnM (TyVarTy tyvar)
+ = returnM (TyVarTy tyvar)
| otherwise
- = getTcTyVar tyvar `thenM` \ maybe_ty ->
- case maybe_ty of
- Nothing -> unbound_var_fn tyvar -- Mutable and unbound
- Just other_ty -> zonkType unbound_var_fn other_ty -- Bound
+ = 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
+ FlexiTv -> unbound_var_fn tyvar -- Unbound flexi
+ RigidTv -> return (TyVarTy tyvar) -- Rigid, no zonking necessary
\end{code}
-> TcRnTypes.TcM (HsExpr.GRHSs Var.Id)
tcMatchesFun :: Name.Name
- -> [HsExpr.LMatch Name.Name]
+ -> HsExpr.MatchGroup Name.Name
-> TcUnify.Expected TcType.TcType
- -> TcRnTypes.TcM [HsExpr.LMatch Var.Id]
+ -> TcRnTypes.TcM (HsExpr.MatchGroup Var.Id)
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcCheckRho, tcMonoExpr )
+import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho, tcMonoExpr )
-import HsSyn ( HsExpr(..), LHsExpr, HsBindGroup(..),
+import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..),
Match(..), LMatch, GRHSs(..), GRHS(..),
Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
ReboundNames, LPat,
pprMatch, isDoExpr,
pprMatchContext, pprStmtContext, pprStmtResultContext,
- collectSigTysFromPats, glueBindsOnGRHSs
+ collectPatsBinders, glueBindsOnGRHSs
)
-import TcHsSyn ( ExprCoFn, TcDictBinds, isIdCoercion, (<$>), (<.>) )
+import TcHsSyn ( ExprCoFn, isIdCoercion, (<$>), (<.>) )
import TcRnMonad
-import TcHsType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
+import TcHsType ( tcHsPatSigType, UserTypeCtxt(..) )
import Inst ( tcSyntaxName, tcInstCall )
-import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
-import TcPat ( tcPat, tcMonoPatBndr )
-import TcMType ( newTyVarTy, newTyVarTys, zonkTcType )
-import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType,
- tyVarsOfTypes, tidyOpenTypes, isSigmaTy, typeKind,
- mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
- mkArrowKind, mkAppTy )
+import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv,
+ tcExtendTyVarEnv )
+import TcPat ( PatCtxt(..), tcPats )
+import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, zonkTcType, isRigidType )
+import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, mkFunTys,
+ tyVarsOfTypes, tidyOpenTypes, isSigmaTy, mkTyConApp,
+ liftedTypeKind, openTypeKind, mkArrowKind, mkAppTy )
import TcBinds ( tcBindsAndThen )
-import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, readExpectedType,
- unifyTauTy, subFunTys, unifyPArrTy, unifyListTy, unifyFunTy,
- checkSigTyVarsWrt, tcSubExp, tcGen )
-import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
+import TcUnify ( Expected(..), zapExpectedType, readExpectedType,
+ unifyTauTy, subFunTys, unifyListTy, unifyTyConApp,
+ checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen,
+ unifyAppTy )
import Name ( Name )
-import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
+import TysWiredIn ( boolTy, parrTyCon, listTyCon )
import Id ( idType, mkLocalId )
import CoreFVs ( idFreeTyVars )
-import BasicTypes ( RecFlag(..) )
import VarSet
-import Bag
import Util ( isSingleton, notNull )
import Outputable
import SrcLoc ( Located(..), noLoc )
\begin{code}
tcMatchesFun :: Name
- -> [LMatch Name]
- -> Expected TcRhoType -- Expected type
- -> TcM [LMatch TcId]
-
-tcMatchesFun fun_name matches@(first_match:_) expected_ty
- = -- Check that they all have the same no of arguments
- -- Location is in the monad, set the caller so that
- -- any inter-equation error messages get some vaguely
- -- sensible location. Note: we have to do this odd
- -- ann-grabbing, because we don't always have annotations in
- -- hand when we call tcMatchesFun...
- checkTc (sameNoOfArgs matches)
- (varyingArgsErr fun_name matches) `thenM_`
+ -> MatchGroup Name
+ -> Expected TcRhoType -- Expected type of function
+ -> TcM (MatchGroup TcId) -- Returns type of body
+
+tcMatchesFun fun_name matches exp_ty
+ = do { -- Check that they all have the same no of arguments
+ -- Location is in the monad, set the caller so that
+ -- any inter-equation error messages get some vaguely
+ -- sensible location. Note: we have to do this odd
+ -- ann-grabbing, because we don't always have annotations in
+ -- hand when we call tcMatchesFun...
+ checkTc (sameNoOfArgs matches) (varyingArgsErr fun_name matches)
-- ToDo: Don't use "expected" stuff if there ain't a type signature
-- because inconsistency between branches
-- may show up as something wrong with the (non-existent) type signature
- -- No need to zonk expected_ty, because subFunTys does that on the fly
- tcMatches match_ctxt matches expected_ty
+ -- 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 matches exp_ty' $ \ pat_tys rhs_ty ->
+ tcMatches match_ctxt pat_tys rhs_ty matches
+ }
where
match_ctxt = MC { mc_what = FunRhs fun_name,
mc_body = tcMonoExpr }
\begin{code}
tcMatchesCase :: TcMatchCtxt -- Case context
- -> [LMatch Name] -- The case alternatives
+ -> TcRhoType -- Type of scrutinee
+ -> MatchGroup Name -- The case alternatives
-> Expected TcRhoType -- Type of whole case expressions
- -> TcM (TcRhoType, -- Inferred type of the scrutinee
- [LMatch TcId]) -- Translated alternatives
-
-tcMatchesCase ctxt matches (Check expr_ty)
- = newTyVarTy openTypeKind `thenM` \ scrut_ty ->
- -- openTypeKind because the scrutinee can be an unboxed type
- tcMatches ctxt matches (Check (mkFunTy scrut_ty expr_ty)) `thenM` \ matches' ->
- returnM (scrut_ty, matches')
-
-tcMatchesCase ctxt matches (Infer hole)
- = newHole `thenM` \ fun_hole ->
- tcMatches ctxt matches (Infer fun_hole) `thenM` \ matches' ->
- readMutVar fun_hole `thenM` \ fun_ty ->
- -- The result of tcMatches is bound to be a function type
- unifyFunTy fun_ty `thenM` \ (scrut_ty, res_ty) ->
- writeMutVar hole res_ty `thenM_`
- returnM (scrut_ty, matches')
-
-
-tcMatchLambda :: LMatch Name -> Expected TcRhoType -> TcM (LMatch TcId)
-tcMatchLambda match res_ty = tcMatch match_ctxt res_ty match
+ -> 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 }
+
+tcMatchLambda :: MatchGroup Name -> Expected TcRhoType -> TcM (MatchGroup TcId)
+tcMatchLambda match exp_ty -- One branch so no unifyBranches needed
+ = subFunTys match exp_ty $ \ pat_tys rhs_ty ->
+ tcMatches match_ctxt pat_tys rhs_ty match
where
match_ctxt = MC { mc_what = LambdaExpr,
mc_body = tcMonoExpr }
mc_body = tcMonoExpr }
\end{code}
-\begin{code}
-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
- -> TcM (LHsExpr TcId) }
-
-tcMatches :: TcMatchCtxt
- -> [LMatch Name]
- -> Expected TcRhoType
- -> TcM [LMatch TcId]
-
-tcMatches ctxt matches exp_ty
- = -- If there is more than one branch, 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 matches exp_ty `thenM` \ exp_ty' ->
- mappM (tcMatch ctxt exp_ty') matches
-\end{code}
-
%************************************************************************
%* *
%************************************************************************
\begin{code}
+tcMatches :: TcMatchCtxt
+ -> [Expected TcRhoType] -- Expected pattern types
+ -> Expected TcRhoType -- 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
+ -> 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')) }
+
+-------------
tcMatch :: TcMatchCtxt
- -> Expected TcRhoType -- Expected result-type of the Match.
- -- Early unification with this guy gives better error messages
- -- We regard the Match as having type
- -- (ty1 -> ... -> tyn -> result_ty)
- -- where there are n patterns.
+ -> [Expected TcRhoType] -- Expected pattern types
+ -> Expected TcRhoType -- Expected result-type of the Match.
-> LMatch Name
-> TcM (LMatch TcId)
-tcMatch ctxt exp_ty match = wrapLocM (tc_match ctxt exp_ty) match
+tcMatch ctxt pat_tys rhs_ty match
+ = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
-tc_match ctxt expected_ty match@(Match pats maybe_rhs_sig grhss)
- = addErrCtxt (matchCtxt (mc_what ctxt) match) $ -- I'm not sure why, so I put it back
- subFunTys pats expected_ty $ \ pats_w_tys rhs_ty ->
- -- This is the unique place we call subFunTys
- -- The point is that if expected_y is a "hole", we want
- -- to make arg_ty and rest_ty as "holes" too.
- tcMatchPats pats_w_tys rhs_ty (tc_grhss rhs_ty) `thenM` \ (pats', grhss', ex_binds) ->
- returnM (Match pats' Nothing (glueBindsOnGRHSs ex_binds 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') }
- where
- tc_grhss rhs_ty
- = case maybe_rhs_sig of -- Deal with the result signature
- Nothing -> tcGRHSs ctxt grhss rhs_ty
-
- Just sig -> tcAddScopedTyVars [sig] $
- -- Bring into scope the type variables in the signature
- tcHsSigType ResSigCtxt sig `thenM` \ sig_ty ->
- tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty `thenM` \ (co_fn, grhss') ->
-
- -- Pushes the coercion down to the right hand sides,
- -- because there is no convenient place to hang it otherwise.
- if isIdCoercion co_fn then
- returnM grhss'
- else
- readExpectedType rhs_ty `thenM` \ rhs_ty' ->
- returnM (lift_grhss co_fn rhs_ty' grhss')
-
-lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
- = GRHSs (map (fmap lift_grhs) grhss) binds rhs_ty -- Change the type, since the coercion does
+
+-------------
+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') }
+
+-------------
+lift_grhss co_fn (GRHSs grhss binds)
+ = GRHSs (map (fmap lift_grhs) grhss) binds
where
lift_grhs (GRHS stmts) = GRHS (map lift_stmt stmts)
lift_stmt (L loc (ResultStmt e)) = L loc (ResultStmt (fmap (co_fn <$>) e))
lift_stmt stmt = stmt
+-------------
tcGRHSs :: TcMatchCtxt -> GRHSs Name
-> Expected TcRhoType
-> TcM (GRHSs TcId)
-- 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 [L loc2 (ResultStmt rhs)])] binds _) exp_ty
+tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds) exp_ty
= tcBindsAndThen glueBindsOnGRHSs binds $
mc_body ctxt rhs exp_ty `thenM` \ rhs' ->
- readExpectedType exp_ty `thenM` \ exp_ty' ->
- returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [] exp_ty')
+ returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [])
-tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
+tcGRHSs ctxt (GRHSs grhss binds) exp_ty
= tcBindsAndThen glueBindsOnGRHSs binds $
zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' ->
-- Even if there is only one guard, we zap the RHS type to
-- and even a one-armed guard has a notional second arm
let
stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
- sc_rhs = tcCheckRho,
+ sc_rhs = tcInferRho,
sc_body = sc_body,
sc_ty = exp_ty' }
sc_body body = mc_body ctxt body (Check exp_ty')
returnM (GRHS guarded')
in
mappM (wrapLocM tc_grhs) grhss `thenM` \ grhss' ->
- returnM (GRHSs grhss' [] exp_ty')
+ returnM (GRHSs grhss' [])
\end{code}
-- 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 SignatureOrigin sig_ty `thenM` \ (inst_fn, inst_sig_ty) ->
+ 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.
%************************************************************************
\begin{code}
-tcMatchPats
- :: [(LPat Name, Expected TcRhoType)]
- -> Expected TcRhoType
- -> TcM a
- -> TcM ([LPat TcId], a, HsBindGroup TcId)
+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_w_tys body_ty thing_inside
- = -- STEP 1: Bring pattern-signature type variables into scope
- tcAddScopedTyVars (collectSigTysFromPats (map fst pats_w_tys)) (
-
- -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
- -- then do the thing inside
- getLIE (tc_match_pats pats_w_tys thing_inside)
-
- ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
-
- -- STEP 4: Check for existentially bound type variables
- -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
- -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
- --
- -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
- -- might need (via lie_req2) something made available from an 'outer'
- -- pattern. But it's inconvenient to deal with, and I can't find an example
- tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req
- pats_w_tys body_ty `thenM` \ ex_binds ->
- -- NB: we *must* pass "pats_w_tys" not just "body_ty" to tcCheckExistentialPat
+tcMatchPats pats tys body_ty thing_inside
+ = do { do_refinement <- can_refine body_ty
+ ; (pats', ex_tvs, res) <- tcPats (LamPat do_refinement) pats tys thing_inside
+ ; tcCheckExistentialPat pats' ex_tvs tys body_ty
+ ; returnM (pats', res) }
+ where
+ -- Do GADT refinement if we are doing checking (not inference)
+ -- and the body_ty is completely rigid
+ -- ToDo: explain why
+ can_refine (Infer _) = return False
+ can_refine (Check ty) = isRigidType ty
+
+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).
- returnM (pats', result, HsBindGroup ex_binds [] Recursive)
-
-tc_match_pats [] thing_inside
- = thing_inside `thenM` \ answer ->
- returnM ([], emptyBag, [], [], answer)
+tcCheckExistentialPat pats [] pat_tys body_ty
+ = return () -- Short cut for case when there are no existentials
-tc_match_pats ((pat,pat_ty):pats) thing_inside
- = tcPat tcMonoPatBndr pat pat_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
- let
- xve = bagToList pat_bndrs
- ex_ids = [id | (_, id) <- xve]
- -- ex_ids is all the pattern-bound Ids, a superset
- -- of the existential Ids used in checkExistentialPat
- in
- tcExtendLocalValEnv2 xve $
- traceTc (text "tc_match_pats" <+> (ppr xve $$ ppr (map (idType . snd) xve) $$
- ppr (map (typeKind . idType . snd) xve))) `thenM_`
- tc_match_pats pats thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
- returnM ( pat':pats',
- ex_tvs `unionBags` exs_tvs,
- ex_ids ++ exs_ids,
- ex_lie ++ exs_lie,
- answer
- )
-
-
-tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern
- -> [TcId] -- Ids bound by this pattern; used
- -- (a) by bindsInstsOfLocalFuns
- -- (b) to generate helpful error messages
- -> [Inst] -- and context
- -> [Inst] -- Required context
- -> [(pat,Expected TcRhoType)] -- Types of the patterns
- -> Expected TcRhoType -- Type of the body of the match
- -- Tyvars in either of these must not escape
- -> TcM TcDictBinds -- LIE to float out and dict bindings
-tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty
- | isEmptyBag ex_tvs && all not_overloaded ex_ids
- -- Short cut for case when there are no existentials
- -- and no polymorphic overloaded variables
- -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
- -- f op x = ....
- -- Here we must discharge op Methods
- = ASSERT( null ex_lie )
- extendLIEs lie_req `thenM_`
- returnM emptyBag
-
- | otherwise
- = -- Read the by-now-filled-in expected types
- mapM readExpectedType (body_ty : map snd pats_w_tys) `thenM` \ tys ->
- addErrCtxtM (sigPatCtxt tv_list ex_ids tys) $
-
- -- In case there are any polymorpic, overloaded binders in the pattern
- -- (which can happen in the case of rank-2 type signatures, or data constructors
- -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
- getLIE (bindInstsOfLocalFuns lie_req ex_ids) `thenM` \ (inst_binds, lie) ->
-
- -- Deal with overloaded functions bound by the pattern
- tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds ->
-
- -- Check for type variable escape
- checkSigTyVarsWrt (tyVarsOfTypes tys) tv_list `thenM_`
-
- returnM (dict_binds `unionBags` inst_binds)
- where
- doc = text ("existential context of a data constructor")
- tv_list = bagToList ex_tvs
- not_overloaded id = not (isOverloadedTy (idType id))
+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 }
\end{code}
-> TcRhoType -- To keep it simple, we don't have an "expected" type here
-> TcM ([LStmt TcId], ReboundNames TcId)
tcDoStmts PArrComp stmts method_names res_ty
- = unifyPArrTy res_ty `thenM` \elt_ty ->
- tcComprehension PArrComp mkPArrTy elt_ty stmts `thenM` \ stmts' ->
- returnM (stmts', [{- unused -}])
+ = do { [elt_ty] <- unifyTyConApp parrTyCon res_ty
+ ; stmts' <- tcComprehension PArrComp parrTyCon elt_ty stmts
+ ; return (stmts', [{- unused -}]) }
tcDoStmts ListComp stmts method_names res_ty
= unifyListTy res_ty ` thenM` \ elt_ty ->
- tcComprehension ListComp mkListTy elt_ty stmts `thenM` \ stmts' ->
+ tcComprehension ListComp listTyCon elt_ty stmts `thenM` \ stmts' ->
returnM (stmts', [{- unused -}])
tcDoStmts do_or_mdo stmts method_names res_ty
- = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
- newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
+ = newTyFlexiVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
+ newTyFlexiVarTy liftedTypeKind `thenM` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
let
ctxt = SC { sc_what = do_or_mdo,
- sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mkAppTy m_ty rhs_elt_ty),
+ sc_rhs = \ rhs -> do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; rhs_elt_ty <- unifyAppTy m_ty rhs_ty
+ ; return (rhs', rhs_elt_ty) },
sc_body = \ body -> tcCheckRho body res_ty,
sc_ty = res_ty }
in
returnM (stmts', methods)
-tcComprehension do_or_lc mk_mty elt_ty stmts
+tcComprehension do_or_lc m_tycon elt_ty stmts
= tcStmts ctxt stmts
where
ctxt = SC { sc_what = do_or_lc,
- sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mk_mty rhs_elt_ty),
- sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no mk_mty!
- sc_ty = mk_mty elt_ty }
+ sc_rhs = \ rhs -> do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; [rhs_elt_ty] <- unifyTyConApp m_tycon rhs_ty
+ ; return (rhs', rhs_elt_ty) },
+ sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no m_tycon here!
+ sc_ty = mkTyConApp m_tycon [elt_ty] }
\end{code}
data TcStmtCtxt
= SC { sc_what :: HsStmtContext Name, -- What kind of thing this is
- sc_rhs :: LHsExpr Name -> TcType -> TcM (LHsExpr TcId), -- Type checker for RHS computations
+ sc_rhs :: LHsExpr Name -> TcM (LHsExpr TcId, TcType), -- Type inference for RHS computations
sc_body :: LHsExpr Name -> TcM (LHsExpr TcId), -- Type checker for return computation
sc_ty :: TcType } -- Return type; used *only* to check
-- for escape in existential patterns
+ -- We use type *inference* for the RHS computations, becuase of GADTs.
+ -- do { pat <- rhs; <rest> }
+ -- is rather like
+ -- case rhs of { pat -> <rest> }
+ -- We do inference on rhs, so that information about its type can be refined
+ -- when type-checking the pattern.
+
tcStmtsAndThen
:: (LStmt TcId -> thing -> thing) -- Combiner
-> TcStmtCtxt
-- BindStmt
tcStmtAndThen combine ctxt (L src_loc stmt@(BindStmt pat exp)) thing_inside
- = addSrcSpan src_loc $
+ = setSrcSpan src_loc $
addErrCtxt (stmtCtxt ctxt stmt) $
- newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
- sc_rhs ctxt exp pat_ty `thenM` \ exp' ->
- tcMatchPats [(pat, Check pat_ty)] (Check (sc_ty ctxt)) (
- popErrCtxt thing_inside
- ) `thenM` \ ([pat'], thing, dict_binds) ->
- returnM (combine (L src_loc (BindStmt pat' exp'))
- (glue_binds combine dict_binds thing))
+ do { (exp', pat_ty) <- sc_rhs ctxt exp
+ ; ([pat'], thing) <- tcMatchPats [pat] [Check pat_ty] (Check (sc_ty ctxt)) $
+ popErrCtxt thing_inside
+ ; return (combine (L src_loc (BindStmt pat' exp')) thing) }
-- ExprStmt
tcStmtAndThen combine ctxt (L src_loc stmt@(ExprStmt exp _)) thing_inside
- = addSrcSpan src_loc (
+ = setSrcSpan src_loc (
addErrCtxt (stmtCtxt ctxt stmt) $
if isDoExpr (sc_what ctxt)
then -- do or mdo; the expression is a computation
- newTyVarTy liftedTypeKind `thenM` \ any_ty ->
- sc_rhs ctxt exp any_ty `thenM` \ exp' ->
- returnM (L src_loc (ExprStmt exp' any_ty))
+ sc_rhs ctxt exp `thenM` \ (exp', exp_ty) ->
+ returnM (L src_loc (ExprStmt exp' exp_ty))
else -- List comprehensions, pattern guards; expression is a boolean
tcCheckRho exp boolTy `thenM` \ exp' ->
returnM (L src_loc (ExprStmt exp' boolTy))
-- RecStmt
tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thing_inside
- = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
+-- gaw 2004
+ = newTyFlexiVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
let
rec_ids = zipWith mkLocalId recNames recTys
in
- tcExtendLocalValEnv rec_ids $
+ tcExtendIdEnv rec_ids $
tcStmtsAndThen combine_rec ctxt stmts (
zipWithM tc_ret recNames recTys `thenM` \ rec_rets ->
tcLookupLocalIds laterNames `thenM` \ later_ids ->
returnM ([], (later_ids, rec_rets))
) `thenM` \ (stmts', (later_ids, rec_rets)) ->
- tcExtendLocalValEnv later_ids $
+ tcExtendIdEnv later_ids $
-- NB: The rec_ids for the recursive things
-- already scope over this part
thing_inside `thenM` \ thing ->
number of args are used in each equation.
\begin{code}
-sameNoOfArgs :: [LMatch Name] -> Bool
-sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
+sameNoOfArgs :: MatchGroup Name -> Bool
+sameNoOfArgs (MatchGroup matches _)
+ = isSingleton (nub (map args_in_match matches))
where
args_in_match :: LMatch Name -> Int
args_in_match (L _ (Match pats _ _)) = length pats
ResultStmt _ -> pprStmtResultContext
other -> pprStmtContext
-sigPatCtxt bound_tvs bound_ids tys tidy_env
+sigPatCtxt bound_ids bound_tvs tys tidy_env
= -- tys is (body_ty : pat_tys)
mapM zonkTcType tys `thenM` \ tys' ->
let
\section[TcPat]{Typechecking patterns}
\begin{code}
-module TcPat ( tcPat, tcMonoPatBndr, tcSubPat,
- badFieldCon, polyPatSig
- ) where
+module TcPat ( tcPat, tcPats, PatCtxt(..), badFieldCon, polyPatSig ) where
#include "HsVersions.h"
-import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..), HsExpr(..) )
+import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..),
+ HsExpr(..), LHsBinds, emptyLHsBinds, isEmptyLHsBinds )
import HsUtils
-import TcHsSyn ( TcId, hsLitType,
- mkCoercion, idCoercion, isIdCoercion,
- (<$>), PatCoFn )
-
+import TcHsSyn ( TcId, hsLitType )
import TcRnMonad
import Inst ( InstOrigin(..),
newMethodFromName, newOverloadedLit, newDicts,
- instToId, tcInstDataCon, tcSyntaxName
+ instToId, tcInstStupidTheta, tcSyntaxName
)
-import Id ( idType, mkLocalId, mkSysLocal )
+import Id ( Id, idType, mkLocalId )
import Name ( Name )
-import FieldLabel ( fieldLabelName )
-import TcEnv ( tcLookupClass, tcLookupLocatedDataCon, tcLookupId )
-import TcMType ( newTyVarTy, arityErr )
-import TcType ( TcType, TcTyVar, TcSigmaType, TyVarDetails(..), mkClassPred )
+import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
+import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv,
+ tcLookupClass, tcLookupDataCon, tcLookupId )
+import TcMType ( newTyFlexiVarTy, arityErr, tcSkolTyVars, isRigidType )
+import TcType ( TcType, TcTyVar, TcSigmaType, TcTauType, zipTopTvSubst,
+ SkolemInfo(PatSkol), isSkolemTyVar, pprSkolemTyVar,
+ mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy )
import Kind ( argTypeKind, liftedTypeKind )
-import TcUnify ( tcSubOff, Expected(..), readExpectedType, zapExpectedType,
- unifyTauTy, zapToListTy, zapToPArrTy, zapToTupleTy )
-import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
-
-import TysWiredIn ( stringTy )
+import TcUnify ( tcSubPat, Expected(..), zapExpectedType,
+ zapExpectedTo, zapToListTy, zapToTyConApp )
+import TcHsType ( UserTypeCtxt(..), TcSigInfo( sig_tau ), TcSigFun, tcHsPatSigType )
+import TysWiredIn ( stringTy, parrTyCon, tupleTyCon )
+import Unify ( MaybeErr(..), tcRefineTys, tcMatchTys )
+import Type ( substTys, substTheta )
import CmdLineOpts ( opt_IrrefutableTuples )
-import DataCon ( DataCon, dataConFieldLabels, dataConSourceArity )
+import TyCon ( TyCon )
+import DataCon ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys,
+ dataConFieldLabels, dataConSourceArity, dataConSig )
import PrelNames ( eqStringName, eqName, geName, negateName, minusName,
integralClassName )
import BasicTypes ( isBoxed )
-import SrcLoc ( Located(..), noLoc, unLoc, noLoc )
-import Bag
+import SrcLoc ( Located(..), noLoc, unLoc )
+import ErrUtils ( Message )
import Outputable
import FastString
\end{code}
%************************************************************************
%* *
-\subsection{Variable patterns}
+ External interface
%* *
%************************************************************************
+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}
-type BinderChecker = Name -> Expected TcSigmaType -> TcM (PatCoFn, TcId)
- -- How to construct a suitable (monomorphic)
- -- Id for variables found in the pattern
- -- The TcSigmaType is the expected type
- -- from the pattern context
-
--- The Id may have a sigma type (e.g. f (x::forall a. a->a))
--- so we want to *create* it during pattern type checking.
--- We don't want to make Ids first with a type-variable type
--- and then unify... becuase we can't unify a sigma type with a type variable.
-
-tcMonoPatBndr :: BinderChecker
- -- This is the right function to pass to tcPat when
- -- we're looking at a lambda-bound pattern,
- -- so there's no polymorphic guy to worry about
-
-tcMonoPatBndr binder_name pat_ty
- = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' ->
- -- If there are *no constraints* on the pattern type, we
- -- revert to good old H-M typechecking, making
- -- the type of the binder into an *ordinary*
- -- type variable. We find out if there are no constraints
- -- by seeing if we are given an "open hole" as our info.
- -- What we are trying to avoid here is giving a binder
- -- a type that is a 'hole'. The only place holes should
- -- appear is as an argument to tcPat and tcExpr/tcMonoExpr.
-
- returnM (idCoercion, mkLocalId binder_name pat_ty')
+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 pat exp_ty thing_inside
+ = do { err_ctxt <- getErrCtxt
+ ; maybeAddErrCtxt (patCtxt (unLoc pat)) $
+ tc_lpat ctxt pat exp_ty $
+ setErrCtxt err_ctxt thing_inside }
+ -- Restore error context before doing thing_inside
+ -- See note [Nesting] above
+
+--------------------
+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
\end{code}
%************************************************************************
%* *
-\subsection{Typechecking patterns}
+ Binders
%* *
%************************************************************************
\begin{code}
-tcPat :: BinderChecker
- -> LPat Name
-
- -> Expected TcSigmaType -- Expected type derived from the context
- -- In the case of a function with a rank-2 signature,
- -- this type might be a forall type.
-
- -> TcM (LPat TcId,
- Bag TcTyVar, -- TyVars bound by the pattern
- -- These are just the existentially-bound ones.
- -- Any tyvars bound by *type signatures* in the
- -- patterns are brought into scope before we begin.
- Bag (Name, TcId), -- Ids bound by the pattern, along with the Name under
- -- which it occurs in the pattern
- -- The two aren't the same because we conjure up a new
- -- local name for each variable.
- [Inst]) -- Dicts or methods [see below] bound by the pattern
- -- from existential constructor patterns
-tcPat tc_bndr (L span pat) exp_ty
- = addSrcSpan span $
- do { (pat', tvs, ids, lie) <- tc_pat tc_bndr pat exp_ty
- ; return (L span pat', tvs, ids, lie) }
+data PatCtxt = LamPat Bool | LetPat TcSigFun
+ -- True <=> we are checking the case expression,
+ -- so can do full-blown refinement
+ -- False <=> inferring, do no refinement
+
+-------------------
+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 the SigmaType: we can get
+ -- 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
+ ; return (mkLocalId mono_name mono_ty) }
+
+ | otherwise
+ = do { mono_name <- newLocalName bndr_name
+ ; pat_ty' <- zapExpectedType pat_ty argTypeKind
+ ; return (mkLocalId mono_name pat_ty') }
+
+
+-------------------
+bindInstsOfPatId :: TcId -> TcM a -> TcM (a, LHsBinds TcId)
+bindInstsOfPatId id thing_inside
+ | not (isOverloadedTy (idType id))
+ = do { res <- thing_inside; return (res, emptyLHsBinds) }
+ | otherwise
+ = do { (res, lie) <- getLIE thing_inside
+ ; binds <- bindInstsOfLocalFuns lie [id]
+ ; return (res, binds) }
\end{code}
%************************************************************************
%* *
-\subsection{Variables, wildcards, lazy pats, as-pats}
+ tc_pat: the main worker function
%* *
%************************************************************************
\begin{code}
-tc_pat tc_bndr pat@(TypePat ty) pat_ty
- = failWithTc (badTypePat pat)
-
-tc_pat tc_bndr (VarPat name) pat_ty
- = tc_bndr name pat_ty `thenM` \ (co_fn, bndr_id) ->
- returnM (co_fn <$> VarPat bndr_id,
- emptyBag, unitBag (name, bndr_id), [])
-
-tc_pat tc_bndr (LazyPat pat) pat_ty
- = tcPat tc_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
- returnM (LazyPat pat', tvs, ids, lie_avail)
-
-tc_pat tc_bndr pat_in@(AsPat (L nm_loc name) pat) pat_ty
- = addSrcSpan nm_loc (tc_bndr name pat_ty) `thenM` \ (co_fn, bndr_id) ->
- tcPat tc_bndr pat (Check (idType bndr_id)) `thenM` \ (pat', tvs, ids, lie_avail) ->
- -- NB: if we have:
- -- \ (y@(x::forall a. a->a)) = e
- -- we'll fail. The as-pattern infers a monotype for 'y', which then
- -- fails to unify with the polymorphic type for 'x'. This could be
- -- fixed, but only with a bit more work.
- returnM (co_fn <$> (AsPat (L nm_loc bndr_id) pat'),
- tvs, (name, bndr_id) `consBag` ids, lie_avail)
-
-tc_pat tc_bndr (WildPat _) pat_ty
- = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' ->
- -- We might have an incoming 'hole' type variable; no annotation
- -- so zap it to a type. Rather like tcMonoPatBndr.
+tc_lpat :: PatCtxt
+ -> LPat Name -> Expected TcSigmaType
+ -> TcM a -- Thing inside
+ -> TcM (LPat TcId, -- Translated pattern
+ [TcTyVar], -- Existential binders
+ a) -- Result of thing inside
+
+tc_lpat ctxt (L span pat) pat_ty thing_inside
+ = setSrcSpan span $
+ -- It's OK to keep setting the SrcSpan;
+ -- it just overwrites the previous value
+ do { (pat', tvs, res) <- tc_pat ctxt pat pat_ty thing_inside
+ ; return (L span pat', tvs, res) }
+
+---------------------
+tc_pat ctxt (VarPat name) pat_ty thing_inside
+ = do { id <- tcPatBndr ctxt name pat_ty
+ ; (res, binds) <- bindInstsOfPatId id $
+ tcExtendIdEnv1 name id $
+ (traceTc (text "binding" <+> ppr name <+> ppr (idType id))
+ >> thing_inside)
+ ; 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) <- tc_lpat ctxt pat pat_ty thing_inside
+ ; return (ParPat pat', tvs, res) }
+
+-- There's a wrinkle with irrefuatable patterns, namely that we
+-- must not propagate type refinement from them. For example
+-- data T a where { T1 :: Int -> T Int; ... }
+-- f :: T a -> Int -> a
+-- f ~(T1 i) y = y
+-- It's obviously not sound to refine a to Int in the right
+-- hand side, because the arugment might not match T1 at all!
+--
+-- 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) <- tc_lpat ctxt pat pat_ty $
+ setTypeRefinement reft thing_inside
+ ; 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
-- (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...
- returnM (WildPat pat_ty', emptyBag, emptyBag, [])
-
-tc_pat tc_bndr (ParPat parend_pat) pat_ty
--- Leave the parens in, so that warnings from the
--- desugarer have parens in them
- = tcPat tc_bndr parend_pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
- returnM (ParPat pat', tvs, ids, lie_avail)
-
-tc_pat tc_bndr pat_in@(SigPatIn pat sig) pat_ty
- = addErrCtxt (patCtxt pat_in) $
- tcHsSigType PatSigCtxt sig `thenM` \ sig_ty ->
- tcSubPat sig_ty pat_ty `thenM` \ co_fn ->
- tcPat tc_bndr pat (Check sig_ty) `thenM` \ (pat', tvs, ids, lie_avail) ->
- returnM (co_fn <$> unLoc pat', tvs, ids, lie_avail)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Explicit lists, parallel arrays, and tuples}
-%* *
-%************************************************************************
-
-\begin{code}
-tc_pat tc_bndr pat_in@(ListPat pats _) pat_ty
- = addErrCtxt (patCtxt pat_in) $
- zapToListTy pat_ty `thenM` \ elem_ty ->
- tcPats tc_bndr pats (repeat elem_ty) `thenM` \ (pats', tvs, ids, lie_avail) ->
- returnM (ListPat pats' elem_ty, tvs, ids, lie_avail)
-
-tc_pat tc_bndr pat_in@(PArrPat pats _) pat_ty
- = addErrCtxt (patCtxt pat_in) $
- zapToPArrTy pat_ty `thenM` \ elem_ty ->
- tcPats tc_bndr pats (repeat elem_ty) `thenM` \ (pats', tvs, ids, lie_avail) ->
- returnM (PArrPat pats' elem_ty, tvs, ids, lie_avail)
+ ; res <- thing_inside
+ ; 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)
+ ; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $
+ tc_lpat ctxt pat (Check (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
+ -- fails to unify with the polymorphic type for 'x'. This could
+ -- perhaps be fixed, but only with a bit more work.
+ --
+ -- 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
+ ; (pat', tvs, res) <- tcExtendTyVarEnv sig_tvs $
+ tc_lpat ctxt pat (Check sig_ty) thing_inside
+ ; return (SigPatOut pat' sig_ty, tvs, res) }
+
+tc_pat ctxt pat@(TypePat ty) pat_ty thing_inside
+ = failWithTc (badTypePat pat)
-tc_pat tc_bndr pat_in@(TuplePat pats boxity) pat_ty
- = addErrCtxt (patCtxt pat_in) $
+------------------------
+-- 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) }
- zapToTupleTy boxity arity pat_ty `thenM` \ arg_tys ->
- tcPats tc_bndr pats arg_tys `thenM` \ (pats', tvs, ids, lie_avail) ->
+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) }
- -- possibly do the "make all tuple-pats irrefutable" test:
- let
- unmangled_result = TuplePat pats' boxity
+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
-- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
-- so that we can experiment with lazy tuple-matching.
-- This is a pretty odd place to make the switch, but
-- it was easy to do.
-
- possibly_mangled_result
- | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result)
- | otherwise = unmangled_result
- in
- returnM (possibly_mangled_result, tvs, ids, lie_avail)
- where
- arity = length pats
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Other constructors}
-%* *
-
-%************************************************************************
-
-\begin{code}
-tc_pat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty
- = addErrCtxt (patCtxt pat_in) $
-
- -- Check that it's a constructor, and instantiate it
- tcLookupLocatedDataCon con_name `thenM` \ data_con ->
- tcInstDataCon (PatOrigin pat_in) ExistTv data_con `thenM` \ (_, ex_dicts1, arg_tys, con_res_ty, ex_tvs) ->
-
- -- Check overall type matches.
- -- The pat_ty might be a for-all type, in which
- -- case we must instantiate to match
- tcSubPat con_res_ty pat_ty `thenM` \ co_fn ->
-
- -- Check the argument patterns
- tcConStuff tc_bndr data_con arg_pats arg_tys `thenM` \ (arg_pats', arg_tvs, arg_ids, ex_dicts2) ->
-
- returnM (co_fn <$> ConPatOut data_con arg_pats' con_res_ty ex_tvs (map instToId ex_dicts1),
- listToBag ex_tvs `unionBags` arg_tvs,
- arg_ids,
- ex_dicts1 ++ ex_dicts2)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Literals}
-%* *
-%************************************************************************
-
-\begin{code}
-tc_pat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty
- = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' ->
- unifyTauTy pat_ty' stringTy `thenM_`
- tcLookupId eqStringName `thenM` \ eq_id ->
- returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit),
- emptyBag, emptyBag, [])
-
-tc_pat tc_bndr (LitPat simple_lit) pat_ty
- = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' ->
- unifyTauTy pat_ty' (hsLitType simple_lit) `thenM_`
- returnM (LitPat simple_lit, emptyBag, emptyBag, [])
-
-tc_pat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
- = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' ->
- newOverloadedLit origin over_lit pat_ty' `thenM` \ pos_lit_expr ->
- newMethodFromName origin pat_ty' eqName `thenM` \ eq ->
- (case mb_neg of
- Nothing -> returnM pos_lit_expr -- Positive literal
- Just neg -> -- Negative literal
- -- The 'negate' is re-mappable syntax
- tcSyntaxName origin pat_ty' (negateName, HsVar neg) `thenM` \ (_, neg_expr) ->
- returnM (mkHsApp (noLoc neg_expr) pos_lit_expr)
- ) `thenM` \ lit_expr ->
-
- let
- -- The literal in an NPatIn is always positive...
- -- But in NPat, the literal is used to find identical patterns
- -- so we must negate the literal when necessary!
- lit' = case (over_lit, mb_neg) of
- (HsIntegral i _, Nothing) -> HsInteger i pat_ty'
- (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty'
- (HsFractional f _, Nothing) -> HsRat f pat_ty'
- (HsFractional f _, Just _) -> HsRat (-f) pat_ty'
- in
- returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr),
- emptyBag, emptyBag, [])
- where
- origin = PatOrigin pat
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{n+k patterns}
-%* *
-%************************************************************************
-
-\begin{code}
-tc_pat tc_bndr pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty
- = addSrcSpan nm_loc (tc_bndr name pat_ty) `thenM` \ (co_fn, bndr_id) ->
- let
- pat_ty' = idType bndr_id
- in
- newOverloadedLit origin lit pat_ty' `thenM` \ over_lit_expr ->
- newMethodFromName origin pat_ty' geName `thenM` \ ge ->
+ ; let unmangled_result = TuplePat pats' boxity
+ possibly_mangled_result
+ | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result)
+ | otherwise = unmangled_result
+
+ ; ASSERT( length arg_tys == arity ) -- 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
+ = do { data_con <- tcLookupDataCon con_name
+ ; let tycon = dataConTyCon data_con
+ ; ty_args <- zapToTyConApp tycon pat_ty
+ ; (pat', tvs, res) <- tcConPat ctxt data_con tycon ty_args arg_pats thing_inside
+ ; return (pat', tvs, res) }
+
+
+------------------------
+-- Literal patterns
+tc_pat ctxt pat@(LitPat lit@(HsString _)) pat_ty thing_inside
+ = do { -- Strings are mapped to NPatOuts, which have a guard expression
+ zapExpectedTo pat_ty stringTy
+ ; eq_id <- tcLookupId eqStringName
+ ; res <- thing_inside
+ ; returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit), [], res) }
+
+tc_pat ctxt (LitPat simple_lit) pat_ty thing_inside
+ = do { -- All other simple lits
+ zapExpectedTo pat_ty (hsLitType simple_lit)
+ ; res <- thing_inside
+ ; returnM (LitPat simple_lit, [], res) }
+
+------------------------
+-- Overloaded patterns: n, and n+k
+tc_pat ctxt pat@(NPatIn over_lit mb_neg) pat_ty thing_inside
+ = do { pat_ty' <- zapExpectedType pat_ty liftedTypeKind
+ ; let origin = LiteralOrigin over_lit
+ ; pos_lit_expr <- newOverloadedLit origin over_lit pat_ty'
+ ; eq <- newMethodFromName origin pat_ty' eqName
+ ; lit_expr <- case mb_neg of
+ Nothing -> returnM pos_lit_expr -- Positive literal
+ Just neg -> -- Negative literal
+ -- The 'negate' is re-mappable syntax
+ do { (_, neg_expr) <- tcSyntaxName origin pat_ty'
+ (negateName, HsVar neg)
+ ; returnM (mkHsApp (noLoc neg_expr) pos_lit_expr) }
+
+ ; let -- The literal in an NPatIn is always positive...
+ -- But in NPatOut, the literal is used to find identical patterns
+ -- so we must negate the literal when necessary!
+ lit' = case (over_lit, mb_neg) of
+ (HsIntegral i _, Nothing) -> HsInteger i pat_ty'
+ (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty'
+ (HsFractional f _, Nothing) -> HsRat f pat_ty'
+ (HsFractional f _, Just _) -> HsRat (-f) pat_ty'
+
+ ; res <- thing_inside
+ ; returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr), [], res) }
+
+tc_pat ctxt pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty thing_inside
+ = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty)
+ ; let pat_ty' = idType bndr_id
+ origin = LiteralOrigin lit
+ ; over_lit_expr <- newOverloadedLit origin lit pat_ty'
+ ; ge <- newMethodFromName origin pat_ty' geName
-- The '-' part is re-mappable syntax
- tcSyntaxName origin pat_ty' (minusName, HsVar minus_name) `thenM` \ (_, minus_expr) ->
+ ; (_, minus_expr) <- tcSyntaxName origin pat_ty' (minusName, HsVar minus_name)
-- The Report says that n+k patterns must be in Integral
-- We may not want this when using re-mappable syntax, though (ToDo?)
- tcLookupClass integralClassName `thenM` \ icls ->
- newDicts origin [mkClassPred icls [pat_ty']] `thenM` \ dicts ->
- extendLIEs dicts `thenM_`
+ ; icls <- tcLookupClass integralClassName
+ ; dicts <- newDicts origin [mkClassPred icls [pat_ty']]
+ ; extendLIEs dicts
- returnM (NPlusKPatOut (L nm_loc bndr_id) i
- (SectionR (nlHsVar ge) over_lit_expr)
- (SectionR (noLoc minus_expr) over_lit_expr),
- emptyBag, unitBag (name, bndr_id), [])
- where
- origin = PatOrigin pat
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Lists of patterns}
-%* *
-%************************************************************************
-
-Helper functions
-
-\begin{code}
-tcPats :: BinderChecker -- How to deal with variables
- -> [LPat Name] -> [TcType] -- Excess 'expected types' discarded
- -> TcM ([LPat TcId],
- Bag TcTyVar,
- Bag (Name, TcId), -- Ids bound by the pattern
- [Inst]) -- Dicts bound by the pattern
-
-tcPats tc_bndr [] tys = returnM ([], emptyBag, emptyBag, [])
-
-tcPats tc_bndr (pat:pats) (ty:tys)
- = tcPat tc_bndr pat (Check ty) `thenM` \ (pat', tvs1, ids1, lie_avail1) ->
- tcPats tc_bndr pats tys `thenM` \ (pats', tvs2, ids2, lie_avail2) ->
-
- returnM (pat':pats',
- tvs1 `unionBags` tvs2, ids1 `unionBags` ids2,
- lie_avail1 ++ lie_avail2)
+ ; res <- tcExtendIdEnv1 name bndr_id thing_inside
+ ; returnM (NPlusKPatOut (L nm_loc bndr_id) i
+ (SectionR (nlHsVar ge) over_lit_expr)
+ (SectionR (noLoc minus_expr) over_lit_expr),
+ [], res) }
\end{code}
%************************************************************************
%* *
-\subsection{Constructor arguments}
+ Most of the work for constructors is here
+ (the rest is in the ConPatIn case of tc_pat)
%* *
%************************************************************************
\begin{code}
-tcConStuff tc_bndr data_con (PrefixCon arg_pats) arg_tys
- = -- Check correct arity
- checkTc (con_arity == no_of_args)
- (arityErr "Constructor" data_con con_arity no_of_args) `thenM_`
-
- -- Check arguments
- tcPats tc_bndr arg_pats arg_tys `thenM` \ (arg_pats', tvs, ids, lie_avail) ->
-
- returnM (PrefixCon arg_pats', tvs, ids, lie_avail)
+tcConPat :: PatCtxt -> DataCon -> TyCon -> [TcTauType]
+ -> HsConDetails Name (LPat Name) -> TcM a
+ -> TcM (Pat TcId, [TcTyVar], a)
+tcConPat ctxt data_con tycon ty_args arg_pats thing_inside
+ | isVanillaDataCon data_con
+ = do { let arg_tys = dataConInstOrigArgTys data_con ty_args
+ ; 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 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
+ ; 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'
+ ; tcInstStupidTheta data_con tv_tys'
+
+ -- Do type refinement!
+ ; traceTc (text "tcGadtPat" <+> vcat [ppr data_con, ppr tvs', ppr arg_tys', ppr res_tys',
+ text "ty-args:" <+> ppr ty_args ])
+ ; refineAlt ctxt data_con tvs' ty_args res_tys' $ do
+
+ { ((arg_pats', inner_tvs, res), lie_req)
+ <- getLIE (tcConArgs ctxt data_con arg_pats arg_tys' thing_inside)
+
+ ; dict_binds <- tcSimplifyCheck doc tvs' dicts lie_req
+
+ ; return (ConPatOut data_con
+ tvs' (map instToId dicts) dict_binds
+ arg_pats' (mkTyConApp tycon ty_args),
+ tvs' ++ inner_tvs, res) } }
+ where
+ doc = ptext SLIT("existential context for") <+> quotes (ppr data_con)
+
+tcConArgs :: PatCtxt -> DataCon
+ -> HsConDetails Name (LPat Name) -> [TcSigmaType]
+ -> TcM a
+ -> TcM (HsConDetails TcId (LPat Id), [TcTyVar], a)
+
+tcConArgs ctxt 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
+ ; return (PrefixCon arg_pats', tvs, res) }
where
con_arity = dataConSourceArity data_con
no_of_args = length arg_pats
-tcConStuff tc_bndr data_con (InfixCon p1 p2) arg_tys
- = -- Check correct arity
- checkTc (con_arity == 2)
- (arityErr "Constructor" data_con con_arity 2) `thenM_`
-
- -- Check arguments
- tcPat tc_bndr p1 (Check ty1) `thenM` \ (p1', tvs1, ids1, lie_avail1) ->
- tcPat tc_bndr p2 (Check ty2) `thenM` \ (p2', tvs2, ids2, lie_avail2) ->
-
- returnM (InfixCon p1' p2',
- tvs1 `unionBags` tvs2, ids1 `unionBags` ids2,
- lie_avail1 ++ lie_avail2)
+tcConArgs ctxt 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
+ ; return (InfixCon p1' p2', tvs, res) }
where
con_arity = dataConSourceArity data_con
- [ty1, ty2] = arg_tys
-
-tcConStuff tc_bndr data_con (RecCon rpats) arg_tys
- = -- Check the fields
- tc_fields field_tys rpats `thenM` \ (rpats', tvs, ids, lie_avail) ->
- returnM (RecCon rpats', tvs, ids, lie_avail)
+tcConArgs ctxt data_con (RecCon rpats) arg_tys thing_inside
+ = do { (rpats', tvs, res) <- tc_fields rpats thing_inside
+ ; return (RecCon rpats', tvs, res) }
where
- field_tys = zip (map fieldLabelName (dataConFieldLabels data_con)) arg_tys
- -- Don't use zipEqual! If the constructor isn't really a record, then
- -- dataConFieldLabels will be empty (and each field in the pattern
- -- will generate an error below).
+ tc_fields :: [(Located Name, LPat Name)] -> TcM a
+ -> TcM ([(Located TcId, LPat TcId)], [TcTyVar], a)
+ tc_fields [] thing_inside
+ = do { res <- thing_inside
+ ; return ([], [], res) }
- tc_fields field_tys []
- = returnM ([], emptyBag, emptyBag, [])
+ tc_fields (rpat : rpats) thing_inside
+ = do { (rpat', tvs1, (rpats', tvs2, res))
+ <- tc_field rpat (tc_fields rpats thing_inside)
+ ; return (rpat':rpats', tvs1 ++ tvs2, res) }
- tc_fields field_tys ((L lbl_loc field_label, rhs_pat) : rpats)
- = tc_fields field_tys rpats `thenM` \ (rpats', tvs1, ids1, lie_avail1) ->
+ tc_field (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
+ ; return ((sel_id, pat'), tvs, res) }
- (case [ty | (f,ty) <- field_tys, f == field_label] of
+ find_field_ty field_lbl
+ = case [ty | (f,ty) <- field_tys, f == field_lbl] of
-- No matching field; chances are this field label comes from some
-- other record type (or maybe none). As well as reporting an
-- f (R { foo = (a,b) }) = a+b
-- If foo isn't one of R's fields, we don't want to crash when
-- typechecking the "a+b".
- [] -> addErrTc (badFieldCon data_con field_label) `thenM_`
- newTyVarTy liftedTypeKind `thenM` \ bogus_ty ->
- returnM (error "Bogus selector Id", bogus_ty)
+ [] -> do { addErrTc (badFieldCon data_con field_lbl)
+ ; bogus_ty <- newTyFlexiVarTy liftedTypeKind
+ ; return (error "Bogus selector Id", bogus_ty) }
-- The normal case, when the field comes from the right constructor
(pat_ty : extras) ->
ASSERT( null extras )
- addSrcSpan lbl_loc (tcLookupId field_label) `thenM` \ sel_id ->
- returnM (sel_id, pat_ty)
- ) `thenM` \ (sel_id, pat_ty) ->
+ do { sel_id <- tcLookupId field_lbl
+ ; return (sel_id, pat_ty) }
- tcPat tc_bndr rhs_pat (Check pat_ty) `thenM` \ (rhs_pat', tvs2, ids2, lie_avail2) ->
-
- returnM ((L lbl_loc sel_id, rhs_pat') : rpats',
- tvs1 `unionBags` tvs2,
- ids1 `unionBags` ids2,
- lie_avail1 ++ lie_avail2)
+ field_tys = zip (dataConFieldLabels data_con) arg_tys
+ -- Don't use zipEqual! If the constructor isn't really a record, then
+ -- dataConFieldLabels will be empty (and each field in the pattern
+ -- will generate an error below).
\end{code}
%************************************************************************
%* *
-\subsection{Subsumption}
+ Type refinement
%* *
%************************************************************************
-Example:
- f :: (forall a. a->a) -> Int -> Int
- f (g::Int->Int) y = g y
-This is ok: the type signature allows fewer callers than
-the (more general) signature f :: (Int->Int) -> Int -> Int
-I.e. (forall a. a->a) <= Int -> Int
-We end up translating this to:
- f = \g' :: (forall a. a->a). let g = g' Int in g' y
-
-tcSubPat does the work
- sig_ty is the signature on the pattern itself
- (Int->Int in the example)
- expected_ty is the type passed inwards from the context
- (forall a. a->a in the example)
-
\begin{code}
-tcSubPat :: TcSigmaType -> Expected TcSigmaType -> TcM PatCoFn
-
-tcSubPat sig_ty exp_ty
- = tcSubOff sig_ty exp_ty `thenM` \ co_fn ->
- -- co_fn is a coercion on *expressions*, and we
- -- need to make a coercion on *patterns*
- if isIdCoercion co_fn then
- returnM idCoercion
- else
- newUnique `thenM` \ uniq ->
- readExpectedType exp_ty `thenM` \ exp_ty' ->
- let
- arg_id = mkSysLocal FSLIT("sub") uniq exp_ty'
- the_fn = DictLam [arg_id] (noLoc (co_fn <$> HsVar arg_id))
- pat_co_fn p = SigPatOut (noLoc p) exp_ty' the_fn
- in
- returnM (mkCoercion pat_co_fn)
+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
+ ; let refiner | can_i_refine ctxt = tcRefineTys
+ | otherwise = tcMatchTys
+ ; case refiner ex_tvs 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
+ can_i_refine (LamPat can_refine) = can_refine
+ can_i_refine other_ctxt = False
\end{code}
+%************************************************************************
+%* *
+ Note [Pattern coercions]
+%* *
+%************************************************************************
+
+In principle, these program would be reasonable:
+
+ f :: (forall a. a->a) -> Int
+ f (x :: Int->Int) = x 3
+
+ g :: (forall a. [a]) -> Bool
+ g [] = True
+
+In both cases, the function type signature restricts what arguments can be passed
+in a call (to polymorphic ones). The pattern type signature then instantiates this
+type. For example, in the first case, (forall a. a->a) <= Int -> Int, and we
+generate the translated term
+ f = \x' :: (forall a. a->a). let x = x' Int in x 3
+
+From a type-system point of view, this is perfectly fine, but it's *very* seldom useful.
+And it requires a significant amount of code to implement, becuase we need to decorate
+the translated pattern with coercion functions (generated from the subsumption check
+by tcSub).
+
+So for now I'm just insisting on type *equality* in patterns. No subsumption.
+
+Old notes about desugaring, at a time when pattern coercions were handled:
+
+A SigPat is a type coercion and must be handled one at at time. We can't
+combine them unless the type of the pattern inside is identical, and we don't
+bother to check for that. For example:
+
+ data T = T1 Int | T2 Bool
+ f :: (forall a. a -> a) -> T -> t
+ f (g::Int->Int) (T1 i) = T1 (g i)
+ f (g::Bool->Bool) (T2 b) = T2 (g b)
+
+We desugar this as follows:
+
+ f = \ g::(forall a. a->a) t::T ->
+ let gi = g Int
+ in case t of { T1 i -> T1 (gi i)
+ other ->
+ let gb = g Bool
+ in case t of { T2 b -> T2 (gb b)
+ other -> fail }}
+
+Note that we do not treat the first column of patterns as a
+column of variables, because the coerced variables (gi, gb)
+would be of different types. So we get rather grotty code.
+But I don't think this is a common case, and if it was we could
+doubtless improve it.
+
+Meanwhile, the strategy is:
+ * treat each SigPat coercion (always non-identity coercions)
+ as a separate block
+ * deal with the stuff inside, and then wrap a binding round
+ the result to bind the new variable (gi, gb, etc)
+
%************************************************************************
%* *
%************************************************************************
\begin{code}
-patCtxt pat = hang (ptext SLIT("When checking the pattern:"))
- 4 (ppr pat)
+patCtxt :: Pat Name -> Maybe Message -- Not all patterns are worth pushing a context
+patCtxt (VarPat _) = Nothing
+patCtxt (ParPat _) = Nothing
+patCtxt (AsPat _ _) = Nothing
+patCtxt pat = Just (hang (ptext SLIT("When checking the pattern:"))
+ 4 (ppr pat))
badFieldCon :: DataCon -> Name -> SDoc
badFieldCon con field
4 (ppr sig_ty)
badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
-\end{code}
+lazyPatErr pat tvs
+ = failWithTc $
+ hang (ptext SLIT("A lazy (~) pattern connot bind existential type variables"))
+ 2 (vcat (map get tvs))
+ where
+ get tv = ASSERT( isSkolemTyVar tv ) pprSkolemTyVar tv
+
+inaccessibleAlt msg
+ = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg
+\end{code}
import TcHsSyn ( zonkTopDecls )
import TcExpr ( tcInferRho )
import TcRnMonad
-import TcType ( tidyTopType, isUnLiftedType )
+import TcType ( tidyTopType )
import Inst ( showLIE )
import TcBinds ( tcTopBinds )
import TcDefaults ( tcDefaults )
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcIface ( tcExtCoreBindings, loadImportedInsts )
+import TcIface ( tcExtCoreBindings )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules )
import Var ( Var )
import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts )
import OccName ( mkVarOcc )
-import Name ( Name, isExternalName, getSrcLoc, getOccName, nameSrcLoc )
+import Name ( Name, isExternalName, getSrcLoc, getOccName )
import NameSet
import TyCon ( tyConHasGenerics )
-import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc )
+import SrcLoc ( srcLocSpan, Located(..), noLoc )
import Outputable
-import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ),
- GhciMode(..), isOneShot, Dependencies(..), noDependencies,
+import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
+ GhciMode(..), noDependencies, isOneShot,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TypeEnv,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
)
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
- LStmt, LHsExpr, LHsType,
+ LStmt, LHsExpr, LHsType, mkMatchGroup,
collectStmtsBinders, mkSimpleMatch, placeHolderType,
nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
import TcHsType ( kcHsType )
import TcExpr ( tcCheckRho )
+import TcIface ( loadImportedInsts )
import TcMType ( zonkTcType )
+import TcUnify ( unifyTyConApp )
import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
-import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, tyClsNamesOfDFunHead )
+import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
+ isUnLiftedType, tyClsNamesOfDFunHead )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
import Inst ( tcStdSyntaxName, tcGetInstEnvs )
tyThingToIfaceDecl, dfunToIfaceInst )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( Id, isImplicitId, globalIdDetails )
-import FieldLabel ( fieldLabelTyCon )
import MkId ( unsafeCoerceId )
import DataCon ( dataConTyCon )
import TyCon ( tyConName )
import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ),
HomeModInfo(..), typeEnvElts, typeEnvClasses,
TyThing(..), availName, availNames, icPrintUnqual,
- ModIface(..), ModDetails(..) )
+ ModIface(..), ModDetails(..), Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Bag ( unitBag )
import ListSetOps ( removeDups )
import Panic ( ghcError, GhcException(..) )
+import SrcLoc ( SrcLoc )
#endif
import FastString ( mkFastString )
-- The normal case
initTc hsc_env this_mod $
- addSrcSpan loc $
+ setSrcSpan loc $
do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
{ let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
-- :Main.main :: IO () = runIO main
- ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
+ ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
tcInferRho rhs
; let { root_main_id = mkExportedLocalId rootMainName ty ;
let
fresh_it = itName uniq
the_bind = noLoc $ FunBind (noLoc fresh_it) False
- [ mkSimpleMatch [] expr placeHolderType ]
+ (mkMatchGroup [mkSimpleMatch [] expr])
in
tryTcLIE_ (do { -- Try this if the other fails
traceTc (text "tcs 1b") ;
names = map unLoc (collectStmtsBinders stmts) ;
stmt_ctxt = SC { sc_what = DoExpr,
- sc_rhs = check_rhs,
+ sc_rhs = infer_rhs,
sc_body = check_body,
sc_ty = ret_ty } ;
- check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
- check_body body = tcCheckRho body io_ret_ty ;
+ infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
+ ; return (rhs', pat_ty) } ;
+ check_body body = tcCheckRho body io_ret_ty ;
-- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
= decl { ifSigs = filter (keep_sig occs) sigs }
-filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
- = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
+filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons})
+ = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) }
filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
| keep_con occs con = decl
| otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
filter_decl occs decl
= decl
-keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
-keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs
+keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
+keep_con occs con = ifConOcc con `elem` occs
availOccs avail = map nameOccName (availNames avail)
-- munge transforms a thing to it's "parent" thing
munge (ADataCon dc) = ATyCon (dataConTyCon dc)
munge (AnId id) = case globalIdDetails id of
- RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
- ClassOpId cls -> AClass cls
- other -> AnId id
+ RecordSelId tc lbl -> ATyCon tc
+ ClassOpId cls -> AClass cls
+ other -> AnId id
munge other_thing = other_thing
#endif /* GHCI */
-\begin{code}
+ \begin{code}
module TcRnMonad(
module TcRnMonad,
module TcRnTypes,
import TcRnTypes -- Re-export all
import IOEnv -- Re-export all
+import HsSyn ( emptyLHsBinds )
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
- TyThing, Dependencies(..), TypeEnv, emptyTypeEnv,
+ TyThing, TypeEnv, emptyTypeEnv,
ExternalPackageState(..), HomePackageTable,
ModDetails(..), HomeModInfo(..),
Deprecs(..), FixityEnv, FixItem,
GhciMode, lookupType, unQualInScope )
-import Module ( Module, ModuleName, unitModuleEnv, foldModuleEnv, emptyModuleEnv )
+import Module ( Module, ModuleName, unitModuleEnv, foldModuleEnv )
import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv,
LocalRdrEnv, emptyLocalRdrEnv )
import Name ( Name, isInternalName )
import InstEnv ( InstEnv, emptyInstEnv, extendInstEnv )
import VarSet ( emptyVarSet )
-import VarEnv ( TidyEnv, emptyTidyEnv )
+import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv )
import ErrUtils ( Message, Messages, emptyMessages, errorsFound,
- mkErrMsg, mkWarnMsg, printErrorsAndWarnings,
+ mkWarnMsg, printErrorsAndWarnings,
mkLocMessage, mkLongErrMsg )
import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
import NameEnv ( emptyNameEnv )
tcg_exports = emptyNameSet,
tcg_imports = init_imports,
tcg_dus = emptyDUs,
- tcg_binds = emptyBag,
+ tcg_binds = emptyLHsBinds,
tcg_deprecs = NoDeprecs,
tcg_insts = [],
tcg_rules = [],
tcl_arrow_ctxt = topArrowCtxt,
tcl_env = emptyNameEnv,
tcl_tyvars = tvs_var,
- tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE
+ tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE
+ tcl_gadt = emptyVarEnv
} ;
} ;
-- Avoid clash with Name.getSrcLoc
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
-addSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-addSrcSpan loc thing_inside
+setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
+setSrcSpan loc thing_inside
| isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
| otherwise = thing_inside -- Don't overwrite useful info with useless
addLocM :: (a -> TcM b) -> Located a -> TcM b
-addLocM fn (L loc a) = addSrcSpan loc $ fn a
+addLocM fn (L loc a) = setSrcSpan loc $ fn a
wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
-wrapLocM fn (L loc a) = addSrcSpan loc $ do b <- fn a; return (L loc b)
+wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
- addSrcSpan loc $ do
+ setSrcSpan loc $ do
(b,c) <- fn a
return (L loc b, c)
wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
wrapLocSndM fn (L loc a) =
- addSrcSpan loc $ do
+ setSrcSpan loc $ do
(b,c) <- fn a
return (b, L loc c)
\end{code}
%************************************************************************
\begin{code}
-setErrCtxtM, addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
-setErrCtxtM msg = updCtxt (\ msgs -> [msg])
-addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
+getErrCtxt :: TcM ErrCtxt
+getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
-setErrCtxt, addErrCtxt :: Message -> TcM a -> TcM a
-setErrCtxt msg = setErrCtxtM (\env -> returnM (env, msg))
-addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
+setErrCtxt :: ErrCtxt -> TcM a -> TcM a
+setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
-popErrCtxt :: TcM a -> TcM a
-popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms })
+addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
+addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
-getErrCtxt :: TcM ErrCtxt
-getErrCtxt = do { env <- getLclEnv ; return (tcl_ctxt env) }
+addErrCtxt :: Message -> TcM a -> TcM a
+addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
-- Helper function for the above
updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
env { tcl_ctxt = upd ctxt })
+-- Conditionally add an error context
+maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
+maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
+maybeAddErrCtxt Nothing thing_inside = thing_inside
+
+popErrCtxt :: TcM a -> TcM a
+popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms })
+
getInstLoc :: InstOrigin -> TcM InstLoc
getInstLoc origin
= do { loc <- getSrcSpanM ; env <- getLclEnv ;
-- Add the SrcSpan and context from the first Inst in the list
-- (they all have similar locations)
addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
- = addSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
+ = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
\end{code}
The addErrTc functions add an error message, but do not cause failure.
| otherwise = take 3 ctxt
\end{code}
-%************************************************************************
+debugTc is useful for monadi debugging code
+
+\begin{code}
+debugTc :: TcM () -> TcM ()
+#ifdef DEBUG
+debugTc thing = thing
+#else
+debugTc thing = return ()
+#endif
+\end{code}
+
+ %************************************************************************
%* *
Type constraints (the so-called LIE)
%* *
Nothing -> pprPanic "forkM" doc
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(..),
+ TcTyThing(..), GadtRefinement,
-- Template Haskell
ThStage(..), topStage, topSpliceStage,
plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
-- Misc other types
- TcId, TcIdSet
+ TcId, TcIdSet, TcDictBinds
) where
#include "HsVersions.h"
-import HsSyn ( PendingSplice, HsOverLit, LHsBind, LRuleDecl, LForeignDecl,
- Pat, ArithSeqInfo )
+import HsSyn ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl,
+ ArithSeqInfo, DictBinds, LHsBinds )
import HscTypes ( FixityEnv,
HscEnv, TypeEnv, TyThing,
- Avails, GenAvailInfo(..), AvailInfo,
+ GenAvailInfo(..), AvailInfo,
availName, IsBootInterface, Deprecations )
import Packages ( PackageName )
-import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType,
+import Type ( Type, TvSubstEnv )
+import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, SkolemInfo,
TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes )
import InstEnv ( DFunId, InstEnv )
import IOEnv
import NameEnv
import NameSet ( NameSet, emptyNameSet, DefUses )
import OccName ( OccEnv )
-import Type ( Type )
-import Class ( Class )
import Var ( Id, TyVar )
import VarEnv ( TidyEnv )
import Module
The monad itself has to be defined here, because it is mentioned by ErrCtxt
\begin{code}
-type TcRef a = IORef a
-type TcId = Id -- Type may be a TcType
-type TcIdSet = IdSet
+type TcRef a = IORef a
+type TcId = Id -- Type may be a TcType
+type TcIdSet = IdSet
+type TcDictBinds = DictBinds TcId -- Bag of dictionary bindings
+
+
type TcRnIf a b c = IOEnv (Env a b) c
type IfM lcl a = TcRnIf IfGblEnv lcl a -- Iface stuff
-- The next fields accumulate the payload of the module
-- The binds, rules and foreign-decl fiels are collected
-- initially in un-zonked form and are finally zonked in tcRnSrcDecls
- tcg_binds :: Bag (LHsBind Id), -- Value bindings in this module
+ tcg_binds :: LHsBinds Id, -- Value bindings in this module
tcg_deprecs :: Deprecations, -- ...Deprecations
tcg_insts :: [DFunId], -- ...Instances
tcg_rules :: [LRuleDecl Id], -- ...Rules
-- We still need the unsullied global name env so that
-- we can look up record field names
- tcl_env :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
- -- defined in this module
+ tcl_env :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
+ -- defined in this module
+ tcl_gadt :: GadtRefinement, -- The current type refinement for GADTs
+
tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars"
-- Namely, the in-scope TyVars bound in tcl_lenv,
-- plus the tyvars mentioned in the types of Ids bound in tcl_lenv
tcl_lie :: TcRef LIE -- Place to accumulate type constraints
}
+type GadtRefinement = TvSubstEnv -- Binds rigid type variables to their refinements
+
+
---------------------------
-- Template Haskell levels
---------------------------
-- type of (f tys dicts(from theta)) = tau
-- INVARIANT 2: tau must not be of form (Pred -> Tau)
- -- Reason: two methods are considerd equal if the
+ -- Reason: two methods are considered equal if the
-- base Id matches, and the instantiating types
-- match. The TcThetaType should then match too.
-- This only bites in the call to tcInstClassOp in TcClassDcl.mkMethodBind
instLocSrcSpan (InstLoc _ src_span _) = src_span
data InstOrigin
- = OccurrenceOf Name -- Occurrence of an overloaded identifier
+ = SigOrigin SkolemInfo -- Pattern, class decl, inst decl etc;
+ -- Places that bind type variables and introduce
+ -- available constraints
- | IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter
| IPBindOrigin (IPName Name) -- Binding site of an implicit parameter
- | RecordUpdOrigin
-
- | DataDeclOrigin -- Typechecking a data declaration
+ -------------------------------------------------------
+ -- The rest are all occurrences: Insts that are 'wanted'
+ -------------------------------------------------------
+ | OccurrenceOf Name -- Occurrence of an overloaded identifier
- | InstanceDeclOrigin -- Typechecking an instance decl
+ | IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter
| LiteralOrigin HsOverLit -- Occurrence of a literal
- | PatOrigin (Pat Name)
-
| ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc
| PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:]
- | SignatureOrigin -- A dict created from a type signature
- | Rank2Origin -- A dict created when typechecking the argument
- -- of a rank-2 typed function
-
- | DoOrigin -- The monad for a do expression
- | ProcOrigin -- A proc expression
-
- | ClassDeclOrigin -- Manufactured during a class decl
-
- | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
- Type
+ | InstSigOrigin -- A dict occurrence arising from instantiating
+ -- a polymorphic type during a subsumption check
- -- When specialising instances the instance info attached to
- -- each class is not yet ready, so we record it inside the
- -- origin information. This is a bit of a hack, but it works
- -- fine. (Patrick is to blame [WDP].)
-
- | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
-
- -- Argument or result of a ccall
- -- Dictionaries with this origin aren't actually mentioned in the
- -- translated term, and so need not be bound. Nor should they
- -- be abstracted over.
-
- | UnknownOrigin -- Help! I give up...
+ | RecordUpdOrigin
+ | InstScOrigin -- Typechecking superclasses of an instance declaration
+ | DerivOrigin -- Typechecking deriving
+ | DefaultOrigin -- Typechecking a default decl
+ | DoOrigin -- Arising from a do expression
+ | ProcOrigin -- Arising from a proc expression
\end{code}
\begin{code}
pprInstLoc :: InstLoc -> SDoc
-pprInstLoc (InstLoc orig locn ctxt)
+pprInstLoc (InstLoc (SigOrigin info) locn _)
+ = text "arising from" <+> ppr info -- I don't think this happens much, if at all
+pprInstLoc (InstLoc orig locn _)
= hsep [text "arising from", pp_orig orig, text "at", ppr locn]
where
- pp_orig (OccurrenceOf name)
- = hsep [ptext SLIT("use of"), quotes (ppr name)]
- pp_orig (IPOccOrigin name)
- = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
- pp_orig (IPBindOrigin name)
- = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)]
- pp_orig RecordUpdOrigin
- = ptext SLIT("a record update")
- pp_orig DataDeclOrigin
- = ptext SLIT("the data type declaration")
- pp_orig InstanceDeclOrigin
- = ptext SLIT("the instance declaration")
- pp_orig (LiteralOrigin lit)
- = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
- pp_orig (PatOrigin pat)
- = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
- pp_orig (ArithSeqOrigin seq)
- = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
- pp_orig (PArrSeqOrigin seq)
- = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
- pp_orig (SignatureOrigin)
- = ptext SLIT("a type signature")
- pp_orig (Rank2Origin)
- = ptext SLIT("a function with an overloaded argument type")
- pp_orig (DoOrigin)
- = ptext SLIT("a do statement")
- pp_orig (ProcOrigin)
- = ptext SLIT("a proc expression")
- pp_orig (ClassDeclOrigin)
- = ptext SLIT("a class declaration")
- pp_orig (InstanceSpecOrigin clas ty)
- = hsep [text "a SPECIALIZE instance pragma; class",
- quotes (ppr clas), text "type:", ppr ty]
- pp_orig (ValSpecOrigin name)
- = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
- pp_orig (UnknownOrigin)
- = ptext SLIT("...oops -- I don't know where the overloading came from!")
+ pp_orig (OccurrenceOf name) = hsep [ptext SLIT("use of"), quotes (ppr name)]
+ pp_orig (IPOccOrigin name) = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
+ pp_orig (IPBindOrigin name) = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)]
+ pp_orig RecordUpdOrigin = ptext SLIT("a record update")
+ pp_orig (LiteralOrigin lit) = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
+ pp_orig (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
+ pp_orig (PArrSeqOrigin seq) = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
+ pp_orig InstSigOrigin = ptext SLIT("instantiating a type signature")
+ pp_orig InstScOrigin = ptext SLIT("the superclasses of an instance declaration")
+ pp_orig DerivOrigin = ptext SLIT("the 'deriving' clause of a data type declaration")
+ pp_orig DefaultOrigin = ptext SLIT("a 'default' declaration")
+ pp_orig DoOrigin = ptext SLIT("a do statement")
+ pp_orig ProcOrigin = ptext SLIT("a proc expression")
+ pp_orig (SigOrigin info) = ppr info
\end{code}
#include "HsVersions.h"
-import HsSyn ( RuleDecl(..), LRuleDecl, RuleBndr(..), collectRuleBndrSigTys, mkHsLet )
+import HsSyn ( RuleDecl(..), LRuleDecl, RuleBndr(..), mkHsLet )
import TcRnMonad
import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck )
-import TcMType ( newTyVarTy )
+import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar )
import TcType ( tyVarsOfTypes, openTypeKind )
-import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars )
+import TcHsType ( UserTypeCtxt(..), tcHsPatSigType )
import TcExpr ( tcCheckRho )
-import TcEnv ( tcExtendLocalValEnv )
+import TcEnv ( tcExtendIdEnv, tcExtendTyVarEnv )
import Inst ( instToId )
import Id ( idType, mkLocalId )
import Name ( Name )
= addErrCtxt (ruleCtxt name) $
traceTc (ptext SLIT("---- Rule ------")
<+> ppr name) `thenM_`
- newTyVarTy openTypeKind `thenM` \ rule_ty ->
+ newTyFlexiVarTy openTypeKind `thenM` \ rule_ty ->
-- Deal with the tyvars mentioned in signatures
- tcAddScopedTyVars (collectRuleBndrSigTys vars) (
-
- -- Ditto forall'd variables
- mappM new_id vars `thenM` \ ids ->
- tcExtendLocalValEnv ids $
-
+ 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) ->
-
returnM (ids, lhs', rhs', lhs_lie, rhs_lie)
) `thenM` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
tcSimplifyInferCheck (text "tcRule")
forall_tvs
lhs_dicts rhs_lie `thenM` \ (forall_tvs1, rhs_binds) ->
+ mappM zonkQuantifiedTyVar forall_tvs1 `thenM` \ forall_tvs2 ->
+ -- This zonk is exactly the same as the one in TcBinds.tcBindWithSigs
returnM (HsRule name act
- (map (RuleBndr . noLoc) (forall_tvs1 ++ tpl_ids)) -- yuk
+ (map (RuleBndr . noLoc) (forall_tvs2 ++ tpl_ids)) -- yuk
(mkHsLet lhs_binds lhs')
(mkHsLet rhs_binds rhs'))
where
- new_id (RuleBndr var) = newTyVarTy openTypeKind `thenM` \ ty ->
- returnM (mkLocalId (unLoc var) ty)
- new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt nl_var) rn_ty `thenM` \ ty ->
- returnM (mkLocalId nl_var ty)
- where
- nl_var = unLoc var
+
+tcRuleBndrs [] thing_inside = thing_inside []
+tcRuleBndrs (RuleBndr var : vars) thing_inside
+ = do { ty <- newTyFlexiVarTy 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 $
+ tcExtendIdEnv [id] $
+ tcRuleBndrs vars (\ids -> thing_inside (id:ids)) }
ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
doubleQuotes (ftext name)
import {-# SOURCE #-} TcUnify( unifyTauTy )
import TcEnv -- temp
-import HsSyn ( HsBind(..), LHsBinds, HsExpr(..), LHsExpr, pprLHsBinds )
+import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
import TcHsSyn ( TcId, TcDictBinds, mkHsApp, mkHsTyApp, mkHsDictApp )
import TcRnMonad
import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals )
import InstEnv ( lookupInstEnv, classInstances )
import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
-import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
- mkClassPred, isOverloadedTy, mkTyConApp,
+import TcType ( TcTyVar, TcTyVarSet, ThetaType,
+ mkClassPred, isOverloadedTy, mkTyConApp,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
tyVarsOfPred, tcEqType, pprPred )
import Id ( idType, mkUserLocal )
import PrelInfo ( isNumericClass )
import PrelNames ( splitName, fstName, sndName, integerTyConName,
showClassKey, eqClassKey, ordClassKey )
-import Subst ( mkTopTyVarSubst, substTheta, substTy )
+import Type ( zipTopTvSubst, substTheta, substTy )
import TysWiredIn ( pairTyCon, doubleTy )
import ErrUtils ( Message )
import VarSet
| isClassDict inst = DontReduceUnlessConstant -- Dicts
| otherwise = ReduceMe -- Lits and Methods
in
- traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_`
+ traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds,
+ ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_`
-- Step 2
reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
givens wanted_lie `thenM` \ (qtvs', binds) ->
returnM binds
where
- get_qtvs = zonkTcTyVarsAndFV qtvs
+-- get_qtvs = zonkTcTyVarsAndFV qtvs
+ get_qtvs = return (mkVarSet qtvs)
-- tcSimplifyInferCheck is used when we know the constraints we are to simplify
@LIE@), as well as the @HsBinds@ generated.
\begin{code}
-bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM (LHsBinds TcId)
+bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM TcDictBinds
+-- Simlifies only MethodInsts, and generate only bindings of form
+-- fm = f tys dicts
+-- We're careful not to even generate bindings of the form
+-- d1 = d2
+-- You'd think that'd be fine, but it interacts with what is
+-- arguably a bug in Match.tidyEqnInfo (see notes there)
bindInstsOfLocalFuns wanteds local_ids
| null overloaded_ids
-- Common case
= extendLIEs wanteds `thenM_`
- returnM emptyBag
+ returnM emptyLHsBinds
| otherwise
- = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) ->
+ = simpleReduceLoop doc try_me for_me `thenM` \ (frees, binds, irreds) ->
ASSERT( null irreds )
+ extendLIEs not_for_me `thenM_`
extendLIEs frees `thenM_`
returnM binds
where
doc = text "bindInsts" <+> ppr local_ids
overloaded_ids = filter is_overloaded local_ids
is_overloaded id = isOverloadedTy (idType id)
+ (for_me, not_for_me) = partition (isMethodFor overloaded_set) wanteds
overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
-- so it's worth building a set, so that
-- lookup (in isMethodFor) is faster
-
- try_me inst | isMethodFor overloaded_set inst = ReduceMe
- | otherwise = Free
+ try_me inst | isMethod inst = ReduceMe
+ | otherwise = Free
\end{code}
returnM False
where
unify ((qtvs, pairs), doc)
- = addErrCtxt doc $
- tcInstTyVars VanillaTv (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
+ = addErrCtxt doc $
+ tcInstTyVars (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
mapM_ (unif_pr tenv) pairs
unif_pr tenv (ty1,ty2) = unifyTauTy (substTy tenv ty1) (substTy tenv ty2)
\end{code}
where
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _) = classBigSig clas
- sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
+ sc_theta' = substTheta (zipTopTvSubst tyvars tys) sc_theta
add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
| add_me sc_dict = addSCs is_loop avails' sc_dict
-> TcM ThetaType -- Needed
tcSimplifyDeriv tyvars theta
- = tcInstTyVars VanillaTv tyvars `thenM` \ (tvs, _, tenv) ->
+ = tcInstTyVars tyvars `thenM` \ (tvs, _, tenv) ->
-- The main loop may do unification, and that may crash if
-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
-- ToDo: what if two of them do get unified?
- newDicts DataDeclOrigin (substTheta tenv theta) `thenM` \ wanteds ->
+ newDicts DerivOrigin (substTheta tenv theta) `thenM` \ wanteds ->
simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- reduceMe never returns Free
-- of problems; in particular, it's hard to compare solutions for
-- equality when finding the fixpoint. So I just rule it out for now.
- rev_env = mkTopTyVarSubst tvs (mkTyVarTys tyvars)
+ rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
-- This reverse-mapping is a Royal Pain,
-- but the result should mention TyVars not TcTyVars
in
-> TcM ()
tcSimplifyDefault theta
- = newDicts DataDeclOrigin theta `thenM` \ wanteds ->
+ = newDicts DefaultOrigin theta `thenM` \ wanteds ->
simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- try_me never returns Free
addNoInstanceErrs Nothing [] irreds `thenM_`
report :: [(Inst,[TcTyVar])] -> TcM ()
report pairs@((inst,tvs) : _) -- The pairs share a common set of ambiguous tyvars
= mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) ->
- addSrcSpan (instLocSrcSpan (instLoc inst)) $
+ setSrcSpan (instLocSrcSpan (instLoc inst)) $
-- the location of the first one will do for the err message
addErrTcM (tidy_env, msg $$ mono_msg)
where
import TcUnify ( Expected, zapExpectedTo, zapExpectedType )
import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
import TcEnv ( spliceOK, tcMetaTy, bracketOK )
-import TcMType ( newTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
+import TcMType ( newTyFlexiVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
import TcHsType ( tcHsSigType, kcHsType )
import TcIface ( tcImportDecl )
import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification
import TcRnMonad
import IfaceEnv ( lookupOrig )
import Class ( Class, classBigSig )
-import TyCon ( TyCon, tyConTheta, tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons )
+import TyCon ( TyCon, AlgTyConRhs(..), tyConTyVars, getSynTyConDefn,
+ isSynTyCon, isNewTyCon, tyConDataCons, algTcRhs )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks,
- dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix )
+ dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix,
+ isVanillaDataCon )
import Id ( idName, globalIdDetails )
import IdInfo ( GlobalIdDetails(..) )
import TysWiredIn ( mkListTy )
import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy
import Monad ( liftM )
+import Maybes ( orElse )
#ifdef GHCI
import FastString ( mkFastString )
-- Result type is Var (not Q-monadic)
tc_bracket (ExpBr expr)
- = newTyVarTy liftedTypeKind `thenM` \ any_ty ->
- tcCheckRho expr any_ty `thenM_`
+ = newTyFlexiVarTy liftedTypeKind `thenM` \ any_ty ->
+ tcCheckRho expr any_ty `thenM_`
tcMetaTy expQTyConName
-- Result type is Expr (= Q Exp)
\begin{code}
tcSpliceExpr (HsSplice name expr) res_ty
- = addSrcSpan (getLoc expr) $
+ = setSrcSpan (getLoc expr) $
getStage `thenM` \ level ->
case spliceOK level of {
Nothing -> failWithTc (illegalSplice level) ;
\begin{code}
kcSpliceType (HsSplice name hs_expr)
- = addSrcSpan (getLoc hs_expr) $ do
+ = setSrcSpan (getLoc hs_expr) $ do
{ level <- getStage
; case spliceOK level of {
Nothing -> failWithTc (illegalSplice level) ;
; rhs' <- reifyType rhs
; return (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
- | isNewTyCon tc
- = do { cxt <- reifyCxt (tyConTheta tc)
- ; con <- reifyDataCon (head (tyConDataCons tc))
- ; return (TH.NewtypeD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
- con [{- Don't know about deriving -}]) }
-
- | otherwise -- Algebraic
- = do { cxt <- reifyCxt (tyConTheta tc)
- ; cons <- mapM reifyDataCon (tyConDataCons tc)
- ; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
- cons [{- Don't know about deriving -}]) }
+reifyTyCon tc
+ = case algTcRhs tc of
+ NewTyCon data_con _ _
+ -> do { con <- reifyDataCon data_con
+ ; return (TH.NewtypeD [] (reifyName tc) (reifyTyVars (tyConTyVars tc))
+ con [{- Don't know about deriving -}]) }
+
+ DataTyCon mb_cxt cons _
+ -> do { cxt <- reifyCxt (mb_cxt `orElse` [])
+ ; cons <- mapM reifyDataCon (tyConDataCons tc)
+ ; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc))
+ cons [{- Don't know about deriving -}]) }
reifyDataCon :: DataCon -> TcM TH.Con
reifyDataCon dc
+ | isVanillaDataCon dc
= do { arg_tys <- reifyTypes (dataConOrigArgTys dc)
; let stricts = map reifyStrict (dataConStrictMarks dc)
fields = dataConFieldLabels dc
return (TH.InfixC (s1,a1) name (s1,a2))
else
return (TH.NormalC name (stricts `zip` arg_tys)) }
+ | otherwise
+ = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:")
+ <+> quotes (ppr dc))
------------------------------
reifyClass :: Class -> TcM TH.Dec
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
- ConDecl(..), Sig(..), BangType(..), HsBang(..), NewOrData(..),
- tyClDeclTyVars, getBangType, getBangStrictness, isSynDecl,
- LTyClDecl, tcdName, LHsTyVarBndr
+ ConDecl(..), Sig(..), , NewOrData(..),
+ tyClDeclTyVars, isSynDecl, LConDecl,
+ LTyClDecl, tcdName, LHsTyVarBndr, LHsContext
)
+import HsTypes ( HsBang(..), getBangStrictness )
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
-import HscTypes ( implicitTyThings, lookupFixity )
+import HscTypes ( implicitTyThings )
import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
tcExtendRecEnv, tcLookupTyVar )
import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles )
import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
-import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcHsType,
- kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext )
+import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType,
+ kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext,
+ kcHsSigType, tcHsBangType, tcLHsConSig )
import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness,
UserTypeCtxt(..), SourceTyCtxt(..) )
import TcUnify ( unifyKind )
-import TcType ( TcKind, ThetaType, TcType, tyVarsOfType,
- mkArrowKind, liftedTypeKind,
+import TcType ( TcKind, ThetaType, TcType, tyVarsOfType,
+ mkArrowKind, liftedTypeKind, mkTyVarTys, tcEqTypes,
tcSplitSigmaTy, tcEqType )
import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
-import FieldLabel ( fieldLabelName, fieldLabelType )
import Generics ( validGenericMethodType, canDoGenerics )
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
import TyCon ( TyCon, ArgVrcs,
tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
- tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName )
-import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
+ tyConStupidTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName )
+import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig,
+ dataConFieldLabels, dataConOrigArgTys, dataConTyCon )
+import Type ( zipTopTvSubst, substTys )
import Var ( TyVar, idType, idName )
import VarSet ( elemVarSet )
import Name ( Name )
do { ex_ctxt' <- kcHsContext ex_ctxt
; details' <- kc_con_details details
; return (ConDecl name ex_tvs' ex_ctxt' details')}
+ kc_con_decl (GadtDecl name ty)
+ = do { ty' <- kcHsSigType ty
+ ; return (GadtDecl name ty') }
kc_con_details (PrefixCon btys)
= do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') }
- kc_larg_ty = wrapLocM kc_arg_ty
-
- kc_arg_ty (BangType str ty) = do { ty' <- kc_arg_ty_body ty; return (BangType str ty') }
- kc_arg_ty_body = case new_or_data of
- DataType -> kcHsSigType
- NewType -> kcHsLiftedSigType
- -- Can't allow an unlifted type for newtypes, because we're effectively
- -- going to remove the constructor while coercing it to a lifted type.
+ kc_larg_ty bty = case new_or_data of
+ DataType -> kcHsSigType bty
+ NewType -> kcHsLiftedSigType bty
+ -- Can't allow an unlifted type for newtypes, because we're effectively
+ -- going to remove the constructor while coercing it to a lifted type.
+ -- And newtypes can't be bang'd
kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs})
= kcTyClDeclBody decl $ \ tvs' ->
(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
tcdLName = L _ tc_name, tcdCons = cons})
= tcTyVarBndrs tvs $ \ tvs' -> do
- { ctxt' <- tcHsKindedContext ctxt
+ { stupid_theta <- tcStupidTheta ctxt cons
; want_generic <- doptM Opt_Generics
; tycon <- fixM (\ tycon -> do
- { data_cons <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons
+ { unbox_strict <- doptM Opt_UnboxStrictFields
+ ; data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon tvs')) cons
; let tc_rhs = case new_or_data of
- DataType -> mkDataTyConRhs data_cons
+ DataType -> mkDataTyConRhs stupid_theta data_cons
NewType -> ASSERT( isSingleton data_cons )
- mkNewTyConRhs (head data_cons)
- ; buildAlgTyCon tc_name tvs' ctxt'
- tc_rhs arg_vrcs is_rec
+ mkNewTyConRhs tycon (head data_cons)
+ ; buildAlgTyCon tc_name tvs' tc_rhs arg_vrcs is_rec
(want_generic && canDoGenerics data_cons)
})
; return (ATyCon tycon)
= returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))
-----------------------------------
-tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType
+tcConDecl :: Bool -- True <=> -funbox-strict_fields
+ -> NewOrData -> TyCon -> [TyVar]
-> ConDecl Name -> TcM DataCon
-tcConDecl new_or_data tycon tyvars ctxt
- (ConDecl name ex_tvs ex_ctxt details)
+tcConDecl unbox_strict new_or_data tycon tc_tvs
+ (ConDecl name ex_tvs ex_ctxt details)
= tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do
{ ex_ctxt' <- tcHsKindedContext ex_ctxt
- ; unbox_strict <- doptM Opt_UnboxStrictFields
; let
+ is_vanilla = null ex_tvs && null (unLoc ex_ctxt)
+ -- Vanilla iff no ex_tvs and no context
+
tc_datacon is_infix field_lbls btys
- = do { let { ubtys = map unLoc btys }
- ; arg_tys <- mappM (tcHsKindedType . getBangType) ubtys
- ; buildDataCon (unLoc name) is_infix
- (argStrictness unbox_strict tycon ubtys arg_tys)
+ = do { let { bangs = map getBangStrictness btys }
+ ; arg_tys <- mappM tcHsBangType btys
+ ; buildDataCon (unLoc name) is_infix is_vanilla
+ (argStrictness unbox_strict tycon bangs arg_tys)
(map unLoc field_lbls)
- tyvars ctxt ex_tvs' ex_ctxt'
- arg_tys tycon }
+ (tc_tvs ++ ex_tvs')
+ ex_ctxt'
+ arg_tys
+ tycon (mkTyVarTys tc_tvs) }
; case details of
PrefixCon btys -> tc_datacon False [] btys
InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
- RecCon fields -> do { checkTc (null ex_tvs') (exRecConErr name)
+ RecCon fields -> do { checkTc is_vanilla (exRecConErr name)
; let { (field_names, btys) = unzip fields }
; tc_datacon False field_names btys } }
+tcConDecl unbox_strict new_or_data tycon tc_tvs
+ decl@(GadtDecl name con_ty)
+ = do { traceTc (text "tcConDecl" <+> ppr name)
+ ; (tvs, theta, bangs, arg_tys, tc, res_tys) <- tcLHsConSig con_ty
+
+ ; traceTc (text "tcConDecl1" <+> ppr name)
+ ; let -- Now dis-assemble the type, and check its form
+ is_vanilla = null theta && mkTyVarTys tvs `tcEqTypes` res_tys
+
+ -- Vanilla datacons guarantee to use the same
+ -- type variables as the parent tycon
+ (tvs', arg_tys', res_tys')
+ | is_vanilla = (tc_tvs, substTys subst arg_tys, substTys subst res_tys)
+ | otherwise = (tvs, arg_tys, res_tys)
+ subst = zipTopTvSubst tvs (mkTyVarTys tc_tvs)
+
+ ; traceTc (text "tcConDecl3" <+> ppr name)
+ ; buildDataCon (unLoc name) False {- Not infix -} is_vanilla
+ (argStrictness unbox_strict tycon bangs arg_tys)
+ [{- No field labels -}]
+ tvs' theta arg_tys' tycon res_tys' }
+
+tcStupidTheta :: LHsContext Name -> [LConDecl Name] -> TcM (Maybe ThetaType)
+-- For GADTs we don't allow a context on the data declaration
+-- whereas for standard Haskell style data declarations, we do
+tcStupidTheta ctxt (L _ (ConDecl _ _ _ _) : _)
+ = do { theta <- tcHsKindedContext ctxt; return (Just theta) }
+tcStupidTheta ctxt other -- Includes an empty constructor list
+ = ASSERT( null (unLoc ctxt) ) return Nothing
+
+-------------------
argStrictness :: Bool -- True <=> -funbox-strict_fields
- -> TyCon -> [BangType Name]
+ -> TyCon -> [HsBang]
-> [TcType] -> [StrictnessMark]
-argStrictness unbox_strict tycon btys arg_tys
- = zipWith (chooseBoxingStrategy unbox_strict tycon)
- arg_tys
- (map getBangStrictness btys ++ repeat HsNoBang)
+argStrictness unbox_strict tycon bangs arg_tys
+ = ASSERT( length bangs == length arg_tys )
+ zipWith (chooseBoxingStrategy unbox_strict tycon) arg_tys bangs
-- We attempt to unbox/unpack a strict field when either:
-- (i) The field is marked '!!', or
= checkValidType syn_ctxt syn_rhs
| otherwise
= -- Check the context on the data decl
- checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_`
+ checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_`
-- Check arg types of data constructors
- mappM_ checkValidDataCon data_cons `thenM_`
+ mappM_ (checkValidDataCon tc) data_cons `thenM_`
-- Check that fields with the same name share a type
mappM_ check_fields groups
(_, syn_rhs) = getSynTyConDefn tc
data_cons = tyConDataCons tc
- fields = [field | con <- data_cons, field <- dataConFieldLabels con]
- groups = equivClasses cmp_name fields
- cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
+ groups = equivClasses cmp_fld (concatMap get_fields data_cons)
+ cmp_fld (f1,_) (f2,_) = f1 `compare` f2
+ get_fields con = dataConFieldLabels con `zip` dataConOrigArgTys con
+ -- dataConFieldLabels may return the empty list, which is fine
- check_fields fields@(first_field_label : other_fields)
+ check_fields fields@((first_field_label, field_ty) : other_fields)
-- These fields all have the same name, but are from
-- different constructors in the data type
= -- Check that all the fields in the group have the same type
-- NB: this check assumes that all the constructors of a given
-- data type use the same type variables
- checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
- where
- field_ty = fieldLabelType first_field_label
- field_name = fieldLabelName first_field_label
- other_tys = map fieldLabelType other_fields
+ checkTc (all (tcEqType field_ty . snd) other_fields)
+ (fieldTypeMisMatch first_field_label)
-------------------------------
-checkValidDataCon :: DataCon -> TcM ()
-checkValidDataCon con
- = addErrCtxt (dataConCtxt con) (
- checkValidType ctxt (idType (dataConWrapId con)) `thenM_`
+checkValidDataCon :: TyCon -> DataCon -> TcM ()
+checkValidDataCon tc con
+ = addErrCtxt (dataConCtxt con) $
+ do { checkTc (dataConTyCon con == tc) (badDataConTyCon con)
+ ; checkValidType ctxt (idType (dataConWrapId con)) }
+
-- This checks the argument types and
-- ambiguity of the existential context (if any)
- checkFreeness ex_tvs ex_theta)
+ --
+ -- Note [Sept 04] Now that tvs is all the tvs, this
+ -- test doesn't actually check anything
+-- ; checkFreeness tvs ex_theta }
where
ctxt = ConArgCtxt (dataConName con)
- (_, _, ex_tvs, ex_theta, _, _) = dataConSig con
+ (tvs, ex_theta, _, _, _) = dataConSig con
-------------------------------
dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
where
- (_, _, ex_tvs, ex_theta, arg_tys, _) = dataConSig con
+ (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
ptext SLIT("You can only use type variables, arrows, and tuples")])
recSynErr syn_decls
- = addSrcSpan (getLoc (head syn_decls)) $
+ = setSrcSpan (getLoc (head syn_decls)) $
addErr (sep [ptext SLIT("Cycle in type synonym declarations:"),
nest 2 (vcat (map ppr_decl syn_decls))])
where
ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
recClsErr cls_decls
- = addSrcSpan (getLoc (head cls_decls)) $
+ = setSrcSpan (getLoc (head cls_decls)) $
addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"),
nest 2 (vcat (map ppr_decl cls_decls))])
where
ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
exRecConErr name
- = ptext SLIT("Can't combine named fields with locally-quantified type variables")
+ = ptext SLIT("Can't combine named fields with locally-quantified type variables or context")
$$
(ptext SLIT("In the declaration of data constructor") <+> ppr name)
+
+badDataConTyCon data_con
+ = hang (ptext SLIT("Data constructor does not return its parent type:"))
+ 2 (ppr data_con)
\end{code}
getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
import Class ( classTyCon )
-import DataCon ( dataConRepArgTys, dataConOrigArgTys )
+import DataCon ( dataConOrigArgTys )
import Var ( TyVar )
import VarSet
import Name ( Name, isTyVarName )
where
data_cons = tyConDataCons tc
vs = tyConTyVars tc
- argtys = concatMap dataConRepArgTys data_cons -- Rep? or Orig?
+ argtys = concatMap dataConOrigArgTys data_cons -- Rep? or Orig?
tcaoIter oi tc | isSynTyCon tc
= let (tyvs,ty) = getSynTyConDefn tc
module TcType where
-data TyVarDetails
+data TcTyVarDetails
-%
+
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcType]{Types used in the typechecker}
TcTyVar, TcTyVarSet, TcKind,
--------------------------------
- -- TyVarDetails
- TyVarDetails(..), isUserTyVar, isSkolemTyVar, isExistentialTyVar,
- tyVarBindingInfo,
+ -- MetaDetails
+ TcTyVarDetails(..),
+ MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar,
+ isImmutableTyVar, isSkolemTyVar, isMetaTyVar, skolemTvInfo, metaTvRef,
+ isFlexi, isIndirect,
--------------------------------
-- Builders
isDoubleTy, isFloatTy, isIntTy,
isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
isTauTy, tcIsTyVarTy, tcIsForAllTy,
- allDistinctTyVars,
---------------------------------
-- Misc type manipulators
toDNType, -- :: Type -> DNType
- ---------------------------------
- -- Unifier and matcher
- unifyTysX, unifyTyListsX, unifyExtendTyListsX,
- matchTy, matchTys, match,
-
--------------------------------
-- Rexported from Type
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
+ -- Type substitutions
+ TvSubst(..), -- Representation visible to a few friends
+ TvSubstEnv, emptyTvSubst,
+ mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ extendTvSubst, extendTvSubstList, isInScope,
+ substTy, substTys, substTyWith, substTheta, substTyVar,
+
isUnLiftedType, -- Source types are always lifted
isUnboxedTupleType, -- Ditto
isPrimitiveType,
tidyTyVarBndr, tidyOpenTyVar,
tidyOpenTyVars,
isSubKind,
+ TvSubst(..),
+ TvSubstEnv, emptyTvSubst,
+ mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ extendTvSubst, extendTvSubstList, isInScope,
+ substTy, substTys, substTyWith, substTheta, substTyVar,
+
typeKind, repType,
pprKind, pprParendKind,
pprType, pprParendType,
pprPred, pprTheta, pprThetaArrow, pprClassPred
)
import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
+import DataCon ( DataCon )
import Class ( Class )
-import Var ( TyVar, tyVarKind, tcTyVarDetails )
+import Var ( TyVar, Id, isTcTyVar, tcTyVarDetails )
import ForeignCall ( Safety, playSafe, DNType(..) )
import VarEnv
import VarSet
import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
import BasicTypes ( IPName(..), ipNameName )
import Unique ( Unique, Uniquable(..) )
-import SrcLoc ( SrcLoc )
-import Util ( cmpList, thenCmp, equalLength, snocView )
+import SrcLoc ( SrcLoc, SrcSpan )
+import Util ( cmpList, thenCmp, snocView )
import Maybes ( maybeToBool, expectJust )
import Outputable
+import DATA_IOREF
\end{code}
type TcSigmaType = TcType
type TcRhoType = TcType
type TcTauType = TcType
-
type TcKind = Kind
+type TcTyVarSet = TyVarSet
\end{code}
\begin{code}
type TcTyVar = TyVar -- Used only during type inference
-data TyVarDetails
- = SigTv -- Introduced when instantiating a type signature,
- -- prior to checking that the defn of a fn does
- -- have the expected type. Should not be instantiated.
- -- f :: forall a. a -> a
- -- f = e
- -- When checking e, with expected type (a->a), we
- -- should not instantiate a
-
- | ClsTv -- Scoped type variable introduced by a class decl
- -- class C a where ...
-
- | InstTv -- Ditto, but instance decl
-
- | PatSigTv -- Scoped type variable, introduced by a pattern
- -- type signature \ x::a -> e
-
- | ExistTv -- An existential type variable bound by a pattern for
- -- a data constructor with an existential type. E.g.
- -- data T = forall a. Eq a => MkT a
- -- f (MkT x) = ...
- -- The pattern MkT x will allocate an existential type
- -- variable for 'a'. We distinguish these from all others
- -- on one place, namely InstEnv.lookupInstEnv.
-
- | VanillaTv -- Everything else
-
-isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible
-isUserTyVar tv = case tcTyVarDetails tv of
- VanillaTv -> False
- other -> True
-
-isSkolemTyVar :: TcTyVar -> Bool
-isSkolemTyVar tv = case tcTyVarDetails tv of
- SigTv -> True
- ClsTv -> True
- InstTv -> True
- ExistTv -> True
- other -> False
-
-isExistentialTyVar :: TcTyVar -> Bool
-isExistentialTyVar tv = case tcTyVarDetails tv of
- ExistTv -> True
- other -> False
-
-tyVarBindingInfo :: TcTyVar -> SDoc -- Used in checkSigTyVars
-tyVarBindingInfo tv
- = sep [ptext SLIT("is bound by the") <+> details (tcTyVarDetails tv),
- ptext SLIT("at") <+> ppr (getSrcLoc tv)]
- where
- details SigTv = ptext SLIT("type signature")
- details ClsTv = ptext SLIT("class declaration")
- details InstTv = ptext SLIT("instance declaration")
- details PatSigTv = ptext SLIT("pattern type signature")
- details ExistTv = ptext SLIT("existential constructor")
- details VanillaTv = ptext SLIT("//vanilla//") -- Ditto
+-- A TyVarDetails is inside a TyVar
+data TcTyVarDetails
+ = SkolemTv SkolemInfo -- A skolem constant
+ | MetaTv (IORef MetaDetails) -- A meta type variable stands for a tau-type
+
+data SkolemInfo
+ = SigSkol Name -- Bound at a type signature
+ | 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
+ SrcSpan -- a data constructor with an existential type. E.g.
+ -- data T = forall a. Eq a => MkT a
+ -- f (MkT x) = ...
+ -- The pattern MkT x will allocate an existential type
+ -- variable for 'a'.
+ | ArrowSkol SrcSpan -- An arrow form (see TcArrows)
+
+ | GenSkol TcType -- Bound when doing a subsumption check for this type
+ SrcSpan
+
+data MetaDetails
+ = Flexi -- Flexi type variables unify to become
+ -- Indirects.
+
+ | Indirect TcType -- Type indirections, treated as wobbly
+ -- for the purpose of GADT unification.
+
+pprSkolemTyVar :: TcTyVar -> SDoc
+pprSkolemTyVar tv
+ = ASSERT( isSkolemTyVar tv )
+ quotes (ppr tv) <+> ptext SLIT("is bound by") <+> ppr (skolemTvInfo tv)
+
+instance Outputable SkolemInfo where
+ ppr (SigSkol id) = ptext SLIT("the type signature for") <+> quotes (ppr id)
+ ppr (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
+ ppr (InstSkol df) = ptext SLIT("the instance declaration at") <+> ppr (getSrcLoc df)
+ ppr (ArrowSkol loc) = ptext SLIT("the arrow form at") <+> ppr loc
+ ppr (PatSkol dc loc) = sep [ptext SLIT("the pattern for") <+> quotes (ppr dc),
+ nest 2 (ptext SLIT("at") <+> ppr loc)]
+ ppr (GenSkol ty loc) = sep [ptext SLIT("the polymorphic type") <+> quotes (ppr ty),
+ nest 2 (ptext SLIT("at") <+> ppr loc)]
+
+instance Outputable MetaDetails where
+ ppr Flexi = ptext SLIT("Flexi")
+ ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
+
+isImmutableTyVar, isSkolemTyVar, isMetaTyVar :: TyVar -> Bool
+isImmutableTyVar tv
+ | isTcTyVar tv = isSkolemTyVar tv
+ | otherwise = True
+
+isSkolemTyVar tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ SkolemTv _ -> True
+ MetaTv _ -> False
+
+isMetaTyVar tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ SkolemTv _ -> False
+ MetaTv _ -> True
+
+skolemTvInfo :: TyVar -> SkolemInfo
+skolemTvInfo tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ SkolemTv info -> info
+
+metaTvRef :: TyVar -> IORef MetaDetails
+metaTvRef tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ MetaTv ref -> ref
+
+isFlexi, isIndirect :: MetaDetails -> Bool
+isFlexi Flexi = True
+isFlexi other = False
+
+isIndirect (Indirect _) = True
+isIndirect other = False
\end{code}
-\begin{code}
-type TcTyVarSet = TyVarSet
-\end{code}
%************************************************************************
%* *
(tvs, theta, clas, tys) }}
\end{code}
-(allDistinctTyVars tys tvs) = True
- iff
-all the types tys are type variables,
-distinct from each other and from tvs.
-
-This is useful when checking that unification hasn't unified signature
-type variables. For example, if the type sig is
- f :: forall a b. a -> b -> b
-we want to check that 'a' and 'b' havn't
- (a) been unified with a non-tyvar type
- (b) been unified with each other (all distinct)
- (c) been unified with a variable free in the environment
-
-\begin{code}
-allDistinctTyVars :: [Type] -> TyVarSet -> Bool
-
-allDistinctTyVars [] acc
- = True
-allDistinctTyVars (ty:tys) acc
- = case tcGetTyVar_maybe ty of
- Nothing -> False -- (a)
- Just tv | tv `elemVarSet` acc -> False -- (b) or (c)
- | otherwise -> allDistinctTyVars tys (acc `extendVarSet` tv)
-\end{code}
%************************************************************************
\end{code}
-%************************************************************************
-%* *
-\subsection{Unification with an explicit substitution}
-%* *
-%************************************************************************
-
-Unify types with an explicit substitution and no monad.
-
-\begin{code}
-type MySubst
- = (TyVarSet, -- Set of template tyvars
- TyVarSubstEnv) -- Not necessarily idempotent
-
-unifyTysX :: TyVarSet -- Template tyvars
- -> Type
- -> Type
- -> Maybe TyVarSubstEnv
-unifyTysX tmpl_tyvars ty1 ty2
- = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv)
-
-unifyExtendTyListsX
- :: TyVarSet -- Template tyvars
- -> TyVarSubstEnv -- Substitution to start with
- -> [Type]
- -> [Type]
- -> Maybe TyVarSubstEnv -- Extended substitution
-unifyExtendTyListsX tmpl_tyvars subst tys1 tys2
- = uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, subst)
-
-unifyTyListsX :: TyVarSet -> [Type] -> [Type]
- -> Maybe TyVarSubstEnv
-unifyTyListsX tmpl_tyvars tys1 tys2
- = uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv)
-
-
-uTysX :: Type
- -> Type
- -> (MySubst -> Maybe result)
- -> MySubst
- -> Maybe result
-
-uTysX (NoteTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst
-uTysX ty1 (NoteTy _ ty2) k subst = uTysX ty1 ty2 k subst
-
- -- Variables; go for uVar
-uTysX (TyVarTy tyvar1) (TyVarTy tyvar2) k subst
- | tyvar1 == tyvar2
- = k subst
-uTysX (TyVarTy tyvar1) ty2 k subst@(tmpls,_)
- | tyvar1 `elemVarSet` tmpls
- = uVarX tyvar1 ty2 k subst
-uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_)
- | tyvar2 `elemVarSet` tmpls
- = uVarX tyvar2 ty1 k subst
-
- -- Predicates
-uTysX (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) k subst
- | n1 == n2 = uTysX t1 t2 k subst
-uTysX (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) k subst
- | c1 == c2 = uTyListsX tys1 tys2 k subst
-
- -- Functions; just check the two parts
-uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst
- = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst
-
- -- Type constructors must match
-uTysX (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) k subst
- | tc1 == tc2 = uTyListsX tys1 tys2 k subst
-uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst
- | (con1 == con2 && equalLength tys1 tys2)
- = uTyListsX tys1 tys2 k subst
-
- -- 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
-uTysX (AppTy s1 t1) ty2 k subst
- = case tcSplitAppTy_maybe ty2 of
- Just (s2, t2) -> uTysX s1 s2 (uTysX t1 t2 k) subst
- Nothing -> Nothing -- Fail
-
-uTysX ty1 (AppTy s2 t2) k subst
- = case tcSplitAppTy_maybe ty1 of
- Just (s1, t1) -> uTysX s1 s2 (uTysX t1 t2 k) subst
- Nothing -> Nothing -- Fail
-
- -- Not expecting for-alls in unification
-#ifdef DEBUG
-uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)"
-uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)"
-#endif
-
- -- Anything else fails
-uTysX ty1 ty2 k subst = Nothing
-
-
-uTyListsX [] [] k subst = k subst
-uTyListsX (ty1:tys1) (ty2:tys2) k subst = uTysX ty1 ty2 (uTyListsX tys1 tys2 k) subst
-uTyListsX tys1 tys2 k subst = Nothing -- Fail if the lists are different lengths
-\end{code}
-
-\begin{code}
--- Invariant: tv1 is a unifiable variable
-uVarX tv1 ty2 k subst@(tmpls, env)
- = case lookupSubstEnv env tv1 of
- Just (DoneTy ty1) -> -- Already bound
- uTysX ty1 ty2 k subst
-
- Nothing -- Not already bound
- | typeKind ty2 == tyVarKind tv1
- && occur_check_ok ty2
- -> -- No kind mismatch nor occur check
- k (tmpls, extendSubstEnv env tv1 (DoneTy ty2))
-
- | otherwise -> Nothing -- Fail if kind mis-match or occur check
- where
- occur_check_ok ty = all occur_check_ok_tv (varSetElems (tyVarsOfType ty))
- occur_check_ok_tv tv | tv1 == tv = False
- | otherwise = case lookupSubstEnv env tv of
- Nothing -> True
- Just (DoneTy ty) -> occur_check_ok ty
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Matching on types}
-%* *
-%************************************************************************
-
-Matching is a {\em unidirectional} process, matching a type against a
-template (which is just a type with type variables in it). The
-matcher assumes that there are no repeated type variables in the
-template, so that it simply returns a mapping of type variables to
-types. It also fails on nested foralls.
-
-@matchTys@ matches corresponding elements of a list of templates and
-types. It and @matchTy@ both ignore usage annotations, unlike the
-main function @match@.
-
-\begin{code}
-matchTy :: TyVarSet -- Template tyvars
- -> Type -- Template
- -> Type -- Proposed instance of template
- -> Maybe TyVarSubstEnv -- Matching substitution
-
-
-matchTys :: TyVarSet -- Template tyvars
- -> [Type] -- Templates
- -> [Type] -- Proposed instance of template
- -> Maybe (TyVarSubstEnv, -- Matching substitution
- [Type]) -- Left over instance types
-
-matchTy tmpls ty1 ty2 = match ty1 ty2 tmpls (\ senv -> Just senv) emptySubstEnv
-
-matchTys tmpls tys1 tys2 = match_list tys1 tys2 tmpls
- (\ (senv,tys) -> Just (senv,tys))
- emptySubstEnv
-\end{code}
-
-@match@ is the main function. It takes a flag indicating whether
-usage annotations are to be respected.
-
-\begin{code}
-match :: Type -> Type -- Current match pair
- -> TyVarSet -- Template vars
- -> (TyVarSubstEnv -> Maybe result) -- Continuation
- -> TyVarSubstEnv -- Current subst
- -> Maybe result
-
--- When matching against a type variable, see if the variable
--- has already been bound. If so, check that what it's bound to
--- is the same as ty; if not, bind it and carry on.
-
-match (TyVarTy v) ty tmpls k senv
- | v `elemVarSet` tmpls
- = -- v is a template variable
- case lookupSubstEnv senv v of
- Nothing | typeKind ty `isSubKind` tyVarKind v
- -- We do a kind check, just as in the uVarX above
- -- The kind check is needed to avoid bogus matches
- -- of (a b) with (c d), where the kinds don't match
- -- An occur check isn't needed when matching.
- -> k (extendSubstEnv senv v (DoneTy ty))
-
- | otherwise -> Nothing -- Fails
-
- Just (DoneTy ty') | ty' `tcEqType` ty -> k senv -- Succeeds
- | otherwise -> Nothing -- Fails
-
- | otherwise
- = -- v is not a template variable; ty had better match
- -- Can't use (==) because types differ
- case tcGetTyVar_maybe ty of
- Just v' | v == v' -> k senv -- Success
- other -> Nothing -- Failure
- -- This tcGetTyVar_maybe is *required* because it must strip Notes.
- -- I guess the reason the Note-stripping case is *last* rather than first
- -- is to preserve type synonyms etc., so I'm not moving it to the
- -- top; but this means that (without the deNotetype) a type
- -- variable may not match the pattern (TyVarTy v') as one would
- -- expect, due to an intervening Note. KSW 2000-06.
-
- -- Predicates
-match (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) tmpls k senv
- | n1 == n2 = match t1 t2 tmpls k senv
-match (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) tmpls k senv
- | c1 == c2 = match_list_exactly tys1 tys2 tmpls k senv
-
- -- Functions; just check the two parts
-match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv
- = match arg1 arg2 tmpls (match res1 res2 tmpls k) senv
-
- -- If the template is an application, try to make the
- -- thing we are matching look like an application
-match (AppTy fun1 arg1) ty2 tmpls k senv
- = case tcSplitAppTy_maybe ty2 of
- Just (fun2,arg2) -> match fun1 fun2 tmpls (match arg1 arg2 tmpls k) senv
- Nothing -> Nothing -- Fail
-
- -- Newtypes are opaque; predicate types should not happen
-match (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) tmpls k senv
- | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv
-match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv
- | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv
-
- -- With type synonyms, we have to be careful for the exact
- -- same reasons as in the unifier. Please see the
- -- considerable commentary there before changing anything
- -- here! (WDP 95/05)
-match (NoteTy n1 ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv
-match ty1 (NoteTy n2 ty2) tmpls k senv = match ty1 ty2 tmpls k senv
-
--- Catch-all fails
-match _ _ _ _ _ = Nothing
-
-match_list_exactly tys1 tys2 tmpls k senv
- = match_list tys1 tys2 tmpls k' senv
- where
- k' (senv', tys2') | null tys2' = k senv' -- Succeed
- | otherwise = Nothing -- Fail
-
-match_list [] tys2 tmpls k senv = k (senv, tys2)
-match_list (ty1:tys1) [] tmpls k senv = Nothing -- Not enough arg tys => failure
-match_list (ty1:tys1) (ty2:tys2) tmpls k senv
- = match ty1 ty2 tmpls (match_list tys1 tys2 tmpls k) senv
-\end{code}
\begin{code}
module TcUnify (
-- Full-blown subsumption
- tcSubOff, tcSubExp, tcGen,
+ tcSubPat, tcSubExp, tcGen,
checkSigTyVars, checkSigTyVarsWrt, sigCtxt, findGlobals,
-- Various unifications
- unifyTauTy, unifyTauTyList, unifyTauTyLists,
+ unifyTauTy, unifyTauTyList,
unifyKind, unifyKinds, unifyFunKind,
checkExpectedKind,
--------------------------------
-- Holes
- Expected(..), newHole, readExpectedType,
+ Expected(..), tcInfer, readExpectedType,
zapExpectedType, zapExpectedTo, zapExpectedBranches,
- subFunTys, unifyFunTy,
- zapToListTy, unifyListTy,
- zapToPArrTy, unifyPArrTy,
- zapToTupleTy, unifyTupleTy
-
+ subFunTys, unifyFunTys,
+ zapToListTy, unifyListTy,
+ zapToTyConApp, unifyTyConApp,
+ unifyAppTy
) where
#include "HsVersions.h"
-
-import HsSyn ( HsExpr(..) )
+-- gaw 2004
+import HsSyn ( HsExpr(..) , MatchGroup(..), hsLMatchPats )
import TcHsSyn ( mkHsLet, mkHsDictLam,
ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) )
import TypeRep ( Type(..), PredType(..), TyNote(..) )
import TcRnMonad -- TcType, amongst others
import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
- TcTyVarSet, TcThetaType, TyVarDetails(SigTv),
- isTauTy, isSigmaTy, mkFunTys, mkTyConApp,
+ TcTyVarSet, TcThetaType,
+ SkolemInfo( GenSkol ), MetaDetails(..),
+ pprSkolemTyVar, isTauTy, isSigmaTy, mkFunTys, mkTyConApp,
tcSplitAppTy_maybe, tcSplitTyConApp_maybe,
- tcGetTyVar_maybe, tcGetTyVar,
- mkFunTy, tyVarsOfType, mkPhiTy,
- typeKind, tcSplitFunTy_maybe, mkForAllTys,
- isSkolemTyVar, isUserTyVar,
+ tyVarsOfType, mkPhiTy, mkTyVarTy,
+ typeKind, tcSplitFunTy_maybe, mkForAllTys, mkAppTy,
tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
- allDistinctTyVars, pprType )
+ pprType, isSkolemTyVar )
import Kind ( Kind(..), SimpleKind, KindVar, isArgTypeKind,
- openTypeKind, liftedTypeKind, mkArrowKind,
+ openTypeKind, liftedTypeKind, mkArrowKind, kindFunResult,
isOpenTypeKind, argTypeKind, isLiftedTypeKind, isUnliftedTypeKind,
isSubKind, pprKind, splitKindFunTys )
import Inst ( newDicts, instToId, tcInstCall )
-import TcMType ( getTcTyVar, putTcTyVar, tcInstType, newKindVar,
- newTyVarTy, newTyVarTys, zonkTcKind,
- zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV,
- readKindVar,writeKindVar )
+import TcMType ( condLookupTcTyVar, LookupTyVarResult(..),
+ putMetaTyVar, tcSkolType, newKindVar, tcInstTyVars, newMetaTyVar,
+ newTyFlexiVarTy, zonkTcKind,
+ zonkType, zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV,
+ readKindVar, writeKindVar )
import TcSimplify ( tcSimplifyCheck )
-import TysWiredIn ( listTyCon, parrTyCon, tupleTyCon )
import TcEnv ( tcGetGlobalTyVars, findGlobals )
-import TyCon ( TyCon, tyConArity, isTupleTyCon, tupleTyConBoxity )
+import TyCon ( TyCon, tyConArity, tyConTyVars )
+import TysWiredIn ( listTyCon )
import Id ( Id, mkSysLocal )
import Var ( Var, varName, tyVarKind )
-import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems )
+import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet,
+ varSetElems, intersectsVarSet, mkVarSet )
import VarEnv
-import Name ( isSystemName )
+import Name ( isSystemName, mkSysTvName )
import ErrUtils ( Message )
import SrcLoc ( noLoc )
-import BasicTypes ( Boxity, Arity, isBoxed )
-import Util ( equalLength, lengthExceeds, notNull )
+import BasicTypes ( Arity )
+import Util ( equalLength, notNull )
import Outputable
\end{code}
data Expected ty = Infer (TcRef ty) -- The hole to fill in for type inference
| Check ty -- The type to check during type checking
-newHole :: TcM (TcRef ty)
newHole = newMutVar (error "Empty hole in typechecker")
+tcInfer :: (Expected ty -> TcM a) -> TcM (a,ty)
+tcInfer tc_infer
+ = do { hole <- newHole
+ ; res <- tc_infer (Infer hole)
+ ; res_ty <- readMutVar hole
+ ; return (res, res_ty) }
+
readExpectedType :: Expected ty -> TcM ty
readExpectedType (Infer hole) = readMutVar hole
readExpectedType (Check ty) = returnM ty
-- In the inference case, ensure we have a monotype
-- (including an unboxed tuple)
zapExpectedType (Infer hole) kind
- = do { ty <- newTyVarTy kind ;
+ = do { ty <- newTyFlexiVarTy kind ;
writeMutVar hole ty ;
return ty }
zapExpectedType (Check ty) kind
| typeKind ty `isSubKind` kind = return ty
- | otherwise = do { ty1 <- newTyVarTy kind
+ | 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 (Infer hole) ty2 = writeMutVar hole ty2
zapExpectedTo (Check ty1) ty2 = unifyTauTy ty1 ty2
-
-zapExpectedBranches :: [a] -> Expected TcType -> TcM (Expected TcType)
--- Zap the expected type to a monotype if there is more than one branch
-zapExpectedBranches branches exp_ty
- | lengthExceeds branches 1 = zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' ->
- return (Check exp_ty')
- | otherwise = returnM exp_ty
+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
type variables, so we should create new ordinary type variables
\begin{code}
-subFunTys :: [pat]
- -> Expected TcRhoType -- Fail if ty isn't a function type
- -> ([(pat, Expected TcRhoType)] -> Expected TcRhoType -> TcM a)
- -> TcM a
+subFunTys :: MatchGroup name
+ -> Expected TcRhoType -- Fail if ty isn't a function type
+ -> ([Expected TcRhoType] -> Expected TcRhoType -> TcM a)
+ -> TcM a
-subFunTys pats (Infer hole) thing_inside
+subFunTys (MatchGroup (match:null_matches) _) (Infer hole) thing_inside
= -- This is the interesting case
- mapM new_pat_hole pats `thenM` \ pats_w_holes ->
- newHole `thenM` \ res_hole ->
+ ASSERT( null null_matches )
+ do { pat_holes <- mapM (\ _ -> newHole) (hsLMatchPats match)
+ ; res_hole <- newHole
- -- Do the business
- thing_inside pats_w_holes (Infer res_hole) `thenM` \ answer ->
+ -- Do the business
+ ; res <- thing_inside (map Infer pat_holes) (Infer res_hole)
- -- Extract the answers
- mapM read_pat_hole pats_w_holes `thenM` \ arg_tys ->
- readMutVar res_hole `thenM` \ res_ty ->
+ -- 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) `thenM_`
+ -- Write the answer into the incoming hole
+ ; writeMutVar hole (mkFunTys arg_tys res_ty)
- -- And return the answer
- returnM answer
- where
- new_pat_hole pat = newHole `thenM` \ hole -> return (pat, Infer hole)
- read_pat_hole (pat, Infer hole) = readMutVar hole
+ -- And return the answer
+ ; return res }
-subFunTys pats (Check ty) thing_inside
- = go pats ty `thenM` \ (pats_w_tys, res_ty) ->
- thing_inside pats_w_tys res_ty
- where
- go [] ty = return ([], Check ty)
- go (pat:pats) ty = unifyFunTy ty `thenM` \ (arg,res) ->
- go pats res `thenM` \ (pats_w_tys, final_res) ->
- return ((pat, Check arg) : pats_w_tys, final_res)
-
-unifyFunTy :: TcRhoType -- Fail if ty isn't a function type
- -> TcM (TcType, TcType) -- otherwise return arg and result types
-
-unifyFunTy ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenM` \ maybe_ty ->
- case maybe_ty of
- Just ty' -> unifyFunTy ty'
- Nothing -> unify_fun_ty_help ty
-
-unifyFunTy ty
+subFunTys (MatchGroup (match:matches) _) (Check ty) thing_inside
+ = ASSERT( all ((== length (hsLMatchPats match)) . length . hsLMatchPats) matches )
+ -- Assertion just checks that all the matches have the same number of pats
+ do { (pat_tys, res_ty) <- unifyFunTys (length (hsLMatchPats match)) ty
+ ; thing_inside (map Check pat_tys) (Check res_ty) }
+
+unifyFunTys :: 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
+--
+-- (b) GADTs: if the argument is not wobbly we do not want the result to be
+
+unifyFunTys arity ty = unify_fun_ty True arity ty
+
+unify_fun_ty use_refinement arity ty
+ | arity == 0
+ = do { res_ty <- wobblify use_refinement ty
+ ; return ([], ty) }
+
+unify_fun_ty use_refinement arity (NoteTy _ 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'
+ other -> unify_fun_help arity ty
+ }
+
+unify_fun_ty use_refinement arity ty
= case tcSplitFunTy_maybe ty of
- Just arg_and_res -> returnM arg_and_res
- Nothing -> unify_fun_ty_help ty
-
-unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification
- = newTyVarTy argTypeKind `thenM` \ arg ->
- newTyVarTy openTypeKind `thenM` \ res ->
- unifyTauTy ty (mkFunTy arg res) `thenM_`
- returnM (arg,res)
+ Just (arg,res) -> do { arg' <- wobblify use_refinement arg
+ ; (args', res') <- unify_fun_ty use_refinement (arity-1) res
+ ; return (arg':args', res') }
+
+ Nothing -> unify_fun_help arity ty
+ -- Usually an error, but ty could be (a Int Bool), which can match
+
+unify_fun_help :: Arity -> TcRhoType -> TcM ([TcSigmaType], TcRhoType)
+unify_fun_help arity ty
+ = do { args <- mappM newTyFlexiVarTy (replicate arity argTypeKind)
+ ; res <- newTyFlexiVarTy openTypeKind
+ ; unifyTauTy ty (mkFunTys args res)
+ ; return (args, res) }
\end{code}
\begin{code}
----------------------
-zapToListTy, zapToPArrTy :: Expected TcType -- expected list type
- -> TcM TcType -- list element type
-unifyListTy, unifyPArrTy :: TcType -> TcM TcType
-zapToListTy = zapToXTy listTyCon
-unifyListTy = unifyXTy listTyCon
-zapToPArrTy = zapToXTy parrTyCon
-unifyPArrTy = unifyXTy parrTyCon
+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
+
+zapToTyConApp tc (Check ty)
+ = unifyTyConApp tc ty -- NB: fails for a forall-type
+zapToTyConApp tc (Infer hole)
+ = do { (tc_app, elt_tys) <- newTyConApp tc
+ ; writeMutVar hole tc_app
+ ; 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 }
----------------------
-zapToXTy :: TyCon -- T :: *->*
- -> Expected TcType -- Expected type (T a)
- -> TcM TcType -- Element type, a
+unifyTyConApp :: TyCon -> TcType -> TcM [TcType]
+unifyTyConApp tc ty = unify_tc_app 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 }
+
+----------
+unify_tc_app use_refinement tc (NoteTy _ ty)
+ = unify_tc_app use_refinement tc ty
+
+unify_tc_app use_refinement tc ty@(TyVarTy tyvar)
+ = do { details <- condLookupTcTyVar use_refinement tyvar
+ ; case details of
+ IndirectTv use' ty' -> unify_tc_app use' tc ty'
+ other -> unify_tc_app_help tc ty
+ }
+
+unify_tc_app use_refinement tc ty
+ | Just (tycon, arg_tys) <- tcSplitTyConApp_maybe ty,
+ tycon == tc
+ = ASSERT( tyConArity tycon == length arg_tys ) -- ty::*
+ mapM (wobblify use_refinement) arg_tys
+
+unify_tc_app use_refinement tc ty = unify_tc_app_help tc ty
+
+----------
+unify_tc_app_help tc ty -- Revert to ordinary unification
+ = do { (tc_app, arg_tys) <- newTyConApp tc
+ ; 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 arg_tys } }
-zapToXTy tc (Check ty) = unifyXTy tc ty
-zapToXTy tc (Infer hole) = do { elt_ty <- newTyVarTy liftedTypeKind ;
- writeMutVar hole (mkTyConApp tc [elt_ty]) ;
- return elt_ty }
----------------------
-unifyXTy :: TyCon -> TcType -> TcM TcType
-unifyXTy tc ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenM` \ maybe_ty ->
- case maybe_ty of
- Just ty' -> unifyXTy tc ty'
- other -> unify_x_ty_help tc ty
-
-unifyXTy tc ty
- = case tcSplitTyConApp_maybe ty of
- Just (tycon, [arg_ty]) | tycon == tc -> returnM arg_ty
- other -> unify_x_ty_help tc ty
-
-unify_x_ty_help tc ty -- Revert to ordinary unification
- = newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
- unifyTauTy ty (mkTyConApp tc [elt_ty]) `thenM_`
- returnM elt_ty
-\end{code}
+unifyAppTy :: TcType -- Expected type function: m
+ -> TcType -- Type to split: m a
+ -> TcM TcType -- Type arg: a
+unifyAppTy tc ty = unify_app_ty True tc ty
+
+unify_app_ty use tc (NoteTy _ ty) = unify_app_ty use tc ty
+
+unify_app_ty use tc ty@(TyVarTy tyvar)
+ = do { details <- condLookupTcTyVar use tyvar
+ ; case details of
+ IndirectTv use' ty' -> unify_app_ty use' tc ty'
+ other -> unify_app_ty_help tc ty
+ }
+
+unify_app_ty use tc ty
+ | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
+ = do { unifyTauTy tc fun_ty
+ ; wobblify use arg_ty }
+
+ | otherwise = unify_app_ty_help tc ty
+
+unify_app_ty_help tc ty -- Revert to ordinary unification
+ = do { arg_ty <- newTyFlexiVarTy (kindFunResult (typeKind tc))
+ ; unifyTauTy (mkAppTy tc arg_ty) ty
+ ; return arg_ty }
+
-\begin{code}
----------------------
-zapToTupleTy :: Boxity -> Arity -> Expected TcType -> TcM [TcType]
-zapToTupleTy boxity arity (Check ty) = unifyTupleTy boxity arity ty
-zapToTupleTy boxity arity (Infer hole) = do { (tup_ty, arg_tys) <- new_tuple_ty boxity arity ;
- writeMutVar hole tup_ty ;
- return arg_tys }
-
-unifyTupleTy boxity arity ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenM` \ maybe_ty ->
- case maybe_ty of
- Just ty' -> unifyTupleTy boxity arity ty'
- other -> unify_tuple_ty_help boxity arity ty
-
-unifyTupleTy boxity arity ty
- = case tcSplitTyConApp_maybe ty of
- Just (tycon, arg_tys)
- | isTupleTyCon tycon
- && tyConArity tycon == arity
- && tupleTyConBoxity tycon == boxity
- -> returnM arg_tys
- other -> unify_tuple_ty_help boxity arity ty
-
-unify_tuple_ty_help boxity arity ty
- = new_tuple_ty boxity arity `thenM` \ (tup_ty, arg_tys) ->
- unifyTauTy ty tup_ty `thenM_`
- returnM arg_tys
-
-new_tuple_ty boxity arity
- = newTyVarTys arity kind `thenM` \ arg_tys ->
- return (mkTyConApp tup_tc arg_tys, arg_tys)
- where
- tup_tc = tupleTyCon boxity arity
- kind | isBoxed boxity = liftedTypeKind
- | otherwise = argTypeKind -- Components of an unboxed tuple
- -- can be unboxed, but not unboxed tuples
+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
+wobblify False ty = do { uniq <- newUnique
+ ; tv <- newMetaTyVar (mkSysTvName uniq FSLIT("w"))
+ (typeKind ty)
+ (Indirect ty)
+ ; return (mkTyVarTy tv) }
+
+----------------------
+newTyConApp :: TyCon -> TcM (TcTauType, [TcTauType])
+newTyConApp tc = do { (tvs, args, _) <- tcInstTyVars (tyConTyVars tc)
+ ; return (mkTyConApp tc args, args) }
\end{code}
expected_ty.
\begin{code}
+-----------------------
+-- tcSubExp is used for expressions
tcSubExp :: Expected TcRhoType -> TcRhoType -> TcM ExprCoFn
-tcSubOff :: TcSigmaType -> Expected TcSigmaType -> TcM ExprCoFn
-\end{code}
-These two check for holes
+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 }
-\begin{code}
-tcSubExp expected_ty offered_ty
- = traceTc (text "tcSubExp" <+> (ppr expected_ty $$ ppr offered_ty)) `thenM_`
- checkHole expected_ty offered_ty tcSub
+tcSubExp (Check expected_ty) offered_ty
+ = tcSub expected_ty offered_ty
-tcSubOff expected_ty offered_ty
- = checkHole offered_ty expected_ty (\ off exp -> tcSub exp off)
+-----------------------
+-- 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
+
+tcSubPat sig_ty (Infer hole)
+ = do { sig_ty' <- zonkTcType sig_ty
+ ; writeMutVar hole sig_ty' -- See notes with tcSubExp above
+ ; return () }
+
+tcSubPat sig_ty (Check exp_ty)
+ = do { co_fn <- tcSub sig_ty exp_ty
+
+ ; if isIdCoercion co_fn then
+ return ()
+ else
+ unifyMisMatch sig_ty exp_ty }
+\end{code}
--- checkHole looks for a hole in its first arg;
--- If so, and it is uninstantiated, it fills in the hole
--- with its second arg
--- Otherwise it calls thing_inside, passing the two args, looking
--- through any instantiated hole
-checkHole (Infer hole) other_ty thing_inside
- = do { writeMutVar hole other_ty; return idCoercion }
-checkHole (Check ty) other_ty thing_inside
- = thing_inside ty other_ty
-\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
+ -- act <= exp
tcSub expected_ty actual_ty
= traceTc (text "tcSub" <+> details) `thenM_`
addErrCtxtM (unifyCtxt "type" expected_ty actual_ty)
where
details = vcat [text "Expected:" <+> ppr expected_ty,
text "Actual: " <+> ppr actual_ty]
-\end{code}
-
-tc_sub carries the types before and after expanding type synonyms
-\begin{code}
+-----------------
tc_sub :: TcSigmaType -- expected_ty, before expanding synonyms
-> TcSigmaType -- ..and after
-> TcSigmaType -- actual_ty, before
tc_sub exp_sty expected_ty act_sty actual_ty
| isSigmaTy actual_ty
- = tcInstCall Rank2Origin actual_ty `thenM` \ (inst_fn, body_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)
-- 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 instantiat f's type to a monotype
+-- 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
--
-- I'm not quite sure what to do about this!
-tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ (TyVarTy tv)
- = getTcTyVar tv `thenM` \ maybe_ty ->
- case maybe_ty of
- Just ty -> tc_sub exp_sty exp_ty ty ty
- Nothing -> imitateFun tv exp_sty `thenM` \ (act_arg, act_res) ->
- tcSub_fun exp_arg exp_res act_arg act_res
+tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ act_ty
+ = do { ([act_arg], act_res) <- unifyFunTys 1 act_ty
+ ; tcSub_fun exp_arg exp_res act_arg act_res }
-tc_sub _ (TyVarTy tv) act_sty act_ty@(FunTy act_arg act_res)
- = getTcTyVar tv `thenM` \ maybe_ty ->
- case maybe_ty of
- Just ty -> tc_sub ty ty act_sty act_ty
- Nothing -> imitateFun tv act_sty `thenM` \ (exp_arg, exp_res) ->
- tcSub_fun exp_arg exp_res act_arg act_res
+tc_sub _ exp_ty act_sty act_ty@(FunTy act_arg act_res)
+ = do { ([exp_arg], exp_res) <- unifyFunTys 1 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 exp_sty expected_ty act_sty actual_ty `thenM_`
+ = uTys True exp_sty expected_ty True act_sty actual_ty `thenM_`
returnM idCoercion
\end{code}
-%************************************************************************
-%* *
-\subsection{Functions}
-%* *
-%************************************************************************
-
\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 ->
-- co_fn_res $it :: HsExpr exp_res
in
returnM coercion
-
-imitateFun :: TcTyVar -> TcType -> TcM (TcType, TcType)
-imitateFun tv ty
- = -- NB: tv is an *ordinary* tyvar and so are the new ones
-
- -- Check that tv isn't a type-signature type variable
- -- (This would be found later in checkSigTyVars, but
- -- we get a better error message if we do it here.)
- checkM (not (isSkolemTyVar tv))
- (failWithTcM (unifyWithSigErr tv ty)) `thenM_`
-
- newTyVarTy argTypeKind `thenM` \ arg ->
- newTyVarTy openTypeKind `thenM` \ res ->
- putTcTyVar tv (mkFunTy arg res) `thenM_`
- returnM (arg,res)
\end{code}
tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall-type
-- If not, the call is a no-op
- = tcInstType SigTv expected_ty `thenM` \ (forall_tvs, theta, phi_ty) ->
+ = do { span <- getSrcSpanM
+ ; let rigid_info = GenSkol expected_ty span
+ ; (forall_tvs, theta, phi_ty) <- tcSkolType rigid_info expected_ty
-- Type-check the arg and unify with poly type
- getLIE (thing_inside phi_ty) `thenM` \ (result, lie) ->
+ ; (result, lie) <- getLIE (thing_inside phi_ty)
-- Check that the "forall_tvs" havn't been constrained
-- The interesting bit here is that we must include the free variables
-- Conclusion: include the free vars of the expected_ty in the
-- list of "free vars" for the signature check.
- newDicts SignatureOrigin theta `thenM` \ dicts ->
- tcSimplifyCheck sig_msg forall_tvs dicts lie `thenM` \ inst_binds ->
+ ; dicts <- newDicts (SigOrigin rigid_info) theta
+ ; inst_binds <- tcSimplifyCheck sig_msg forall_tvs dicts lie
#ifdef DEBUG
- zonkTcTyVars forall_tvs `thenM` \ forall_tys ->
- traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs,
+ ; forall_tys <- zonkTcTyVars forall_tvs
+ ; traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs,
text "expected_ty" <+> ppr expected_ty,
text "inst ty" <+> ppr forall_tvs <+> ppr theta <+> ppr phi_ty,
text "free_tvs" <+> ppr free_tvs,
- text "forall_tys" <+> ppr forall_tys]) `thenM_`
+ text "forall_tys" <+> ppr forall_tys])
#endif
- checkSigTyVarsWrt free_tvs forall_tvs `thenM` \ zonked_tvs ->
-
- traceTc (text "tcGen:done") `thenM_`
+ ; checkSigTyVarsWrt free_tvs forall_tvs
+ ; traceTc (text "tcGen:done")
- let
+ ; let
-- This HsLet binds any Insts which came out of the simplification.
-- It's a bit out of place here, but using AbsBind involves inventing
-- a couple of new names which seems worse.
- dict_ids = map instToId dicts
- co_fn e = TyLam zonked_tvs (mkHsDictLam dict_ids (mkHsLet inst_binds (noLoc e)))
- in
- returnM (mkCoercion co_fn, result)
+ dict_ids = map instToId dicts
+ co_fn e = TyLam forall_tvs (mkHsDictLam dict_ids (mkHsLet inst_binds (noLoc e)))
+ ; returnM (mkCoercion co_fn, result) }
where
free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
sig_msg = ptext SLIT("expected type of an expression")
ASSERT2( isTauTy ty1, ppr ty1 )
ASSERT2( isTauTy ty2, ppr ty2 )
addErrCtxtM (unifyCtxt "type" ty1 ty2) $
- uTys ty1 ty1 ty2 ty2
+ uTys True ty1 ty1 True ty2 ty2
\end{code}
@unifyTauTyList@ unifies corresponding elements of two lists of
complain if their lengths differ.
\begin{code}
-unifyTauTyLists :: [TcTauType] -> [TcTauType] -> TcM ()
-unifyTauTyLists [] [] = returnM ()
-unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenM_`
- unifyTauTyLists tys1 tys2
-unifyTauTyLists ty1s ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!"
+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!"
\end{code}
@unifyTauTyList@ takes a single list of @TauType@s and unifies them
We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''.
\begin{code}
-uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1
+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
-> TcM ()
-- Always expand synonyms (see notes at end)
-- (this also throws away FTVs)
-uTys ps_ty1 (NoteTy n1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
-uTys ps_ty1 ty1 ps_ty2 (NoteTy n2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
+uTys r1 ps_ty1 (NoteTy n1 ty1) r2 ps_ty2 ty2 = uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2
+uTys r1 ps_ty1 ty1 r2 ps_ty2 (NoteTy n2 ty2) = uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2
-- Variables; go for uVar
-uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2
-uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1
+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
-- Predicates
-uTys _ (PredTy (IParam n1 t1)) _ (PredTy (IParam n2 t2))
- | n1 == n2 = uTys t1 t1 t2 t2
-uTys _ (PredTy (ClassP c1 tys1)) _ (PredTy (ClassP c2 tys2))
- | c1 == c2 = unifyTauTyLists tys1 tys2
+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 _ (FunTy fun1 arg1) _ (FunTy fun2 arg2)
- = uTys fun1 fun1 fun2 fun2 `thenM_` uTys arg1 arg1 arg2 arg2
+uTys r1 _ (FunTy fun1 arg1) r2 _ (FunTy fun2 arg2)
+ = uTys r1 fun1 fun1 r2 fun2 fun2 `thenM_` uTys r1 arg1 arg1 r2 arg2 arg2
-- NewType constructors must match
-uTys _ (NewTcApp tc1 tys1) _ (NewTcApp tc2 tys2)
- | tc1 == tc2 = unifyTauTyLists tys1 tys2
+uTys r1 _ (NewTcApp tc1 tys1) r2 _ (NewTcApp tc2 tys2)
+ | tc1 == tc2 = unifyTauTyLists r1 tys1 r2 tys2
+ -- See Note [TyCon app]
-- Ordinary type constructors must match
-uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2)
- | con1 == con2 && equalLength tys1 tys2
- = unifyTauTyLists tys1 tys2
+uTys r1 ps_ty1 (TyConApp con1 tys1) r2 ps_ty2 (TyConApp con2 tys2)
+ | con1 == con2 = unifyTauTyLists r1 tys1 r2 tys2
+ -- See Note [TyCon app]
-- Applications need a bit of care!
-- They can match FunTy and TyConApp, so use splitAppTy_maybe
-- NB: we've already dealt with type variables and Notes,
-- so if one type is an App the other one jolly well better be too
-uTys ps_ty1 (AppTy s1 t1) ps_ty2 ty2
+uTys r1 ps_ty1 (AppTy s1 t1) r2 ps_ty2 ty2
= case tcSplitAppTy_maybe ty2 of
- Just (s2,t2) -> uTys s1 s1 s2 s2 `thenM_` uTys t1 t1 t2 t2
+ Just (s2,t2) -> uTys r1 s1 s1 r2 s2 s2 `thenM_` uTys r1 t1 t1 r2 t2 t2
Nothing -> unifyMisMatch ps_ty1 ps_ty2
-- Now the same, but the other way round
-- Don't swap the types, because the error messages get worse
-uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2)
+uTys r1 ps_ty1 ty1 r2 ps_ty2 (AppTy s2 t2)
= case tcSplitAppTy_maybe ty1 of
- Just (s1,t1) -> uTys s1 s1 s2 s2 `thenM_` uTys t1 t1 t2 t2
+ 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
-- than a panic message!
-- Anything else fails
-uTys ps_ty1 ty1 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2
+uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2
\end{code}
+Note [Tycon app]
+~~~~~~~~~~~~~~~~
+When we find two TyConApps, the argument lists are guaranteed equal
+length. Reason: intially the kinds of the two types to be unified is
+the same. The only way it can become not the same is when unifying two
+AppTys (f1 a1):=:(f2 a2). In that case there can't be a TyConApp in
+the f1,f2 (because it'd absorb the app). If we unify f1:=:f2 first,
+which we do, that ensures that f1,f2 have the same kind; and that
+means a1,a2 have the same kind. And now the argument repeats.
+
Notes on synonyms
~~~~~~~~~~~~~~~~~
\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?
-> TcTauType -> TcTauType -- printing and real versions
-> TcM ()
-uVar swapped tv1 ps_ty2 ty2
+uVar swapped r1 tv1 r2 ps_ty2 ty2
= traceTc (text "uVar" <+> ppr swapped <+> ppr tv1 <+> (ppr ps_ty2 $$ ppr ty2)) `thenM_`
- getTcTyVar tv1 `thenM` \ maybe_ty1 ->
- case maybe_ty1 of
- Just ty1 | swapped -> uTys ps_ty2 ty2 ty1 ty1 -- Swap back
- | otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order
- other -> uUnboundVar swapped tv1 ps_ty2 ty2
+ 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
+ FlexiTv -> uFlexiVar swapped tv1 r2 ps_ty2 ty2
+ RigidTv -> uRigidVar swapped tv1 r2 ps_ty2 ty2
-- Expand synonyms; ignore FTVs
-uUnboundVar swapped tv1 ps_ty2 (NoteTy n2 ty2)
- = uUnboundVar swapped tv1 ps_ty2 ty2
-
-
- -- The both-type-variable case
-uUnboundVar swapped tv1 ps_ty2 ty2@(TyVarTy tv2)
-
+uFlexiVar :: Bool -> TcTyVar ->
+ Bool -> -- Allow refinements to ty2
+ TcTauType -> TcTauType -> TcM ()
+-- Invariant: tv1 is Flexi
+uFlexiVar swapped tv1 r2 ps_ty2 (NoteTy n2 ty2)
+ = uFlexiVar swapped tv1 r2 ps_ty2 ty2
+
+uFlexiVar swapped tv1 r2 ps_ty2 ty2@(TyVarTy tv2)
-- Same type variable => no-op
| tv1 == tv2
= returnM ()
-- Distinct type variables
| otherwise
- = getTcTyVar tv2 `thenM` \ maybe_ty2 ->
- case maybe_ty2 of
- Just ty2' -> uUnboundVar swapped tv1 ty2' ty2'
-
- Nothing | update_tv2
- -- It should always be the case that either k1 <: k2 or k2 <: k1
- -- Reason: a type variable never gets the kinds (#) or #
-
- -> ASSERT2( k1 `isSubKind` k2, (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) )
- putTcTyVar tv2 (TyVarTy tv1) `thenM_`
- returnM ()
-
- | otherwise
- -> ASSERT2( k2 `isSubKind` k1, (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) )
- putTcTyVar tv1 ps_ty2 `thenM_`
- returnM ()
+ = condLookupTcTyVar r2 tv2 `thenM` \ details ->
+ case details of
+ IndirectTv b ty2' -> uFlexiVar swapped tv1 b ty2' ty2'
+ FlexiTv | update_tv2 -> putMetaTyVar tv2 (TyVarTy tv1)
+ | otherwise -> updateFlexi swapped tv1 ty2
+ RigidTv -> updateFlexi swapped tv1 ty2
+ -- Note that updateFlexi 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
-- The "nicer to" part only applies if the two kinds are the same,
-- so we can choose which to do.
- nicer_to_update_tv2 = isUserTyVar tv1
- -- Don't unify a signature type variable if poss
- || isSystemName (varName tv2)
- -- Try to update sys-y type variables in preference to sig-y ones
-
- -- Second one isn't a type variable
-uUnboundVar swapped tv1 ps_ty2 non_var_ty2
- = -- Check that tv1 isn't a type-signature type variable
- checkM (not (isSkolemTyVar tv1))
- (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenM_`
+ nicer_to_update_tv2 = isSystemName (varName tv2)
+ -- Try to update sys-y type variables in preference to sig-y ones
- -- Do the occurs check, and check that we are not
+ -- First one is flexi, second one isn't a type variable
+uFlexiVar swapped tv1 r2 ps_ty2 non_var_ty2
+ = -- 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
- checkValue tv1 ps_ty2 non_var_ty2 `thenM` \ ty2 ->
+ do { ty2 <- checkValue tv1 r2 ps_ty2 non_var_ty2
+ ; updateFlexi swapped tv1 ty2 }
+
+-- Ready to update tv1, which is flexi; occurs check is done
+updateFlexi swapped tv1 ty2
+ = do { checkKinds swapped tv1 ty2
+ ; putMetaTyVar tv1 ty2 }
+
- -- Check that the kinds match
- checkKinds swapped tv1 ty2 `thenM_`
+uRigidVar :: Bool -> TcTyVar
+ -> Bool -> -- Allow refinements to ty2
+ TcTauType -> TcTauType -> TcM ()
+-- Invariant: tv1 is Rigid
+uRigidVar swapped tv1 r2 ps_ty2 (NoteTy n2 ty2)
+ = uRigidVar swapped tv1 r2 ps_ty2 ty2
+
+ -- The both-type-variable case
+uRigidVar swapped tv1 r2 ps_ty2 ty2@(TyVarTy tv2)
+ -- Same type variable => no-op
+ | tv1 == tv2
+ = returnM ()
- -- Perform the update
- putTcTyVar tv1 ty2 `thenM_`
- returnM ()
+ -- Distinct type variables
+ | otherwise
+ = condLookupTcTyVar r2 tv2 `thenM` \ details ->
+ case details of
+ IndirectTv b ty2' -> uRigidVar swapped tv1 b ty2' ty2'
+ FlexiTv -> updateFlexi swapped tv2 (TyVarTy tv1)
+ RigidTv -> unifyMisMatch (TyVarTy tv1) (TyVarTy tv2)
+
+ -- Second one isn't a type variable
+uRigidVar swapped tv1 r2 ps_ty2 non_var_ty2
+ = unifyMisMatch (TyVarTy tv1) ps_ty2
\end{code}
\begin{code}
\end{code}
\begin{code}
-checkValue tv1 ps_ty2 non_var_ty2
+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
-- Rather, we should bind t to () (= non_var_ty2).
--
-- That's why we have this two-state occurs-check
- = zonkTcType ps_ty2 `thenM` \ ps_ty2' ->
+ = zonk_tc_type r2 ps_ty2 `thenM` \ ps_ty2' ->
case okToUnifyWith tv1 ps_ty2' of {
Nothing -> returnM ps_ty2' ; -- Success
other ->
- zonkTcType non_var_ty2 `thenM` \ non_var_ty2' ->
+ 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
Just problem -> failWithTcM (unifyCheck problem tv1 ps_ty2')
}
+ 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
data Problem = OccurCheck | NotMonoType
-- tv1 and ty2 are zonked already
= returnM msg
where
- msg = (env2, ptext SLIT("When matching types") <+>
+ msg = (env2, ptext SLIT("When matching the kinds of") <+>
sep [quotes pp_expected <+> ptext SLIT("and"), quotes pp_actual])
(pp_expected, pp_actual) | swapped = (pp2, pp1)
pp2 = ppr ty2' <+> dcolon <+> ppr (typeKind ty2)
unifyMisMatch ty1 ty2
- = zonkTcType ty1 `thenM` \ ty1' ->
- zonkTcType ty2 `thenM` \ ty2' ->
- let
- (env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2']
- msg = hang (ptext SLIT("Couldn't match"))
- 2 (sep [quotes (ppr tidy_ty1),
- ptext SLIT("against"),
- quotes (ppr tidy_ty2)])
+ = do { (env1, pp1, extra1) <- ppr_ty emptyTidyEnv ty1
+ ; (env2, pp2, extra2) <- ppr_ty env1 ty2
+ ; let msg = sep [sep [ptext SLIT("Couldn't match") <+> pp1, nest 7 (ptext SLIT("against") <+> pp2)],
+ nest 2 extra1, nest 2 extra2]
in
- failWithTcM (env, msg)
-
-
-unifyWithSigErr tyvar ty
- = (env2, hang (ptext SLIT("Cannot unify the type-signature variable") <+> quotes (ppr tidy_tyvar))
- 2 (ptext SLIT("with the type") <+> quotes (ppr tidy_ty)))
+ failWithTcM (env2, msg) }
+
+ppr_ty :: TidyEnv -> TcType -> TcM (TidyEnv, SDoc, SDoc)
+ppr_ty env ty
+ = do { ty' <- zonkTcType ty
+ ; let (env1,tidy_ty) = tidyOpenType env ty'
+ simple_result = (env1, quotes (ppr tidy_ty), empty)
+ ; case tidy_ty of
+ TyVarTy tv
+ | isSkolemTyVar tv -> return (env1, pp_rigid tv,
+ pprSkolemTyVar tv)
+ | otherwise -> return simple_result
+ other -> return simple_result }
where
- (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar
- (env2, tidy_ty) = tidyOpenType env1 ty
+ pp_rigid tv = ptext SLIT("the rigid variable") <+> quotes (ppr tv)
unifyCheck problem tyvar ty
= (env2, hang msg
give a helpful message in checkSigTyVars.
\begin{code}
-checkSigTyVars :: [TcTyVar] -> TcM [TcTyVar]
+checkSigTyVars :: [TcTyVar] -> TcM ()
checkSigTyVars sig_tvs = check_sig_tyvars emptyVarSet sig_tvs
-checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM [TcTyVar]
+checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM ()
checkSigTyVarsWrt extra_tvs sig_tvs
= zonkTcTyVarsAndFV (varSetElems extra_tvs) `thenM` \ extra_tvs' ->
check_sig_tyvars extra_tvs' sig_tvs
check_sig_tyvars
- :: TcTyVarSet -- Global type variables. The universally quantified
- -- tyvars should not mention any of these
- -- Guaranteed already zonked.
- -> [TcTyVar] -- Universally-quantified type variables in the signature
- -- Not guaranteed zonked.
- -> TcM [TcTyVar] -- Zonked signature type variables
+ :: TcTyVarSet -- Global type variables. The universally quantified
+ -- tyvars should not mention any of these
+ -- Guaranteed already zonked.
+ -> [TcTyVar] -- Universally-quantified type variables in the signature
+ -- Not guaranteed zonked.
+ -> TcM ()
check_sig_tyvars extra_tvs []
- = returnM []
+ = returnM ()
check_sig_tyvars extra_tvs sig_tvs
- = zonkTcTyVars sig_tvs `thenM` \ sig_tys ->
- tcGetGlobalTyVars `thenM` \ gbl_tvs ->
- let
- env_tvs = gbl_tvs `unionVarSet` extra_tvs
- in
- traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tys,
+ = do { gbl_tvs <- tcGetGlobalTyVars
+ ; traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tvs,
text "gbl_tvs" <+> ppr gbl_tvs,
- text "extra_tvs" <+> ppr extra_tvs])) `thenM_`
+ text "extra_tvs" <+> ppr extra_tvs]))
- checkM (allDistinctTyVars sig_tys env_tvs)
- (complain sig_tys env_tvs) `thenM_`
-
- returnM (map (tcGetTyVar "checkSigTyVars") sig_tys)
+ -- Check that that the signature type vars are not free in the envt
+ ; let env_tvs = gbl_tvs `unionVarSet` extra_tvs
+ ; checkM (not (mkVarSet sig_tvs `intersectsVarSet` env_tvs))
+ (complain sig_tvs env_tvs)
+ ; ASSERT( all isSkolemTyVar sig_tvs )
+ return () }
where
- complain sig_tys globals
+ complain sig_tvs globals
= -- "check" checks each sig tyvar in turn
foldlM check
- (env2, emptyVarEnv, [])
- (tidy_tvs `zip` tidy_tys) `thenM` \ (env3, _, msgs) ->
+ (env, emptyVarEnv, [])
+ tidy_tvs `thenM` \ (env2, _, msgs) ->
- failWithTcM (env3, main_msg $$ nest 2 (vcat msgs))
+ failWithTcM (env2, main_msg $$ nest 2 (vcat msgs))
where
- (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tvs
- (env2, tidy_tys) = tidyOpenTypes env1 sig_tys
+ (env, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tvs
main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
- check (tidy_env, acc, msgs) (sig_tyvar,ty)
+ check (tidy_env, acc, msgs) tv
-- sig_tyvar is from the signature;
-- ty is what you get if you zonk sig_tyvar and then tidy it
--
-- acc maps a zonked type variable back to a signature type variable
- = case tcGetTyVar_maybe ty of {
- Nothing -> -- Error (a)!
- returnM (tidy_env, acc, unify_msg sig_tyvar (quotes (ppr ty)) : msgs) ;
-
- Just tv ->
-
- case lookupVarEnv acc tv of {
+ = case lookupVarEnv acc tv of {
Just sig_tyvar' -> -- Error (b)!
- returnM (tidy_env, acc, unify_msg sig_tyvar thing : msgs)
+ returnM (tidy_env, acc, unify_msg tv thing : msgs)
where
thing = ptext SLIT("another quantified type variable") <+> quotes (ppr sig_tyvar')
-- Game plan:
-- get the local TcIds and TyVars from the environment,
-- and pass them to find_globals (they might have tv free)
- then findGlobals (unitVarSet tv) tidy_env `thenM` \ (tidy_env1, globs) ->
- returnM (tidy_env1, acc, escape_msg sig_tyvar tv globs : msgs)
+ then
+ findGlobals (unitVarSet tv) tidy_env `thenM` \ (tidy_env1, globs) ->
+ -- This rigid type variable has escaped into the envt
+ -- We make it flexi so that subequent uses of these
+ -- variables don't give rise to a cascade of further errors
+ returnM (tidy_env1, acc, escape_msg tv globs : msgs)
else -- All OK
- returnM (tidy_env, extendVarEnv acc tv sig_tyvar, msgs)
- }}
+ returnM (tidy_env, extendVarEnv acc tv tv, msgs)
+ }
\end{code}
\begin{code}
-----------------------
-escape_msg sig_tv tv globs
+escape_msg sig_tv globs
= mk_msg sig_tv <+> ptext SLIT("escapes") $$
if notNull globs then
- vcat [pp_it <+> ptext SLIT("is mentioned in the environment:"),
+ vcat [ptext SLIT("It is mentioned in the environment:"),
nest 2 (vcat globs)]
else
empty -- Sigh. It's really hard to give a good error message
-- all the time. One bad case is an existential pattern match.
-- We rely on the "When..." context to help.
- where
- pp_it | sig_tv /= tv = ptext SLIT("It unifies with") <+> quotes (ppr tv) <> comma <+> ptext SLIT("which")
- | otherwise = ptext SLIT("It")
-
unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> thing
mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv)
import Name ( getSrcLoc )
import Var ( Id, TyVar )
import Class ( Class, FunDep, classTvsFds )
-import Subst ( mkSubst, emptyInScopeSet, substTy )
-import TcType ( Type, ThetaType, PredType(..),
- predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred,
- unifyTyListsX, unifyExtendTyListsX, tcEqType
- )
+import Unify ( unifyTys, unifyTysX )
+import Type ( mkTvSubst, substTy )
+import TcType ( Type, ThetaType, PredType(..), tcEqType,
+ predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred )
import VarSet
import VarEnv
import Outputable
--
-- We can instantiate x to t1, and then we want to force
-- (Tree x) [t1/x] :=: t2
-
--- We use 'unify' even though we are often only matching
--- unifyTyListsX will only bind variables in qtvs, so it's OK!
- = case unifyTyListsX qtvs ls1 ls2 of
+--
+-- The same function is also used from InstEnv.badFunDeps, when we need
+-- to *unify*; in which case the qtvs are the variables of both ls1 and ls2.
+-- However unifying with the qtvs being the left-hand lot *is* just matching,
+-- so we can call unifyTys in both cases
+ = case unifyTys qtvs ls1 ls2 of
Nothing -> []
- Just unif | maybeToBool (unifyExtendTyListsX qtvs unif rs1 rs2)
+ Just unif | maybeToBool (unifyTysX qtvs unif rs1 rs2)
-- Don't include any equations that already hold.
-- Reason: then we know if any actual improvement has happened,
-- in which case we need to iterate the solver
-- In making this check we must taking account of the fact that any
-- qtvs that aren't already instantiated can be instantiated to anything
-- at all
- -- NB: qtvs, not qtvs' because unifyExtendTyListsX only tries to
+ -- NB: qtvs, not qtvs' because matchTysX only tries to
-- look template tyvars up in the substitution
-> []
-- executed. What we're doing instead is recording the partial
-- work of the ls1/ls2 unification leaving a smaller unification problem
where
- full_unif = mkSubst emptyInScopeSet unif
- -- No for-alls in sight; hmm
+ full_unif = mkTvSubst unif
- qtvs' = filterVarSet (\v -> not (v `elemSubstEnv` unif)) qtvs
+ qtvs' = filterVarSet (\v -> not (v `elemVarEnv` unif)) qtvs
-- qtvs' are the quantified type variables
-- that have not been substituted out
--
)
import TcHsSyn ( mkSimpleHsAlt )
import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy )
-import DataCon ( DataCon, dataConOrigArgTys, isExistentialDataCon,
+import DataCon ( DataCon, dataConOrigArgTys, isVanillaDataCon,
dataConSourceArity )
import TyCon ( TyCon, tyConName, tyConDataCons,
= not (any bad_con data_cons) -- See comment below
&& not (null data_cons) -- No values of the type
where
- bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || isExistentialDataCon dc
+ bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
-- If any of the constructor has an unboxed type as argument,
-- then we can't build the embedding-projection pair, because
-- it relies on instantiating *polymorphic* sum and product types
mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
mkTyConGenericBinds tycon
= unitBag (L loc (FunBind (L loc from_RDR) False {- Not infix -}
- [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]))
+ (mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts])))
`unionBags`
unitBag (L loc (FunBind (L loc to_RDR) False
- [mkSimpleHsAlt to_pat to_body]))
+ (mkMatchGroup [mkSimpleHsAlt to_pat to_body])))
where
loc = srcLocSpan (getSrcLoc tycon)
datacons = tyConDataCons tycon
= (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
nlVarPat to_arg,
noLoc (HsCase (nlHsVar to_arg)
- [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
- mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body]))
+ (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
+ mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
where
(l_datacons, r_datacons) = splitInHalf datacons
(l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
= (us'',
nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
nlVarPat to_arg,
- \x -> noLoc (HsCase (nlHsVar to_arg)
- [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))]))
+-- gaw 2004 FIX?
+ \x -> noLoc (HsCase (nlHsVar to_arg)
+ (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
where
to_arg = mkGenericLocal us
(l_arg_vars, r_arg_vars) = splitInHalf arg_vars
#include "HsVersions.h"
import Class ( Class, classTvsFds )
-import Var ( Id, isTcTyVar )
+import Var ( Id )
import VarSet
-import VarEnv
+import Type ( TvSubstEnv )
import TcType ( Type, tcTyConAppTyCon, tcIsTyVarTy,
- tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar,
- matchTys, unifyTyListsX
+ tcSplitDFunTy, tyVarsOfTypes, isSkolemTyVar
)
+import Unify ( matchTys, unifyTys )
import FunDeps ( checkClsFD )
import TyCon ( TyCon )
import Outputable
-> (InstEnv -- External package inst-env
,InstEnv) -- Home-package inst-env
-> Class -> [Type] -- What we are looking for
- -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches
+ -> ([(TvSubstEnv, InstEnvElt)], -- Successful matches
[Id]) -- These don't match but do unify
-- The second component of the tuple happens when we look up
-- Foo [a]
lookup_inst_env :: InstEnv -- The envt
-> Class -> [Type] -- What we are looking for
-> Bool -- All the [Type] are tyvars
- -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches
+ -> ([(TvSubstEnv, InstEnvElt)], -- Successful matches
[Id]) -- These don't match but do unify
lookup_inst_env env key_cls key_tys key_all_tvs
= case lookupUFM env key_cls of
| otherwise -> find insts [] []
where
key_vars = filterVarSet not_existential (tyVarsOfTypes key_tys)
- not_existential tv = not (isTcTyVar tv && isExistentialTyVar tv)
+ not_existential tv = not (isSkolemTyVar tv)
-- The key_tys can contain skolem constants, and we can guarantee that those
-- are never going to be instantiated to anything, so we should not involve
-- them in the unification test. Example:
find [] ms us = (ms, us)
find (item@(tpl_tyvars, tpl, dfun_id) : rest) ms us
= case matchTys tpl_tyvars tpl key_tys of
- Just (subst, leftovers) -> ASSERT( null leftovers )
- find rest ((subst,item):ms) us
+ Just subst -> find rest ((subst,item):ms) us
Nothing
-- Does not match, so next check whether the things unify
-- [see notes about overlapping instances above]
- -> ASSERT( not (key_vars `intersectsVarSet` tpl_tyvars) )
+ -> ASSERT2( not (key_vars `intersectsVarSet` tpl_tyvars),
+ (ppr key_cls <+> ppr key_tys <+> ppr key_all_tvs) $$
+ (ppr dfun_id <+> ppr tpl_tyvars <+> ppr tpl)
+ )
-- Unification will break badly if the variables overlap
-- They shouldn't because we allocate separate uniques for them
- case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of
+ case unifyTys (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of
Just _ -> find rest ms (dfun_id:us)
Nothing -> find rest ms us
-insert_overlapping :: (TyVarSubstEnv, InstEnvElt) -> [(TyVarSubstEnv, InstEnvElt)]
- -> [(TyVarSubstEnv, InstEnvElt)]
+insert_overlapping :: (TvSubstEnv, InstEnvElt) -> [(TvSubstEnv, InstEnvElt)]
+ -> [(TvSubstEnv, InstEnvElt)]
-- Add a new solution, knocking out strictly less specific ones
insert_overlapping new_item [] = [new_item]
insert_overlapping new_item (item:items)
have a glb if one is a sub-kind of the other. In that case, we bind the
less-informative one to the more informative one. Neat, eh?
-In the olden days, when we generalise, we make generic type variables
-whose kind is simple. So generic type variables (other than built-in
-constants like 'error') always have simple kinds. But I don't see any
-reason to do that any more (TcMType.zapTcTyVarToTyVar).
-
\begin{code}
liftedTypeKind = LiftedTypeKind
defaultKind :: Kind -> Kind
-- Used when generalising: default kind '?' and '??' to '*'
+--
+-- When we generalise, we make generic type variables whose kind is
+-- simple (* or *->* etc). So generic type variables (other than
+-- built-in constants like 'error') always have simple kinds. This is important;
+-- consider
+-- f x = True
+-- We want f to get type
+-- f :: forall (a::*). a -> Bool
+-- Not
+-- f :: forall (a::??). a -> Bool
+-- because that would allow a call like (f 3#) as well as (f True),
+--and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr.
defaultKind OpenTypeKind = LiftedTypeKind
defaultKind ArgTypeKind = LiftedTypeKind
defaultKind kind = kind
\begin{code}
module TyCon(
- TyCon, ArgVrcs,
+ TyCon, ArgVrcs, FieldLabel,
PrimRep(..),
tyConPrimRep,
tyConUnique,
tyConTyVars,
tyConArgVrcs,
- algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
- tyConSelIds,
- tyConTheta,
+ algTcRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
+ tyConFields, tyConSelIds,
+ tyConStupidTheta,
tyConArity,
isClassTyCon, tyConClass_maybe,
getSynTyConDefn,
-- Should just be Type(Type), but this fails due to bug present up to
-- and including 4.02 involving slurping of hi-boot files. Bug is now fixed.
-import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon )
+import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon )
import Var ( TyVar, Id )
tyConKind :: Kind,
tyConArity :: Arity,
- tyConTyVars :: [TyVar],
- argVrcs :: ArgVrcs,
- algTyConTheta :: [PredType],
+ tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in DataTyCon
+ -- (b) the cached types in NewTyCon
+ -- (c) the types in algTcFields
+ -- But not over the data constructors
+ argVrcs :: ArgVrcs,
- selIds :: [Id], -- Its record selectors (if any)
+ algTcFields :: [(FieldLabel, Type, Id)],
+ -- Its fields (empty if none):
+ -- * field name
+ -- * its type (scoped over tby tyConTyVars)
+ -- * record selector (name = field name)
- algRhs :: AlgTyConRhs, -- Data constructors in here
+ algTcRhs :: AlgTyConRhs, -- Data constructors in here
- algTyConRec :: RecFlag, -- Tells whether the data type is part of
+ algTcRec :: RecFlag, -- Tells whether the data type is part of
-- a mutually-recursive group or not
hasGenerics :: Bool, -- True <=> generic to/from functions are available
-- (in the exports of the data type's source module)
- algTyConClass :: Maybe Class
+ algTcClass :: Maybe Class
-- Just cl if this tycon came from a class declaration
}
argVrcs :: ArgVrcs
}
+type FieldLabel = Name
+
type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)]
-- [] means "no information, assume the worst"
-- an hi file
| DataTyCon
+ (Maybe [PredType]) -- Just theta => this tycon was declared in H98 syntax
+ -- with the specified "stupid theta"
+ -- e.g. data Ord a => T a = ...
+ -- Nothing => this tycon was declared by giving the
+ -- type signatures for each constructor
+ -- (new GADT stuff)
+ -- e.g. data T a where { ... }
[DataCon] -- The constructors; can be empty if the user declares
-- the type to have no constructors
Bool -- Cached: True <=> an enumeration type
-- newtypes.
visibleDataCons :: AlgTyConRhs -> [DataCon]
-visibleDataCons AbstractTyCon = []
-visibleDataCons (DataTyCon cs _) = cs
-visibleDataCons (NewTyCon c _ _) = [c]
+visibleDataCons AbstractTyCon = []
+visibleDataCons (DataTyCon _ cs _) = cs
+visibleDataCons (NewTyCon c _ _) = [c]
\end{code}
%************************************************************************
-- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
-- but now you also have to pass in the generic information about the type
-- constructor - you can get hold of it easily (see Generics module)
-mkAlgTyCon name kind tyvars theta argvrcs rhs sels is_rec gen_info
+mkAlgTyCon name kind tyvars argvrcs rhs flds is_rec gen_info
= AlgTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConKind = kind,
- tyConArity = length tyvars,
- tyConTyVars = tyvars,
- argVrcs = argvrcs,
- algTyConTheta = theta,
- algRhs = rhs,
- selIds = sels,
- algTyConClass = Nothing,
- algTyConRec = is_rec,
- hasGenerics = gen_info
+ tyConName = name,
+ tyConUnique = nameUnique name,
+ tyConKind = kind,
+ tyConArity = length tyvars,
+ tyConTyVars = tyvars,
+ argVrcs = argvrcs,
+ algTcRhs = rhs,
+ algTcFields = flds,
+ algTcClass = Nothing,
+ algTcRec = is_rec,
+ hasGenerics = gen_info
}
mkClassTyCon name kind tyvars argvrcs rhs clas is_rec
= AlgTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConKind = kind,
- tyConArity = length tyvars,
- tyConTyVars = tyvars,
- argVrcs = argvrcs,
- algTyConTheta = [],
- algRhs = rhs,
- selIds = [],
- algTyConClass = Just clas,
- algTyConRec = is_rec,
- hasGenerics = False
+ tyConName = name,
+ tyConUnique = nameUnique name,
+ tyConKind = kind,
+ tyConArity = length tyvars,
+ tyConTyVars = tyvars,
+ argVrcs = argvrcs,
+ algTcRhs = rhs,
+ algTcFields = [],
+ algTcClass = Just clas,
+ algTcRec = is_rec,
+ hasGenerics = False
}
isFunTyCon _ = False
isAbstractTyCon :: TyCon -> Bool
-isAbstractTyCon (AlgTyCon { algRhs = AbstractTyCon }) = True
+isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True
isAbstractTyCon _ = False
isPrimTyCon :: TyCon -> Bool
isAlgTyCon (TupleTyCon {}) = True
isAlgTyCon other = False
-algTyConRhs :: TyCon -> AlgTyConRhs
-algTyConRhs (AlgTyCon {algRhs = rhs}) = rhs
-algTyConRhs (TupleTyCon {dataCon = dc}) = DataTyCon [dc] False
-
isDataTyCon :: TyCon -> Bool
-- isDataTyCon returns True for data types that are represented by
-- heap-allocated constructors.
-- True for all @data@ types
-- False for newtypes
-- unboxed tuples
-isDataTyCon (AlgTyCon {algRhs = rhs})
+isDataTyCon (AlgTyCon {algTcRhs = rhs})
= case rhs of
- DataTyCon _ _ -> True
- NewTyCon _ _ _ -> False
- AbstractTyCon -> panic "isDataTyCon"
+ DataTyCon _ _ _ -> True
+ NewTyCon _ _ _ -> False
+ AbstractTyCon -> panic "isDataTyCon"
isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isDataTyCon other = False
isNewTyCon :: TyCon -> Bool
-isNewTyCon (AlgTyCon {algRhs = NewTyCon _ _ _}) = True
-isNewTyCon other = False
+isNewTyCon (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = True
+isNewTyCon other = False
isProductTyCon :: TyCon -> Bool
-- A "product" tycon
-- may be DataType or NewType,
-- may be unboxed or not,
-- may be recursive or not
-isProductTyCon tc@(AlgTyCon {}) = case algRhs tc of
- DataTyCon [data_con] _ -> not (isExistentialDataCon data_con)
- NewTyCon _ _ _ -> True
- other -> False
+isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of
+ DataTyCon _ [data_con] _ -> isVanillaDataCon data_con
+ NewTyCon _ _ _ -> True
+ other -> False
isProductTyCon (TupleTyCon {}) = True
isProductTyCon other = False
isSynTyCon _ = False
isEnumerationTyCon :: TyCon -> Bool
-isEnumerationTyCon (AlgTyCon {algRhs = DataTyCon _ is_enum}) = is_enum
-isEnumerationTyCon other = False
+isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon _ _ is_enum}) = is_enum
+isEnumerationTyCon other = False
isTupleTyCon :: TyCon -> Bool
-- The unit tycon didn't used to be classed as a tuple tycon
tupleTyConBoxity tc = tyConBoxed tc
isRecursiveTyCon :: TyCon -> Bool
-isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True
+isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True
isRecursiveTyCon other = False
isHiBootTyCon :: TyCon -> Bool
-- Used for knot-tying in hi-boot files
-isHiBootTyCon (AlgTyCon {algRhs = AbstractTyCon}) = True
-isHiBootTyCon other = False
+isHiBootTyCon (AlgTyCon {algTcRhs = AbstractTyCon}) = True
+isHiBootTyCon other = False
isForeignTyCon :: TyCon -> Bool
-- isForeignTyCon identifies foreign-imported type constructors
tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` []
tyConDataCons_maybe :: TyCon -> Maybe [DataCon]
-tyConDataCons_maybe (AlgTyCon {algRhs = DataTyCon cons _}) = Just cons
-tyConDataCons_maybe (AlgTyCon {algRhs = NewTyCon con _ _}) = Just [con]
-tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con]
-tyConDataCons_maybe other = Nothing
+tyConDataCons_maybe (AlgTyCon {algTcRhs = DataTyCon _ cons _}) = Just cons
+tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon con _ _}) = Just [con]
+tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con]
+tyConDataCons_maybe other = Nothing
tyConFamilySize :: TyCon -> Int
-tyConFamilySize (AlgTyCon {algRhs = DataTyCon cons _}) = length cons
-tyConFamilySize (AlgTyCon {algRhs = NewTyCon _ _ _}) = 1
-tyConFamilySize (TupleTyCon {}) = 1
+tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon _ cons _}) = length cons
+tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = 1
+tyConFamilySize (TupleTyCon {}) = 1
#ifdef DEBUG
tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
#endif
+tyConFields :: TyCon -> [(FieldLabel,Type,Id)]
+tyConFields (AlgTyCon {algTcFields = fs}) = fs
+tyConFields other_tycon = []
+
tyConSelIds :: TyCon -> [Id]
-tyConSelIds (AlgTyCon {selIds = sels}) = sels
-tyConSelIds other_tycon = []
+tyConSelIds tc = [id | (_,_,id) <- tyConFields tc]
\end{code}
\begin{code}
newTyConRep :: TyCon -> ([TyVar], Type)
-newTyConRep (AlgTyCon {tyConTyVars = tvs, algRhs = NewTyCon _ _ rep}) = (tvs, rep)
+newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ _ rep}) = (tvs, rep)
newTyConRhs :: TyCon -> ([TyVar], Type)
-newTyConRhs (AlgTyCon {tyConTyVars = tvs, algRhs = NewTyCon _ rhs _}) = (tvs, rhs)
-\end{code}
+newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ rhs _}) = (tvs, rhs)
-\begin{code}
tyConPrimRep :: TyCon -> PrimRep
tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep
\end{code}
\begin{code}
-tyConTheta :: TyCon -> [PredType]
-tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta
-tyConTheta (TupleTyCon {}) = []
+tyConStupidTheta :: TyCon -> [PredType]
+tyConStupidTheta (AlgTyCon {algTcRhs = DataTyCon mb_th _ _}) = mb_th `orElse` []
+tyConStupidTheta (AlgTyCon {algTcRhs = other}) = []
+tyConStupidTheta (TupleTyCon {}) = []
-- shouldn't ask about anything else
\end{code}
\begin{code}
maybeTyConSingleCon :: TyCon -> Maybe DataCon
-maybeTyConSingleCon (AlgTyCon {algRhs = DataTyCon [c] _}) = Just c
-maybeTyConSingleCon (AlgTyCon {algRhs = NewTyCon c _ _}) = Just c
-maybeTyConSingleCon (AlgTyCon {}) = Nothing
-maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con
-maybeTyConSingleCon (PrimTyCon {}) = Nothing
-maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty
+maybeTyConSingleCon (AlgTyCon {algTcRhs = DataTyCon _ [c] _}) = Just c
+maybeTyConSingleCon (AlgTyCon {algTcRhs = NewTyCon c _ _}) = Just c
+maybeTyConSingleCon (AlgTyCon {}) = Nothing
+maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con
+maybeTyConSingleCon (PrimTyCon {}) = Nothing
+maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty
maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr tc
\end{code}
\begin{code}
isClassTyCon :: TyCon -> Bool
-isClassTyCon (AlgTyCon {algTyConClass = Just _}) = True
+isClassTyCon (AlgTyCon {algTcClass = Just _}) = True
isClassTyCon other_tycon = False
tyConClass_maybe :: TyCon -> Maybe Class
-tyConClass_maybe (AlgTyCon {algTyConClass = maybe_clas}) = maybe_clas
+tyConClass_maybe (AlgTyCon {algTcClass = maybe_clas}) = maybe_clas
tyConClass_maybe ther_tycon = Nothing
\end{code}
\begin{code}
module Type (
-- re-exports from TypeRep
- TyThing(..), Type, PredType(..), ThetaType, TyVarSubst,
+ TyThing(..), Type, PredType(..), ThetaType,
funTyCon,
-- Re-exports from Kind
mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
- mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys,
+ mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe,
+ splitFunTys, splitFunTysN,
funResultTy, funArgTy, zipFunTys, isFunTy,
mkGenTyConApp, mkTyConApp, mkTyConTy,
applyTy, applyTys, isForAllTy, dropForAlls,
-- Source types
- predTypeRep, mkPredTy, mkPredTys,
+ predTypeRep, newTypeRep, mkPredTy, mkPredTys,
-- Newtypes
splitRecNewType_maybe,
-- Seq
seqType, seqTypes,
+ -- Type substitutions
+ TvSubst(..), -- Representation visible to a few friends
+ TvSubstEnv, emptyTvSubst,
+ mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ extendTvSubst, extendTvSubstList, isInScope,
+
+ -- Performing substitution on types
+ substTy, substTys, substTyWith, substTheta, substTyVar,
+ deShadowTy,
+
-- Pretty-printing
pprType, pprParendType,
pprPred, pprTheta, pprThetaArrow, pprClassPred
import TypeRep
--- Other imports:
-
-import {-# SOURCE #-} Subst ( substTyWith )
-
-- friends:
import Kind
-import Var ( TyVar, tyVarKind, tyVarName, setTyVarName )
+import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
import VarEnv
import VarSet
split args orig_ty (NewTcApp tc tys) = split args orig_ty (newTypeRep tc tys)
split args orig_ty ty = (reverse args, orig_ty)
+splitFunTysN :: Int -> Type -> ([Type], Type)
+-- Split off exactly n arg tys
+splitFunTysN 0 ty = ([], ty)
+splitFunTysN n ty = case splitFunTy ty of { (arg, res) ->
+ case splitFunTysN (n-1) res of { (args, res) ->
+ (arg:args, res) }}
+
zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
where
eq_tys env tys1 tys2 = False
\end{code}
+
+%************************************************************************
+%* *
+ Type substitutions
+%* *
+%************************************************************************
+
+\begin{code}
+data TvSubst
+ = TvSubst InScopeSet -- The in-scope type variables
+ TvSubstEnv -- The substitution itself; guaranteed idempotent
+ -- See Note [Apply Once]
+
+{- ----------------------------------------------------------
+ Note [Apply Once]
+
+We use TvSubsts to instantiate things, and we might instantiate
+ forall a b. ty
+\with the types
+ [a, b], or [b, a].
+So the substition might go [a->b, b->a]. A similar situation arises in Core
+when we find a beta redex like
+ (/\ a /\ b -> e) b a
+Then we also end up with a substition that permutes type variables. Other
+variations happen to; for example [a -> (a, b)].
+
+ ***************************************************
+ *** So a TvSubst must be applied precisely once ***
+ ***************************************************
+
+A TvSubst is not idempotent, but, unlike the non-idempotent substitution
+we use during unifications, it must not be repeatedly applied.
+-------------------------------------------------------------- -}
+
+
+type TvSubstEnv = TyVarEnv Type
+ -- A TvSubstEnv is used both inside a TvSubst (with the apply-once
+ -- invariant discussed in Note [Apply Once]), and also independently
+ -- in the middle of matching, and unification (see Types.Unify)
+ -- So you have to look at the context to know if it's idempotent or
+ -- apply-once or whatever
+
+emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
+isEmptyTvSubst :: TvSubst -> Bool
+isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env
+
+getTvSubstEnv :: TvSubst -> TvSubstEnv
+getTvSubstEnv (TvSubst _ env) = env
+
+getTvInScope :: TvSubst -> InScopeSet
+getTvInScope (TvSubst in_scope _) = in_scope
+
+isInScope :: Var -> TvSubst -> Bool
+isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope
+
+setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
+setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
+
+extendTvInScope :: TvSubst -> [Var] -> TvSubst
+extendTvInScope (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env
+
+extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst
+extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty)
+
+extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst
+extendTvSubstList (TvSubst in_scope env) tvs tys
+ = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys))
+
+-- mkTvSubst and zipTvSubst generate the in-scope set from
+-- the types given; but it's just a thunk so with a bit of luck
+-- it'll never be evaluated
+
+mkTvSubst :: TvSubstEnv -> TvSubst
+mkTvSubst env
+ = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
+
+zipTvSubst :: [TyVar] -> [Type] -> TvSubst
+zipTvSubst tyvars tys
+ = TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys)
+
+-- mkTopTvSubst is called when doing top-level substitutions.
+-- Here we expect that the free vars of the range of the
+-- substitution will be empty.
+mkTopTvSubst :: [(TyVar, Type)] -> TvSubst
+mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs)
+
+zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst
+zipTopTvSubst tyvars tys = TvSubst emptyInScopeSet (zipTyEnv tyvars tys)
+
+zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv
+zipTyEnv tyvars tys
+#ifdef DEBUG
+ | length tyvars /= length tys
+ = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv
+ | otherwise
+#endif
+ = zip_ty_env tyvars tys emptyVarEnv
+
+-- Later substitutions in the list over-ride earlier ones,
+-- but there should be no loops
+zip_ty_env [] [] env = env
+zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendVarEnv env tv ty)
+ -- There used to be a special case for when
+ -- ty == TyVarTy tv
+ -- (a not-uncommon case) in which case the substitution was dropped.
+ -- But the type-tidier changes the print-name of a type variable without
+ -- changing the unique, and that led to a bug. Why? Pre-tidying, we had
+ -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype.
+ -- And it happened that t was the type variable of the class. Post-tiding,
+ -- it got turned into {Foo t2}. The ext-core printer expanded this using
+ -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,
+ -- and so generated a rep type mentioning t not t2.
+ --
+ -- Simplest fix is to nuke the "optimisation"
+
+instance Outputable TvSubst where
+ ppr (TvSubst ins env)
+ = sep[ ptext SLIT("<TvSubst"),
+ nest 2 (ptext SLIT("In scope:") <+> ppr ins),
+ nest 2 (ptext SLIT("Env:") <+> ppr env) ]
+\end{code}
+
+%************************************************************************
+%* *
+ Performing type substitutions
+%* *
+%************************************************************************
+
+\begin{code}
+substTyWith :: [TyVar] -> [Type] -> Type -> Type
+substTyWith tvs tys = substTy (zipTvSubst tvs tys)
+
+substTy :: TvSubst -> Type -> Type
+substTy subst ty | isEmptyTvSubst subst = ty
+ | otherwise = subst_ty subst ty
+
+substTys :: TvSubst -> [Type] -> [Type]
+substTys subst tys | isEmptyTvSubst subst = tys
+ | otherwise = map (subst_ty subst) tys
+
+deShadowTy :: Type -> Type -- Remove any shadowing from the type
+deShadowTy ty = subst_ty emptyTvSubst ty
+
+substTheta :: TvSubst -> ThetaType -> ThetaType
+substTheta subst theta
+ | isEmptyTvSubst subst = theta
+ | otherwise = map (substPred subst) theta
+
+substPred :: TvSubst -> PredType -> PredType
+substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
+substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
+
+-- Note that the in_scope set is poked only if we hit a forall
+-- so it may often never be fully computed
+subst_ty subst@(TvSubst in_scope env) ty
+ = go ty
+ where
+ go ty@(TyVarTy tv) = case (lookupVarEnv env tv) of
+ Nothing -> ty
+ Just ty' -> ty' -- See Note [Apply Once]
+
+ go (TyConApp tc tys) = let args = map go tys
+ in args `seqList` TyConApp tc args
+
+ go (NewTcApp tc tys) = let args = map go tys
+ in args `seqList` NewTcApp tc args
+
+ go (PredTy p) = PredTy $! (substPred subst p)
+
+ go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
+ go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
+
+ go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
+ go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
+ -- The mkAppTy smart constructor is important
+ -- we might be replacing (a Int), represented with App
+ -- by [Int], represented with TyConApp
+ go (ForAllTy tv ty) = case substTyVar subst tv of
+ (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
+
+substTyVar :: TvSubst -> TyVar -> (TvSubst, TyVar)
+substTyVar subst@(TvSubst in_scope env) old_var
+ | old_var == new_var -- No need to clone
+ -- But we *must* zap any current substitution for the variable.
+ -- For example:
+ -- (\x.e) with id_subst = [x |-> e']
+ -- Here we must simply zap the substitution for x
+ --
+ -- The new_id isn't cloned, but it may have a different type
+ -- etc, so we must return it, not the old id
+ = (TvSubst (in_scope `extendInScopeSet` new_var) (delVarEnv env old_var),
+ new_var)
+
+ | otherwise -- The new binder is in scope so
+ -- we'd better rename it away from the in-scope variables
+ -- Extending the substitution to do this renaming also
+ -- has the (correct) effect of discarding any existing
+ -- substitution for that variable
+ = (TvSubst (in_scope `extendInScopeSet` new_var) (extendVarEnv env old_var (TyVarTy new_var)),
+ new_var)
+ where
+ new_var = uniqAway in_scope old_var
+ -- The uniqAway part makes sure the new variable is not already in scope
+\end{code}
+
+
PredType(..), -- to friends
Kind, ThetaType, -- Synonyms
- TyVarSubst,
funTyCon,
-- friends:
import Kind
-import Var ( Id, TyVar, tyVarKind )
-import VarEnv ( TyVarEnv )
+import Var ( Var, Id, TyVar, tyVarKind )
import VarSet ( TyVarSet )
import Name ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName )
import OccName ( mkOccFS, tcName )
import Class ( Class )
-- others
-import PrelNames ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey )
+import PrelNames ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey )
import Outputable
\end{code}
\begin{code}
-type TyVarSubst = TyVarEnv Type
-
data Type
= TyVarTy TyVar
| AppTy
- Type -- Function is *not* a TyConApp
- Type
+ Type -- Function is *not* a TyConApp or NewTcApp
+ Type -- It must be another AppTy, or TyVarTy
+ -- (or NoteTy of these)
| TyConApp -- Application of a TyCon
TyCon -- *Invariant* saturated appliations of FunTyCon and
--- /dev/null
+\begin{code}
+module Unify (
+ -- Matching and unification
+ matchTys, matchTyX, matchTysX,
+ unifyTys, unifyTysX,
+
+ tcRefineTys, tcMatchTys, tcMatchPreds, coreRefineTys,
+
+ -- Re-export
+ MaybeErr(..)
+ ) where
+
+#include "HsVersions.h"
+
+import Var ( Var, TyVar, tyVarKind )
+import VarEnv
+import VarSet
+import Kind ( isSubKind )
+import Type ( predTypeRep, newTypeRep, typeKind,
+ tyVarsOfType, tyVarsOfTypes,
+ TvSubstEnv, TvSubst(..), substTy )
+import TypeRep ( Type(..), PredType(..), funTyCon )
+import Util ( snocView )
+import ErrUtils ( Message )
+import Outputable
+import Maybes
+\end{code}
+
+
+%************************************************************************
+%* *
+ External interface
+%* *
+%************************************************************************
+
+\begin{code}
+----------------------------
+tcRefineTys, tcMatchTys
+ :: [TyVar] -- Try to unify these
+ -> TvSubstEnv -- Not idempotent
+ -> [Type] -> [Type]
+ -> MaybeErr TvSubstEnv Message -- Not idempotent
+-- This one is used by the type checker. Neither the input nor result
+-- substitition is idempotent
+tcRefineTys ex_tvs subst tys1 tys2
+ = initUM (tryToBind (mkVarSet ex_tvs)) (unify_tys Src subst tys1 tys2)
+
+tcMatchTys ex_tvs subst tys1 tys2
+ = initUM (bindOnly (mkVarSet ex_tvs)) (unify_tys Src subst tys1 tys2)
+
+tcMatchPreds
+ :: [TyVar] -- Bind these
+ -> [PredType] -> [PredType]
+ -> Maybe TvSubstEnv
+tcMatchPreds tvs preds1 preds2
+ = maybeErrToMaybe $ initUM (bindOnly (mkVarSet tvs)) $
+ unify_preds Src emptyVarEnv preds1 preds2
+
+----------------------------
+coreRefineTys :: [TyVar] -- Try to unify these
+ -> TvSubst -- A full-blown apply-once substitition
+ -> Type -- A fixed point of the incoming substitution
+ -> Type
+ -> Maybe TvSubstEnv -- In-scope set is unaffected
+-- Used by Core Lint and the simplifier. Takes a full apply-once substitution.
+-- The incoming substitution's in-scope set should mention all the variables free
+-- in the incoming types
+coreRefineTys ex_tvs subst@(TvSubst in_scope orig_env) ty1 ty2
+ = maybeErrToMaybe $ initUM (tryToBind (mkVarSet ex_tvs)) $
+ do { -- Apply the input substitution; nothing int ty2
+ let ty1' = substTy subst ty1
+ -- Run the unifier, starting with an empty env
+ ; extra_env <- unify Src emptyTvSubstEnv ty1' ty2
+
+ -- Find the fixed point of the resulting non-idempotent
+ -- substitution, and apply it to the
+ ; let extra_subst = TvSubst in_scope extra_env_fixpt
+ extra_env_fixpt = mapVarEnv (substTy extra_subst) extra_env
+ orig_env' = mapVarEnv (substTy extra_subst) orig_env
+ ; return (orig_env' `plusVarEnv` extra_env_fixpt) }
+
+
+----------------------------
+matchTys :: TyVarSet -- Template tyvars
+ -> [Type] -- Template
+ -> [Type] -- Target
+ -> Maybe TvSubstEnv -- Idempotent, because when matching
+ -- the range and domain are distinct
+
+-- PRE-CONDITION for matching: template variables are not free in the target
+
+matchTys tmpls tys1 tys2
+ = ASSERT2( not (intersectsVarSet tmpls (tyVarsOfTypes tys2)),
+ ppr tmpls $$ ppr tys1 $$ ppr tys2 )
+ maybeErrToMaybe $ initUM (bindOnly tmpls)
+ (unify_tys Src emptyTvSubstEnv tys1 tys2)
+
+matchTyX :: TyVarSet -- Template tyvars
+ -> TvSubstEnv -- Idempotent substitution to extend
+ -> Type -- Template
+ -> Type -- Target
+ -> Maybe TvSubstEnv -- Idempotent
+
+matchTyX tmpls env ty1 ty2
+ = ASSERT( not (intersectsVarSet tmpls (tyVarsOfType ty2)) )
+ maybeErrToMaybe $ initUM (bindOnly tmpls)
+ (unify Src env ty1 ty2)
+
+matchTysX :: TyVarSet -- Template tyvars
+ -> TvSubstEnv -- Idempotent substitution to extend
+ -> [Type] -- Template
+ -> [Type] -- Target
+ -> Maybe TvSubstEnv -- Idempotent
+
+matchTysX tmpls env tys1 tys2
+ = ASSERT( not (intersectsVarSet tmpls (tyVarsOfTypes tys2)) )
+ maybeErrToMaybe $ initUM (bindOnly tmpls)
+ (unify_tys Src env tys1 tys2)
+
+
+----------------------------
+unifyTys :: TyVarSet -> [Type] -> [Type] -> Maybe TvSubstEnv
+unifyTys bind_these tys1 tys2
+ = maybeErrToMaybe $ initUM (bindOnly bind_these) $
+ unify_tys Src emptyTvSubstEnv tys1 tys2
+
+unifyTysX :: TyVarSet -> TvSubstEnv -> [Type] -> [Type] -> Maybe TvSubstEnv
+unifyTysX bind_these subst tys1 tys2
+ = maybeErrToMaybe $ initUM (bindOnly bind_these) $
+ unify_tys Src subst tys1 tys2
+
+----------------------------
+tryToBind, bindOnly :: TyVarSet -> TyVar -> BindFlag
+tryToBind tv_set tv | tv `elemVarSet` tv_set = BindMe
+ | otherwise = AvoidMe
+
+bindOnly tv_set tv | tv `elemVarSet` tv_set = BindMe
+ | otherwise = DontBindMe
+
+emptyTvSubstEnv :: TvSubstEnv
+emptyTvSubstEnv = emptyVarEnv
+\end{code}
+
+
+%************************************************************************
+%* *
+ The workhorse
+%* *
+%************************************************************************
+
+\begin{code}
+unify :: SrcFlag -- True, unifying source types, false core types.
+ -> TvSubstEnv -- An existing substitution to extend
+ -> Type -> Type -- Types to be unified
+ -> UM TvSubstEnv -- Just the extended substitution,
+ -- Nothing if unification failed
+-- We do not require the incoming substitution to be idempotent,
+-- nor guarantee that the outgoing one is. That's fixed up by
+-- the wrappers.
+
+-- ToDo: remove debugging junk
+unify s subst ty1 ty2 = -- pprTrace "unify" (ppr subst <+> pprParendType ty1 <+> pprParendType ty2) $
+ unify_ s subst ty1 ty2
+
+-- Look through NoteTy in the obvious fashion
+unify_ s subst (NoteTy _ ty1) ty2 = unify s subst ty1 ty2
+unify_ s subst ty1 (NoteTy _ ty2) = unify s subst ty1 ty2
+
+-- In Core mode, look through NewTcApps and Preds
+unify_ Core subst (NewTcApp tc tys) ty2 = unify Core subst (newTypeRep tc tys) ty2
+unify_ Core subst ty1 (NewTcApp tc tys) = unify Core subst ty1 (newTypeRep tc tys)
+
+unify_ Core subst (PredTy p) ty2 = unify Core subst (predTypeRep p) ty2
+unify_ Core subst ty1 (PredTy p) = unify Core subst ty1 (predTypeRep p)
+
+-- From now on, any NewTcApps/Preds should be taken at face value
+
+unify_ s subst (TyVarTy tv1) ty2 = uVar s False subst tv1 ty2
+unify_ s subst ty1 (TyVarTy tv2) = uVar s True subst tv2 ty1
+
+unify_ s subst (PredTy p1) (PredTy p2) = unify_pred s subst p1 p2
+
+unify_ s subst t1@(TyConApp tyc1 tys1) t2@(TyConApp tyc2 tys2)
+ | tyc1 == tyc2 = unify_tys s subst tys1 tys2
+unify_ Src subst t1@(NewTcApp tc1 tys1) t2@(NewTcApp tc2 tys2)
+ | tc1 == tc2 = unify_tys Src subst tys1 tys2
+unify_ s subst (FunTy ty1a ty1b) (FunTy ty2a ty2b)
+ = do { subst' <- unify s subst ty1a ty2a
+ ; unify s subst' ty1b ty2b }
+
+ -- 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
+unify_ s subst (AppTy ty1a ty1b) ty2
+ | Just (ty2a, ty2b) <- unifySplitAppTy_maybe ty2
+ = do { subst' <- unify s subst ty1a ty2a
+ ; unify s subst' ty1b ty2b }
+
+unify_ s subst ty1 (AppTy ty2a ty2b)
+ | Just (ty1a, ty1b) <- unifySplitAppTy_maybe ty1
+ = do { subst' <- unify s subst ty1a ty2a
+ ; unify s subst' ty1b ty2b }
+
+unify_ s subst ty1 ty2 = failWith (misMatch ty1 ty2)
+
+------------------------------
+unify_pred s subst (ClassP c1 tys1) (ClassP c2 tys2)
+ | c1 == c2 = unify_tys s subst tys1 tys2
+unify_pred s subst (IParam n1 t1) (IParam n2 t2)
+ | n1 == n2 = unify s subst t1 t2
+
+------------------------------
+unifySplitAppTy_maybe :: Type -> Maybe (Type,Type)
+-- NoteTy is already dealt with; take NewTcApps at face value
+unifySplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
+unifySplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
+unifySplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
+ Just (tys', ty') -> Just (TyConApp tc tys', ty')
+ Nothing -> Nothing
+unifySplitAppTy_maybe (NewTcApp tc tys) = case snocView tys of
+ Just (tys', ty') -> Just (NewTcApp tc tys', ty')
+ Nothing -> Nothing
+unifySplitAppTy_maybe other = Nothing
+
+------------------------------
+unify_tys s = unifyList (unify s)
+
+unify_preds :: SrcFlag -> TvSubstEnv -> [PredType] -> [PredType] -> UM TvSubstEnv
+unify_preds s = unifyList (unify_pred s)
+
+unifyList :: Outputable a
+ => (TvSubstEnv -> a -> a -> UM TvSubstEnv)
+ -> TvSubstEnv -> [a] -> [a] -> UM TvSubstEnv
+unifyList unifier subst orig_xs orig_ys
+ = go subst orig_xs orig_ys
+ where
+ go subst [] [] = return subst
+ go subst (x:xs) (y:ys) = do { subst' <- unifier subst x y
+ ; go subst' xs ys }
+ go subst _ _ = failWith (lengthMisMatch orig_xs orig_ys)
+
+------------------------------
+uVar :: SrcFlag -- True, unifying source types, false core types.
+ -> Bool -- Swapped
+ -> TvSubstEnv -- An existing substitution to extend
+ -> TyVar -- Type variable to be unified
+ -> Type -- with this type
+ -> UM TvSubstEnv
+
+uVar s swap subst tv1 ty
+ = -- check to see whether tv1 is refined
+ case (lookupVarEnv subst tv1) of
+ -- yes, call back into unify'
+ Just ty' | swap -> unify s subst ty ty'
+ | otherwise -> unify s subst ty' ty
+ -- No, continue
+ Nothing -> uUnrefined subst tv1 ty
+
+
+uUnrefined :: TvSubstEnv -- An existing substitution to extend
+ -> TyVar -- Type variable to be unified
+ -> Type -- with this type
+ -> UM TvSubstEnv
+
+-- We know that tv1 isn't refined
+uUnrefined subst tv1 ty2@(TyVarTy tv2)
+ | tv1 == tv2 -- Same, do nothing
+ = return subst
+
+ -- Check to see whether tv2 is refined
+ | Just ty' <- lookupVarEnv subst tv2
+ = uUnrefined subst tv1 ty'
+
+ -- So both are unrefined; next, see if the kinds force the direction
+ | k1 == k2 -- Can update either; so check the bind-flags
+ = do { b1 <- tvBindFlag tv1
+ ; b2 <- tvBindFlag tv2
+ ; case (b1,b2) of
+ (DontBindMe, DontBindMe) -> failWith (misMatch ty1 ty2)
+ (DontBindMe, _) -> bindTv subst tv2 ty1
+ (BindMe, _) -> bindTv subst tv1 ty2
+ (AvoidMe, BindMe) -> bindTv subst tv2 ty1
+ (AvoidMe, _) -> bindTv subst tv1 ty2
+ }
+
+ | k1 `isSubKind` k2 -- Must update tv2
+ = do { b2 <- tvBindFlag tv2
+ ; case b2 of
+ DontBindMe -> failWith (misMatch ty1 ty2)
+ other -> bindTv subst tv2 ty1
+ }
+
+ | k2 `isSubKind` k1 -- Must update tv1
+ = do { b1 <- tvBindFlag tv1
+ ; case b1 of
+ DontBindMe -> failWith (misMatch ty1 ty2)
+ other -> bindTv subst tv1 ty2
+ }
+
+ | otherwise = failWith (kindMisMatch tv1 ty2)
+ where
+ ty1 = TyVarTy tv1
+ k1 = tyVarKind tv1
+ k2 = tyVarKind tv2
+
+uUnrefined subst tv1 ty2 -- ty2 is not a type variable
+ -- Do occurs check...
+ | tv1 `elemVarSet` substTvSet subst (tyVarsOfType ty2)
+ = failWith (occursCheck tv1 ty2)
+ -- And a kind check...
+ | k2 `isSubKind` k1
+ = do { b1 <- tvBindFlag tv1
+ ; case b1 of -- And check that tv1 is bindable
+ DontBindMe -> failWith (misMatch ty1 ty2)
+ other -> bindTv subst tv1 ty2
+ }
+ | otherwise
+ = pprTrace "kind" (ppr tv1 <+> ppr k1 $$ ppr ty2 <+> ppr k2) $
+ failWith (kindMisMatch tv1 ty2)
+ where
+ ty1 = TyVarTy tv1
+ k1 = tyVarKind tv1
+ k2 = typeKind ty2
+
+substTvSet :: TvSubstEnv -> TyVarSet -> TyVarSet
+-- Apply the non-idempotent substitution to a set of type variables,
+-- remembering that the substitution isn't necessarily idempotent
+substTvSet subst tvs
+ = foldVarSet (unionVarSet . get) emptyVarSet tvs
+ where
+ get tv = case lookupVarEnv subst tv of
+ Nothing -> unitVarSet tv
+ Just ty -> substTvSet subst (tyVarsOfType ty)
+
+bindTv subst tv ty = return (extendVarEnv subst tv ty)
+\end{code}
+
+%************************************************************************
+%* *
+ Unification monad
+%* *
+%************************************************************************
+
+\begin{code}
+data SrcFlag = Src | Core -- Unifying at the source level, or core level?
+
+data BindFlag = BindMe | AvoidMe | DontBindMe
+
+isCore Core = True
+isCore Src = False
+
+newtype UM a = UM { unUM :: (TyVar -> BindFlag)
+ -> MaybeErr a Message }
+
+instance Monad UM where
+ return a = UM (\tvs -> Succeeded a)
+ fail s = UM (\tvs -> Failed (text s))
+ m >>= k = UM (\tvs -> case unUM m tvs of
+ Failed err -> Failed err
+ Succeeded v -> unUM (k v) tvs)
+
+initUM :: (TyVar -> BindFlag) -> UM a -> MaybeErr a Message
+initUM badtvs um = unUM um badtvs
+
+tvBindFlag :: TyVar -> UM BindFlag
+tvBindFlag tv = UM (\tv_fn -> Succeeded (tv_fn tv))
+
+failWith :: Message -> UM a
+failWith msg = UM (\tv_fn -> Failed msg)
+
+maybeErrToMaybe :: MaybeErr succ fail -> Maybe succ
+maybeErrToMaybe (Succeeded a) = Just a
+maybeErrToMaybe (Failed m) = Nothing
+\end{code}
+
+
+%************************************************************************
+%* *
+ Error reporting
+ We go to a lot more trouble to tidy the types
+ in TcUnify. Maybe we'll end up having to do that
+ here too, but I'll leave it for now.
+%* *
+%************************************************************************
+
+\begin{code}
+misMatch t1 t2
+ = ptext SLIT("Can't match types") <+> quotes (ppr t1) <+>
+ ptext SLIT("and") <+> quotes (ppr t2)
+
+lengthMisMatch tys1 tys2
+ = sep [ptext SLIT("Can't match unequal length lists"),
+ nest 2 (ppr tys1), nest 2 (ppr tys2) ]
+
+kindMisMatch tv1 t2
+ = vcat [ptext SLIT("Can't match kinds") <+> quotes (ppr (tyVarKind tv1)) <+>
+ ptext SLIT("and") <+> quotes (ppr (typeKind t2)),
+ ptext SLIT("when matching") <+> quotes (ppr tv1) <+>
+ ptext SLIT("with") <+> quotes (ppr t2)]
+
+occursCheck tv ty
+ = hang (ptext SLIT("Can't construct the infinite type"))
+ 2 (ppr tv <+> equals <+> ppr ty)
+\end{code}
\ No newline at end of file
showSDocUnqual, showsPrecSDoc,
pprHsChar, pprHsString,
-
-- error handling
- pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
- trace, panic, panic#, assertPanic
+ pprPanic, assertPprPanic, pprPanic#, pprPgmError,
+ pprTrace, warnPprTrace,
+ trace, pgmError, panic, panic#, assertPanic
) where
#include "HsVersions.h"
%************************************************************************
\begin{code}
-pprPanic :: String -> SDoc -> a
-pprError :: String -> SDoc -> a
+pprPanic, pprPgmError :: String -> SDoc -> a
pprTrace :: String -> SDoc -> a -> a
-pprPanic = pprAndThen panic
-pprError = pprAndThen error
-pprTrace = pprAndThen trace
+pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
+
+pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
+ -- (used for unusual pgm errors)
+pprTrace = pprAndThen trace
pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
where
module Panic
(
GhcException(..), ghcError, progName,
+ pgmError,
panic, panic#, assertPanic, trace,
showException, showGhcException, tryMost,
- installSignalHandlers,
+ installSignalHandlers,
catchJust, tryJust, ioErrors, throwTo,
) where
Panics and asserts.
\begin{code}
-panic :: String -> a
-panic x = Exception.throwDyn (Panic x)
+panic, pgmError :: String -> a
+panic x = Exception.throwDyn (Panic x)
+pgmError x = Exception.throwDyn (ProgramError x)
-- #-versions because panic can't return an unboxed int, and that's
-- what TAG_ is with GHC at the moment. Ugh. (Simon)
-%
+%ilter
% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[UniqFM]{Specialised finite maps, for things with @Uniques@}
foldUFM,
mapUFM,
elemUFM,
- filterUFM,
+ filterUFM, filterUFM_Directly,
sizeUFM,
hashUFM,
isNullUFM,
foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
+filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
sizeUFM :: UniqFM elt -> Int
hashUFM :: UniqFM elt -> Int
FastInt -- the delta
(UniqFM ele)
(UniqFM ele)
+-- INVARIANT: the children of a NodeUFM are never EmptyUFMs
{-
-- for debugging only :-)
mapUFM fn fm = map_tree fn fm
filterUFM fn EmptyUFM = EmptyUFM
-filterUFM fn fm = filter_tree fn fm
+filterUFM fn fm = filter_tree pred fm
+ where
+ pred (i::FastInt) e = fn e
+
+filterUFM_Directly fn EmptyUFM = EmptyUFM
+filterUFM_Directly fn fm = filter_tree pred fm
+ where
+ pred i e = fn (mkUniqueGrimily (iBox i)) e
\end{code}
Note, this takes a long time, O(n), but
\end{code}
\begin{code}
+filter_tree :: (FastInt -> a -> Bool) -> UniqFM a -> UniqFM a
filter_tree f nd@(NodeUFM j p t1 t2)
= mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
filter_tree f lf@(LeafUFM i obj)
- | f obj = lf
+ | f i obj = lf
| otherwise = EmptyUFM
filter_tree f _ = panic "filter_tree failed"
\end{code}
projects / ghc-hetmet.git / commitdiff