Commit 5c89f880 authored by Sjoerd Visscher's avatar Sjoerd Visscher

Merge branch 'master' of git://git.haskell.org/ghc

Conflicts:
	docs/users_guide/flags.xml
parents 63e1f096 7ac600d5
{
"project.name" : "ghc",
"repository.callsign" : "GHC",
"phabricator.uri" : "https://phabricator.haskell.org"
}
......@@ -254,8 +254,9 @@ mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info
-- | Create a local 'Id' that is marked as exported.
-- This prevents things attached to it from being removed as dead code.
mkExportedLocalId :: Name -> Type -> Id
mkExportedLocalId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo
-- See Note [Exported LocalIds]
mkExportedLocalId :: IdDetails -> Name -> Type -> Id
mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo
-- Note [Free type variables]
......@@ -307,6 +308,40 @@ mkTemplateLocalsNum :: Int -> [Type] -> [Id]
mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
\end{code}
Note [Exported LocalIds]
~~~~~~~~~~~~~~~~~~~~~~~~
We use mkExportedLocalId for things like
- Dictionary functions (DFunId)
- Wrapper and matcher Ids for pattern synonyms
- Default methods for classes
- etc
They marked as "exported" in the sense that they should be kept alive
even if apparently unused in other bindings, and not dropped as dead
code by the occurrence analyser. (But "exported" here does not mean
"brought into lexical scope by an import declaration". Indeed these
things are always internal Ids that the user never sees.)
It's very important that they are *LocalIds*, not GlobalIs, for lots
of reasons:
* We want to treat them as free variables for the purpose of
dependency analysis (e.g. CoreFVs.exprFreeVars).
* Look them up in the current substitution when we come across
occurrences of them (in Subst.lookupIdSubst)
* Ensure that for dfuns that the specialiser does not float dict uses
above their defns, which would prevent good simplifications happening.
* The strictness analyser treats a occurrence of a GlobalId as
imported and assumes it contains strictness in its IdInfo, which
isn't true if the thing is bound in the same module as the
occurrence.
In CoreTidy we must make all these LocalIds into GlobalIds, so that in
importing modules (in --make mode) we treat them as properly global.
That is what is happening in, say tidy_insts in TidyPgm.
%************************************************************************
%* *
......
......@@ -67,7 +67,6 @@ import PrimOp
import ForeignCall
import DataCon
import Id
import Var ( mkExportedLocalVar )
import IdInfo
import Demand
import CoreSyn
......@@ -955,29 +954,13 @@ mkFCallId dflags uniq fcall ty
%* *
%************************************************************************
Important notes about dict funs and default methods
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [Dict funs and default methods]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dict funs and default methods are *not* ImplicitIds. Their definition
involves user-written code, so we can't figure out their strictness etc
based on fixed info, as we can for constructors and record selectors (say).
We build them as LocalIds, but with External Names. This ensures that
they are taken to account by free-variable finding and dependency
analysis (e.g. CoreFVs.exprFreeVars).
Why shouldn't they be bound as GlobalIds? Because, in particular, if
they are globals, the specialiser floats dict uses above their defns,
which prevents good simplifications happening. Also the strictness
analyser treats a occurrence of a GlobalId as imported and assumes it
contains strictness in its IdInfo, which isn't true if the thing is
bound in the same module as the occurrence.
It's OK for dfuns to be LocalIds, because we form the instance-env to
pass on to the next module (md_insts) in CoreTidy, afer tidying
and globalising the top-level Ids.
BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
that they aren't discarded by the occurrence analyser.
NB: See also Note [Exported LocalIds] in Id
\begin{code}
mkDictFunId :: Name -- Name to use for the dict fun;
......@@ -987,12 +970,12 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-> [Type]
-> Id
-- Implements the DFun Superclass Invariant (see TcInstDcls)
-- See Note [Dict funs and default methods]
mkDictFunId dfun_name tvs theta clas tys
= mkExportedLocalVar (DFunId n_silent is_nt)
dfun_name
dfun_ty
vanillaIdInfo
= mkExportedLocalId (DFunId n_silent is_nt)
dfun_name
dfun_ty
where
is_nt = isNewTyCon (classTyCon clas)
(n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
......
......@@ -32,6 +32,8 @@
module OccName (
-- * The 'NameSpace' type
NameSpace, -- Abstract
nameSpacesRelated,
-- ** Construction
-- $real_vs_source_data_constructors
......@@ -102,7 +104,10 @@ module OccName (
-- * Lexical characteristics of Haskell names
isLexCon, isLexVar, isLexId, isLexSym,
isLexConId, isLexConSym, isLexVarId, isLexVarSym,
startsVarSym, startsVarId, startsConSym, startsConId
startsVarSym, startsVarId, startsConSym, startsConId,
-- FsEnv
FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv
) where
import Util
......@@ -117,6 +122,29 @@ import Data.Char
import Data.Data
\end{code}
%************************************************************************
%* *
FastStringEnv
%* *
%************************************************************************
FastStringEnv can't be in FastString becuase the env depends on UniqFM
\begin{code}
type FastStringEnv a = UniqFM a -- Keyed by FastString
emptyFsEnv :: FastStringEnv a
lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a
extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a
mkFsEnv :: [(FastString,a)] -> FastStringEnv a
emptyFsEnv = emptyUFM
lookupFsEnv = lookupUFM
extendFsEnv = addToUFM
mkFsEnv = listToUFM
\end{code}
%************************************************************************
%* *
\subsection{Name space}
......@@ -246,6 +274,9 @@ instance Data OccName where
toConstr _ = abstractConstr "OccName"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "OccName"
instance HasOccName OccName where
occName = id
\end{code}
......@@ -341,6 +372,19 @@ demoteOccName (OccName space name) = do
space' <- demoteNameSpace space
return $ OccName space' name
-- Name spaces are related if there is a chance to mean the one when one writes
-- the other, i.e. variables <-> data construtors and type variables <-> type constructors
nameSpacesRelated :: NameSpace -> NameSpace -> Bool
nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2
otherNameSpace :: NameSpace -> NameSpace
otherNameSpace VarName = DataName
otherNameSpace DataName = VarName
otherNameSpace TvName = TcClsName
otherNameSpace TcClsName = TvName
{- | Other names in the compiler add aditional information to an OccName.
This class provides a consistent way to access the underlying OccName. -}
class HasOccName name where
......
......@@ -12,15 +12,18 @@ module PatSyn (
PatSyn, mkPatSyn,
-- ** Type deconstruction
patSynId, patSynType, patSynArity, patSynIsInfix,
patSynArgs, patSynTyDetails,
patSynName, patSynArity, patSynIsInfix,
patSynArgs, patSynTyDetails, patSynType,
patSynWrapper, patSynMatcher,
patSynExTyVars, patSynSig, patSynInstArgTys
patSynExTyVars, patSynSig,
patSynInstArgTys, patSynInstResTy,
tidyPatSynIds, patSynIds
) where
#include "HsVersions.h"
import Type
import TcType( mkSigmaTy )
import Name
import Outputable
import Unique
......@@ -28,8 +31,6 @@ import Util
import BasicTypes
import FastString
import Var
import Id
import TcType
import HsBinds( HsPatSynDetails(..) )
import qualified Data.Data as Data
......@@ -114,7 +115,7 @@ expression when available.
-- See Note [Pattern synonym representation]
data PatSyn
= MkPatSyn {
psId :: Id,
psName :: Name,
psUnique :: Unique, -- Cached from Name
psArgs :: [Type],
......@@ -125,7 +126,7 @@ data PatSyn
psExTyVars :: [TyVar], -- Existentially-quantified type vars
psProvTheta :: ThetaType, -- Provided dictionaries
psReqTheta :: ThetaType, -- Required dictionaries
psOrigResTy :: Type,
psOrigResTy :: Type, -- Mentions only psUnivTyVars
-- See Note [Matchers and wrappers for pattern synonyms]
psMatcher :: Id,
......@@ -167,7 +168,7 @@ instance Uniquable PatSyn where
getUnique = psUnique
instance NamedThing PatSyn where
getName = getName . psId
getName = patSynName
instance Outputable PatSyn where
ppr = ppr . getName
......@@ -208,7 +209,7 @@ mkPatSyn name declared_infix orig_args
prov_theta req_theta
orig_res_ty
matcher wrapper
= MkPatSyn {psId = id, psUnique = getUnique name,
= MkPatSyn {psName = name, psUnique = getUnique name,
psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
psProvTheta = prov_theta, psReqTheta = req_theta,
psInfix = declared_infix,
......@@ -217,20 +218,21 @@ mkPatSyn name declared_infix orig_args
psOrigResTy = orig_res_ty,
psMatcher = matcher,
psWrapper = wrapper }
where
pat_ty = mkSigmaTy univ_tvs req_theta $
mkSigmaTy ex_tvs prov_theta $
mkFunTys orig_args orig_res_ty
id = mkLocalId name pat_ty
\end{code}
\begin{code}
-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
patSynId :: PatSyn -> Id
patSynId = psId
patSynName :: PatSyn -> Name
patSynName = psName
patSynType :: PatSyn -> Type
patSynType = psOrigResTy
-- The full pattern type, used only in error messages
patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
, psExTyVars = ex_tvs, psProvTheta = prov_theta
, psArgs = orig_args, psOrigResTy = orig_res_ty })
= mkSigmaTy univ_tvs req_theta $
mkSigmaTy ex_tvs prov_theta $
mkFunTys orig_args orig_res_ty
-- | Should the 'PatSyn' be presented infix?
patSynIsInfix :: PatSyn -> Bool
......@@ -244,17 +246,20 @@ patSynArgs :: PatSyn -> [Type]
patSynArgs = psArgs
patSynTyDetails :: PatSyn -> HsPatSynDetails Type
patSynTyDetails ps = case (patSynIsInfix ps, patSynArgs ps) of
(True, [left, right]) -> InfixPatSyn left right
(_, tys) -> PrefixPatSyn tys
patSynTyDetails (MkPatSyn { psInfix = is_infix, psArgs = arg_tys })
| is_infix, [left,right] <- arg_tys
= InfixPatSyn left right
| otherwise
= PrefixPatSyn arg_tys
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars = psExTyVars
patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType)
patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType, [Type], Type)
patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
, psProvTheta = prov, psReqTheta = req })
= (univ_tvs, ex_tvs, prov, req)
, psProvTheta = prov, psReqTheta = req
, psArgs = arg_tys, psOrigResTy = res_ty })
= (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
patSynWrapper :: PatSyn -> Maybe Id
patSynWrapper = psWrapper
......@@ -262,12 +267,43 @@ patSynWrapper = psWrapper
patSynMatcher :: PatSyn -> Id
patSynMatcher = psMatcher
patSynIds :: PatSyn -> [Id]
patSynIds (MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
= case mb_wrap_id of
Nothing -> [match_id]
Just wrap_id -> [match_id, wrap_id]
tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
= ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id }
patSynInstArgTys :: PatSyn -> [Type] -> [Type]
patSynInstArgTys ps inst_tys
-- Return the types of the argument patterns
-- e.g. data D a = forall b. MkD a b (b->a)
-- pattern P f x y = MkD (x,True) y f
-- D :: forall a. forall b. a -> b -> (b->a) -> D a
-- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
-- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
-- NB: the inst_tys should be both universal and existential
patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
, psExTyVars = ex_tvs, psArgs = arg_tys })
inst_tys
= ASSERT2( length tyvars == length inst_tys
, ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
map (substTyWith tyvars inst_tys) (psArgs ps)
, ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
where
(univ_tvs, ex_tvs, _, _) = patSynSig ps
tyvars = univ_tvs ++ ex_tvs
patSynInstResTy :: PatSyn -> [Type] -> Type
-- Return the type of whole pattern
-- E.g. pattern P x y = Just (x,x,y)
-- P :: a -> b -> Just (a,a,b)
-- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
-- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
, psOrigResTy = res_ty })
inst_tys
= ASSERT2( length univ_tvs == length inst_tys
, ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
substTyWith univ_tvs inst_tys res_ty
\end{code}
......@@ -23,7 +23,6 @@ import Name
import TysWiredIn
import PrelNames
import TyCon
import Type
import SrcLoc
import UniqSet
import Util
......@@ -146,7 +145,7 @@ untidy b (L loc p) = L loc (untidy' b p)
untidy' _ p@(ConPatIn _ (PrefixCon [])) = p
untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps)))
untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing
untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty
untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys
untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"
untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
......@@ -470,8 +469,8 @@ get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
where
used_set :: UniqSet DataCon
used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons]
(ConPatOut { pat_ty = ty }) = head used_cons
Just (ty_con, inst_tys) = splitTyConApp_maybe ty
(ConPatOut { pat_con = L _ (RealDataCon con1), pat_arg_tys = inst_tys }) = head used_cons
ty_con = dataConTyCon con1
unused_cons = filterOut is_used (tyConDataCons ty_con)
is_used con = con `elementOfUniqSet` used_set
|| dataConCannotMatch inst_tys con
......@@ -595,9 +594,9 @@ make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)
| isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints)
where q = unLoc lq
make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_ty = ty }) (ps, constraints)
| isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints)
| isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints)
make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_arg_tys = tys }) (ps, constraints)
| isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) tys) : rest_pats, constraints)
| isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints)
| otherwise = (nlConPat name pats_con : rest_pats, constraints)
where
name = getName id
......@@ -698,17 +697,16 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat
tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
tidy_pat (ViewPat _ _ ty) = WildPat ty
tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty
tidy_pat (ConPatOut { pat_con = L _ PatSynCon{}, pat_ty = ty })
= WildPat ty
tidy_pat (ConPatOut { pat_con = L _ (PatSynCon syn), pat_arg_tys = tys })
= WildPat (patSynInstResTy syn tys)
tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps })
= pat { pat_args = tidy_con con ps }
tidy_pat (ListPat ps ty Nothing)
= unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
(mkNilPat list_ty)
= unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] [ty])
(mkNilPat ty)
(map tidy_lpat ps)
where list_ty = mkListTy ty
-- introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
......@@ -716,11 +714,11 @@ tidy_pat (ListPat ps ty Nothing)
tidy_pat (PArrPat ps ty)
= unLoc $ mkPrefixConPat (parrFakeCon (length ps))
(map tidy_lpat ps)
(mkPArrTy ty)
[ty]
tidy_pat (TuplePat ps boxity ty)
tidy_pat (TuplePat ps boxity tys)
= unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity)
(map tidy_lpat ps) ty
(map tidy_lpat ps) tys
where
arity = length ps
......@@ -737,8 +735,8 @@ tidy_lit_pat :: HsLit -> Pat Id
-- overlap with each other, or even explicit lists of Chars.
tidy_lit_pat lit
| HsString s <- lit
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
(mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
(mkPrefixConPat nilDataCon [] [charTy]) (unpackFS s)
| otherwise
= tidyLitPat lit
......
......@@ -52,8 +52,6 @@ import OrdList
import Data.List
import Data.IORef
import Control.Monad( when )
import Data.Maybe ( mapMaybe )
import UniqFM
\end{code}
%************************************************************************
......@@ -125,27 +123,20 @@ deSugar hsc_env
; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty
; let patsyn_defs = [(patSynId ps, ps) | ps <- patsyns]
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
, ds_fords `appendStubC` hpc_init
, patsyn_defs) }
, ds_fords `appendStubC` hpc_init) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, patsyn_defs) -> do
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
do { -- Add export flags to bindings
keep_alive <- readIORef keep_var
; let (rules_for_locals, rules_for_imps)
= partition isLocalRule all_rules
final_patsyns = addExportFlagsAndRules target export_set keep_alive [] patsyn_defs
exp_patsyn_wrappers = mapMaybe (patSynWrapper . snd) final_patsyns
exp_patsyn_matchers = map (patSynMatcher . snd) final_patsyns
keep_alive' = addListToUFM keep_alive (map (\x -> (x, getName x)) (exp_patsyn_wrappers ++ exp_patsyn_matchers))
final_prs = addExportFlagsAndRules target
export_set keep_alive' rules_for_locals (fromOL all_prs)
; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
final_prs = addExportFlagsAndRules target export_set keep_alive
rules_for_locals (fromOL all_prs)
final_pgm = combineEvBinds ds_ev_binds final_prs
-- Notice that we put the whole lot in a big Rec, even the foreign binds
......@@ -189,7 +180,7 @@ deSugar hsc_env
mg_fam_insts = fam_insts,
mg_inst_env = inst_env,
mg_fam_inst_env = fam_inst_env,
mg_patsyns = map snd . filter (isExportedId . fst) $ final_patsyns,
mg_patsyns = filter ((`elemNameSet` export_set) . patSynName) patsyns,
mg_rules = ds_rules_for_imps,
mg_binds = ds_binds,
mg_foreign = ds_fords,
......
......@@ -550,7 +550,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
, pat_dicts = eqs_vars ++ theta_vars
, pat_binds = emptyTcEvBinds
, pat_args = PrefixCon $ map nlVarPat arg_ids
, pat_ty = in_ty
, pat_arg_tys = in_inst_tys
, pat_wrap = idHsWrapper }
; let wrapped_rhs | null eq_spec = rhs
| otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs
......
......@@ -709,8 +709,7 @@ mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat pats box
= TuplePat pats box (mkTupleTy (boxityNormalTupleSort box) (map hsLPatType pats))
mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [Id] -> LHsExpr Id
......
......@@ -554,9 +554,8 @@ tidy1 v (LazyPat pat)
tidy1 _ (ListPat pats ty Nothing)
= return (idDsWrapper, unLoc list_ConPat)
where
list_ty = mkListTy ty
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
(mkNilPat list_ty)
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
(mkNilPat ty)
pats
-- Introduce fake parallel array constructors to be able to handle parallel
......@@ -565,13 +564,13 @@ tidy1 _ (PArrPat pats ty)
= return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
tidy1 _ (TuplePat pats boxity ty)
tidy1 _ (TuplePat pats boxity tys)
= return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty
tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys
-- LitPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (LitPat lit)
......
......@@ -125,7 +125,7 @@ matchOneConLike :: [Id]
-> [EquationInfo]
-> DsM (CaseAlt ConLike)
matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
= do { arg_vars <- selectConMatchVars arg_tys args1
= do { arg_vars <- selectConMatchVars val_arg_tys args1
-- Use the first equation as a source of
-- suggestions for the new variables
......@@ -141,27 +141,24 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
alt_wrapper = wrapper1,
alt_result = foldr1 combineMatchResults match_results } }
where
ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, pat_wrap = wrapper1,
ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
= firstPat eqn1
fields1 = case con1 of
RealDataCon dcon1 -> dataConFieldLabels dcon1
PatSynCon{} -> []
arg_tys = inst inst_tys
where
inst = case con1 of
RealDataCon dcon1 -> dataConInstOrigArgTys dcon1
PatSynCon psyn1 -> patSynInstArgTys psyn1
inst_tys = tcTyConAppArgs pat_ty1 ++
mkTyVarTys (takeList exVars tvs1)
-- Newtypes opaque, hence tcTyConAppArgs
RealDataCon dcon1 -> dataConFieldLabels dcon1
PatSynCon{} -> []
val_arg_tys = case con1 of
RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys
PatSynCon psyn1 -> patSynInstArgTys psyn1 inst_tys
inst_tys = ASSERT( tvs1 `equalLength` ex_tvs )
arg_tys ++ mkTyVarTys tvs1
-- dataConInstOrigArgTys takes the univ and existential tyvars
-- and returns the types of the *value* args, which is what we want
where
exVars = case con1 of
RealDataCon dcon1 -> dataConExTyVars dcon1
PatSynCon psyn1 -> patSynExTyVars psyn1
ex_tvs = case con1 of
RealDataCon dcon1 -> dataConExTyVars dcon1
PatSynCon psyn1 -> patSynExTyVars psyn1
match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
-- All members of the group have compatible ConArgPats
......@@ -179,7 +176,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_bind
, eqn { eqn_pats = conArgPats arg_tys args ++ pats }
, eqn { eqn_pats = conArgPats val_arg_tys args ++ pats }
)
shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
......
......@@ -266,8 +266,8 @@ tidyLitPat :: HsLit -> Pat Id
tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
tidyLitPat (HsString s)
| lengthFS s <= 1 -- Short string literals only
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
(mkNilPat stringTy) (unpackFS s)
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
(mkNilPat charTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
tidyLitPat lit = LitPat lit
......@@ -299,7 +299,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
| isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
......
......@@ -830,8 +830,8 @@ cvtp (TH.LitP l)
| otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
; return $ ConPatIn s' (PrefixCon ps') }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
......@@ -1158,7 +1158,7 @@ Consider this TH term construction:
; x3 <- TH.newName "x"
; let x = mkName "x" -- mkName :: String -> TH.Name
-- Builds a NameL
-- Builds a NameS
; return (LamE (..pattern [x1,x2]..) $
LamE (VarPat x3) $
......
......@@ -75,10 +75,13 @@ data Pat id
-- overall type of the pattern, and the toList
-- function to convert the scrutinee to a list value
| TuplePat [LPat id] -- Tuple
Boxity -- UnitPat is TuplePat []
PostTcType
-- You might think that the PostTcType was redundant, but it's essential
| TuplePat [LPat id] -- Tuple sub-patterns
Boxity -- UnitPat is TuplePat []
[PostTcType] -- [] before typechecker, filled in afterwards with
-- the types of the tuple components
-- You might think that the PostTcType was redundant, because we can
-- get the pattern type by getting the types of the sub-patterns.
-- But it's essential
-- data T a where
-- T1 :: Int -> T Int
-- f :: (T a, a) -> Int
......@@ -89,6 +92,8 @@ data Pat id
-- Note the (w::a), NOT (w::Int), because we have not yet
-- refined 'a' to Int. So we must know that the second component
-- of the tuple is of type 'a' not Int. See selectMatchVar
-- (June 14: I'm not sure this comment is right; the sub-patterns
-- will be wrapped in CoPats, no?)
| PArrPat [LPat id] -- Syntactic parallel array
PostTcType -- The type of the elements
......@@ -98,14 +103,18 @@ data Pat id
(HsConPatDetails id)
| ConPatOut {
pat_con :: Located ConLike,
pat_con :: Located ConLike,
pat_arg_tys :: [Type], -- The univeral arg types, 1-1 with the universal
-- tyvars of the constructor/pattern synonym
-- Use (conLikeResTy pat_con pat_arg_tys) to get
-- the type of the pattern
pat_tvs :: [TyVar], -- Existentially bound type variables (tyvars only)
pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries*
-- One reason for putting coercion variable here, I think,
-- is to ensure their kinds are zonked
pat_binds :: TcEvBinds, -- Bindings involving those dictionaries
pat_args :: HsConPatDetails id,
pat_ty :: Type, -- The type of the pattern
pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher
}
......@@ -313,18 +322,18 @@ instance (OutputableBndr id, Outputable arg)
%************************************************************************
\begin{code}
mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
-- Make a vanilla Prefix constructor pattern
mkPrefixConPat dc pats ty
mkPrefixConPat dc pats tys
= noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
pat_ty = ty, pat_wrap = idHsWrapper }
pat_arg_tys = tys, pat_wrap = idHsWrapper }
mkNilPat :: Type -> OutPat id
mkNilPat ty = mkPrefixConPat nilDataCon [] ty
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]