diff options
| author | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-01-13 20:12:34 +0800 |
|---|---|---|
| committer | Austin Seipp <austin@well-typed.com> | 2014-01-20 11:30:22 -0600 |
| commit | 4f8369bf47d27b11415db251e816ef1a2e1eb3d8 (patch) | |
| tree | 61437b3b947951aace16f66379c462f2374fc709 | |
| parent | 59cb44a3ee4b25fce6dc19816e9647e92e5ff743 (diff) | |
| download | haskell-4f8369bf47d27b11415db251e816ef1a2e1eb3d8.tar.gz | |
Implement pattern synonyms
This patch implements Pattern Synonyms (enabled by -XPatternSynonyms),
allowing y ou to assign names to a pattern and abstract over it.
The rundown is this:
* Named patterns are introduced by the new 'pattern' keyword, and can
be either *unidirectional* or *bidirectional*. A unidirectional
pattern is, in the simplest sense, simply an 'alias' for a pattern,
where the LHS may mention variables to occur in the RHS. A
bidirectional pattern synonym occurs when a pattern may also be used
in expression context.
* Unidirectional patterns are declared like thus:
pattern P x <- x:_
The synonym 'P' may only occur in a pattern context:
foo :: [Int] -> Maybe Int
foo (P x) = Just x
foo _ = Nothing
* Bidirectional patterns are declared like thus:
pattern P x y = [x, y]
Here, P may not only occur as a pattern, but also as an expression
when given values for 'x' and 'y', i.e.
bar :: Int -> [Int]
bar x = P x 10
* Patterns can't yet have their own type signatures; signatures are inferred.
* Pattern synonyms may not be recursive, c.f. type synonyms.
* Pattern synonyms are also exported/imported using the 'pattern'
keyword in an import/export decl, i.e.
module Foo (pattern Bar) where ...
Note that pattern synonyms share the namespace of constructors, so
this disambiguation is required as a there may also be a 'Bar'
type in scope as well as the 'Bar' pattern.
* The semantics of a pattern synonym differ slightly from a typical
pattern: when using a synonym, the pattern itself is matched,
followed by all the arguments. This means that the strictness
differs slightly:
pattern P x y <- [x, y]
f (P True True) = True
f _ = False
g [True, True] = True
g _ = False
In the example, while `g (False:undefined)` evaluates to False,
`f (False:undefined)` results in undefined as both `x` and `y`
arguments are matched to `True`.
For more information, see the wiki:
https://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms
https://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms/Implementation
Reviewed-by: Simon Peyton Jones <simonpj@microsoft.com>
Signed-off-by: Austin Seipp <austin@well-typed.com>
99 files changed, 2341 insertions, 487 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 71dc6c7df2..cb90fc9979 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -35,6 +35,7 @@ module BasicTypes( compareFixity, RecFlag(..), isRec, isNonRec, boolToRecFlag, + Origin(..), isGenerated, RuleName, @@ -419,6 +420,25 @@ instance Outputable RecFlag where %************************************************************************ %* * + Code origin +%* * +%************************************************************************ +\begin{code} +data Origin = FromSource + | Generated + deriving( Eq, Data, Typeable ) + +isGenerated :: Origin -> Bool +isGenerated Generated = True +isGenerated FromSource = False + +instance Outputable Origin where + ppr FromSource = ptext (sLit "FromSource") + ppr Generated = ptext (sLit "Generated") +\end{code} + +%************************************************************************ +%* * Instance overlap flag %* * %************************************************************************ diff --git a/compiler/basicTypes/ConLike.lhs b/compiler/basicTypes/ConLike.lhs new file mode 100644 index 0000000000..de10d0fb0a --- /dev/null +++ b/compiler/basicTypes/ConLike.lhs @@ -0,0 +1,82 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% +\section[ConLike]{@ConLike@: Constructor-like things} + +\begin{code} + +module ConLike ( + ConLike(..) + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DataCon (DataCon) +import {-# SOURCE #-} PatSyn (PatSyn) +import Outputable +import Unique +import Util +import Name + +import Data.Function (on) +import qualified Data.Data as Data +import qualified Data.Typeable +\end{code} + + +%************************************************************************ +%* * +\subsection{Constructor-like things} +%* * +%************************************************************************ + +\begin{code} +-- | A constructor-like thing +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + deriving Data.Typeable.Typeable +\end{code} + +%************************************************************************ +%* * +\subsection{Instances} +%* * +%************************************************************************ + +\begin{code} +instance Eq ConLike where + (==) = (==) `on` getUnique + (/=) = (/=) `on` getUnique + +instance Ord ConLike where + (<=) = (<=) `on` getUnique + (<) = (<) `on` getUnique + (>=) = (>=) `on` getUnique + (>) = (>) `on` getUnique + compare = compare `on` getUnique + +instance Uniquable ConLike where + getUnique (RealDataCon dc) = getUnique dc + getUnique (PatSynCon ps) = getUnique ps + +instance NamedThing ConLike where + getName (RealDataCon dc) = getName dc + getName (PatSynCon ps) = getName ps + +instance Outputable ConLike where + ppr (RealDataCon dc) = ppr dc + ppr (PatSynCon ps) = ppr ps + +instance OutputableBndr ConLike where + pprInfixOcc (RealDataCon dc) = pprInfixOcc dc + pprInfixOcc (PatSynCon ps) = pprInfixOcc ps + pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc + pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps + +instance Data.Data ConLike where + -- don't traverse? + toConstr _ = abstractConstr "ConLike" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ConLike" +\end{code} diff --git a/compiler/basicTypes/DataCon.lhs-boot b/compiler/basicTypes/DataCon.lhs-boot index 6f9a3858f9..08920ccf64 100644 --- a/compiler/basicTypes/DataCon.lhs-boot +++ b/compiler/basicTypes/DataCon.lhs-boot @@ -1,13 +1,20 @@ \begin{code} module DataCon where -import Name( Name ) +import Name( Name, NamedThing ) import {-# SOURCE #-} TyCon( TyCon ) +import Unique ( Uniquable ) +import Outputable ( Outputable, OutputableBndr ) data DataCon data DataConRep dataConName :: DataCon -> Name dataConTyCon :: DataCon -> TyCon isVanillaDataCon :: DataCon -> Bool + instance Eq DataCon instance Ord DataCon +instance Uniquable DataCon +instance NamedThing DataCon +instance Outputable DataCon +instance OutputableBndr DataCon \end{code} diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 9c3161263d..6dbae4bb61 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -58,7 +58,7 @@ module OccName ( -- ** Derived 'OccName's isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, + mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, @@ -570,7 +570,7 @@ isDerivedOccName occ = \end{code} \begin{code} -mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, +mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkGenD, mkGenR, mkGen1R, mkGenRCo, @@ -582,6 +582,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, -- These derived variables have a prefix that no Haskell value could have mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkWorkerOcc = mk_simple_deriv varName "$w" +mkMatcherOcc = mk_simple_deriv varName "$m" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" mkGenDefMethodOcc = mk_simple_deriv varName "$gdm" mkClassOpAuxOcc = mk_simple_deriv varName "$c" diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs new file mode 100644 index 0000000000..9285b3c365 --- /dev/null +++ b/compiler/basicTypes/PatSyn.lhs @@ -0,0 +1,225 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% +\section[PatSyn]{@PatSyn@: Pattern synonyms} + +\begin{code} + +module PatSyn ( + -- * Main data types + PatSyn, mkPatSyn, + + -- ** Type deconstruction + patSynId, patSynType, patSynArity, patSynIsInfix, + patSynArgs, patSynArgTys, patSynTyDetails, + patSynWrapper, patSynMatcher, + patSynExTyVars, patSynSig, patSynInstArgTys + ) where + +#include "HsVersions.h" + +import Type +import Name +import Outputable +import Unique +import Util +import BasicTypes +import FastString +import Var +import Id +import TcType +import HsBinds( HsPatSynDetails(..) ) + +import qualified Data.Data as Data +import qualified Data.Typeable +import Data.Function +\end{code} + + +Pattern synonym representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following pattern synonym declaration + + pattern P x = MkT [x] (Just 42) + +where + data T a where + MkT :: (Show a, Ord b) => [b] -> a -> T a + +so pattern P has type + + b -> T (Maybe t) + +with the following typeclass constraints: + + provides: (Show (Maybe t), Ord b) + requires: (Eq t, Num t) + +In this case, the fields of MkPatSyn will be set as follows: + + psArgs = [x :: b] + psArity = 1 + psInfix = False + + psUnivTyVars = [t] + psExTyVars = [b] + psTheta = ((Show (Maybe t), Ord b), (Eq t, Num t)) + psOrigResTy = T (Maybe t) + + +%************************************************************************ +%* * +\subsection{Pattern synonyms} +%* * +%************************************************************************ + +\begin{code} +-- | A pattern synonym +data PatSyn + = MkPatSyn { + psId :: Id, + psUnique :: Unique, -- Cached from Name + psMatcher :: Id, + psWrapper :: Maybe Id, + + psArgs :: [Var], + psArity :: Arity, -- == length psArgs + psInfix :: Bool, -- True <=> declared infix + + psUnivTyVars :: [TyVar], -- Universially-quantified type variables + psExTyVars :: [TyVar], -- Existentially-quantified type vars + psTheta :: (ThetaType, ThetaType), -- Provided and required dictionaries + psOrigResTy :: Type + } + deriving Data.Typeable.Typeable +\end{code} + +%************************************************************************ +%* * +\subsection{Instances} +%* * +%************************************************************************ + +\begin{code} +instance Eq PatSyn where + (==) = (==) `on` getUnique + (/=) = (/=) `on` getUnique + +instance Ord PatSyn where + (<=) = (<=) `on` getUnique + (<) = (<) `on` getUnique + (>=) = (>=) `on` getUnique + (>) = (>) `on` getUnique + compare = compare `on` getUnique + +instance Uniquable PatSyn where + getUnique = psUnique + +instance NamedThing PatSyn where + getName = getName . psId + +instance Outputable PatSyn where + ppr = ppr . getName + +instance OutputableBndr PatSyn where + pprInfixOcc = pprInfixName . getName + pprPrefixOcc = pprPrefixName . getName + +instance Data.Data PatSyn where + -- don't traverse? + toConstr _ = abstractConstr "PatSyn" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "PatSyn" +\end{code} + + +%************************************************************************ +%* * +\subsection{Construction} +%* * +%************************************************************************ + +\begin{code} +-- | Build a new pattern synonym +mkPatSyn :: Name + -> Bool -- ^ Is the pattern synonym declared infix? + -> [Var] -- ^ Original arguments + -> [TyVar] -- ^ Universially-quantified type variables + -> [TyVar] -- ^ Existentially-quantified type variables + -> ThetaType -- ^ Wanted dicts + -> ThetaType -- ^ Given dicts + -> Type -- ^ Original result type + -> Id -- ^ Name of matcher + -> Maybe Id -- ^ Name of wrapper + -> PatSyn +mkPatSyn name declared_infix orig_args + univ_tvs ex_tvs + prov_theta req_theta + orig_res_ty + matcher wrapper + = MkPatSyn {psId = id, psUnique = getUnique name, + psUnivTyVars = univ_tvs, psExTyVars = ex_tvs, + psTheta = (prov_theta, req_theta), + psInfix = declared_infix, + psArgs = orig_args, + psArity = length orig_args, + psOrigResTy = orig_res_ty, + psMatcher = matcher, + psWrapper = wrapper } + where + pat_ty = mkSigmaTy univ_tvs req_theta $ + mkSigmaTy ex_tvs prov_theta $ + mkFunTys (map varType 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 + +patSynType :: PatSyn -> Type +patSynType = psOrigResTy + +-- | Should the 'PatSyn' be presented infix? +patSynIsInfix :: PatSyn -> Bool +patSynIsInfix = psInfix + +-- | Arity of the pattern synonym +patSynArity :: PatSyn -> Arity +patSynArity = psArity + +patSynArgs :: PatSyn -> [Var] +patSynArgs = psArgs + +patSynArgTys :: PatSyn -> [Type] +patSynArgTys = map varType . patSynArgs + +patSynTyDetails :: PatSyn -> HsPatSynDetails Type +patSynTyDetails ps = case (patSynIsInfix ps, patSynArgTys ps) of + (True, [left, right]) -> InfixPatSyn left right + (_, tys) -> PrefixPatSyn tys + +patSynExTyVars :: PatSyn -> [TyVar] +patSynExTyVars = psExTyVars + +patSynSig :: PatSyn -> ([TyVar], [TyVar], (ThetaType, ThetaType)) +patSynSig ps = (psUnivTyVars ps, psExTyVars ps, psTheta ps) + +patSynWrapper :: PatSyn -> Maybe Id +patSynWrapper = psWrapper + +patSynMatcher :: PatSyn -> Id +patSynMatcher = psMatcher + +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +patSynInstArgTys ps inst_tys + = ASSERT2( length tyvars == length inst_tys + , ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys + where + (univ_tvs, ex_tvs, _) = patSynSig ps + arg_tys = map varType (psArgs ps) + tyvars = univ_tvs ++ ex_tvs +\end{code} diff --git a/compiler/basicTypes/PatSyn.lhs-boot b/compiler/basicTypes/PatSyn.lhs-boot new file mode 100644 index 0000000000..0bb85e9413 --- /dev/null +++ b/compiler/basicTypes/PatSyn.lhs-boot @@ -0,0 +1,19 @@ +\begin{code} +module PatSyn where +import Name( NamedThing ) +import Data.Typeable ( Typeable ) +import Data.Data ( Data ) +import Outputable ( Outputable, OutputableBndr ) +import Unique ( Uniquable ) + +data PatSyn + +instance Eq PatSyn +instance Ord PatSyn +instance NamedThing PatSyn +instance Outputable PatSyn +instance OutputableBndr PatSyn +instance Uniquable PatSyn +instance Typeable PatSyn +instance Data PatSyn +\end{code} diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 76a8c0136b..960475cedd 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -14,7 +14,9 @@ import TcHsSyn import DsUtils import MatchLit import Id +import ConLike import DataCon +import PatSyn import Name import TysWiredIn import PrelNames @@ -310,6 +312,7 @@ same constructor. \begin{code} split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) split_by_constructor qs + | null used_cons = ([], mkUniqSet $ map fst qs) | notNull unused_cons = need_default_case used_cons unused_cons qs | otherwise = no_need_default_case used_cons qs where @@ -410,8 +413,11 @@ make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) = takeList (tail pats) (repeat nlWildPat) compare_cons :: Pat Id -> Pat Id -> Bool -compare_cons (ConPatOut{ pat_con = L _ id1 }) (ConPatOut { pat_con = L _ id2 }) = id1 == id2 -compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut" +compare_cons (ConPatOut{ pat_con = L _ con1 }) (ConPatOut{ pat_con = L _ con2 }) + = case (con1, con2) of + (RealDataCon id1, RealDataCon id2) -> id1 == id2 + _ -> False +compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut with RealDataCon" remove_dups :: [Pat Id] -> [Pat Id] remove_dups [] = [] @@ -423,8 +429,8 @@ get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q, isConPatOut pat] isConPatOut :: Pat Id -> Bool -isConPatOut (ConPatOut {}) = True -isConPatOut _ = False +isConPatOut ConPatOut{ pat_con = L _ RealDataCon{} } = True +isConPatOut _ = False remove_dups' :: [HsLit] -> [HsLit] remove_dups' [] = [] @@ -461,7 +467,7 @@ get_unused_cons :: [Pat Id] -> [DataCon] 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 _ d} <- used_cons] + 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 unused_cons = filterOut is_used (tyConDataCons ty_con) @@ -512,10 +518,10 @@ is_var :: Pat Id -> Bool is_var (WildPat _) = True is_var _ = False -is_var_con :: DataCon -> Pat Id -> Bool -is_var_con _ (WildPat _) = True -is_var_con con (ConPatOut{ pat_con = L _ id }) | id == con = True -is_var_con _ _ = False +is_var_con :: ConLike -> Pat Id -> Bool +is_var_con _ (WildPat _) = True +is_var_con con (ConPatOut{ pat_con = L _ id }) = id == con +is_var_con _ _ = False is_var_lit :: HsLit -> Pat Id -> Bool is_var_lit _ (WildPat _) = True @@ -582,12 +588,12 @@ make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing make_list _ _ = panic "Check.make_list: Invalid argument" make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat -make_con (ConPatOut{ pat_con = L _ id }) (lp:lq:ps, constraints) +make_con (ConPatOut{ pat_con = L _ (RealDataCon 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 q = unLoc lq -make_con (ConPatOut{ pat_con = L _ id, pat_args = PrefixCon pats, pat_ty = ty }) (ps, constraints) +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) | otherwise = (nlConPat name pats_con : rest_pats, constraints) @@ -640,6 +646,7 @@ might_fail_pat :: Pat Id -> Bool -- that is not covered by the checking algorithm. Specifically: -- NPlusKPat -- ViewPat (if refutable) +-- ConPatOut of a PatSynCon -- First the two special cases might_fail_pat (NPlusKPat {}) = True @@ -654,7 +661,10 @@ might_fail_pat (ListPat _ _ (Just _)) = True might_fail_pat (TuplePat ps _ _) = any might_fail_lpat ps might_fail_pat (PArrPat ps _) = any might_fail_lpat ps might_fail_pat (BangPat p) = might_fail_lpat p -might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs ps) +might_fail_pat (ConPatOut { pat_con = con, pat_args = ps }) + = case unLoc con of + RealDataCon _dcon -> any might_fail_lpat (hsConPatArgs ps) + PatSynCon _psyn -> True -- Finally the ones that are sure to succeed, or which are covered by the checking algorithm might_fail_pat (LazyPat _) = False -- Always succeeds @@ -686,9 +696,11 @@ 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 pat@(ConPatOut { pat_con = L _ id, pat_args = ps }) - = pat { pat_args = tidy_con id ps } +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) @@ -729,16 +741,22 @@ tidy_lit_pat lit = tidyLitPat lit ----------------- -tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id +tidy_con :: ConLike -> HsConPatDetails Id -> HsConPatDetails Id tidy_con _ (PrefixCon ps) = PrefixCon (map tidy_lpat ps) tidy_con _ (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2] tidy_con con (RecCon (HsRecFields fs _)) - | null fs = PrefixCon [nlWildPat | _ <- dataConOrigArgTys con] + | null fs = PrefixCon (replicate arity nlWildPat) -- Special case for null patterns; maybe not a record at all | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats) where + arity = case con of + RealDataCon dcon -> dataConSourceArity dcon + PatSynCon psyn -> patSynArity psyn + -- pad out all the missing fields with WildPats. - field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con) + field_pats = case con of + RealDataCon dc -> map (\ f -> (f, nlWildPat)) (dataConFieldLabels dc) + PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax" all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc) field_pats fs diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index e3e2bfc915..0ac7de8022 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -117,7 +117,7 @@ guessSourceFile :: LHsBinds Id -> FilePath -> FilePath guessSourceFile binds orig_file = -- Try look for a file generated from a .hsc file to a -- .hs file, by peeking ahead. - let top_pos = catMaybes $ foldrBag (\ (L pos _) rest -> + let top_pos = catMaybes $ foldrBag (\ (_, (L pos _)) rest -> srcSpanFileName_maybe pos : rest) [] binds in case top_pos of @@ -229,7 +229,11 @@ shouldTickPatBind density top_lev -- Adding ticks to bindings addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id) -addTickLHsBinds binds = mapBagM addTickLHsBind binds +addTickLHsBinds binds = mapBagM addTick binds + where + addTick (origin, bind) = do + bind' <- addTickLHsBind bind + return (origin, bind') addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, @@ -325,6 +329,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do -- Only internal stuff, not from source, uses VarBind, so we ignore it. addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind +addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 7ef407b10c..e13767ff59 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -21,6 +21,7 @@ import FamInstEnv import InstEnv import Class import Avail +import PatSyn import CoreSyn import CoreSubst import PprCore @@ -45,6 +46,8 @@ import OrdList import Data.List import Data.IORef import Control.Monad( when ) +import Data.Maybe ( mapMaybe ) +import UniqFM \end{code} %************************************************************************ @@ -80,6 +83,7 @@ deSugar hsc_env tcg_fords = fords, tcg_rules = rules, tcg_vects = vects, + tcg_patsyns = patsyns, tcg_tcs = tcs, tcg_insts = insts, tcg_fam_insts = fam_insts, @@ -115,21 +119,27 @@ 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 ) } + , ds_fords `appendStubC` hpc_init + , patsyn_defs) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> + Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, patsyn_defs) -> 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) + 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 @@ -173,6 +183,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_rules = ds_rules_for_imps, mg_binds = ds_binds, mg_foreign = ds_fords, diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index f507f19fc9..cd683ba365 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -95,9 +95,13 @@ ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds ; return (foldBag appOL id nilOL ds_bs) } -dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr)) -dsLHsBind (L loc bind) - = putSrcSpanDs loc $ dsHsBind bind +dsLHsBind :: (Origin, LHsBind Id) -> DsM (OrdList (Id,CoreExpr)) +dsLHsBind (origin, L loc bind) + = handleWarnings $ putSrcSpanDs loc $ dsHsBind bind + where + handleWarnings = if isGenerated origin + then discardWarningsDs + else id dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr)) @@ -211,6 +215,8 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts add_inline :: Id -> Id -- tran add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id +dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind" + ------------------------ makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) makeCorePair dflags gbl_id is_default_method dict_arity rhs diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 1fda49b567..546a198ca8 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -47,6 +47,7 @@ import Id import Module import VarSet import VarEnv +import ConLike import DataCon import TysWiredIn import BasicTypes @@ -98,7 +99,7 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body - | [L loc bind] <- bagToList hsbinds, + | [(_, L loc bind)] <- bagToList hsbinds, -- Non-recursive, non-overloaded bindings only come in ones -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes @@ -132,7 +133,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] , abs_binds = binds }) body = do { let body1 = foldr bind_export body exports bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b - ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) + ; body2 <- foldlBagM (\body (_, bind) -> dsStrictBind (unLoc bind) body) body1 binds ; ds_binds <- dsTcEvBinds ev_binds ; return (mkCoreLets ds_binds body2) } @@ -163,7 +164,7 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) ---------------------- strictMatchOnly :: HsBind Id -> Bool strictMatchOnly (AbsBinds { abs_binds = binds }) - = anyBag (strictMatchOnly . unLoc) binds + = anyBag (strictMatchOnly . unLoc . snd) binds strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty }) = isUnLiftedType ty || isBangLPat lpat @@ -542,11 +543,13 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ] - pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs + pat = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon con) + , pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars , pat_binds = emptyTcEvBinds , pat_args = PrefixCon $ map nlVarPat arg_ids - , pat_ty = in_ty } + , pat_ty = in_ty + , pat_wrap = idHsWrapper } ; let wrapped_rhs | null eq_spec = rhs | otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs ; return (mkSimpleMatch [pat] wrapped_rhs) } diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 0ee963ec44..56fba1434f 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1196,7 +1196,7 @@ rep_binds binds = do { binds_w_locs <- rep_binds' binds ; return (de_loc (sort_by_loc binds_w_locs)) } rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] -rep_binds' binds = mapM rep_bind (bagToList binds) +rep_binds' binds = mapM (rep_bind . snd) (bagToList binds) rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are alrady in the meta-env @@ -1238,7 +1238,7 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) ; return (srcLocSpan (getSrcLoc v), ans) } rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" - +rep_bind (L _ (PatSynBind {})) = panic "rep_bind: PatSynBind" ----------------------------------------------------------------------------- -- Since everything in a Bind is mutually recursive we need rename all -- all the variables simultaneously. For example: diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index e97ab4e8bd..b590f4b2d2 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -29,7 +29,7 @@ module DsMonad ( DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, -- Warnings - DsWarning, warnDs, failWithDs, + DsWarning, warnDs, failWithDs, discardWarningsDs, -- Data types DsMatchContext(..), @@ -495,3 +495,19 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a dsExtendMetaEnv menv thing_inside = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside \end{code} + +\begin{code} +discardWarningsDs :: DsM a -> DsM a +-- Ignore warnings inside the thing inside; +-- used to ignore inaccessable cases etc. inside generated code +discardWarningsDs thing_inside + = do { env <- getGblEnv + ; old_msgs <- readTcRef (ds_msgs env) + + ; result <- thing_inside + + -- Revert messages to old_msgs + ; writeTcRef (ds_msgs env) old_msgs + + ; return result } +\end{code} diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 55eefc70f7..2ad70c67d3 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -20,13 +20,13 @@ module DsUtils ( EquationInfo(..), firstPat, shiftEqns, - MatchResult(..), CanItFail(..), + MatchResult(..), CanItFail(..), CaseAlt(..), cantFailMatchResult, alwaysFailMatchResult, extractMatchResult, combineMatchResults, adjustMatchResult, adjustMatchResultDs, mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, matchCanFail, mkEvalMatchResult, - mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, + mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, wrapBind, wrapBinds, mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, @@ -52,6 +52,7 @@ import TcHsSyn import TcType( tcSplitTyConApp ) import CoreSyn import DsMonad +import {-# SOURCE #-} DsExpr ( dsLExpr ) import CoreUtils import MkCore @@ -59,7 +60,9 @@ import MkId import Id import Literal import TyCon +import ConLike import DataCon +import PatSyn import Type import Coercion import TysPrim @@ -75,6 +78,8 @@ import Util import DynFlags import FastString +import TcEvidence + import Control.Monad ( zipWithM ) \end{code} @@ -272,72 +277,43 @@ mkCoPrimCaseMatchResult var ty match_alts do body <- body_fn fail return (LitAlt lit, [], body) +data CaseAlt a = MkCaseAlt{ alt_pat :: a, + alt_bndrs :: [CoreBndr], + alt_wrapper :: HsWrapper, + alt_result :: MatchResult } mkCoAlgCaseMatchResult :: DynFlags - -> Id -- Scrutinee - -> Type -- Type of exp - -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts) + -> Id -- Scrutinee + -> Type -- Type of exp + -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts) -> MatchResult mkCoAlgCaseMatchResult dflags var ty match_alts - | isNewTyCon tycon -- Newtype case; use a let + | isNewtype -- Newtype case; use a let = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) mkCoLetMatchResult (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 + | isPArrFakeAlts match_alts + = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts) + | otherwise + = mkDataConCase var ty match_alts where - tycon = dataConTyCon con1 + isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1)) + -- [Interesting: because 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 - (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts - arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 - var_ty = idType var + alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } + = ASSERT( notNull match_alts ) head match_alts + -- Stuff for newtype + arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 + var_ty = idType var (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes -- (not that splitTyConApp does, these days) newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) - - -- Stuff for data types - data_cons = tyConDataCons tycon - match_results = [match_result | (_,_,match_result) <- match_alts] - - fail_flag | exhaustive_case - = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results] - | otherwise - = CanFail - - sorted_alts = sortWith get_tag match_alts - get_tag (con, _, _) = dataConTag con - mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts - return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)) - - mk_alt fail (con, args, MatchResult _ body_fn) - = do { body <- body_fn fail - ; case dataConBoxer con of { - Nothing -> return (DataAlt con, args, body) ; - Just (DCB boxer) -> - do { us <- newUniqueSupply - ; let (rep_ids, binds) = initUs_ us (boxer ty_args args) - ; return (DataAlt con, rep_ids, mkLets binds body) } } } - - mk_default fail | exhaustive_case = [] - | otherwise = [(DEFAULT, [], fail)] - - un_mentioned_constructors - = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts] - exhaustive_case = isEmptyUniqSet un_mentioned_constructors - -- Stuff for parallel arrays - -- - -- * the following is to desugar cases over fake constructors for - -- parallel arrays, which are introduced by `tidy1' in the `PArrPat' - -- case - -- + --- Stuff for parallel arrays + -- -- Concerning `isPArrFakeAlts': -- -- * it is *not* sufficient to just check the type of the type @@ -354,47 +330,127 @@ mkCoAlgCaseMatchResult dflags var ty match_alts -- earlier and raise a proper error message, but it can really -- only happen in `PrelPArr' anyway. -- - isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon - isPArrFakeAlts ((dcon, _, _):alts) = - case (isPArrFakeCon dcon, isPArrFakeAlts alts) of + + isPArrFakeAlts :: [CaseAlt DataCon] -> Bool + isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt) + isPArrFakeAlts (alt:alts) = + case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of (True , True ) -> True (False, False) -> False _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns" isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" + +mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult +mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt + +\end{code} + +\begin{code} +sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon] +sort_alts = sortWith (dataConTag . alt_pat) + +mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr +mkPatSynCase var ty alt fail = do + matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty] + let MatchResult _ mkCont = match_result + cont <- mkCoreLams bndrs <$> mkCont fail + return $ mkCoreAppsDs matcher [Var var, cont, fail] + where + MkCaseAlt{ alt_pat = psyn, + alt_bndrs = bndrs, + alt_wrapper = wrapper, + alt_result = match_result} = alt + matcher = patSynMatcher psyn + +mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult +mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives" +mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case + where + con1 = alt_pat alt1 + tycon = dataConTyCon con1 + data_cons = tyConDataCons tycon + match_results = map alt_result alts + + sorted_alts :: [CaseAlt DataCon] + sorted_alts = sort_alts alts + + var_ty = idType var + (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes + -- (not that splitTyConApp does, these days) + + mk_case :: CoreExpr -> DsM CoreExpr + mk_case fail = do + alts <- mapM (mk_alt fail) sorted_alts + return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts) + + mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt + mk_alt fail MkCaseAlt{ alt_pat = con, + alt_bndrs = args, + alt_result = MatchResult _ body_fn } + = do { body <- body_fn fail + ; case dataConBoxer con of { + Nothing -> return (DataAlt con, args, body) ; + Just (DCB boxer) -> + do { us <- newUniqueSupply + ; let (rep_ids, binds) = initUs_ us (boxer ty_args args) + ; return (DataAlt con, rep_ids, mkLets binds body) } } } + + mk_default :: CoreExpr -> [CoreAlt] + mk_default fail | exhaustive_case = [] + | otherwise = [(DEFAULT, [], fail)] + + fail_flag :: CanItFail + fail_flag | exhaustive_case + = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results] + | otherwise + = CanFail + + mentioned_constructors = mkUniqSet $ map alt_pat alts + un_mentioned_constructors + = mkUniqSet data_cons `minusUniqSet` mentioned_constructors + exhaustive_case = isEmptyUniqSet un_mentioned_constructors + +--- Stuff for parallel arrays +-- +-- * the following is to desugar cases over fake constructors for +-- parallel arrays, which are introduced by `tidy1' in the `PArrPat' +-- case +-- +mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr +mkPArrCase dflags var ty sorted_alts fail = do + lengthP <- dsDPHBuiltin lengthPVar + alt <- unboxAlt + return (mkWildCase (len lengthP) intTy ty [alt]) + where + elemTy = case splitTyConApp (idType var) of + (_, [elemTy]) -> elemTy + _ -> panic panicMsg + panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" + len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] -- - mk_parrCase fail = do - lengthP <- dsDPHBuiltin lengthPVar - alt <- unboxAlt - return (mkWildCase (len lengthP) intTy ty [alt]) + unboxAlt = do + l <- newSysLocalDs intPrimTy + indexP <- dsDPHBuiltin indexPVar + alts <- mapM (mkAlt indexP) sorted_alts + return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) where - elemTy = case splitTyConApp (idType var) of - (_, [elemTy]) -> elemTy - _ -> panic panicMsg - panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" - len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] - -- - unboxAlt = do - l <- newSysLocalDs intPrimTy - indexP <- dsDPHBuiltin indexPVar - alts <- mapM (mkAlt indexP) sorted_alts - return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) - where - dft = (DEFAULT, [], fail) - -- - -- each alternative matches one array length (corresponding to one - -- fake array constructor), so the match is on a literal; each - -- alternative's body is extended by a local binding for each - -- constructor argument, which are bound to array elements starting - -- with the first - -- - mkAlt indexP (con, args, MatchResult _ bodyFun) = do - body <- bodyFun fail - return (LitAlt lit, [], mkCoreLets binds body) - where - lit = MachInt $ toInteger (dataConSourceArity con) - binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args] - -- - indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] + dft = (DEFAULT, [], fail) + + -- + -- each alternative matches one array length (corresponding to one + -- fake array constructor), so the match is on a literal; each + -- alternative's body is extended by a local binding for each + -- constructor argument, which are bound to array elements starting + -- with the first + -- + mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do + body <- bodyFun fail + return (LitAlt lit, [], mkCoreLets binds body) + where + lit = MachInt $ toInteger (dataConSourceArity (alt_pat alt)) + binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)] + -- + indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] \end{code} %************************************************************************ @@ -621,8 +677,10 @@ mkSelectorBinds ticks pat val_expr is_simple_lpat p = is_simple_pat (unLoc p) is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps - is_simple_pat pat@(ConPatOut{}) = isProductTyCon (dataConTyCon (unLoc (pat_con pat))) - && all is_triv_lpat (hsConPatArgs (pat_args pat)) + is_simple_pat pat@(ConPatOut{}) = case unLoc (pat_con pat) of + RealDataCon con -> isProductTyCon (dataConTyCon con) + && all is_triv_lpat (hsConPatArgs (pat_args pat)) + PatSynCon _ -> False is_simple_pat (VarPat _) = True is_simple_pat (ParPat p) = is_simple_lpat p is_simple_pat _ = False diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 7a905104a2..0433d873d5 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -27,7 +27,9 @@ import DsBinds import DsGRHSs import DsUtils import Id +import ConLike import DataCon +import PatSyn import MatchCon import MatchLit import Type @@ -91,6 +93,7 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs incomplete_flag RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags incomplete_flag ThPatSplice = False + incomplete_flag PatSyn = False incomplete_flag ThPatQuote = False incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns -- in list comprehensions, pattern guards @@ -314,6 +317,7 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty match_group eqns@((group,_) : _) = case group of PgCon _ -> matchConFamily vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns]) + PgSyn _ -> matchPatSyn vars ty (dropGroup eqns) PgLit _ -> matchLiterals vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns]) PgAny -> matchVariables vars ty (dropGroup eqns) PgN _ -> matchNPats vars ty (dropGroup eqns) @@ -831,6 +835,7 @@ data PatGroup = PgAny -- Immediate match: variables, wildcards, -- lazy patterns | PgCon DataCon -- Constructor patterns (incl list, tuple) + | PgSyn PatSyn | PgLit Literal -- Literal patterns | PgN Literal -- Overloaded literals | PgNpK Literal -- n+k patterns @@ -886,6 +891,7 @@ sameGroup :: PatGroup -> PatGroup -> Bool sameGroup PgAny PgAny = True sameGroup PgBang PgBang = True sameGroup (PgCon _) (PgCon _) = True -- One case expression +sameGroup (PgSyn p1) (PgSyn p2) = p1==p2 sameGroup (PgLit _) (PgLit _) = True -- One case expression sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] @@ -1004,16 +1010,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_co _ _ = False patGroup :: DynFlags -> Pat Id -> PatGroup -patGroup _ (WildPat {}) = PgAny -patGroup _ (BangPat {}) = PgBang -patGroup _ (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) -patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) -patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) -patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) -patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern -patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) -patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList -patGroup _ pat = pprPanic "patGroup" (ppr pat) +patGroup _ (WildPat {}) = PgAny +patGroup _ (BangPat {}) = PgBang +patGroup _ (ConPatOut { pat_con = con }) = case unLoc con of + RealDataCon dcon -> PgCon dcon + PatSynCon psyn -> PgSyn psyn +patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) +patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) +patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern +patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) +patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList +patGroup _ pat = pprPanic "patGroup" (ppr pat) \end{code} Note [Grouping overloaded literal patterns] diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index f2bff1e5cd..2b51638bf3 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -13,7 +13,7 @@ Pattern-matching constructors -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details -module MatchCon ( matchConFamily ) where +module MatchCon ( matchConFamily, matchPatSyn ) where #include "HsVersions.h" @@ -21,7 +21,9 @@ import {-# SOURCE #-} Match ( match ) import HsSyn import DsBinds +import ConLike import DataCon +import PatSyn import TcType import DsMonad import DsUtils @@ -94,17 +96,34 @@ matchConFamily :: [Id] -- Each group of eqns is for a single constructor matchConFamily (var:vars) ty groups = do dflags <- getDynFlags - alts <- mapM (matchOneCon vars ty) groups + alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups return (mkCoAlgCaseMatchResult dflags var ty alts) + where + toRealAlt alt = case alt_pat alt of + RealDataCon dcon -> alt{ alt_pat = dcon } + _ -> panic "matchConFamily: not RealDataCon" matchConFamily [] _ _ = panic "matchConFamily []" -type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) - -matchOneCon :: [Id] +matchPatSyn :: [Id] -> Type -> [EquationInfo] - -> DsM (DataCon, [Var], MatchResult) -matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor + -> DsM MatchResult +matchPatSyn (var:vars) ty eqns + = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns + return (mkCoSynCaseMatchResult var ty alt) + where + toSynAlt alt = case alt_pat alt of + PatSynCon psyn -> alt{ alt_pat = psyn } + _ -> panic "matchPatSyn: not PatSynCon" +matchPatSyn _ _ _ = panic "matchPatSyn []" + +type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) + +matchOneConLike :: [Id] + -> Type + -> [EquationInfo] + -> DsM (CaseAlt ConLike) +matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor = do { arg_vars <- selectConMatchVars arg_tys args1 -- Use the first equation as a source of -- suggestions for the new variables @@ -116,20 +135,32 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor ; match_results <- mapM (match_group arg_vars) groups - ; return (con1, tvs1 ++ dicts1 ++ arg_vars, - foldr1 combineMatchResults match_results) } + ; return $ MkCaseAlt{ alt_pat = con1, + alt_bndrs = tvs1 ++ dicts1 ++ arg_vars, + alt_wrapper = wrapper1, + alt_result = foldr1 combineMatchResults match_results } } where - ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, + ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, pat_wrap = wrapper1, pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } = firstPat eqn1 - fields1 = dataConFieldLabels con1 - - arg_tys = dataConInstOrigArgTys con1 inst_tys + 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 (dataConExTyVars con1) tvs1) + mkTyVarTys (takeList exVars tvs1) -- Newtypes opaque, hence tcTyConAppArgs -- 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 match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult -- All members of the group have compatible ConArgPats @@ -167,7 +198,7 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor lookup_fld rpat = lookupNameEnv_NF fld_var_env (idName (unLoc (hsRecFieldId rpat))) select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" -matchOneCon _ _ [] = panic "matchOneCon []" +matchOneConLike _ _ [] = panic "matchOneCon []" ----------------- compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 70f7c1634d..a5d9785a43 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -130,7 +130,9 @@ Library Exposed-Modules: Avail BasicTypes + ConLike DataCon + PatSyn Demand Exception GhcMonad @@ -372,6 +374,7 @@ Library TcValidity TcMatches TcPat + TcPatSyn TcRnDriver TcRnMonad TcRnTypes diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 3d0a981d17..0a1871307e 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -479,6 +479,7 @@ compiler_stage2_dll0_MODULES = \ CmmType \ CmmUtils \ CoAxiom \ + ConLike \ CodeGen.Platform \ CodeGen.Platform.ARM \ CodeGen.Platform.NoRegs \ @@ -563,6 +564,7 @@ compiler_stage2_dll0_MODULES = \ Packages \ Pair \ Panic \ + PatSyn \ PipelineMonad \ Platform \ PlatformConstants \ diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 216ab22bcf..9996e620f0 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -298,7 +298,9 @@ cvt_ci_decs doc decs ; let (binds', prob_fams') = partitionWith is_bind prob_binds' ; let (fams', bads) = partitionWith is_fam_decl prob_fams' ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - ; return (listToBag binds', sigs', fams', ats', adts') } + --We use FromSource as the origin of the bind + -- because the TH declaration is user-written + ; return (listToBag (map (\bind -> (FromSource, bind)) binds'), sigs', fams', ats', adts') } ---------------- cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] @@ -533,7 +535,9 @@ cvtLocalDecs doc ds ; let (binds, prob_sigs) = partitionWith is_bind ds' ; let (sigs, bads) = partitionWith is_sig prob_sigs ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } + ; return (HsValBinds (ValBindsIn (toBindBag binds) sigs)) } + where + toBindBag = listToBag . map (\bind -> (FromSource, bind)) cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) cvtClause (Clause ps body wheres) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 139f5bf118..e904633eec 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -35,6 +35,10 @@ import BooleanFormula (BooleanFormula) import Data.Data hiding ( Fixity ) import Data.List import Data.Ord +import Data.Foldable ( Foldable(..) ) +import Data.Traversable ( Traversable(..) ) +import Data.Monoid ( mappend ) +import Control.Applicative ( (<$>), (<*>) ) \end{code} %************************************************************************ @@ -85,7 +89,7 @@ type LHsBind id = LHsBindLR id id type LHsBinds id = LHsBindsLR id id type HsBind id = HsBindLR id id -type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) +type LHsBindsLR idL idR = Bag (Origin, LHsBindLR idL idR) type LHsBindLR idL idR = Located (HsBindLR idL idR) data HsBindLR idL idR @@ -162,6 +166,14 @@ data HsBindLR idL idR abs_binds :: LHsBinds idL -- ^ Typechecked user bindings } + | PatSynBind { + patsyn_id :: Located idL, -- ^ Name of the pattern synonym + bind_fvs :: NameSet, -- ^ See Note [Bind free vars] + patsyn_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names + patsyn_def :: LPat idR, -- ^ Right-hand side + patsyn_dir :: HsPatSynDir idR -- ^ Directionality + } + deriving (Data, Typeable) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -310,7 +322,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty - | otherwise = pprDeclList (map ppr (bagToList binds)) + | otherwise = pprDeclList (map (ppr . snd) (bagToList binds)) pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2) => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] @@ -326,7 +338,7 @@ pprLHsBindsForUser binds sigs decls :: [(SrcSpan, SDoc)] decls = [(loc, ppr sig) | L loc sig <- sigs] ++ - [(loc, ppr bind) | L loc bind <- bagToList binds] + [(loc, ppr bind) | (_, L loc bind) <- bagToList binds] sort_by_loc decls = sortBy (comparing fst) decls @@ -425,6 +437,19 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, $$ ifPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind (unLoc fun) inf matches $$ ifPprDebug (ppr wrap) +ppr_monobind (PatSynBind{ patsyn_id = L _ psyn, patsyn_args = details, + patsyn_def = pat, patsyn_dir = dir }) + = ppr_lhs <+> ppr_rhs + where + ppr_lhs = ptext (sLit "pattern") <+> ppr_details details + ppr_simple syntax = syntax <+> ppr pat + + ppr_details (InfixPatSyn v1 v2) = hsep [ppr v1, pprInfixOcc psyn, ppr v2] + ppr_details (PrefixPatSyn vs) = hsep (pprPrefixOcc psyn : map ppr vs) + + ppr_rhs = case dir of + Unidirectional -> ppr_simple (ptext (sLit "<-")) + ImplicitBidirectional -> ppr_simple equals ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , abs_exports = exports, abs_binds = val_binds @@ -517,6 +542,14 @@ data Sig name -- @f :: Num a => a -> a@ TypeSig [Located name] (LHsType name) + -- | A pattern synonym type signature + -- @pattern (Eq b) => P a b :: (Num a) => T a + | PatSynSig (Located name) + (HsPatSynDetails (LHsType name)) + (LHsType name) -- Type + (LHsContext name) -- Provided context + (LHsContext name) -- Required contex + -- | A type signature for a default method inside a class -- -- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool @@ -644,6 +677,7 @@ isMinimalLSig _ = False hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = ptext (sLit "type signature") +hsSigDoc (PatSynSig {}) = ptext (sLit "pattern synonym signature") hsSigDoc (GenericSig {}) = ptext (sLit "default type signature") hsSigDoc (IdSig {}) = ptext (sLit "id signature") hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") @@ -670,6 +704,34 @@ ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec (unLoc var) (ppr ty) i ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var)) ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) ppr_sig (MinimalSig bf) = pragBrackets (pprMinimalSig bf) +ppr_sig (PatSynSig name arg_tys ty prov req) + = pprPatSynSig (unLoc name) False args (ppr ty) (pprCtx prov) (pprCtx req) + where + args = fmap ppr arg_tys + + pprCtx lctx = case unLoc lctx of + [] -> Nothing + ctx -> Just (pprHsContextNoArrow ctx) + +pprPatSynSig :: (OutputableBndr a) + => a -> Bool -> HsPatSynDetails SDoc -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc +pprPatSynSig ident is_bidir args rhs_ty prov_theta req_theta + = sep [ ptext (sLit "pattern") + , thetaOpt prov_theta, name_and_args + , colon + , thetaOpt req_theta, rhs_ty + ] + where + name_and_args = case args of + PrefixPatSyn arg_tys -> + pprPrefixOcc ident <+> sep arg_tys + InfixPatSyn left_ty right_ty -> + left_ty <+> pprInfixOcc ident <+> right_ty + + -- TODO: support explicit foralls + thetaOpt = maybe empty (<+> darrow) + + colon = if is_bidir then dcolon else dcolon -- TODO instance OutputableBndr name => Outputable (FixitySig name) where ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)] @@ -698,3 +760,35 @@ instance Outputable TcSpecPrag where pprMinimalSig :: OutputableBndr name => BooleanFormula (Located name) -> SDoc pprMinimalSig bf = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf) \end{code} + +%************************************************************************ +%* * +\subsection[PatSynBind]{A pattern synonym definition} +%* * +%************************************************************************ + +\begin{code} +data HsPatSynDetails a + = InfixPatSyn a a + | PrefixPatSyn [a] + deriving (Data, Typeable) + +instance Functor HsPatSynDetails where + fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right) + fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args) + +instance Foldable HsPatSynDetails where + foldMap f (InfixPatSyn left right) = f left `mappend` f right + foldMap f (PrefixPatSyn args) = foldMap f args + +instance Traversable HsPatSynDetails where + traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right + traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args + +data HsPatSynDirLR idL idR + = Unidirectional + | ImplicitBidirectional + deriving (Data, Typeable) + +type HsPatSynDir id = HsPatSynDirLR id id +\end{code} diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index bb91790bbb..4c0c955cdd 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -1498,6 +1498,7 @@ data HsMatchContext id -- Context of a Match | ThPatSplice -- A Template Haskell pattern splice | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] + | PatSyn -- A pattern synonym declaration deriving (Data, Typeable) data HsStmtContext id @@ -1545,6 +1546,7 @@ matchSeparator (StmtCtxt _) = ptext (sLit "<-") matchSeparator RecUpd = panic "unused" matchSeparator ThPatSplice = panic "unused" matchSeparator ThPatQuote = panic "unused" +matchSeparator PatSyn = panic "unused" \end{code} \begin{code} @@ -1570,6 +1572,7 @@ pprMatchContextNoun LambdaExpr = ptext (sLit "lambda abstraction") pprMatchContextNoun ProcExpr = ptext (sLit "arrow abstraction") pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in") $$ pprStmtContext ctxt +pprMatchContextNoun PatSyn = ptext (sLit "pattern synonym declaration") ----------------- pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc @@ -1618,6 +1621,7 @@ matchContextErrString LambdaExpr = ptext (sLit "lambda") matchContextErrString ProcExpr = ptext (sLit "proc") matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime +matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index bf44505514..9d458b79c4 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -35,6 +35,7 @@ import BasicTypes import PprCore ( {- instance OutputableBndr TyVar -} ) import TysWiredIn import Var +import ConLike import DataCon import TyCon import Outputable @@ -97,14 +98,15 @@ data Pat id (HsConPatDetails id) | ConPatOut { - pat_con :: Located DataCon, + pat_con :: Located ConLike, 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_ty :: Type, -- The type of the pattern + pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher } ------------ View patterns --------------- @@ -262,9 +264,10 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, = 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 <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) - , ppr binds]) - <+> pprConArgs details + ppr con + <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) + , ppr binds]) + <+> pprConArgs details else pprUserCon (unLoc con) details pprPat (LitPat s) = ppr s @@ -313,9 +316,9 @@ instance (OutputableBndr id, Outputable arg) mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id -- Make a vanilla Prefix constructor pattern mkPrefixConPat dc pats ty - = noLoc $ ConPatOut { pat_con = noLoc dc, pat_tvs = [], pat_dicts = [], + = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [], pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats, - pat_ty = ty } + pat_ty = ty, pat_wrap = idHsWrapper } mkNilPat :: Type -> OutPat id mkNilPat ty = mkPrefixConPat nilDataCon [] ty @@ -413,11 +416,13 @@ isIrrefutableHsPat pat go1 (PArrPat {}) = False -- ? go1 (ConPatIn {}) = False -- Conservative - go1 (ConPatOut{ pat_con = L _ con, pat_args = details }) + go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details }) = isJust (tyConSingleDataCon_maybe (dataConTyCon con)) -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because -- the latter is false of existentials. See Trac #4439 && all go (hsConPatArgs details) + go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) }) + = False -- Conservative go1 (LitPat {}) = False go1 (NPat {}) = False @@ -457,4 +462,3 @@ conPatNeedsParens (PrefixCon args) = not (null args) conPatNeedsParens (InfixCon {}) = True conPatNeedsParens (RecCon {}) = True \end{code} - diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot index 85664afe3a..0e7a0e0762 100644 --- a/compiler/hsSyn/HsPat.lhs-boot +++ b/compiler/hsSyn/HsPat.lhs-boot @@ -5,6 +5,7 @@ module HsPat where import SrcLoc( Located ) import Data.Data +import Outputable data Pat (i :: *) type LPat i = Located (Pat i) @@ -16,4 +17,5 @@ instance Typeable1 Pat #endif instance Data i => Data (Pat i) +instance (OutputableBndr name) => Outputable (Pat name) \end{code} diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 2aaa76dd0a..28c6a2b89c 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -35,7 +35,7 @@ module HsTypes ( splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy, -- Printing - pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, + pprParendHsType, pprHsForAll, pprHsContext, pprHsContextNoArrow, ppr_hs_context, ) where import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice ) @@ -553,9 +553,13 @@ pprHsForAll exp qtvs cxt forall_part = ptext (sLit "forall") <+> ppr qtvs <> dot pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc -pprHsContext [] = empty -pprHsContext [L _ pred] = ppr pred <+> darrow -pprHsContext cxt = ppr_hs_context cxt <+> darrow +pprHsContext [] = empty +pprHsContext cxt = pprHsContextNoArrow cxt <+> darrow + +pprHsContextNoArrow :: (OutputableBndr name) => HsContext name -> SDoc +pprHsContextNoArrow [] = empty +pprHsContextNoArrow [L _ pred] = ppr pred +pprHsContextNoArrow cxt = ppr_hs_context cxt ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc ppr_hs_context [] = empty diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 218a45239b..abc4758fcb 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -36,7 +36,7 @@ module HsUtils( toHsType, toHsKind, -- Bindings - mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, + mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, mkPatSynBind, -- Literals mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, @@ -491,18 +491,25 @@ mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False , bind_fvs = emptyNameSet -- NB: closed binding , fun_tick = Nothing } -mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName +mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> (Origin, LHsBind RdrName) mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs mkVarBind :: id -> LHsExpr id -> LHsBind id mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_id = var, var_rhs = rhs, var_inline = False } +mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName +mkPatSynBind name details lpat dir = PatSynBind{ patsyn_id = name + , patsyn_args = details + , patsyn_def = lpat + , patsyn_dir = dir + , bind_fvs = placeHolderNames } + ------------ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] - -> LHsExpr RdrName -> LHsBind RdrName + -> LHsExpr RdrName -> (Origin, LHsBind RdrName) mk_easy_FunBind loc fun pats expr - = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] + = (Generated, L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]) ------------ mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id) @@ -564,6 +571,7 @@ collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc -- I don't think we want the binders from the nested binds -- The only time we collect binders from a typechecked -- binding (hence see AbsBinds) is in zonking in TcHsSyn +collect_bind (PatSynBind { patsyn_id = L _ ps }) acc = ps : acc collectHsBindsBinders :: LHsBindsLR idL idR -> [idL] collectHsBindsBinders binds = collect_binds binds [] @@ -572,14 +580,14 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL] collectHsBindListBinders = foldr (collect_bind . unLoc) [] collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL] -collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds +collect_binds binds acc = foldrBag (collect_bind . unLoc . snd) acc binds collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] -- Used exclusively for the bindings of an instance decl which are all FunBinds -collectMethodBinders binds = foldrBag get [] binds +collectMethodBinders binds = foldrBag (get . unLoc . snd) [] binds where - get (L _ (FunBind { fun_id = f })) fs = f : fs - get _ fs = fs + get (FunBind { fun_id = f }) fs = f : fs + get _ fs = fs -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- @@ -800,9 +808,9 @@ hsValBindsImplicits (ValBindsIn binds _) = lhsBindsImplicits binds lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet -lhsBindsImplicits = foldBag unionNameSets lhs_bind emptyNameSet +lhsBindsImplicits = foldBag unionNameSets (lhs_bind . unLoc . snd) emptyNameSet where - lhs_bind (L _ (PatBind { pat_lhs = lpat })) = lPatImplicits lpat + lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat lhs_bind _ = emptyNameSet lPatImplicits :: LPat Name -> NameSet diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index c4c1bcd69e..9fd0c33423 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -20,6 +20,7 @@ module BinIface ( import TcRnMonad import TyCon +import ConLike import DataCon (dataConName, dataConWorkId, dataConTyCon) import PrelInfo (wiredInThings, basicKnownKeyNames) import Id (idName, isDataConWorkId_maybe) @@ -318,7 +319,7 @@ putName _dict BinSymbolTable{ = case wiredInNameTyThing_maybe name of Just (ATyCon tc) | isTupleTyCon tc -> putTupleName_ bh tc 0 - Just (ADataCon dc) + Just (AConLike (RealDataCon dc)) | let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 1 Just (AnId x) | Just dc <- isDataConWorkId_maybe x, let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 2 diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 38bb930e13..e412d7ef30 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -15,6 +15,7 @@ module BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, + buildPatSyn, mkPatSynMatcherId, mkPatSynWrapperId, TcMethInfo, buildClass, distinctAbstractTyConRhs, totallyAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs, @@ -26,6 +27,7 @@ module BuildTyCl ( import IfaceEnv import FamInstEnv( FamInstEnvs ) import DataCon +import PatSyn import Var import VarSet import BasicTypes @@ -34,6 +36,9 @@ import MkId import Class import TyCon import Type +import TypeRep +import TcType +import Id import Coercion import DynFlags @@ -176,6 +181,70 @@ mkDataConStupidTheta tycon arg_tys univ_tvs arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys pred = not $ isEmptyVarSet $ tyVarsOfType pred `intersectVarSet` arg_tyvars + + +------------------------------------------------------ +buildPatSyn :: Name -> Bool -> Bool + -> [Var] + -> [TyVar] -> [TyVar] -- Univ and ext + -> ThetaType -> ThetaType -- Prov and req + -> Type -- Result type + -> TyVar + -> TcRnIf m n PatSyn +buildPatSyn src_name declared_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv + = do { (matcher, _, _) <- mkPatSynMatcherId src_name args + univ_tvs ex_tvs + prov_theta req_theta + pat_ty tv + ; wrapper <- case has_wrapper of + False -> return Nothing + True -> fmap Just $ + mkPatSynWrapperId src_name args + (univ_tvs ++ ex_tvs) (prov_theta ++ req_theta) + pat_ty + ; return $ mkPatSyn src_name declared_infix + args + univ_tvs ex_tvs + prov_theta req_theta + pat_ty + matcher + wrapper } + +mkPatSynMatcherId :: Name + -> [Var] + -> [TyVar] + -> [TyVar] + -> ThetaType -> ThetaType + -> Type + -> TyVar + -> TcRnIf n m (Id, Type, Type) +mkPatSynMatcherId name args univ_tvs ex_tvs prov_theta req_theta pat_ty res_tv + = do { matcher_name <- newImplicitBinder name mkMatcherOcc + + ; let res_ty = TyVarTy res_tv + cont_ty = mkSigmaTy ex_tvs prov_theta $ + mkFunTys (map varType args) res_ty + + ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty + matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau + matcher_id = mkVanillaGlobal matcher_name matcher_sigma + ; return (matcher_id, res_ty, cont_ty) } + +mkPatSynWrapperId :: Name + -> [Var] + -> [TyVar] + -> ThetaType + -> Type + -> TcRnIf n m Id +mkPatSynWrapperId name args qtvs theta pat_ty + = do { wrapper_name <- newImplicitBinder name mkDataConWrapperOcc + + ; let wrapper_tau = mkFunTys (map varType args) pat_ty + wrapper_sigma = mkSigmaTy qtvs theta wrapper_tau + + ; let wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma + ; return wrapper_id } + \end{code} diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index f693999390..b582305434 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -118,6 +118,16 @@ data IfaceDecl -- beyond .NET ifExtName :: Maybe FastString } + | IfacePatSyn { ifName :: OccName, -- Name of the pattern synonym + ifPatHasWrapper :: Bool, + ifPatIsInfix :: Bool, + ifPatUnivTvs :: [IfaceTvBndr], + ifPatExTvs :: [IfaceTvBndr], + ifPatProvCtxt :: IfaceContext, + ifPatReqCtxt :: IfaceContext, + ifPatArgs :: [IfaceIdBndr], + ifPatTy :: IfaceType } + -- A bit of magic going on here: there's no need to store the OccName -- for a decl on the disk, since we can infer the namespace from the -- context; however it is useful to have the OccName in the IfaceDecl @@ -175,6 +185,18 @@ instance Binary IfaceDecl where put_ bh a3 put_ bh a4 + put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9) = do + putByte bh 6 + put_ bh (occNameFS name) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + get bh = do h <- getByte bh case h of @@ -215,12 +237,24 @@ instance Binary IfaceDecl where a9 <- get bh occ <- return $! mkOccNameFS clsName a2 return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9) - _ -> do a1 <- get bh + 5 -> do a1 <- get bh a2 <- get bh a3 <- get bh a4 <- get bh occ <- return $! mkOccNameFS tcName a1 return (IfaceAxiom occ a2 a3 a4) + 6 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + occ <- return $! mkOccNameFS dataName a1 + return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9) + _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) data IfaceSynTyConRhs = IfaceOpenSynFamilyTyCon @@ -980,6 +1014,11 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, dc_occ = mkClassDataConOcc cls_tc_occ is_newtype = n_sigs + n_ctxt == 1 -- Sigh +ifaceDeclImplicitBndrs (IfacePatSyn{ ifName = ps_occ, ifPatHasWrapper = has_wrapper }) + = [wrap_occ | has_wrapper] + where + wrap_occ = mkDataConWrapperOcc ps_occ -- Id namespace + ifaceDeclImplicitBndrs _ = [] -- ----------------------------------------------------------------------------- @@ -1063,6 +1102,30 @@ pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branche = hang (ptext (sLit "axiom") <+> ppr name <> colon) 2 (vcat $ map (pprAxBranch $ Just tycon) branches) +pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap, + ifPatIsInfix = is_infix, + ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs, + ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, + ifPatArgs = args, + ifPatTy = ty }) + = hang (text "pattern" <+> header) + 4 details + where + header = ppr name <+> dcolon <+> + (pprIfaceForAllPart univ_tvs req_ctxt $ + pprIfaceForAllPart ex_tvs prov_ctxt $ + pp_tau) + + details = sep [ if is_infix then text "Infix" else empty + , if has_wrap then text "HasWrapper" else empty + ] + + pp_tau = case map pprParendIfaceType (arg_tys ++ [ty]) of + (t:ts) -> fsep (t : map (arrow <+>) ts) + [] -> panic "pp_tau" + + arg_tys = map snd args + pprCType :: Maybe CType -> SDoc pprCType Nothing = ptext (sLit "No C type associated") pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType @@ -1332,6 +1395,13 @@ freeNamesIfDecl d@IfaceClass{} = freeNamesIfDecl d@IfaceAxiom{} = freeNamesIfTc (ifTyCon d) &&& fnList freeNamesIfAxBranch (ifAxBranches d) +freeNamesIfDecl d@IfacePatSyn{} = + freeNamesIfTvBndrs (ifPatUnivTvs d) &&& + freeNamesIfTvBndrs (ifPatExTvs d) &&& + freeNamesIfContext (ifPatProvCtxt d) &&& + freeNamesIfContext (ifPatReqCtxt d) &&& + fnList freeNamesIfType (map snd (ifPatArgs d)) &&& + freeNamesIfType (ifPatTy d) freeNamesIfAxBranch :: IfaceAxBranch -> NameSet freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 9aad5ffea2..379b39de58 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -73,7 +73,9 @@ import Class import Kind import TyCon import CoAxiom +import ConLike import DataCon +import PatSyn import Type import TcType import InstEnv @@ -1458,8 +1460,9 @@ tyThingToIfaceDecl :: TyThing -> IfaceDecl tyThingToIfaceDecl (AnId id) = idToIfaceDecl id tyThingToIfaceDecl (ATyCon tycon) = tyConToIfaceDecl emptyTidyEnv tycon tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax -tyThingToIfaceDecl (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) - -- Should be trimmed out earlier +tyThingToIfaceDecl (AConLike cl) = case cl of + RealDataCon dc -> pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier + PatSynCon ps -> patSynToIfaceDecl ps -------------------------- idToIfaceDecl :: Id -> IfaceDecl @@ -1473,6 +1476,29 @@ idToIfaceDecl id ifIdDetails = toIfaceIdDetails (idDetails id), ifIdInfo = toIfaceIdInfo (idInfo id) } +-------------------------- +patSynToIfaceDecl :: PatSyn -> IfaceDecl +patSynToIfaceDecl ps + = IfacePatSyn { ifName = getOccName . getName $ ps + , ifPatHasWrapper = isJust $ patSynWrapper ps + , ifPatIsInfix = patSynIsInfix ps + , ifPatUnivTvs = toIfaceTvBndrs univ_tvs' + , ifPatExTvs = toIfaceTvBndrs ex_tvs' + , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta + , ifPatReqCtxt = tidyToIfaceContext env2 req_theta + , ifPatArgs = map toIfaceArg args + , ifPatTy = tidyToIfaceType env2 rhs_ty + } + where + toIfaceArg var = (occNameFS (getOccName var), + tidyToIfaceType env2 (varType var)) + + (univ_tvs, ex_tvs, (prov_theta, req_theta)) = patSynSig ps + args = patSynArgs ps + rhs_ty = patSynType ps + (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs + (env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs + -------------------------- coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 737616990c..20adfe5896 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -43,6 +43,7 @@ import IdInfo import Class import TyCon import CoAxiom +import ConLike import DataCon import PrelNames import TysWiredIn @@ -582,6 +583,32 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc , co_ax_implicit = False } ; return (ACoAxiom axiom) } +tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name + , ifPatHasWrapper = has_wrapper + , ifPatIsInfix = is_infix + , ifPatUnivTvs = univ_tvs + , ifPatExTvs = ex_tvs + , ifPatProvCtxt = prov_ctxt + , ifPatReqCtxt = req_ctxt + , ifPatArgs = args + , ifPatTy = pat_ty }) + = do { name <- lookupIfaceTop occ_name + ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name) + ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do + { bindIfaceTyVars ex_tvs $ \ex_tvs -> do + { bindIfaceIdVars args $ \args -> do + { ~(prov_theta, req_theta, pat_ty) <- forkM (mk_doc name) $ + do { prov_theta <- tcIfaceCtxt prov_ctxt + ; req_theta <- tcIfaceCtxt req_ctxt + ; pat_ty <- tcIfaceType pat_ty + ; return (prov_theta, req_theta, pat_ty) } + ; bindIfaceTyVar (fsLit "r", toIfaceKind liftedTypeKind) $ \tv -> do + { patsyn <- buildPatSyn name is_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv + ; return (AConLike (PatSynCon patsyn)) }}}}} + where + mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n + + tc_ax_branches :: TyCon -> [IfaceAxBranch] -> IfL [CoAxBranch] tc_ax_branches tc if_branches = foldlM (tc_ax_branch (tyConKind tc)) [] if_branches @@ -1435,8 +1462,8 @@ tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; case thing of -- A "type constructor" can be a promoted data constructor -- c.f. Trac #5881 - ATyCon tc -> return tc - ADataCon dc -> return (promoteDataCon dc) + ATyCon tc -> return tc + AConLike (RealDataCon dc) -> return (promoteDataCon dc) _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) } tcIfaceKindCon :: IfaceTyCon -> IfL TyCon @@ -1459,7 +1486,7 @@ tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name ; case thing of - ADataCon dc -> return dc + AConLike (RealDataCon dc) -> return dc _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } tcIfaceExtId :: Name -> IfL Id @@ -1521,6 +1548,20 @@ bindIfaceTyVars bndrs thing_inside where (occs,kinds) = unzip bndrs +bindIfaceIdVar :: IfaceIdBndr -> (Id -> IfL a) -> IfL a +bindIfaceIdVar (occ, ty) thing_inside + = do { name <- newIfaceName (mkVarOccFS occ) + ; ty' <- tcIfaceType ty + ; let id = mkLocalId name ty' + ; extendIfaceIdEnv [id] (thing_inside id) } + +bindIfaceIdVars :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a +bindIfaceIdVars [] thing_inside = thing_inside [] +bindIfaceIdVars (v:vs) thing_inside + = bindIfaceIdVar v $ \ v' -> + bindIfaceIdVars vs $ \ vs' -> + thing_inside (v':vs') + isSuperIfaceKind :: IfaceKind -> Bool isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName isSuperIfaceKind _ = False @@ -1547,4 +1588,3 @@ bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside bindIfaceTyVars_AT bs $ \bs' -> thing_inside (b':bs') } \end{code} - diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 2d0165be8c..615fdbb08b 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -581,6 +581,7 @@ data ExtensionFlag | Opt_MultiWayIf | Opt_NegativeLiterals | Opt_EmptyCase + | Opt_PatternSynonyms deriving (Eq, Enum, Show) -- | Contains not only a collection of 'GeneralFlag's but also a plethora of @@ -2861,7 +2862,8 @@ xFlags = [ ( "IncoherentInstances", Opt_IncoherentInstances, nop ), ( "PackageImports", Opt_PackageImports, nop ), ( "NegativeLiterals", Opt_NegativeLiterals, nop ), - ( "EmptyCase", Opt_EmptyCase, nop ) + ( "EmptyCase", Opt_EmptyCase, nop ), + ( "PatternSynonyms", Opt_PatternSynonyms, nop ) ] defaultFlags :: Settings -> [GeneralFlag] diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index d2fa195e98..04b0823db4 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1569,6 +1569,7 @@ mkModGuts mod safe binds = mg_tcs = [], mg_insts = [], mg_fam_insts = [], + mg_patsyns = [], mg_rules = [], mg_vect_decls = [], mg_binds = binds, diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 2e60965159..715ee8130c 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -48,6 +48,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ("GenericSigs ", generic_sigs), ("ValBinds ", val_bind_ds), ("FunBinds ", fn_bind_ds), + ("PatSynBinds ", patsyn_ds), ("InlineMeths ", method_inlines), ("InlineBinds ", bind_inlines), ("SpecialisedMeths ", method_specs), @@ -84,24 +85,25 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) export_ds = n_exports - export_ms export_all = case exports of { Nothing -> 1; _ -> 0 } - (val_bind_ds, fn_bind_ds) - = foldr add2 (0,0) (map count_bind val_decls) + (val_bind_ds, fn_bind_ds, patsyn_ds) + = sum3 (map count_bind val_decls) (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) - = foldr add7 (0,0,0,0,0,0,0) (map import_info imports) + = sum7 (map import_info imports) (data_constrs, data_derivs) - = foldr add2 (0,0) (map data_info tycl_decls) + = sum2 (map data_info tycl_decls) (class_method_ds, default_method_ds) - = foldr add2 (0,0) (map class_info tycl_decls) + = sum2 (map class_info tycl_decls) (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) - = foldr add5 (0,0,0,0,0) (map inst_info inst_decls) + = sum5 (map inst_info inst_decls) - count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0) - count_bind (PatBind {}) = (0,1) - count_bind (FunBind {}) = (0,1) + count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0) + count_bind (PatBind {}) = (0,1,0) + count_bind (FunBind {}) = (0,1,0) + count_bind (PatSynBind {}) = (0,0,1) count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) - count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) + count_sigs sigs = sum5 (map sig_info sigs) sig_info (FixSig _) = (1,0,0,0,0) sig_info (TypeSig _ _) = (0,1,0,0,0) @@ -128,9 +130,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) data_info _ = (0,0) class_info decl@(ClassDecl {}) - = case count_sigs (map unLoc (tcdSigs decl)) of - (_,classops,_,_,_) -> - (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) + = (classops, addpr (sum3 (map count_bind methods))) + where + methods = map (unLoc . snd) $ bagToList (tcdMeths decl) + (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) class_info _ = (0,0) inst_info (TyFamInstD {}) = (0,0,0,1,0) @@ -141,17 +144,31 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) , cid_datafam_insts = adts } }) = case count_sigs (map unLoc inst_sigs) of (_,_,ss,is,_) -> - (addpr (foldr add2 (0,0) - (map (count_bind.unLoc) (bagToList inst_meths))), + (addpr (sum3 (map count_bind methods)), ss, is, length ats, length adts) + where + methods = map (unLoc . snd) $ bagToList inst_meths + + -- TODO: use Sum monoid + addpr :: (Int,Int,Int) -> Int + sum2 :: [(Int, Int)] -> (Int, Int) + sum3 :: [(Int, Int, Int)] -> (Int, Int, Int) + sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int) + sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int) + add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int) + -> (Int, Int, Int, Int, Int, Int, Int) + + addpr (x,y,z) = x+y+z + sum2 = foldr add2 (0,0) + where + add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) + sum3 = foldr add3 (0,0,0) + where + add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) + sum5 = foldr add5 (0,0,0,0,0) + where + add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) + sum7 = foldr add7 (0,0,0,0,0,0,0) - addpr :: (Int,Int) -> Int - add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) - add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int) - add7 :: (Int,Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int, Int) - - addpr (x,y) = x+y - add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) - add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index c61c8ec56d..b8ecc109d0 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -70,8 +70,10 @@ module HscTypes ( TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, typeEnvFromEntities, mkTypeEnvWithImplicits, - extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, - typeEnvElts, typeEnvTyCons, typeEnvIds, + extendTypeEnv, extendTypeEnvList, + extendTypeEnvWithIds, extendTypeEnvWithPatSyns, + lookupTypeEnv, + typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, -- * MonadThings @@ -143,7 +145,9 @@ import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) import Class import TyCon import CoAxiom +import ConLike import DataCon +import PatSyn import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) import Packages hiding ( Version(..) ) import DynFlags @@ -996,6 +1000,7 @@ data ModGuts mg_insts :: ![ClsInst], -- ^ Class instances declared in this module mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module + mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains -- See Note [Overall plumbing for rules] in Rules.lhs mg_binds :: !CoreProgram, -- ^ Bindings for this module @@ -1496,8 +1501,15 @@ implicitTyThings :: TyThing -> [TyThing] implicitTyThings (AnId _) = [] implicitTyThings (ACoAxiom _cc) = [] implicitTyThings (ATyCon tc) = implicitTyConThings tc -implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) - -- For data cons add the worker and (possibly) wrapper +implicitTyThings (AConLike cl) = case cl of + RealDataCon dc -> + -- For data cons add the worker and (possibly) wrapper + map AnId (dataConImplicitIds dc) + PatSynCon ps -> + -- For bidirectional pattern synonyms, add the wrapper + case patSynWrapper ps of + Nothing -> [] + Just id -> [AnId id] implicitClassThings :: Class -> [TyThing] implicitClassThings cl @@ -1520,7 +1532,7 @@ implicitTyConThings tc -- for each data constructor in order, -- the contructor, worker, and (possibly) wrapper - concatMap (extras_plus . ADataCon) (tyConDataCons tc) + concatMap (extras_plus . AConLike . RealDataCon) (tyConDataCons tc) -- NB. record selectors are *not* implicit, they have fully-fledged -- bindings that pass through the compilation pipeline as normal. where @@ -1545,7 +1557,9 @@ implicitCoTyCon tc -- of some other declaration, or it is generated implicitly by some -- other declaration. isImplicitTyThing :: TyThing -> Bool -isImplicitTyThing (ADataCon {}) = True +isImplicitTyThing (AConLike cl) = case cl of + RealDataCon{} -> True + PatSynCon ps -> isImplicitId (patSynId ps) isImplicitTyThing (AnId id) = isImplicitId id isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax @@ -1557,7 +1571,9 @@ isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax -- but the tycon could be the associated type of a class, so it in turn -- might have a parent. tyThingParent_maybe :: TyThing -> Maybe TyThing -tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc)) +tyThingParent_maybe (AConLike cl) = case cl of + RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) + PatSynCon{} -> Nothing tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of Just cls -> Just (ATyCon (classTyCon cls)) Nothing -> Nothing @@ -1572,7 +1588,9 @@ tyThingsTyVars tts = unionVarSets $ map ttToVarSet tts where ttToVarSet (AnId id) = tyVarsOfType $ idType id - ttToVarSet (ADataCon dc) = tyVarsOfType $ dataConRepType dc + ttToVarSet (AConLike cl) = case cl of + RealDataCon dc -> tyVarsOfType $ dataConRepType dc + PatSynCon{} -> emptyVarSet ttToVarSet (ATyCon tc) = case tyConClass_maybe tc of Just cls -> (mkVarSet . fst . classTvsFds) cls @@ -1611,6 +1629,7 @@ typeEnvElts :: TypeEnv -> [TyThing] typeEnvTyCons :: TypeEnv -> [TyCon] typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched] typeEnvIds :: TypeEnv -> [Id] +typeEnvPatSyns :: TypeEnv -> [PatSyn] typeEnvDataCons :: TypeEnv -> [DataCon] typeEnvClasses :: TypeEnv -> [Class] lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing @@ -1620,7 +1639,8 @@ typeEnvElts env = nameEnvElts env typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] -typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env] +typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env] +typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env] typeEnvClasses env = [cl | tc <- typeEnvTyCons env, Just cl <- [tyConClass_maybe tc]] @@ -1656,6 +1676,16 @@ extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids = extendNameEnvList env [(getName id, AnId id) | id <- ids] +extendTypeEnvWithPatSyns :: TypeEnv -> [PatSyn] -> TypeEnv +extendTypeEnvWithPatSyns env patsyns + = extendNameEnvList env $ concatMap pat_syn_things patsyns + where + pat_syn_things :: PatSyn -> [(Name, TyThing)] + pat_syn_things ps = (getName ps, AConLike (PatSynCon ps)): + case patSynWrapper ps of + Just wrap_id -> [(getName wrap_id, AnId wrap_id)] + Nothing -> [] + \end{code} \begin{code} @@ -1704,14 +1734,14 @@ tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other) -- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise tyThingDataCon :: TyThing -> DataCon -tyThingDataCon (ADataCon dc) = dc -tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other) +tyThingDataCon (AConLike (RealDataCon dc)) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other) -- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise tyThingId :: TyThing -> Id -tyThingId (AnId id) = id -tyThingId (ADataCon dc) = dataConWrapId dc -tyThingId other = pprPanic "tyThingId" (pprTyThing other) +tyThingId (AnId id) = id +tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc +tyThingId other = pprPanic "tyThingId" (pprTyThing other) \end{code} %************************************************************************ diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 38b28e9c38..27e739009d 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -23,13 +23,16 @@ module PprTyThing ( ) where import TypeRep ( TyThing(..) ) +import ConLike import DataCon +import PatSyn import Id import TyCon import Class import Coercion( pprCoAxiom, pprCoAxBranch ) import CoAxiom( CoAxiom(..), brListMap ) import HscTypes( tyThingParent_maybe ) +import HsBinds( pprPatSynSig ) import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy ) import Kind( synTyConResKind ) import TypeRep( pprTvBndrs, pprForAll, suppressKinds ) @@ -41,6 +44,7 @@ import StaticFlags( opt_PprStyle_Debug ) import DynFlags import Outputable import FastString +import Data.Maybe -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API @@ -97,14 +101,18 @@ pprTyThingInContextLoc tyThing -- and classes it prints only the header part of the declaration. pprTyThingHdr :: TyThing -> SDoc pprTyThingHdr (AnId id) = pprId id -pprTyThingHdr (ADataCon dataCon) = pprDataConSig dataCon +pprTyThingHdr (AConLike conLike) = case conLike of + RealDataCon dataCon -> pprDataConSig dataCon + PatSynCon patSyn -> pprPatSyn patSyn pprTyThingHdr (ATyCon tyCon) = pprTyConHdr tyCon pprTyThingHdr (ACoAxiom ax) = pprCoAxiom ax ------------------------ ppr_ty_thing :: ShowSub -> TyThing -> SDoc ppr_ty_thing _ (AnId id) = pprId id -ppr_ty_thing _ (ADataCon dataCon) = pprDataConSig dataCon +ppr_ty_thing _ (AConLike conLike) = case conLike of + RealDataCon dataCon -> pprDataConSig dataCon + PatSynCon patSyn -> pprPatSyn patSyn ppr_ty_thing ss (ATyCon tyCon) = pprTyCon ss tyCon ppr_ty_thing _ (ACoAxiom ax) = pprCoAxiom ax @@ -155,6 +163,23 @@ pprId ident = hang (ppr_bndr ident <+> dcolon) 2 (pprTypeForUser (idType ident)) +pprPatSyn :: PatSyn -> SDoc +pprPatSyn patSyn + = pprPatSynSig ident is_bidir args (pprTypeForUser rhs_ty) prov req + where + ident = patSynId patSyn + is_bidir = isJust $ patSynWrapper patSyn + + args = fmap pprParendType (patSynTyDetails patSyn) + prov = pprThetaOpt prov_theta + req = pprThetaOpt req_theta + + pprThetaOpt [] = Nothing + pprThetaOpt theta = Just $ pprTheta theta + + (_univ_tvs, _ex_tvs, (prov_theta, req_theta)) = patSynSig patSyn + rhs_ty = patSynType patSyn + pprTypeForUser :: Type -> SDoc -- We do two things here. -- a) We tidy the type, regardless diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 91d0035b1b..7ab6d569bc 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -139,7 +139,8 @@ mkBootModDetailsTc hsc_env ; dfun_ids = map instanceDFunId insts' ; type_env1 = mkBootTypeEnv (availsToNameSet exports) (typeEnvIds type_env) tcs fam_insts - ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids + ; type_env2 = extendTypeEnvWithPatSyns type_env1 (typeEnvPatSyns type_env) + ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids } ; return (ModDetails { md_types = type_env' , md_insts = insts' @@ -296,6 +297,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod , mg_insts = insts , mg_fam_insts = fam_insts , mg_binds = binds + , mg_patsyns = patsyns , mg_rules = imp_rules , mg_vect_info = vect_info , mg_anns = anns @@ -331,9 +333,12 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; let { final_ids = [ id | id <- bindersOfBinds tidy_binds, isExternalName (idName id)] + ; final_patsyns = filter (isExternalName . getName) patsyns - ; tidy_type_env = tidyTypeEnv omit_prags - (extendTypeEnvWithIds type_env final_ids) + ; type_env' = extendTypeEnvWithIds type_env final_ids + ; type_env'' = extendTypeEnvWithPatSyns type_env' final_patsyns + + ; tidy_type_env = tidyTypeEnv omit_prags type_env'' ; tidy_insts = map (tidyClsInstDFun (lookup_dfun tidy_type_env)) insts -- A DFunId will have a binding in tidy_binds, and so diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 8eeab6b6e3..3d02393d17 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -59,7 +59,9 @@ module Lexer ( typeLiteralsEnabled, explicitForallEnabled, inRulePrag, - explicitNamespacesEnabled, sccProfilingOn, hpcEnabled, + explicitNamespacesEnabled, + patternSynonymsEnabled, + sccProfilingOn, hpcEnabled, addWarning, lexTokenStream ) where @@ -489,6 +491,7 @@ data Token | ITgroup | ITby | ITusing + | ITpattern -- Pragmas | ITinline_prag InlineSpec RuleMatchInfo @@ -667,6 +670,7 @@ reservedWordsFM = listToUFM $ -- See Note [Lexing type pseudo-keywords] ( "family", ITfamily, 0 ), ( "role", ITrole, 0 ), + ( "pattern", ITpattern, bit patternSynonymsBit), ( "group", ITgroup, bit transformComprehensionsBit), ( "by", ITby, bit transformComprehensionsBit), ( "using", ITusing, bit transformComprehensionsBit), @@ -1872,7 +1876,8 @@ explicitForallBit = 7 -- the 'forall' keyword and '.' symbol bangPatBit :: Int bangPatBit = 8 -- Tells the parser to understand bang-patterns -- (doesn't affect the lexer) --- Bit #9 is available! +patternSynonymsBit :: Int +patternSynonymsBit = 9 -- pattern synonyms haddockBit :: Int haddockBit = 10 -- Lex and parse Haddock comments magicHashBit :: Int @@ -1917,7 +1922,6 @@ lambdaCaseBit :: Int lambdaCaseBit = 30 negativeLiteralsBit :: Int negativeLiteralsBit = 31 --- need another bit? See bit 9 above. always :: Int -> Bool @@ -1973,6 +1977,8 @@ lambdaCaseEnabled :: Int -> Bool lambdaCaseEnabled flags = testBit flags lambdaCaseBit negativeLiteralsEnabled :: Int -> Bool negativeLiteralsEnabled flags = testBit flags negativeLiteralsBit +patternSynonymsEnabled :: Int -> Bool +patternSynonymsEnabled flags = testBit flags patternSynonymsBit -- PState for parsing options pragmas -- @@ -2036,6 +2042,7 @@ mkPState flags buf loc = .|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags .|. lambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags .|. negativeLiteralsBit `setBitIf` xopt Opt_NegativeLiterals flags + .|. patternSynonymsBit `setBitIf` xopt Opt_PatternSynonyms flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 92e4bd5c93..1715f6cc2f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -249,6 +249,7 @@ incorrect. 'group' { L _ ITgroup } -- for list transform extension 'by' { L _ ITby } -- for list transform extension 'using' { L _ ITusing } -- for list transform extension + 'pattern' { L _ ITpattern } -- for pattern synonyms '{-# INLINE' { L _ (ITinline_prag _ _) } '{-# SPECIALISE' { L _ ITspec_prag } @@ -478,6 +479,7 @@ export :: { OrdList (LIE RdrName) } : qcname_ext export_subspec { unitOL (LL (mkModuleImpExp (unLoc $1) (unLoc $2))) } | 'module' modid { unitOL (LL (IEModuleContents (unLoc $2))) } + | 'pattern' qcon { unitOL (LL (IEVar (unLoc $2))) } export_subspec :: { Located ImpExpSubSpec } : {- empty -} { L0 ImpExpAbs } @@ -804,6 +806,21 @@ role :: { Located (Maybe FastString) } role : VARID { L1 $ Just $ getVARID $1 } | '_' { L1 Nothing } +-- Pattern synonyms + +-- Glasgow extension: pattern synonyms +pattern_synonym_decl :: { LHsDecl RdrName } + : 'pattern' con vars0 patsyn_token pat { LL . ValD $ mkPatSynBind $2 (PrefixPatSyn $3) $5 $4 } + | 'pattern' varid conop varid patsyn_token pat { LL . ValD $ mkPatSynBind $3 (InfixPatSyn $2 $4) $6 $5 } + +vars0 :: { [Located RdrName] } + : {- empty -} { [] } + | varid vars0 { $1 : $2 } + +patsyn_token :: { HsPatSynDir RdrName } + : '<-' { Unidirectional } + | '=' { ImplicitBidirectional } + ----------------------------------------------------------------------------- -- Nested declarations @@ -1376,6 +1393,7 @@ decl_no_th :: { Located (OrdList (LHsDecl RdrName)) } | infixexp opt_sig rhs {% do { r <- checkValDef empty $1 $2 $3; let { l = comb2 $1 $> }; return $! (sL l (unitOL $! (sL l $ ValD r))) } } + | pattern_synonym_decl { LL $ unitOL $1 } | docdecl { LL $ unitOL $1 } decl :: { Located (OrdList (LHsDecl RdrName)) } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 79d2d966ec..b1e177a3a9 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -64,7 +64,7 @@ import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, import OccName ( tcClsName, isVarNameSpace ) import Name ( Name ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, - InlinePragma(..), InlineSpec(..) ) + InlinePragma(..), InlineSpec(..), Origin(..) ) import TcEvidence ( idHsWrapper ) import Lexer import TysWiredIn ( unitTyCon, unitDataCon ) @@ -75,7 +75,7 @@ import PrelNames ( forall_tv_RDR ) import DynFlags import SrcLoc import OrdList ( OrdList, fromOL ) -import Bag ( Bag, emptyBag, consBag ) +import Bag ( emptyBag, consBag ) import Outputable import FastString import Maybes @@ -305,7 +305,7 @@ cvBindGroup binding ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag ( LHsBind RdrName), [LSig RdrName], [LFamilyDecl RdrName] + -> (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName] , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also @@ -315,7 +315,7 @@ cvBindsAndSigs fb = go (fromOL fb) go [] = (emptyBag, [], [], [], [], []) go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs) where (bs, ss, ts, tfis, dfis, docs) = go ds - go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, tfis, dfis, docs) + go (L l (ValD b) : ds) = ((FromSource, b') `consBag` bs, ss, ts, tfis, dfis, docs) where (b', ds') = getMonoBind (L l b) ds (bs, ss, ts, tfis, dfis, docs) = go ds' go (L l (TyClD (FamDecl t)) : ds) = (bs, ss, L l t : ts, tfis, dfis, docs) diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 2830ca2187..bf1907d161 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -87,6 +87,7 @@ import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) import Type ( mkTyConApp ) import DataCon +import ConLike import Var import TyCon import Class ( Class, mkClass ) @@ -170,7 +171,7 @@ mkWiredInTyConName built_in modu fs unique tycon mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name mkWiredInDataConName built_in modu fs unique datacon = mkWiredInName modu (mkDataOccFS fs) unique - (ADataCon datacon) -- Relevant DataCon + (AConLike (RealDataCon datacon)) -- Relevant DataCon built_in eqTyConName, eqBoxDataConName :: Name @@ -400,7 +401,7 @@ mk_tuple sort arity = (tycon, tuple_con) tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon tyvar_tys = mkTyVarTys tyvars dc_name = mkWiredInName modu (mkTupleOcc dataName sort arity) dc_uniq - (ADataCon tuple_con) BuiltInSyntax + (AConLike (RealDataCon tuple_con)) BuiltInSyntax tc_uniq = mkTupleTyConUnique sort arity dc_uniq = mkTupleDataConUnique sort arity @@ -813,7 +814,7 @@ mkPArrFakeCon arity = data_con tyvarTys = replicate arity $ mkTyVarTy tyvar nameStr = mkFastString ("MkPArr" ++ show arity) name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique - (ADataCon data_con) UserSyntax + (AConLike (RealDataCon data_con)) UserSyntax unique = mkPArrDataConUnique arity -- | Checks whether a data constructor is a fake constructor for parallel arrays diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 9f9fd38f47..ed1343f23d 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -35,8 +35,9 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn import TcRnMonad import TcEvidence ( emptyTcEvBinds ) -import RnTypes ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch ) +import RnTypes ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch, rnContext ) import RnPat +import RnNames import RnEnv import DynFlags import Module @@ -46,7 +47,7 @@ import NameSet import RdrName ( RdrName, rdrNameOcc ) import SrcLoc import ListSetOps ( findDupsEq ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), Origin ) import Digraph ( SCC(..) ) import Bag import Outputable @@ -274,7 +275,7 @@ rnValBindsLHS :: NameMaker -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnValBindsLHS topP (ValBindsIn mbinds sigs) - = do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds + = do { mbinds' <- mapBagM (wrapOriginLocM (rnBindLHS topP doc)) mbinds ; return $ ValBindsIn mbinds' sigs } where bndrs = collectHsBindsBinders mbinds @@ -292,7 +293,7 @@ rnValBindsRHS :: HsSigCtxt rnValBindsRHS ctxt (ValBindsIn mbinds sigs) = do { (sigs', sig_fvs) <- renameSigs ctxt sigs - ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds + ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds ; case depAnalBinds binds_w_dus of (anal_binds, anal_dus) -> return (valbind', valbind'_dus) where @@ -413,39 +414,50 @@ dupFixityDecl loc rdr_name rnBindLHS :: NameMaker -> SDoc - -> LHsBind RdrName + -> HsBind RdrName -- returns the renamed left-hand side, -- and the FreeVars *of the LHS* -- (i.e., any free variables of the pattern) - -> RnM (LHsBindLR Name RdrName) + -> RnM (HsBindLR Name RdrName) -rnBindLHS name_maker _ (L loc bind@(PatBind { pat_lhs = pat })) - = setSrcSpan loc $ do +rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) + = do -- we don't actually use the FV processing of rnPatsAndThen here (pat',pat'_fvs) <- rnBindPat name_maker pat - return (L loc (bind { pat_lhs = pat', bind_fvs = pat'_fvs })) + return (bind { pat_lhs = pat', bind_fvs = pat'_fvs }) -- We temporarily store the pat's FVs in bind_fvs; -- gets updated to the FVs of the whole bind -- when doing the RHS below - -rnBindLHS name_maker _ (L loc bind@(FunBind { fun_id = name@(L nameLoc _) })) - = setSrcSpan loc $ - do { newname <- applyNameMaker name_maker name - ; return (L loc (bind { fun_id = L nameLoc newname })) } -rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b) +rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) }) + = do { newname <- applyNameMaker name_maker name + ; return (bind { fun_id = L nameLoc newname }) } + +rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) }) + = do { addLocM checkConName rdrname + ; name <- applyNameMaker name_maker rdrname + ; return (bind{ patsyn_id = L nameLoc name }) } + +rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) + +rnLBind :: (Name -> [Name]) -- Signature tyvar function + -> (Origin, LHsBindLR Name RdrName) + -> RnM ((Origin, LHsBind Name), [Name], Uses) +rnLBind sig_fn (origin, (L loc bind)) + = setSrcSpan loc $ + do { (bind', bndrs, dus) <- rnBind sig_fn bind + ; return ((origin, L loc bind'), bndrs, dus) } -- assumes the left-hands-side vars are in scope rnBind :: (Name -> [Name]) -- Signature tyvar function - -> LHsBindLR Name RdrName - -> RnM (LHsBind Name, [Name], Uses) -rnBind _ (L loc bind@(PatBind { pat_lhs = pat - , pat_rhs = grhss - -- pat fvs were stored in bind_fvs - -- after processing the LHS - , bind_fvs = pat_fvs })) - = setSrcSpan loc $ - do { mod <- getModule + -> HsBindLR Name RdrName + -> RnM (HsBind Name, [Name], Uses) +rnBind _ bind@(PatBind { pat_lhs = pat + , pat_rhs = grhss + -- pat fvs were stored in bind_fvs + -- after processing the LHS + , bind_fvs = pat_fvs }) + = do { mod <- getModule ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss -- No scoped type variables for pattern bindings @@ -470,14 +482,13 @@ rnBind _ (L loc bind@(PatBind { pat_lhs = pat addWarn $ unusedPatBindWarn bind' ; fvs' `seq` -- See Note [Free-variable space leak] - return (L loc bind', bndrs, all_fvs) } + return (bind', bndrs, all_fvs) } -rnBind sig_fn (L loc bind@(FunBind { fun_id = name - , fun_infix = is_infix - , fun_matches = matches })) +rnBind sig_fn bind@(FunBind { fun_id = name + , fun_infix = is_infix + , fun_matches = matches }) -- invariant: no free vars here when it's a FunBind - = setSrcSpan loc $ - do { let plain_name = unLoc name + = do { let plain_name = unLoc name ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ -- bindSigTyVars tests for Opt_ScopedTyVars @@ -491,11 +502,62 @@ rnBind sig_fn (L loc bind@(FunBind { fun_id = name -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan ; fvs' `seq` -- See Note [Free-variable space leak] - return (L loc (bind { fun_matches = matches' - , bind_fvs = fvs' }), + return (bind { fun_matches = matches' + , bind_fvs = fvs' }, [plain_name], rhs_fvs) } +rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name + , patsyn_args = details + , patsyn_def = pat + , patsyn_dir = dir }) + -- invariant: no free vars here when it's a FunBind + = do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms + ; unless pattern_synonym_ok (addErr patternSynonymErr) + + ; ((pat', details'), fvs) <- rnPat PatSyn pat $ \pat' -> do + -- We check the 'RdrName's instead of the 'Name's + -- so that the binding locations are reported + -- from the left-hand side + { (details', fvs) <- case details of + PrefixPatSyn vars -> + do { checkDupRdrNames vars + ; names <- mapM lookupVar vars + ; return (PrefixPatSyn names, mkFVs (map unLoc names)) } + InfixPatSyn var1 var2 -> + do { checkDupRdrNames [var1, var2] + ; name1 <- lookupVar var1 + ; name2 <- lookupVar var2 + -- ; checkPrecMatch -- TODO + ; return (InfixPatSyn name1 name2, mkFVs (map unLoc [name1, name2])) } + ; return ((pat', details'), fvs) } + ; dir' <- case dir of + Unidirectional -> return Unidirectional + ImplicitBidirectional -> return ImplicitBidirectional + + ; mod <- getModule + ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan + + ; let bind' = bind{ patsyn_args = details' + , patsyn_def = pat' + , patsyn_dir = dir' + , bind_fvs = fvs' } + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', [name], fvs) + } + where + lookupVar = wrapLocM lookupOccRn + + patternSynonymErr :: SDoc + patternSynonymErr + = hang (ptext (sLit "Illegal pattern synonym declaration")) + 2 (ptext (sLit "Use -XPatternSynonyms to enable this extension")) + + rnBind _ b = pprPanic "rnBind" (ppr b) {- @@ -512,7 +574,7 @@ trac ticket #1136. -} --------------------- -depAnalBinds :: Bag (LHsBind Name, [Name], Uses) +depAnalBinds :: Bag ((Origin, LHsBind Name), [Name], Uses) -> ([(RecFlag, LHsBinds Name)], DefUses) -- Dependency analysis; this is important so that -- unused-binding reporting is accurate @@ -597,9 +659,10 @@ rnMethodBinds cls sig_fn binds ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) } where meth_names = collectMethodBinders binds - do_one (binds,fvs) bind + do_one (binds,fvs) (origin,bind) = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind - ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) } + ; let bind'' = mapBag (\bind -> (origin,bind)) bind' + ; return (binds `unionBags` bind'', fvs_bind `plusFV` fvs) } rnMethodBind :: Name -> (Name -> [Name]) @@ -720,6 +783,24 @@ renameSig ctxt sig@(MinimalSig bf) = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf return (MinimalSig new_bf, emptyFVs) +renameSig ctxt sig@(PatSynSig v args ty prov req) + = do v' <- lookupSigOccRn ctxt sig v + let doc = quotes (ppr v) + rn_type = rnHsSigType doc + (ty', fvs1) <- rn_type ty + (args', fvs2) <- case args of + PrefixPatSyn tys -> + do (tys, fvs) <- unzip <$> mapM rn_type tys + return (PrefixPatSyn tys, plusFVs fvs) + InfixPatSyn left right -> + do (left', fvs1) <- rn_type left + (right', fvs2) <- rn_type right + return (InfixPatSyn left' right', fvs1 `plusFV` fvs2) + (prov', fvs3) <- rnContext (TypeSigCtx doc) prov + (req', fvs4) <- rnContext (TypeSigCtx doc) req + let fvs = plusFVs [fvs1, fvs2, fvs3, fvs4] + return (PatSynSig v' args' ty' prov' req', fvs) + ppr_sig_bndrs :: [Located RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) @@ -731,6 +812,9 @@ okHsSig ctxt (L _ sig) (TypeSig {}, _) -> True + (PatSynSig {}, TopSigCtxt{}) -> True + (PatSynSig {}, _) -> False + (FixSig {}, InstDeclCtxt {}) -> False (FixSig {}, _) -> True diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index d29c3f3b9a..1028d08f03 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -60,6 +60,7 @@ import NameEnv import Avail import Module import UniqFM +import ConLike import DataCon ( dataConFieldLabels, dataConTyCon ) import TyCon ( isTupleTyCon, tyConArity ) import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR ) @@ -233,9 +234,9 @@ lookupExactOcc :: Name -> RnM Name lookupExactOcc name | Just thing <- wiredInNameTyThing_maybe name , Just tycon <- case thing of - ATyCon tc -> Just tc - ADataCon dc -> Just (dataConTyCon dc) - _ -> Nothing + ATyCon tc -> Just tc + AConLike (RealDataCon dc) -> Just (dataConTyCon dc) + _ -> Nothing , isTupleTyCon tycon = do { checkTupSize (tyConArity tycon) ; return name } diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 823123309b..56ee969aed 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -9,6 +9,7 @@ module RnNames ( rnExports, extendGlobalRdrEnvRn, gresFromAvails, reportUnusedNames, + checkConName ) where #include "HsVersions.h" @@ -1689,4 +1690,21 @@ moduleWarn mod (DeprecatedTxt txt) packageImportErr :: SDoc packageImportErr = ptext (sLit "Package-qualified imports are not enabled; use PackageImports") + +-- This data decl will parse OK +-- data T = a Int +-- treating "a" as the constructor. +-- It is really hard to make the parser spot this malformation. +-- So the renamer has to check that the constructor is legal +-- +-- We can get an operator as the constructor, even in the prefix form: +-- data T = :% Int Int +-- from interface files, which always print in prefix form + +checkConName :: RdrName -> TcRn () +checkConName name = checkErr (isRdrDataCon name) (badDataCon name) + +badDataCon :: RdrName -> SDoc +badDataCon name + = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)] \end{code} diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index fc62ed24d5..639ab51101 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -52,6 +52,7 @@ import RnTypes import DynFlags import PrelNames import TyCon ( tyConName ) +import ConLike import DataCon ( dataConTyCon ) import TypeRep ( TyThing(..) ) import Name @@ -135,13 +136,14 @@ wrapSrcSpanCps fn (L loc a) lookupConCps :: Located RdrName -> CpsRn (Located Name) lookupConCps con_rdr = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr - ; k con_name }) - -- We do not add the constructor name to the free vars - -- See Note [Patterns are not uses] + ; (r, fvs) <- k con_name + ; return (r, addOneFV fvs (unLoc con_name)) }) + -- We add the constructor name to the free vars + -- See Note [Patterns are uses] \end{code} -Note [Patterns are not uses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Patterns are uses] +~~~~~~~~~~~~~~~~~~~~~~~~ Consider module Foo( f, g ) where data T = T1 | T2 @@ -154,6 +156,18 @@ Consider Arguaby we should report T2 as unused, even though it appears in a pattern, because it never occurs in a constructed position. See Trac #7336. +However, implementing this in the face of pattern synonyms would be +less straightforward, since given two pattern synonyms + + pattern P1 <- P2 + pattern P2 <- () + +we need to observe the dependency between P1 and P2 so that type +checking can be done in the correct order (just like for value +bindings). Dependencies between bindings is analyzed in the renamer, +where we don't know yet whether P2 is a constructor or a pattern +synonym. So for now, we do report conid occurances in patterns as +uses. %********************************************************* %* * @@ -603,7 +617,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } -- That is, the parent of the data constructor. -- That's the parent to use for looking up record fields. find_tycon env con - | Just (ADataCon dc) <- wiredInNameTyThing_maybe con + | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con = tyConName (dataConTyCon dc) -- Special case for [], which is built-in syntax -- and not in the GlobalRdrEnv (Trac #8448) | [GRE { gre_par = ParentIs p }] <- lookupGRE_Name env con diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 82ca29d9d3..f3b4d9178d 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -35,7 +35,7 @@ import NameEnv import Avail import Outputable import Bag -import BasicTypes ( RuleName ) +import BasicTypes ( RuleName, Origin(..) ) import FastString import SrcLoc import DynFlags @@ -617,8 +617,8 @@ type variable environment iff -fglasgow-exts \begin{code} extendTyVarEnvForMethodBinds :: [Name] - -> RnM (Bag (LHsBind Name), FreeVars) - -> RnM (Bag (LHsBind Name), FreeVars) + -> RnM (LHsBinds Name, FreeVars) + -> RnM (LHsBinds Name, FreeVars) extendTyVarEnvForMethodBinds ktv_names thing_inside = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables ; if scoped_tvs then @@ -1342,23 +1342,6 @@ deprecRecSyntax decl badRecResTy :: SDoc -> SDoc badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc - --- This data decl will parse OK --- data T = a Int --- treating "a" as the constructor. --- It is really hard to make the parser spot this malformation. --- So the renamer has to check that the constructor is legal --- --- We can get an operator as the constructor, even in the prefix form: --- data T = :% Int Int --- from interface files, which always print in prefix form - -checkConName :: RdrName -> TcRn () -checkConName name = checkErr (isRdrDataCon name) (badDataCon name) - -badDataCon :: RdrName -> SDoc -badDataCon name - = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)] \end{code} Note [Infix GADT constructors] @@ -1535,7 +1518,7 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) = tycls { group_roles = d : roles } : rest add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs +add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` (FromSource, b)) sigs add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" add_sig :: LSig a -> HsValBinds a -> HsValBinds a diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index b3b1a3f5c3..47d45ae318 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -14,6 +14,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) +import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl ) import DynFlags import HsSyn @@ -26,6 +27,8 @@ import TcEvidence import TcHsType import TcPat import TcMType +import PatSyn +import ConLike import Type( tidyOpenType ) import FunDeps( growThetaTyVars ) import TyCon @@ -153,8 +156,11 @@ tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv) -- The TcGblEnv contains the new tcg_binds and tcg_spects -- The TcLclEnv has an extended type envt for the new bindings tcTopBinds (ValBindsOut binds sigs) - = do { tcg_env <- getGblEnv - ; (binds', tcl_env) <- tcValBinds TopLevel binds sigs getLclEnv + = do { -- Pattern synonym bindings populate the global environment + (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $ + do { gbl <- getGblEnv + ; lcl <- getLclEnv + ; return (gbl, lcl) } ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids ; let { tcg_env' = tcg_env { tcg_binds = foldr (unionBags . snd) @@ -165,6 +171,7 @@ tcTopBinds (ValBindsOut binds sigs) ; return (tcg_env', tcl_env) } -- The top level bindings are flattened into a giant -- implicitly-mutually-recursive LHsBinds + tcTopBinds (ValBindsIn {}) = panic "tcTopBinds" tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv @@ -318,11 +325,12 @@ tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside -- A single non-recursive binding -- We want to keep non-recursive things non-recursive -- so that we desugar unlifted bindings correctly - = do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn - NonRecursive NonRecursive - (bagToList binds) - ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside - ; return ( [(NonRecursive, binds1)], thing) } + = do { let bind = case bagToList binds of + [] -> panic "tc_group: empty list of binds" + [bind] -> bind + _ -> panic "tc_group: NonRecursive binds is not a singleton bag" + ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside + ; return ( [(NonRecursive, bind')], thing) } tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside = -- To maximise polymorphism, we do a new @@ -330,16 +338,21 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside -- any references to variables with type signatures. -- (This used to be optional, but isn't now.) do { traceTc "tc_group rec" (pprLHsBinds binds) + ; when hasPatSyn $ recursivePatSynErr binds ; (binds1, _ids, thing) <- go sccs -- Here is where we should do bindInstsOfLocalFuns -- if we start having Methods again ; return ([(Recursive, binds1)], thing) } -- Rec them all together where - sccs :: [SCC (LHsBind Name)] + hasPatSyn = anyBag (isPatSyn . unLoc . snd) binds + isPatSyn PatSynBind{} = True + isPatSyn _ = False + + sccs :: [SCC (Origin, LHsBind Name)] sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds) - go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing) + go :: [SCC (Origin, LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing) go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc ; (binds2, ids2, thing) <- tcExtendLetEnv top_lvl closed ids1 $ go sccs @@ -351,14 +364,48 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive +recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a +recursivePatSynErr binds + = failWithTc $ + hang (ptext (sLit "Recursive pattern synonym definition with following bindings:")) + 2 (vcat $ map (pprLBind . snd) . bagToList $ binds) + where + pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc) + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> + pprLoc loc + +tc_single :: forall thing. + TopLevelFlag -> TcSigFun -> PragFun + -> (Origin, LHsBind Name) -> TcM thing + -> TcM (LHsBinds TcId, thing) +tc_single _top_lvl _sig_fn _prag_fn (_, (L _ ps@PatSynBind{})) thing_inside + = do { (pat_syn, aux_binds) <- + tcPatSynDecl (patsyn_id ps) (patsyn_args ps) (patsyn_def ps) (patsyn_dir ps) + + ; let tything = AConLike (PatSynCon pat_syn) + implicit_ids = (patSynMatcher pat_syn) : + (maybeToList (patSynWrapper pat_syn)) + + ; thing <- tcExtendGlobalEnv [tything] $ + tcExtendGlobalEnvImplicit (map AnId implicit_ids) $ + thing_inside + ; return (aux_binds, thing) + } +tc_single top_lvl sig_fn prag_fn lbind thing_inside + = do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn + NonRecursive NonRecursive + [lbind] + ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside + ; return (binds1, thing) } + ------------------------ mkEdges :: TcSigFun -> LHsBinds Name - -> [(LHsBind Name, BKey, [BKey])] + -> [((Origin, LHsBind Name), BKey, [BKey])] type BKey = Int -- Just number off the bindings mkEdges sig_fn binds - = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)), + = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc . snd $ bind)), Just key <- [lookupNameEnv key_map n], no_sig n ]) | (bind, key) <- keyd_binds ] @@ -369,21 +416,22 @@ mkEdges sig_fn binds keyd_binds = bagToList binds `zip` [0::BKey ..] key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + key_map = mkNameEnv [(bndr, key) | ((_, L _ bind), key) <- keyd_binds , bndr <- bindersOfHsBind bind ] bindersOfHsBind :: HsBind Name -> [Name] -bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat -bindersOfHsBind (FunBind { fun_id = L _ f }) = [f] -bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds" -bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind" +bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat +bindersOfHsBind (FunBind { fun_id = L _ f }) = [f] +bindersOfHsBind (PatSynBind { patsyn_id = L _ psyn }) = [psyn] +bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds" +bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind" ------------------------ tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures - -> [LHsBind Name] + -> [(Origin, LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) -- Typechecks a single bunch of bindings all together, @@ -409,9 +457,9 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list binder_names bind_list sig_fn ; traceTc "Generalisation plan" (ppr plan) ; result@(tc_binds, poly_ids, _) <- case plan of - NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list - InferGen mn cl -> tcPolyInfer rec_tc prag_fn sig_fn mn cl bind_list - CheckGen sig -> tcPolyCheck rec_tc prag_fn sig bind_list + NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list + InferGen mn cl -> tcPolyInfer rec_tc prag_fn sig_fn mn cl bind_list + CheckGen lbind sig -> tcPolyCheck rec_tc prag_fn sig lbind -- Check whether strict bindings are ok -- These must be non-recursive etc, and are not generalised @@ -423,8 +471,9 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list ; return result } where - binder_names = collectHsBindListBinders bind_list - loc = foldr1 combineSrcSpans (map getLoc bind_list) + bind_list' = map snd bind_list + binder_names = collectHsBindListBinders bind_list' + loc = foldr1 combineSrcSpans (map getLoc bind_list') -- The mbinds have been dependency analysed and -- may no longer be adjacent; so find the narrowest -- span that includes them all @@ -434,7 +483,7 @@ tcPolyNoGen -- No generalisation whatsoever :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> PragFun -> TcSigFun - -> [LHsBind Name] + -> [(Origin, LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list @@ -459,7 +508,7 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list tcPolyCheck :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> PragFun -> TcSigInfo - -> [LHsBind Name] + -> (Origin, LHsBind Name) -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) -- There is just one binding, -- it binds a single variable, @@ -467,7 +516,7 @@ tcPolyCheck :: RecFlag -- Whether it's recursive after breaking tcPolyCheck rec_tc prag_fn sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped , sig_theta = theta, sig_tau = tau, sig_loc = loc }) - bind_list + bind@(origin, _) = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau) prag_sigs = prag_fn (idName poly_id) @@ -476,7 +525,7 @@ tcPolyCheck rec_tc prag_fn <- setSrcSpan loc $ checkConstraints skol_info tvs ev_vars $ tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $ - tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr bind_list + tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr [bind] ; spec_prags <- tcSpecPrags poly_id prag_sigs ; poly_id <- addInlinePrags poly_id prag_sigs @@ -492,7 +541,7 @@ tcPolyCheck rec_tc prag_fn , abs_exports = [export], abs_binds = binds' } closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel | otherwise = NotTopLevel - ; return (unitBag abs_bind, [poly_id], closed) } + ; return (unitBag (origin, abs_bind), [poly_id], closed) } ------------------ tcPolyInfer @@ -501,7 +550,7 @@ tcPolyInfer -> PragFun -> TcSigFun -> Bool -- True <=> apply the monomorphism restriction -> Bool -- True <=> free vars have closed types - -> [LHsBind Name] + -> [(Origin, LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list = do { ((binds', mono_infos), wanted) @@ -527,8 +576,10 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list ; traceTc "Binding:" (ppr final_closed $$ ppr (poly_ids `zip` map idType poly_ids)) - ; return (unitBag abs_bind, poly_ids, final_closed) } + ; return (unitBag (origin, abs_bind), poly_ids, final_closed) } -- poly_ids are guaranteed zonked by mkExport + where + origin = if all isGenerated (map fst bind_list) then Generated else FromSource -------------- mkExport :: PragFun @@ -672,7 +723,7 @@ mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` [] -- ar_env maps a local to the arity of its definition ar_env :: NameEnv Arity - ar_env = foldrBag lhsBindArity emptyNameEnv binds + ar_env = foldrBag (lhsBindArity . snd) emptyNameEnv binds lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env @@ -941,12 +992,12 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -- i.e. the binders are mentioned in their RHSs, and -- we are not rescued by a type signature -> TcSigFun -> LetBndrSpec - -> [LHsBind Name] + -> [(Origin, LHsBind Name)] -> TcM (LHsBinds TcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen - [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, - fun_matches = matches, bind_fvs = fvs })] + [ (origin, L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, + fun_matches = matches, bind_fvs = fvs }))] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature @@ -964,16 +1015,17 @@ tcMonoBinds is_rec sig_fn no_gen -- type of the thing whose rhs we are type checking tcMatchesFun name inf matches rhs_ty - ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, + ; return (unitBag (origin, + L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', bind_fvs = fvs, fun_co_fn = co_fn, fun_tick = Nothing })), [(name, Nothing, mono_id)]) } tcMonoBinds _ sig_fn no_gen binds - = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds + = do { tc_binds <- mapM (wrapOriginLocM (tcLhs sig_fn no_gen)) binds -- Bring the monomorphic Ids, into scope for the RHSs - ; let mono_info = getMonoBindInfo tc_binds + ; let mono_info = getMonoBindInfo (map snd tc_binds) rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info] -- A monomorphic binding for each term variable that lacks -- a type sig. (Ones with a sig are already in scope.) @@ -981,7 +1033,7 @@ tcMonoBinds _ sig_fn no_gen binds ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env] ; binds' <- tcExtendIdEnv2 rhs_id_env $ - mapM (wrapLocM tcRhs) tc_binds + mapM (wrapOriginLocM tcRhs) tc_binds ; return (listToBag binds', mono_info) } ------------------------ @@ -1242,7 +1294,8 @@ data GeneralisationPlan Bool -- True <=> bindings mention only variables with closed types -- See Note [Bindings with closed types] in TcRnTypes - | CheckGen TcSigInfo -- One binding with a signature + | CheckGen (Origin, LHsBind Name) TcSigInfo + -- One binding with a signature -- Explicit generalisation; there is an AbsBinds -- A consequence of the no-AbsBinds choice (NoGen) is that there is @@ -1251,20 +1304,20 @@ data GeneralisationPlan instance Outputable GeneralisationPlan where ppr NoGen = ptext (sLit "NoGen") ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c - ppr (CheckGen s) = ptext (sLit "CheckGen") <+> ppr s + ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s decideGeneralisationPlan :: DynFlags -> TcTypeEnv -> [Name] - -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan + -> [(Origin, LHsBind Name)] -> TcSigFun -> GeneralisationPlan decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn - | bang_pat_binds = NoGen - | Just sig <- one_funbind_with_sig binds = CheckGen sig - | mono_local_binds = NoGen - | otherwise = InferGen mono_restriction closed_flag + | bang_pat_binds = NoGen + | Just (lbind, sig) <- one_funbind_with_sig lbinds = CheckGen lbind sig + | mono_local_binds = NoGen + | otherwise = InferGen mono_restriction closed_flag where bndr_set = mkNameSet bndr_names - binds = map unLoc lbinds + binds = map (unLoc . snd) lbinds bang_pat_binds = any isBangHsBind binds -- Bang patterns must not be polymorphic, @@ -1305,14 +1358,19 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn -- With OutsideIn, all nested bindings are monomorphic -- except a single function binding with a signature - one_funbind_with_sig [FunBind { fun_id = v }] = sig_fn (unLoc v) - one_funbind_with_sig _ = Nothing + one_funbind_with_sig [lbind@(_, L _ (FunBind { fun_id = v }))] + = case sig_fn (unLoc v) of + Nothing -> Nothing + Just sig -> Just (lbind, sig) + one_funbind_with_sig _ + = Nothing -- The Haskell 98 monomorphism resetriction restricted (PatBind {}) = True restricted (VarBind { var_id = v }) = no_sig v restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m && no_sig (unLoc v) + restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind" restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds" restricted_match (MG { mg_alts = L _ (Match [] _ _) : _ }) = True @@ -1322,7 +1380,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn ------------------- checkStrictBinds :: TopLevelFlag -> RecFlag - -> [LHsBind Name] + -> [(Origin, LHsBind Name)] -> LHsBinds TcId -> [Id] -> TcM () -- Check that non-overloaded unlifted bindings are @@ -1364,31 +1422,31 @@ checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids return () where unlifted = any is_unlifted poly_ids - bang_pat = any (isBangHsBind . unLoc) orig_binds - lifted_pat = any (isLiftedPatBind . unLoc) orig_binds + bang_pat = any (isBangHsBind . unLoc . snd) orig_binds + lifted_pat = any (isLiftedPatBind . unLoc . snd) orig_binds is_unlifted id = case tcSplitForAllTys (idType id) of (_, rho) -> isUnLiftedType rho - is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })) + is_monomorphic (_, (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))) = null tvs && null evs is_monomorphic _ = True -unliftedMustBeBang :: [LHsBind Name] -> SDoc +unliftedMustBeBang :: [(Origin, LHsBind Name)] -> SDoc unliftedMustBeBang binds = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:") - 2 (vcat (map ppr binds)) + 2 (vcat (map (ppr . snd) binds)) -polyBindErr :: [LHsBind Name] -> SDoc +polyBindErr :: [(Origin, LHsBind Name)] -> SDoc polyBindErr binds = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings")) - 2 (vcat [vcat (map ppr binds), + 2 (vcat [vcat (map (ppr . snd) binds), ptext (sLit "Probable fix: use a bang pattern")]) -strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc +strictBindErr :: String -> Bool -> [(Origin, LHsBind Name)] -> SDoc strictBindErr flavour unlifted binds = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) - 2 (vcat (map ppr binds)) + 2 (vcat (map (ppr . snd) binds)) where msg | unlifted = ptext (sLit "bindings for unlifted types") | otherwise = ptext (sLit "bang-pattern bindings") diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 835043afdf..f61f48e92a 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -121,7 +121,7 @@ tcClassSigs clas sigs def_methods vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs] gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs] dm_bind_names :: [Name] -- These ones have a value binding in the class decl - dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] + dm_bind_names = [op | (_, L _ (FunBind {fun_id = L _ op})) <- bagToList def_methods] tc_sig genop_env (op_names, op_hs_ty) = do { traceTc "ClsSig 1" (ppr op_names) @@ -202,7 +202,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) sel_name = idName sel_id prags = prag_fn sel_name (dm_bind,bndr_loc) = findMethodBind sel_name binds_in - `orElse` pprPanic "tcDefMeth" (ppr sel_id) + `orElse` pprPanic "tcDefMeth" (ppr sel_id) -- Eg. class C a where -- op :: forall b. Eq b => a -> [b] -> a @@ -238,18 +238,18 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) --------------- tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] -> Id -> TcSigInfo - -> TcSpecPrags -> LHsBind Name - -> TcM (LHsBind Id) + -> TcSpecPrags -> (Origin, LHsBind Name) + -> TcM (Origin, LHsBind Id) tcInstanceMethodBody skol_info tyvars dfun_ev_vars meth_id local_meth_sig - specs (L loc bind) + specs (origin, (L loc bind)) = do { let local_meth_id = sig_id local_meth_sig lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind ; (ev_binds, (tc_bind, _, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ - tcPolyCheck NonRecursive no_prag_fn local_meth_sig [lm_bind] + tcPolyCheck NonRecursive no_prag_fn local_meth_sig (origin, lm_bind) ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = specs } @@ -258,7 +258,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars , abs_ev_binds = ev_binds , abs_binds = tc_bind } - ; return (L loc full_bind) } + ; return (origin, L loc full_bind) } where no_prag_fn _ = [] -- No pragmas for local_meth_id; -- they are all for meth_id @@ -326,13 +326,13 @@ lookupHsSig = lookupNameEnv --------------------------- findMethodBind :: Name -- Selector name -> LHsBinds Name -- A group of bindings - -> Maybe (LHsBind Name, SrcSpan) + -> Maybe ((Origin, LHsBind Name), SrcSpan) -- Returns the binding, and the binding -- site of the method binder findMethodBind sel_name binds = foldlBag mplus Nothing (mapBag f binds) where - f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) + f bind@(_, L _ (FunBind { fun_id = L bndr_loc op_name })) | op_name == sel_name = Just (bind, bndr_loc) f _other = Nothing diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index dababa1609..db79061e2f 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -60,6 +60,7 @@ import Outputable import FastString import Bag import Pair +import BasicTypes (Origin(..)) import Control.Monad import Data.List @@ -436,7 +437,7 @@ commonAuxiliaries = foldM snoc ([], emptyBag) where renameDeriv :: Bool -> [InstInfo RdrName] - -> Bag (LHsBind RdrName, LSig RdrName) + -> Bag ((Origin, LHsBind RdrName), LSig RdrName) -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses) renameDeriv is_boot inst_infos bagBinds | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 1ac649b77e..a2df338140 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -17,6 +17,7 @@ module TcEnv( tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, + tcLookupConLike, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom, @@ -70,6 +71,7 @@ import VarSet import RdrName import InstEnv import DataCon +import ConLike import TyCon import CoAxiom import TypeRep @@ -152,8 +154,15 @@ tcLookupDataCon :: Name -> TcM DataCon tcLookupDataCon name = do thing <- tcLookupGlobal name case thing of - ADataCon con -> return con - _ -> wrongThingErr "data constructor" (AGlobal thing) name + AConLike (RealDataCon con) -> return con + _ -> wrongThingErr "data constructor" (AGlobal thing) name + +tcLookupConLike :: Name -> TcM ConLike +tcLookupConLike name = do + thing <- tcLookupGlobal name + case thing of + AConLike cl -> return cl + _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name tcLookupClass :: Name -> TcM Class tcLookupClass name = do @@ -249,7 +258,8 @@ tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r -- module being compiled, extend the global environment tcExtendGlobalEnv things thing_inside = do { env <- getGblEnv - ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env } + ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env, + tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env } ; setGblEnv env' $ tcExtendGlobalEnvImplicit things thing_inside } diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 1c355f655e..409a230471 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -35,7 +35,9 @@ import TcMType import TcType import DsMonad hiding (Splice) import Id +import ConLike import DataCon +import PatSyn import RdrName import Name import TyCon @@ -1074,12 +1076,18 @@ tcInferIdWithOrig orig id_name -- nor does it need the 'lifting' treatment -- hence no checkTh stuff here - AGlobal (ADataCon con) -> return (dataConWrapId con) + AGlobal (AConLike cl) -> case cl of + RealDataCon con -> return (dataConWrapId con) + PatSynCon ps -> case patSynWrapper ps of + Nothing -> failWithTc (bad_patsyn ps) + Just id -> return id other -> failWithTc (bad_lookup other) } bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected") + bad_patsyn name = ppr name <+> ptext (sLit "used in an expression, but it's a non-bidirectional pattern synonym") + check_naughty id | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id) | otherwise = return () @@ -1399,7 +1407,7 @@ tcRecordBinds data_con arg_tys (HsRecFields rbinds dd) -- (so the desugarer knows the type of local binder to make) ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) } | otherwise - = do { addErrTc (badFieldCon data_con field_lbl) + = do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl) ; return Nothing } checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 63eb020ff1..26af2c5ebf 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -58,6 +58,7 @@ import SrcLoc import Bag import FastString import Hooks +import BasicTypes (Origin(..)) import Control.Monad \end{code} @@ -350,7 +351,7 @@ tcForeignExports' decls where combine (binds, fs, gres1) (L loc fe) = do (b, f, gres2) <- setSrcSpan loc (tcFExport fe) - return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) + return ((FromSource, b) `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id, Bag GlobalRdrElt) tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 0040be206b..3852106d72 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -33,7 +33,8 @@ module TcGenDeriv ( mkCoerceClassMethEqn, gen_Newtype_binds, genAuxBinds, - ordOpTbl, boxConTbl + ordOpTbl, boxConTbl, + mkRdrFunBind ) where #include "HsVersions.h" @@ -96,7 +97,7 @@ data DerivStuff -- Please add this auxiliary stuff | DerivFamInst (FamInst) -- New type family instances -- New top-level auxiliary bindings - | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB + | DerivHsBind ((Origin, LHsBind RdrName), LSig RdrName) -- Also used for SYB | DerivInst (InstInfo RdrName) -- New, auxiliary instances \end{code} @@ -359,7 +360,7 @@ gen_Ord_binds loc tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons - mkOrdOp :: OrdOp -> LHsBind RdrName + mkOrdOp :: OrdOp -> (Origin, LHsBind RdrName) -- Returns a binding op a b = ... compares a and b according to op .... mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op) @@ -1351,7 +1352,7 @@ gen_Data_binds dflags loc tycon n_cons = length data_cons one_constr = n_cons == 1 - genDataTyCon :: (LHsBind RdrName, LSig RdrName) + genDataTyCon :: ((Origin, LHsBind RdrName), LSig RdrName) genDataTyCon -- $dT = (mkHsVarBind loc rdr_name rhs, L loc (TypeSig [L loc rdr_name] sig_ty)) @@ -1363,7 +1364,7 @@ gen_Data_binds dflags loc tycon `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr tycon))) `nlHsApp` nlList constrs - genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName) + genDataDataCon :: DataCon -> ((Origin, LHsBind RdrName), LSig RdrName) genDataDataCon dc -- $cT1 etc = (mkHsVarBind loc rdr_name rhs, L loc (TypeSig [L loc rdr_name] sig_ty)) @@ -1602,7 +1603,7 @@ gen_Functor_binds loc tycon = (unitBag fmap_bind, emptyBag) where data_cons = tyConDataCons tycon - fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns + fmap_bind = mkRdrFunBind (L loc fmap_RDR) eqns fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs where @@ -1791,13 +1792,13 @@ gen_Foldable_binds loc tycon where data_cons = tyConDataCons tycon - foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns + foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns eqns = map foldr_eqn data_cons foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs where parts = sequence $ foldDataConArgs ft_foldr con - foldMap_bind = L loc $ mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons) + foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons) foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs where parts = sequence $ foldDataConArgs ft_foldMap con @@ -1866,7 +1867,7 @@ gen_Traversable_binds loc tycon where data_cons = tyConDataCons tycon - traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns + traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns eqns = map traverse_eqn data_cons traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs where @@ -1942,9 +1943,9 @@ gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls)) where coerce_RDR = getRdrName coerceId - mk_bind :: Id -> Pair Type -> LHsBind RdrName + mk_bind :: Id -> Pair Type -> (Origin, LHsBind RdrName) mk_bind id (Pair tau_ty user_ty) - = L loc $ mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr] + = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr] where meth_RDR = getRdrName id rhs_expr @@ -1977,7 +1978,7 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. \begin{code} -genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) +genAuxBindSpec :: SrcSpan -> AuxBindSpec -> ((Origin, LHsBind RdrName), LSig RdrName) genAuxBindSpec loc (DerivCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) @@ -2023,7 +2024,7 @@ genAuxBindSpec loc (DerivMaxTag tycon) data_cons -> toInteger ((length data_cons) - fIRST_TAG) type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings - ( Bag (LHsBind RdrName, LSig RdrName) + ( Bag ((Origin, LHsBind RdrName), LSig RdrName) -- Extra bindings (used by Generic only) , Bag TyCon -- Extra top-level datatypes , Bag (FamInst) -- Extra family instances @@ -2078,22 +2079,23 @@ mkParentType tc \begin{code} mk_FunBind :: SrcSpan -> RdrName -> [([LPat RdrName], LHsExpr RdrName)] - -> LHsBind RdrName + -> (Origin, LHsBind RdrName) mk_FunBind loc fun pats_and_exprs - = L loc $ mkRdrFunBind (L loc fun) matches + = mkRdrFunBind (L loc fun) matches where matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] -mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName -mkRdrFunBind fun@(L _ fun_rdr) matches - | null matches = mkFunBind fun [mkMatch [] (error_Expr str) emptyLocalBinds] - -- Catch-all eqn looks like - -- fmap = error "Void fmap" - -- It's needed if there no data cons at all, - -- which can happen with -XEmptyDataDecls - -- See Trac #4302 - | otherwise = mkFunBind fun matches +mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> (Origin, LHsBind RdrName) +mkRdrFunBind fun@(L loc fun_rdr) matches = (Generated, L loc (mkFunBind fun matches')) where + -- Catch-all eqn looks like + -- fmap = error "Void fmap" + -- It's needed if there no data cons at all, + -- which can happen with -XEmptyDataDecls + -- See Trac #4302 + matches' = if null matches + then [mkMatch [] (error_Expr str) emptyLocalBinds] + else matches str = "Void " ++ occNameString (rdrNameOcc fun_rdr) \end{code} diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 2387625bca..564cd9ef9b 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -433,9 +433,9 @@ gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d -- Bindings for the Generic instance mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName mkBindsRep gk tycon = - unitBag (L loc (mkFunBind (L loc from01_RDR) from_matches)) + unitBag (mkRdrFunBind (L loc from01_RDR) from_matches) `unionBags` - unitBag (L loc (mkFunBind (L loc to01_RDR) to_matches)) + unitBag (mkRdrFunBind (L loc to01_RDR) to_matches) where from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ] @@ -677,7 +677,7 @@ mkBindsMetaD :: FixityEnv -> TyCon mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) where mkBag l = foldr1 unionBags - [ unitBag (L loc (mkFunBind (L loc name) matches)) + [ unitBag (mkRdrFunBind (L loc name) matches) | (name, matches) <- l ] dtBinds = mkBag ( [ (datatypeName_RDR, dtName_matches) , (moduleName_RDR, moduleName_matches)] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 2af4d8efce..1c9ac57e80 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -53,6 +53,7 @@ import Bag import FastString import Outputable import Util +import Data.Traversable ( traverse ) \end{code} %************************************************************************ @@ -291,7 +292,7 @@ zonkTopDecls :: Bag EvBind -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] -> TcM ([Id], Bag EvBind, - Bag (LHsBind Id), + LHsBinds Id, [LForeignDecl Id], [LTcSpecPrag], [LRuleDecl Id], @@ -402,7 +403,12 @@ warnMissingSig msg id --------------------------------------------- zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id) -zonkMonoBinds env sig_warn binds = mapBagM (wrapLocM (zonk_bind env sig_warn)) binds +zonkMonoBinds env sig_warn binds = mapBagM (zonk_lbind env sig_warn) binds + +zonk_lbind :: ZonkEnv -> SigWarn -> (Origin, LHsBind TcId) -> TcM (Origin, LHsBind Id) +zonk_lbind env sig_warn (origin, lbind) + = do { lbind' <- wrapLocM (zonk_bind env sig_warn) lbind + ; return (origin, lbind') } zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id) zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) @@ -454,6 +460,28 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abe_mono = zonkIdOcc env mono_id , abe_prags = new_prags }) +zonk_bind env _sig_warn bind@(PatSynBind { patsyn_id = L loc id + , patsyn_args = details + , patsyn_def = lpat + , patsyn_dir = dir }) + = do { id' <- zonkIdBndr env id + ; details' <- zonkPatSynDetails env details + ;(env1, lpat') <- zonkPat env lpat + ; (_env2, dir') <- zonkPatSynDir env1 dir + ; return (bind { patsyn_id = L loc id' + , patsyn_args = details' + , patsyn_def = lpat' + , patsyn_dir = dir' }) } + +zonkPatSynDetails :: ZonkEnv + -> HsPatSynDetails (Located TcId) + -> TcM (HsPatSynDetails (Located Id)) +zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env) + +zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id) +zonkPatSynDir env Unidirectional = return (env, Unidirectional) +zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) + zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps @@ -1006,7 +1034,7 @@ zonk_pat env (TuplePat pats boxed ty) zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars , pat_dicts = evs, pat_binds = binds - , pat_args = args }) + , pat_args = args, pat_wrap = wrapper }) = ASSERT( all isImmutableTyVar tyvars ) do { new_ty <- zonkTcTypeToType env ty ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars @@ -1015,12 +1043,14 @@ zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars -- cf typecheck/should_compile/tc221.hs ; (env1, new_evs) <- zonkEvBndrsX env0 evs ; (env2, new_binds) <- zonkTcEvBinds env1 binds - ; (env', new_args) <- zonkConStuff env2 args + ; (env3, new_wrapper) <- zonkCoFn env2 wrapper + ; (env', new_args) <- zonkConStuff env3 args ; return (env', p { pat_ty = new_ty, pat_tvs = new_tyvars, pat_dicts = new_evs, pat_binds = new_binds, - pat_args = new_args }) } + pat_args = new_args, + pat_wrap = new_wrapper}) } zonk_pat env (LitPat lit) = return (env, LitPat lit) diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index b526f9fe66..eed906898b 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -56,6 +56,7 @@ import Kind import Var import VarSet import TyCon +import ConLike import DataCon import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) import Class @@ -628,7 +629,7 @@ tcTyVar name -- Could be a tyvar, a tycon, or a datacon AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc) - AGlobal (ADataCon dc) + AGlobal (AConLike (RealDataCon dc)) | Just tc <- promoteDataCon_maybe dc -> do { data_kinds <- xoptM Opt_DataKinds ; unless data_kinds $ promotionErr name NoDataKinds diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index f57a419d7a..21af9a6e82 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -887,9 +887,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , abs_ev_vars = dfun_ev_vars , abs_exports = [export] , abs_ev_binds = sc_binds - , abs_binds = unitBag dict_bind } + , abs_binds = unitBag (Generated, dict_bind) } - ; return (unitBag (L loc main_bind) `unionBags` + ; return (unitBag (Generated, L loc main_bind) `unionBags` listToBag meth_binds) } where @@ -1168,7 +1168,7 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar] -> ([Located TcSpecPrag], PragFun) -> [(Id, DefMeth)] -> InstBindings Name - -> TcM ([Id], [LHsBind Id]) + -> TcM ([Id], [(Origin, LHsBind Id)]) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys @@ -1183,7 +1183,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; mapAndUnzipM (tc_item hs_sig_fn) op_items } where ---------------------- - tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id) + tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, (Origin, LHsBind Id)) tc_item sig_fn (sel_id, dm_info) = case findMethodBind (idName sel_id) binds of Just (user_bind, bndr_loc) @@ -1192,10 +1192,10 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; tc_default sig_fn sel_id dm_info } ---------------------- - tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name - -> SrcSpan -> TcM (TcId, LHsBind Id) + tc_body :: HsSigFun -> Id -> Bool -> (Origin, LHsBind Name) + -> SrcSpan -> TcM (TcId, (Origin, LHsBind Id)) tc_body sig_fn sel_id generated_code rn_bind bndr_loc - = add_meth_ctxt sel_id generated_code rn_bind $ + = add_meth_ctxt sel_id generated_code (snd rn_bind) $ do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) ; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $ mkMethIds sig_fn clas tyvars dfun_ev_vars @@ -1211,20 +1211,21 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; return (meth_id1, bind) } ---------------------- - tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id) + tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, (Origin, LHsBind Id)) tc_default sig_fn sel_id (GenDefMeth dm_name) = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name ; tc_body sig_fn sel_id False {- Not generated code? -} - meth_bind inst_loc } + (Generated, meth_bind) inst_loc } tc_default sig_fn sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; dflags <- getDynFlags - ; return (meth_id, mkVarBind meth_id $ - mkLHsWrap lam_wrapper (error_rhs dflags)) } + ; return (meth_id, + (Generated, mkVarBind meth_id $ + mkLHsWrap lam_wrapper (error_rhs dflags))) } where error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID @@ -1266,13 +1267,13 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [export] , abs_ev_binds = EvBinds (unitBag self_ev_bind) - , abs_binds = unitBag meth_bind } + , abs_binds = unitBag (Generated, meth_bind) } -- Default methods in an instance declaration can't have their own -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but -- currently they are rejected with -- "INLINE pragma lacks an accompanying binding" - ; return (meth_id1, L inst_loc bind) } + ; return (meth_id1, (Generated, L inst_loc bind)) } ---------------------- mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags @@ -1313,7 +1314,6 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys where methodExists meth = isJust (findMethodBind meth binds) ------------------- mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name) mkGenericDefMethBind clas inst_tys sel_id dm_name = -- A generic default method diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 416f7ce533..ab6d7bd40c 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -40,6 +40,8 @@ import TysWiredIn import TcEvidence import TyCon import DataCon +import PatSyn +import ConLike import PrelNames import BasicTypes hiding (SuccessFlag(..)) import DynFlags @@ -659,12 +661,25 @@ tcConPat :: PatEnv -> Located Name -> TcRhoType -- Type of the pattern -> HsConPatDetails Name -> TcM a -> TcM (Pat TcId, a) -tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside - = do { data_con <- tcLookupDataCon con_name - ; let tycon = dataConTyCon data_con +tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside + = do { con_like <- tcLookupConLike con_name + ; case con_like of + RealDataCon data_con -> tcDataConPat penv con_lname data_con + pat_ty arg_pats thing_inside + PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn + pat_ty arg_pats thing_inside + } + +tcDataConPat :: PatEnv -> Located Name -> DataCon + -> TcRhoType -- Type of the pattern + -> HsConPatDetails Name -> TcM a + -> TcM (Pat TcId, a) +tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside + = do { let tycon = dataConTyCon data_con -- For data families this is the representation tycon (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con + header = L con_span (RealDataCon data_con) -- Instantiate the constructor type variables [a->ty] -- This may involve doing a family-instance coercion, @@ -689,13 +704,14 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside ; if null ex_tvs && null eq_spec && null theta then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) - (arg_pats', res) <- tcConArgs data_con arg_tys' + (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside - ; let res_pat = ConPatOut { pat_con = L con_span data_con, + ; let res_pat = ConPatOut { pat_con = header, pat_tvs = [], pat_dicts = [], pat_binds = emptyTcEvBinds, pat_args = arg_pats', - pat_ty = pat_ty' } + pat_ty = pat_ty', + pat_wrap = idHsWrapper } ; return (mkHsWrapPat wrap res_pat pat_ty, res) } @@ -706,7 +722,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside -- dictionary binders from theta' no_equalities = not (any isEqPred theta') skol_info = case pe_ctxt penv of - LamPat mc -> PatSkol data_con mc + LamPat mc -> PatSkol (RealDataCon data_con) mc LetPat {} -> UnkSkol -- Doesn't matter ; gadts_on <- xoptM Opt_GADTs @@ -720,17 +736,77 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside ; given <- newEvVars theta' ; (ev_binds, (arg_pats', res)) <- checkConstraints skol_info ex_tvs' given $ - tcConArgs data_con arg_tys' arg_pats penv thing_inside + tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside - ; let res_pat = ConPatOut { pat_con = L con_span data_con, + ; let res_pat = ConPatOut { pat_con = header, pat_tvs = ex_tvs', pat_dicts = given, pat_binds = ev_binds, pat_args = arg_pats', - pat_ty = pat_ty' } + pat_ty = pat_ty', + pat_wrap = idHsWrapper } ; return (mkHsWrapPat wrap res_pat pat_ty, res) } } +tcPatSynPat :: PatEnv -> Located Name -> PatSyn + -> TcRhoType -- Type of the pattern + -> HsConPatDetails Name -> TcM a + -> TcM (Pat TcId, a) +tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside + = do { let (univ_tvs, ex_tvs, (prov_theta, req_theta)) = patSynSig pat_syn + arg_tys = patSynArgTys pat_syn + ty = patSynType pat_syn + + ; (_univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs + + ; checkExistentials ex_tvs penv + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs + ; let ty' = substTy tenv ty + arg_tys' = substTys tenv arg_tys + prov_theta' = substTheta tenv prov_theta + req_theta' = substTheta tenv req_theta + + ; wrap <- coToHsWrapper <$> unifyType ty' pat_ty + ; traceTc "tcPatSynPat" (ppr pat_syn $$ + ppr pat_ty $$ + ppr ty' $$ + ppr ex_tvs' $$ + ppr prov_theta' $$ + ppr req_theta' $$ + ppr arg_tys') + + ; prov_dicts' <- newEvVars prov_theta' + + {- + ; patsyns_on <- xoptM Opt_PatternSynonyms + ; checkTc patsyns_on + (ptext (sLit "A pattern match on a pattern synonym requires PatternSynonyms")) + -- Trac #2905 decided that a *pattern-match* of a GADT + -- should require the GADT language flag. + -- Re TypeFamilies see also #7156 +-} + ; let skol_info = case pe_ctxt penv of + LamPat mc -> PatSkol (PatSynCon pat_syn) mc + LetPat {} -> UnkSkol -- Doesn't matter + + ; req_wrap <- instCall PatOrigin inst_tys req_theta' + ; traceTc "instCall" (ppr req_wrap) + + ; traceTc "checkConstraints {" empty + ; (ev_binds, (arg_pats', res)) + <- checkConstraints skol_info ex_tvs' prov_dicts' $ + tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside + + ; traceTc "checkConstraints }" (ppr ev_binds) + ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn, + pat_tvs = ex_tvs', + pat_dicts = prov_dicts', + pat_binds = ev_binds, + pat_args = arg_pats', + pat_ty = ty', + pat_wrap = req_wrap } + ; return (mkHsWrapPat wrap res_pat pat_ty, res) } + ---------------------------- matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercion, a)) -> TcRhoType -> TcM (HsWrapper, a) @@ -811,31 +887,31 @@ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty error messages; it's a purely internal thing \begin{code} -tcConArgs :: DataCon -> [TcSigmaType] +tcConArgs :: ConLike -> [TcSigmaType] -> Checker (HsConPatDetails Name) (HsConPatDetails Id) -tcConArgs data_con arg_tys (PrefixCon arg_pats) penv thing_inside +tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside = do { checkTc (con_arity == no_of_args) -- Check correct arity - (arityErr "Constructor" data_con con_arity no_of_args) + (arityErr "Constructor" con_like con_arity no_of_args) ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys penv thing_inside ; return (PrefixCon arg_pats', res) } where - con_arity = dataConSourceArity data_con + con_arity = conLikeArity con_like no_of_args = length arg_pats -tcConArgs data_con arg_tys (InfixCon p1 p2) penv thing_inside +tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside = do { checkTc (con_arity == 2) -- Check correct arity - (arityErr "Constructor" data_con con_arity 2) + (arityErr "Constructor" con_like con_arity 2) ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)] penv thing_inside ; return (InfixCon p1' p2', res) } where - con_arity = dataConSourceArity data_con + con_arity = conLikeArity con_like -tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside +tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside = do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside ; return (RecCon (HsRecFields rpats' dd), res) } where @@ -855,7 +931,7 @@ tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside -- 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". - [] -> failWith (badFieldCon data_con field_lbl) + [] -> failWith (badFieldCon con_like field_lbl) -- The normal case, when the field comes from the right constructor (pat_ty : extras) -> @@ -864,10 +940,16 @@ tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside ; return (sel_id, pat_ty) } field_tys :: [(FieldLabel, TcType)] - 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). + field_tys = case con_like of + RealDataCon data_con -> 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). + PatSynCon{} -> [] + +conLikeArity :: ConLike -> Arity +conLikeArity (RealDataCon data_con) = dataConSourceArity data_con +conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn tcConArg :: Checker (LPat Name, TcSigmaType) (LPat Id) tcConArg (arg_pat, arg_ty) penv thing_inside @@ -1021,7 +1103,7 @@ existentialLetPat text "I can't handle pattern bindings for existential or GADT data constructors.", text "Instead, use a case-expression, or do-notation, to unpack the constructor."] -badFieldCon :: DataCon -> Name -> SDoc +badFieldCon :: ConLike -> Name -> SDoc badFieldCon con field = hsep [ptext (sLit "Constructor") <+> quotes (ppr con), ptext (sLit "does not have field"), quotes (ppr field)] diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs new file mode 100644 index 0000000000..a126f0f85f --- /dev/null +++ b/compiler/typecheck/TcPatSyn.lhs @@ -0,0 +1,324 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[TcPatSyn]{Typechecking pattern synonym declarations} + +\begin{code} +module TcPatSyn (tcPatSynDecl) where + +import HsSyn +import TcPat +import TcRnMonad +import TcEnv +import TcMType +import TysPrim +import Name +import SrcLoc +import PatSyn +import Maybes +import NameSet +import Panic +import Outputable +import FastString +import Var +import Id +import TcBinds +import BasicTypes +import TcSimplify +import TcType +import VarSet +import Data.Monoid +import Bag +import TcEvidence +import BuildTyCl + +#include "HsVersions.h" +\end{code} + +\begin{code} +tcPatSynDecl :: Located Name + -> HsPatSynDetails (Located Name) + -> LPat Name + -> HsPatSynDir Name + -> TcM (PatSyn, LHsBinds Id) +tcPatSynDecl lname@(L _ name) details lpat dir + = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat + ; pat_ty <- newFlexiTyVarTy openTypeKind + + ; let (arg_names, is_infix) = case details of + PrefixPatSyn names -> (map unLoc names, False) + InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True) + ; ((lpat', args), wanted) <- captureConstraints $ + tcPat PatSyn lpat pat_ty $ mapM tcLookupId arg_names + ; let named_taus = (name, pat_ty):map (\arg -> (getName arg, varType arg)) args + + ; traceTc "tcPatSynDecl::wanted" (ppr named_taus $$ ppr wanted) + ; (qtvs, given_dicts, _mr_bites, ev_binds) <- simplifyInfer True False named_taus wanted + ; let req_dicts = given_dicts + + ; (ex_vars, prov_dicts) <- tcCollectEx lpat' + ; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs + ex_tvs = varSetElems ex_vars + + ; pat_ty <- zonkTcType pat_ty + ; args <- mapM zonkId args + + ; univ_tvs <- mapM zonkQuantifiedTyVar univ_tvs + ; let prov_theta = map evVarPred prov_dicts + req_theta = map evVarPred req_dicts + ; prov_theta <- zonkTcThetaType prov_theta + ; req_theta <- zonkTcThetaType req_theta + + ; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$ + ppr prov_theta $$ + ppr prov_dicts) + ; traceTc "tcPatSynDecl: univ" (ppr univ_tvs $$ + ppr req_theta $$ + ppr req_dicts $$ + ppr ev_binds) + + ; let theta = prov_theta ++ req_theta + + ; traceTc "tcPatSynDecl: type" (ppr name $$ + ppr univ_tvs $$ + ppr (map varType args) $$ + ppr pat_ty) + + ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' args + univ_tvs ex_tvs + ev_binds + prov_dicts req_dicts + prov_theta req_theta + pat_ty + ; m_wrapper <- tcPatSynWrapper lname lpat dir args + univ_tvs ex_tvs theta pat_ty + ; let binds = matcher_bind `unionBags` maybe emptyBag snd m_wrapper + + ; traceTc "tcPatSynDecl }" $ ppr name + ; let patSyn = mkPatSyn name is_infix + args + univ_tvs ex_tvs + prov_theta req_theta + pat_ty + matcher_id (fmap fst m_wrapper) + ; return (patSyn, binds) } + +tcPatSynMatcher :: Located Name + -> LPat Id + -> [Var] + -> [TcTyVar] -> [TcTyVar] + -> TcEvBinds + -> [EvVar] -> [EvVar] + -> ThetaType -> ThetaType + -> TcType + -> TcM (Id, LHsBinds Id) +tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty + = do { res_tv <- zonkQuantifiedTyVar =<< newFlexiTyVar liftedTypeKind + ; (matcher_id, res_ty, cont_ty) <- mkPatSynMatcherId name args + univ_tvs ex_tvs + prov_theta req_theta + pat_ty res_tv + ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) + ; let matcher_lid = L loc matcher_id + + ; scrutinee <- mkId "scrut" pat_ty + ; cont <- mkId "cont" cont_ty + ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ args) + ; fail <- mkId "fail" res_ty + ; let fail' = nlHsVar fail + + + ; let args = map nlVarPat [scrutinee, cont, fail] + lwpat = noLoc $ WildPat pat_ty + cases = if isIrrefutableHsPat lpat + then [mkSimpleHsAlt lpat cont'] + else [mkSimpleHsAlt lpat cont', + mkSimpleHsAlt lwpat fail'] + body = mkLHsWrap (mkWpLet ev_binds) $ + L (getLoc lpat) $ + HsCase (nlHsVar scrutinee) $ + MG{ mg_alts = cases + , mg_arg_tys = [pat_ty] + , mg_res_ty = res_ty + } + body' = noLoc $ + HsLam $ + MG{ mg_alts = [mkSimpleMatch args body] + , mg_arg_tys = [pat_ty, cont_ty, res_ty] + , mg_res_ty = res_ty + } + + match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds + mg = MG{ mg_alts = [match] + , mg_arg_tys = [] + , mg_res_ty = res_ty + } + + ; let bind = FunBind{ fun_id = matcher_lid + , fun_infix = False + , fun_matches = mg + , fun_co_fn = idHsWrapper + , bind_fvs = emptyNameSet + , fun_tick = Nothing } + matcher_bind = unitBag (Generated, noLoc bind) + + ; traceTc "tcPatSynMatcher" (ppr matcher_bind) + + ; return (matcher_id, matcher_bind) } + where + mkId s ty = do + name <- newName . mkVarOccFS . fsLit $ s + return $ mkLocalId name ty + +tcPatSynWrapper :: Located Name + -> LPat Name + -> HsPatSynDir Name + -> [Var] + -> [TyVar] -> [TyVar] + -> ThetaType + -> TcType + -> TcM (Maybe (Id, LHsBinds Id)) +tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty + = do { let argNames = mkNameSet (map Var.varName args) + ; m_expr <- runMaybeT $ tcPatToExpr argNames lpat + ; case (dir, m_expr) of + (Unidirectional, _) -> + return Nothing + (ImplicitBidirectional, Nothing) -> + cannotInvertPatSynErr (unLoc lpat) + (ImplicitBidirectional, Just lexpr) -> + fmap Just $ tc_pat_syn_wrapper_from_expr lname lexpr args univ_tvs ex_tvs theta pat_ty } + +tc_pat_syn_wrapper_from_expr :: Located Name + -> LHsExpr Name + -> [Var] + -> [TyVar] -> [TyVar] + -> ThetaType + -> Type + -> TcM (Id, LHsBinds Id) +tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_ty + = do { let qtvs = univ_tvs ++ ex_tvs + ; (subst, qtvs') <- tcInstSigTyVars qtvs + ; let theta' = substTheta subst theta + pat_ty' = substTy subst pat_ty + args' = map (\arg -> setVarType arg $ substTy subst (varType arg)) args + + ; wrapper_id <- mkPatSynWrapperId name args qtvs theta pat_ty + ; let wrapper_name = getName wrapper_id + wrapper_lname = L loc wrapper_name + -- (wrapper_tvs, wrapper_theta, wrapper_tau) = tcSplitSigmaTy (idType wrapper_id) + wrapper_tvs = qtvs' + wrapper_theta = theta' + wrapper_tau = mkFunTys (map varType args') pat_ty' + + ; let wrapper_args = map (noLoc . VarPat . Var.varName) args' + wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds + bind = mkTopFunBind wrapper_lname [wrapper_match] + lbind = noLoc bind + ; let sig = TcSigInfo{ sig_id = wrapper_id + , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs + , sig_theta = wrapper_theta + , sig_tau = wrapper_tau + , sig_loc = loc + } + ; (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (Generated, lbind) + ; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds + ; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id) + ; return (wrapper_id, wrapper_binds) } + +tcNothing :: MaybeT TcM a +tcNothing = MaybeT (return Nothing) + +withLoc :: (a -> MaybeT TcM b) -> Located a -> MaybeT TcM (Located b) +withLoc fn (L loc x) = MaybeT $ setSrcSpan loc $ + do { y <- runMaybeT $ fn x + ; return (fmap (L loc) y) } + +tcPatToExpr :: NameSet -> LPat Name -> MaybeT TcM (LHsExpr Name) +tcPatToExpr lhsVars = go + where + go :: LPat Name -> MaybeT TcM (LHsExpr Name) + go (L loc (ConPatIn conName info)) + = MaybeT . setSrcSpan loc . runMaybeT $ do + { let con = L loc (HsVar (unLoc conName)) + ; exprs <- mapM go (hsConPatArgs info) + ; return $ foldl (\x y -> L loc (HsApp x y)) con exprs } + go p = withLoc go1 p + + go1 :: Pat Name -> MaybeT TcM (HsExpr Name) + go1 (VarPat var) + | var `elemNameSet` lhsVars = return (HsVar var) + | otherwise = tcNothing + go1 p@(AsPat _ _) = asPatInPatSynErr p + go1 (LazyPat pat) = fmap HsPar (go pat) + go1 (ParPat pat) = fmap HsPar (go pat) + go1 (BangPat pat) = fmap HsPar (go pat) + go1 (PArrPat pats ptt) + = do { exprs <- mapM go pats + ; return (ExplicitPArr ptt exprs) } + go1 (ListPat pats ptt reb) + = do { exprs <- mapM go pats + ; return (ExplicitList ptt (fmap snd reb) exprs) } + go1 (TuplePat pats box _) + = do { exprs <- mapM go pats + ; return (ExplicitTuple (map Present exprs) box) + } + go1 (LitPat lit) = return (HsLit lit) + go1 (NPat n Nothing _) = return (HsOverLit n) + go1 (NPat n (Just neg) _) = return (noLoc neg `HsApp` noLoc (HsOverLit n)) + go1 (SigPatIn pat (HsWB ty _ _)) + = do { expr <- go pat + ; return (ExprWithTySig expr ty) } + go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" + go1 (SigPatOut{}) = panic "SigPatOut in output of renamer" + go1 (CoPat{}) = panic "CoPat in output of renamer" + go1 _ = tcNothing + +asPatInPatSynErr :: OutputableBndr name => Pat name -> MaybeT TcM a +asPatInPatSynErr pat + = MaybeT . failWithTc $ + hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):")) + 2 (ppr pat) + +-- TODO: Highlight sub-pattern that causes the problem +cannotInvertPatSynErr :: OutputableBndr name => Pat name -> TcM a +cannotInvertPatSynErr pat + = failWithTc $ + hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression")) + 2 (ppr pat) + +tcCollectEx :: LPat Id -> TcM (TyVarSet, [EvVar]) +tcCollectEx = return . go + where + go :: LPat Id -> (TyVarSet, [EvVar]) + go = go1 . unLoc + + go1 :: Pat Id -> (TyVarSet, [EvVar]) + go1 (LazyPat p) = go p + go1 (AsPat _ p) = go p + go1 (ParPat p) = go p + go1 (BangPat p) = go p + go1 (ListPat ps _ _) = mconcat . map go $ ps + go1 (TuplePat ps _ _) = mconcat . map go $ ps + go1 (PArrPat ps _) = mconcat . map go $ ps + go1 (ViewPat _ p _) = go p + go1 (QuasiQuotePat qq) = pprPanic "TODO: tcInstPatSyn QuasiQuotePat" $ ppr qq + go1 con@ConPatOut{} = mappend (mkVarSet (pat_tvs con), pat_dicts con) $ + goConDetails $ pat_args con + go1 (SigPatOut p _) = go p + go1 (CoPat _ p _) = go1 p + go1 (NPlusKPat n k geq subtract) + = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract + go1 _ = mempty + + goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar]) + goConDetails (PrefixCon ps) = mconcat . map go $ ps + goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2 + goConDetails (RecCon HsRecFields{ rec_flds = flds }) + = mconcat . map goRecFd $ flds + + goRecFd :: HsRecField Id (LPat Id) -> (TyVarSet, [EvVar]) + goRecFd HsRecField{ hsRecFieldArg = p } = go p + +\end{code} diff --git a/compiler/typecheck/TcPatSyn.lhs-boot b/compiler/typecheck/TcPatSyn.lhs-boot new file mode 100644 index 0000000000..d0420c0c31 --- /dev/null +++ b/compiler/typecheck/TcPatSyn.lhs-boot @@ -0,0 +1,16 @@ +\begin{code} +module TcPatSyn where + +import Name ( Name ) +import Id ( Id ) +import HsSyn ( LPat, HsPatSynDetails, HsPatSynDir, LHsBinds ) +import TcRnTypes ( TcM ) +import SrcLoc ( Located ) +import PatSyn ( PatSyn ) + +tcPatSynDecl :: Located Name + -> HsPatSynDetails (Located Name) + -> LPat Name + -> HsPatSynDir Name + -> TcM (PatSyn, LHsBinds Id) +\end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 59dc17501d..dad2c67389 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -73,6 +73,7 @@ import SrcLoc import HscTypes import ListSetOps import Outputable +import ConLike import DataCon import Type import Class @@ -82,8 +83,9 @@ import Annotations import Data.List ( sortBy ) import Data.IORef ( readIORef ) import Data.Ord - -#ifdef GHCI +#ifndef GHCI +import BasicTypes ( Origin(..) ) +#else import BasicTypes hiding( SuccessFlag(..) ) import TcType ( isUnitTy, isTauTy ) import TcHsType @@ -374,6 +376,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_fam_insts = tcg_fam_insts tcg_env, mg_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, + mg_patsyns = [], -- TODO mg_rules = [], mg_vect_decls = [], mg_anns = [], @@ -669,7 +672,7 @@ checkHiBootIface ; mb_dfun_prs <- mapM check_inst boot_insts ; let dfun_prs = catMaybes mb_dfun_prs boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) + dfun_binds = listToBag [ (Generated, mkVarBind boot_dfun (nlHsVar dfun)) | (boot_dfun, dfun) <- dfun_prs ] type_env' = extendTypeEnvWithIds local_type_env boot_dfuns tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } @@ -752,7 +755,7 @@ checkBootDecl (AnId id1) (AnId id2) checkBootDecl (ATyCon tc1) (ATyCon tc2) = checkBootTyCon tc1 tc2 -checkBootDecl (ADataCon dc1) (ADataCon _) +checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) = pprPanic "checkBootDecl" (ppr dc1) checkBootDecl _ _ = False -- probably shouldn't happen @@ -1367,7 +1370,7 @@ check_main dflags tcg_env ; return (tcg_env { tcg_main = Just main_name, tcg_binds = tcg_binds tcg_env - `snocBag` main_bind, + `snocBag` (Generated, main_bind), tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (unitFV main_name) -- Record the use of 'main', so that we don't @@ -1609,7 +1612,7 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) -- [let it = expr] let_stmt = L loc $ LetStmt $ HsValBinds $ - ValBindsOut [(NonRecursive,unitBag the_bind)] [] + ValBindsOut [(NonRecursive,unitBag (FromSource, the_bind))] [] -- [it <- e] bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index c5c1c30e3d..b3d37f6178 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -49,7 +49,7 @@ import FastString import Panic import Util import Annotations -import BasicTypes( TopLevelFlag ) +import BasicTypes( TopLevelFlag, Origin ) import Control.Exception import Data.IORef @@ -150,6 +150,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_rules = [], tcg_fords = [], tcg_vects = [], + tcg_patsyns = [], tcg_dfun_n = dfun_n_var, tcg_keep = keep_var, tcg_doc_hdr = Nothing, @@ -587,6 +588,11 @@ addLocM fn (L loc a) = setSrcSpan loc $ fn a wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b) +wrapOriginLocM :: (a -> TcM r) -> (Origin, Located a) -> TcM (Origin, Located r) +wrapOriginLocM fn (origin, lbind) + = do { lbind' <- wrapLocM fn lbind + ; return (origin, lbind') } + wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) wrapLocFstM fn (L loc a) = setSrcSpan loc $ do diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 5a8fb13f04..44dc3faa1e 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -43,7 +43,7 @@ module TcRnTypes( -- Canonical constraints Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, dropDerivedWC, - singleCt, listToCts, ctsElts, extendCts, extendCtsList, + singleCt, listToCts, ctsElts, extendCts, extendCtsList, isEmptyCts, isCTyEqCan, isCFunEqCan, isCDictCan_Maybe, isCFunEqCan_maybe, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, @@ -90,7 +90,9 @@ import TcEvidence import Type import Class ( Class ) import TyCon ( TyCon ) +import ConLike ( ConLike(..) ) import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) +import PatSyn ( PatSyn, patSynId ) import TcType import Annotations import InstEnv @@ -143,14 +145,14 @@ type TcId = Id type TcIdSet = IdSet -type TcRnIf a b c = IOEnv (Env a b) c -type IfM lcl a = TcRnIf IfGblEnv lcl a -- Iface stuff +type TcRnIf a b = IOEnv (Env a b) +type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff -type IfG a = IfM () a -- Top level -type IfL a = IfM IfLclEnv a -- Nested -type TcRn a = TcRnIf TcGblEnv TcLclEnv a -type RnM a = TcRn a -- Historical -type TcM a = TcRn a -- Historical +type IfG = IfM () -- Top level +type IfL = IfM IfLclEnv -- Nested +type TcRn = TcRnIf TcGblEnv TcLclEnv +type RnM = TcRn -- Historical +type TcM = TcRn -- Historical \end{code} Representation of type bindings to uninstantiated meta variables used during @@ -332,6 +334,7 @@ data TcGblEnv tcg_rules :: [LRuleDecl Id], -- ...Rules tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations + tcg_patsyns :: [PatSyn], -- ...Pattern synonyms tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the @@ -1690,7 +1693,7 @@ data SkolemInfo | DataSkol -- Bound at a data type declaration | FamInstSkol -- Bound at a family instance decl | PatSkol -- An existential type variable bound by a pattern for - DataCon -- a data constructor with an existential type. + ConLike -- a data constructor with an existential type. (HsMatchContext Name) -- e.g. data T = forall a. Eq a => MkT a -- f (MkT x) = ... @@ -1735,10 +1738,15 @@ pprSkolInfo FamInstSkol = ptext (sLit "the family instance declaration") pprSkolInfo BracketSkol = ptext (sLit "a Template Haskell bracket") pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name) pprSkolInfo ArrowSkol = ptext (sLit "the arrow form") -pprSkolInfo (PatSkol dc mc) = sep [ ptext (sLit "a pattern with constructor") - , nest 2 $ ppr dc <+> dcolon - <+> ppr (dataConUserType dc) <> comma - , ptext (sLit "in") <+> pprMatchContext mc ] +pprSkolInfo (PatSkol cl mc) = case cl of + RealDataCon dc -> sep [ ptext (sLit "a pattern with constructor") + , nest 2 $ ppr dc <+> dcolon + <+> ppr (dataConUserType dc) <> comma + , ptext (sLit "in") <+> pprMatchContext mc ] + PatSynCon ps -> sep [ ptext (sLit "a pattern with pattern synonym") + , nest 2 $ ppr ps <+> dcolon + <+> ppr (varType (patSynId ps)) <> comma + , ptext (sLit "in") <+> pprMatchContext mc ] pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") , vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]] @@ -1861,4 +1869,3 @@ pprO ListOrigin = ptext (sLit "an overloaded list") instance Outputable CtOrigin where ppr = pprO \end{code} - diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index b6186b8d6f..b7e26997c6 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -70,6 +70,7 @@ import Class import Inst import TyCon import CoAxiom +import ConLike import DataCon import TcEvidence( TcEvBinds(..) ) import Id @@ -1165,7 +1166,7 @@ reifyThing (AGlobal (AnId id)) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (ADataCon dc)) +reifyThing (AGlobal (AConLike (RealDataCon dc))) = do { let name = dataConName dc ; ty <- reifyType (idType (dataConWrapId dc)) ; fix <- reifyFixity name diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 47d970d882..1fbdbb22be 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1823,7 +1823,7 @@ mkRecSelBinds tycons mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) mkRecSelBind (tycon, sel_name) - = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) + = (L loc (IdSig sel_id), unitBag (Generated, L loc sel_bind)) where loc = getSrcSpan sel_name sel_id = Var.mkExportedLocalVar rec_details sel_name diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index a843be3165..906989a718 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -63,7 +63,8 @@ module TypeRep ( #include "HsVersions.h" -import {-# SOURCE #-} DataCon( DataCon, dataConTyCon, dataConName ) +import {-# SOURCE #-} DataCon( dataConTyCon ) +import ConLike ( ConLike(..) ) import {-# SOURCE #-} Type( noParenPred, isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop -- friends: @@ -365,7 +366,7 @@ The Class and its associated TyCon have the same Name. -- | A typecheckable-thing, essentially anything that has a name data TyThing = AnId Id - | ADataCon DataCon + | AConLike ConLike | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] | ACoAxiom (CoAxiom Branched) deriving (Eq, Ord) @@ -382,14 +383,15 @@ pprTyThingCategory (ATyCon tc) | otherwise = ptext (sLit "Type constructor") pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") pprTyThingCategory (AnId _) = ptext (sLit "Identifier") -pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor") +pprTyThingCategory (AConLike (RealDataCon _)) = ptext (sLit "Data constructor") +pprTyThingCategory (AConLike (PatSynCon _)) = ptext (sLit "Pattern synonym") instance NamedThing TyThing where -- Can't put this with the type getName (AnId id) = getName id -- decl, because the DataCon instance getName (ATyCon tc) = getName tc -- isn't visible there getName (ACoAxiom cc) = getName cc - getName (ADataCon dc) = dataConName dc + getName (AConLike cl) = getName cl \end{code} diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 7fde82a3c7..52cd3dd791 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -73,6 +73,7 @@ import qualified Data.Foldable as Foldable import qualified Data.Traversable as Traversable import Data.Typeable import Data.Data +import Data.Monoid \end{code} %************************************************************************ @@ -185,6 +186,18 @@ ufmToList :: UniqFM elt -> [(Unique, elt)] %************************************************************************ %* * +\subsection{Monoid interface} +%* * +%************************************************************************ + +\begin{code} +instance Monoid (UniqFM a) where + mempty = emptyUFM + mappend = plusUFM +\end{code} + +%************************************************************************ +%* * \subsection{Implementation using ``Data.IntMap''} %* * %************************************************************************ diff --git a/compiler/utils/UniqSet.lhs b/compiler/utils/UniqSet.lhs index 1653f2dc43..fae5ddabb6 100644 --- a/compiler/utils/UniqSet.lhs +++ b/compiler/utils/UniqSet.lhs @@ -75,6 +75,7 @@ isEmptyUniqSet :: UniqSet a -> Bool lookupUniqSet :: Uniquable a => UniqSet a -> a -> Maybe a uniqSetToList :: UniqSet a -> [a] \end{code} + %************************************************************************ %* * \subsection{Implementation using ``UniqFM''} diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs index 2815a74dcb..b250637b07 100644 --- a/ghc/GhciTags.hs +++ b/ghc/GhciTags.hs @@ -22,6 +22,7 @@ import Outputable -- into the GHC API instead import Name (nameOccName) import OccName (pprOccName) +import ConLike import MonadUtils import Data.Function @@ -103,10 +104,11 @@ listModuleTags m = do ] where - tyThing2TagKind (AnId _) = 'v' - tyThing2TagKind (ADataCon _) = 'd' - tyThing2TagKind (ATyCon _) = 't' - tyThing2TagKind (ACoAxiom _) = 'x' + tyThing2TagKind (AnId _) = 'v' + tyThing2TagKind (AConLike RealDataCon{}) = 'd' + tyThing2TagKind (AConLike PatSynCon{}) = 'p' + tyThing2TagKind (ATyCon _) = 't' + tyThing2TagKind (ACoAxiom _) = 'x' data TagInfo = TagInfo diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index e816f8aa46..40ddb4b66b 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -33,7 +33,8 @@ expectedGhcOnlyExtensions :: [String] expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", - "JavaScriptFFI"] + "JavaScriptFFI", + "PatternSynonyms"] expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions = ["Generics", diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs index 0332b05a51..98e8bd0219 100644 --- a/testsuite/tests/ghc-api/T6145.hs +++ b/testsuite/tests/ghc-api/T6145.hs @@ -27,17 +27,17 @@ main = do l <- loadModule d let ts=typecheckedSource l -- liftIO (putStr (showSDocDebug (ppr ts))) - let fs=filterBag getDataCon ts + let fs=filterBag (isDataCon . snd) ts return $ not $ isEmptyBag fs removeFile "Test.hs" print ok where - getDataCon (L _ (AbsBinds { abs_binds = bs })) - = not (isEmptyBag (filterBag getDataCon bs)) - getDataCon (L l (f@FunBind {})) + isDataCon (L _ (AbsBinds { abs_binds = bs })) + = not (isEmptyBag (filterBag (isDataCon . snd) bs)) + isDataCon (L l (f@FunBind {})) | (MG (m:_) _ _) <- fun_matches f, (L _ (c@ConPatOut{}):_)<-hsLMatchPats m, (L l _)<-pat_con c = isGoodSrcSpan l -- Check that the source location is a good one - getDataCon _ + isDataCon _ = False diff --git a/testsuite/tests/patsyn/Makefile b/testsuite/tests/patsyn/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/patsyn/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/patsyn/should_compile/.gitignore b/testsuite/tests/patsyn/should_compile/.gitignore new file mode 100644 index 0000000000..492f1e78dd --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/.gitignore @@ -0,0 +1,9 @@ +.hpc.bidir +.hpc.ex +.hpc.ex-num +.hpc.ex-prov +.hpc.ex-view +.hpc.incomplete +.hpc.num +.hpc.overlap +.hpc.univ diff --git a/testsuite/tests/patsyn/should_compile/Makefile b/testsuite/tests/patsyn/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T new file mode 100644 index 0000000000..84b231cf61 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/all.T @@ -0,0 +1,9 @@ +test('bidir', normal, compile, ['']) +test('overlap', normal, compile, ['']) +test('univ', normal, compile, ['']) +test('ex', normal, compile, ['']) +test('ex-prov', normal, compile, ['']) +test('ex-view', normal, compile, ['']) +test('ex-num', normal, compile, ['']) +test('num', normal, compile, ['']) +test('incomplete', normal, compile, ['']) diff --git a/testsuite/tests/patsyn/should_compile/bidir.hs b/testsuite/tests/patsyn/should_compile/bidir.hs new file mode 100644 index 0000000000..16f435c2c2 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/bidir.hs @@ -0,0 +1,6 @@ +-- Pattern synonyms + +{-# LANGUAGE PatternSynonyms #-} +module ShouldCompile where + +pattern Single x = [x] diff --git a/testsuite/tests/patsyn/should_compile/ex-num.hs b/testsuite/tests/patsyn/should_compile/ex-num.hs new file mode 100644 index 0000000000..ff0bf2c97d --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/ex-num.hs @@ -0,0 +1,9 @@ +-- Pattern synonyms + +{-# LANGUAGE PatternSynonyms, GADTs #-} +module ShouldCompile where + +data T a where + MkT :: (Eq b) => a -> b -> T a + +pattern P x <- MkT 42 x diff --git a/testsuite/tests/patsyn/should_compile/ex-prov.hs b/testsuite/tests/patsyn/should_compile/ex-prov.hs new file mode 100644 index 0000000000..9225cf2e1c --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/ex-prov.hs @@ -0,0 +1,12 @@ +-- Pattern synonyms + +{-# LANGUAGE PatternSynonyms, GADTs #-} +module ShouldCompile where + +data T a where + MkT :: (Eq b) => a -> b -> T a + +pattern P x y <- MkT x y + +f :: T Bool -> Bool +f (P x y) = x && y == y diff --git a/testsuite/tests/patsyn/should_compile/ex-view.hs b/testsuite/tests/patsyn/should_compile/ex-view.hs new file mode 100644 index 0000000000..e317274993 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/ex-view.hs @@ -0,0 +1,12 @@ +-- Pattern synonyms + +{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-} +module ShouldCompile where + +data T a where + MkT :: (Eq b) => a -> b -> T a + +f :: (Show a) => a -> Bool +f = undefined + +pattern P x <- MkT (f -> True) x diff --git a/testsuite/tests/patsyn/should_compile/ex.hs b/testsuite/tests/patsyn/should_compile/ex.hs new file mode 100644 index 0000000000..717fe427f5 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/ex.hs @@ -0,0 +1,13 @@ +-- Pattern synonyms +-- Existentially-quantified type variables + +{-# LANGUAGE GADTs, PatternSynonyms #-} +module ShouldCompile where + +data T where + MkT :: b -> (b -> Bool) -> T + +pattern P x f <- MkT x f + +test :: T -> Bool +test (P x f) = f x diff --git a/testsuite/tests/patsyn/should_compile/incomplete.hs b/testsuite/tests/patsyn/should_compile/incomplete.hs new file mode 100644 index 0000000000..6f43c7c786 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/incomplete.hs @@ -0,0 +1,11 @@ +-- Pattern synonyms +-- Generated code doesn't emit overlapping pattern warnings + +{-# LANGUAGE PatternSynonyms #-} +module ShouldCompile where + +pattern P <- Just True + +test1 P = 2 +test1 Nothing = 3 +test1 (Just _) = 4 diff --git a/testsuite/tests/patsyn/should_compile/num.hs b/testsuite/tests/patsyn/should_compile/num.hs new file mode 100644 index 0000000000..a75ebddd6d --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/num.hs @@ -0,0 +1,6 @@ +-- Pattern synonyms + +{-# LANGUAGE PatternSynonyms #-} +module ShouldCompile where + +pattern P = 42 diff --git a/testsuite/tests/patsyn/should_compile/overlap.hs b/testsuite/tests/patsyn/should_compile/overlap.hs new file mode 100644 index 0000000000..c3c9387a2f --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/overlap.hs @@ -0,0 +1,9 @@ +-- Pattern synonyms +-- Generated code doesn't emit overlapping pattern warnings + +{-# LANGUAGE PatternSynonyms #-} +module ShouldCompile where + +pattern P = () + +test P = () diff --git a/testsuite/tests/patsyn/should_compile/univ.hs b/testsuite/tests/patsyn/should_compile/univ.hs new file mode 100644 index 0000000000..ea7898e8fe --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/univ.hs @@ -0,0 +1,11 @@ +-- Pattern synonyms +-- Universially-quantified type variables + +{-# LANGUAGE PatternSynonyms #-} +module ShouldCompile where + +pattern Single x <- [x] + +singleTuple :: [a] -> [b] -> Maybe (a, b) +singleTuple (Single x) (Single y) = Just (x, y) +singleTuple _ _ = Nothing diff --git a/testsuite/tests/patsyn/should_fail/Makefile b/testsuite/tests/patsyn/should_fail/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T new file mode 100644 index 0000000000..e1708d29e0 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/all.T @@ -0,0 +1,3 @@ + +test('mono', normal, compile_fail, ['']) +test('unidir', normal, compile_fail, ['']) diff --git a/testsuite/tests/patsyn/should_fail/mono.hs b/testsuite/tests/patsyn/should_fail/mono.hs new file mode 100644 index 0000000000..ef83668934 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/mono.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} +module ShouldFail where + +pattern Single x = [(x :: Int)] + +f :: [Bool] -> Bool +f (Single x) = x diff --git a/testsuite/tests/patsyn/should_fail/mono.stderr b/testsuite/tests/patsyn/should_fail/mono.stderr new file mode 100644 index 0000000000..db54f0b11a --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/mono.stderr @@ -0,0 +1,12 @@ + +mono.hs:7:4: + Couldn't match type ‛Int’ with ‛Bool’ + Expected type: [Bool] + Actual type: [Int] + In the pattern: Single x + In an equation for ‛f’: f (Single x) = x + +mono.hs:7:16: + Couldn't match expected type ‛Bool’ with actual type ‛Int’ + In the expression: x + In an equation for ‛f’: f (Single x) = x diff --git a/testsuite/tests/patsyn/should_fail/unidir.hs b/testsuite/tests/patsyn/should_fail/unidir.hs new file mode 100644 index 0000000000..020fc12821 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/unidir.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +module ShouldFail where + +pattern Head x = x:_ diff --git a/testsuite/tests/patsyn/should_fail/unidir.stderr b/testsuite/tests/patsyn/should_fail/unidir.stderr new file mode 100644 index 0000000000..ea019bc8e1 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/unidir.stderr @@ -0,0 +1,4 @@ + +unidir.hs:1:1: + Right-hand side of bidirectional pattern synonym cannot be used as an expression + x : _ diff --git a/testsuite/tests/patsyn/should_run/.gitignore b/testsuite/tests/patsyn/should_run/.gitignore new file mode 100644 index 0000000000..7380291005 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/.gitignore @@ -0,0 +1,7 @@ +eval +ex-prov +match + +.hpc.eval +.hpc.ex-prov +.hpc.match diff --git a/testsuite/tests/patsyn/should_run/Makefile b/testsuite/tests/patsyn/should_run/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/patsyn/should_run/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T new file mode 100644 index 0000000000..f5936c66c2 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/all.T @@ -0,0 +1,3 @@ +test('eval', normal, compile_and_run, ['']) +test('match', normal, compile_and_run, ['']) +test('ex-prov-run', normal, compile_and_run, ['']) diff --git a/testsuite/tests/patsyn/should_run/eval.hs b/testsuite/tests/patsyn/should_run/eval.hs new file mode 100644 index 0000000000..a36dc0b0fe --- /dev/null +++ b/testsuite/tests/patsyn/should_run/eval.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE PatternSynonyms #-} +module Main where + +pattern P x y <- [x, y] + +f (P True True) = True +f _ = False + +g [True, True] = True +g _ = False + + +main = do + mapM_ (print . f) tests + putStrLn "" + mapM_ (print . g) tests + where + tests = [ [True, True] + , [True, False] + , [True, True, True] + -- , False:undefined + ] diff --git a/testsuite/tests/patsyn/should_run/eval.stdout b/testsuite/tests/patsyn/should_run/eval.stdout new file mode 100644 index 0000000000..302d62b2cf --- /dev/null +++ b/testsuite/tests/patsyn/should_run/eval.stdout @@ -0,0 +1,7 @@ +True +False +False + +True +False +False diff --git a/testsuite/tests/patsyn/should_run/ex-prov-run.hs b/testsuite/tests/patsyn/should_run/ex-prov-run.hs new file mode 100644 index 0000000000..846ca90c27 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/ex-prov-run.hs @@ -0,0 +1,21 @@ +-- Pattern synonyms + +{-# LANGUAGE PatternSynonyms, GADTs #-} +module Main where + +data T a where + MkT :: (Eq b) => a -> b -> T a + +pattern P x y <- MkT x y + +f :: T Bool -> Bool +f (P x y) = x && y == y + +data Crazy = Crazy + +instance Eq Crazy where + _ == _ = False + +main = do + print (f $ MkT True True) + print (f $ MkT True Crazy) diff --git a/testsuite/tests/patsyn/should_run/ex-prov-run.stdout b/testsuite/tests/patsyn/should_run/ex-prov-run.stdout new file mode 100644 index 0000000000..1cc8b5e10d --- /dev/null +++ b/testsuite/tests/patsyn/should_run/ex-prov-run.stdout @@ -0,0 +1,2 @@ +True +False diff --git a/testsuite/tests/patsyn/should_run/match.hs b/testsuite/tests/patsyn/should_run/match.hs new file mode 100644 index 0000000000..830c99f270 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/match.hs @@ -0,0 +1,21 @@ +-- Pattern synonyms + +{-# LANGUAGE PatternSynonyms #-} +module Main where + +pattern Single x y = [(x,y)] + +foo [] = 0 +foo [(True, True)] = 1 +foo (Single True True) = 2 +foo (Single False False) = 3 +foo _ = 4 + +main = mapM_ (print . foo) tests + where + tests = [ [(True, True)] + , [] + , [(True, False)] + , [(False, False)] + , repeat (True, True) + ] diff --git a/testsuite/tests/patsyn/should_run/match.stdout b/testsuite/tests/patsyn/should_run/match.stdout new file mode 100644 index 0000000000..2d90204568 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/match.stdout @@ -0,0 +1,5 @@ +1 +0 +4 +3 +4 diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 0f9886fc14..9fffd52464 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -257,7 +257,7 @@ boundValues mod group = let vals = case hs_valds group of ValBindsOut nest _sigs -> [ x | (_rec, binds) <- nest - , bind <- bagToList binds + , (_, bind) <- bagToList binds , x <- boundThings mod bind ] _other -> error "boundValues" tys = [ n | ns <- map hsLTyClDeclBinders (tyClGroupConcat (hs_tyclds group)) @@ -284,6 +284,7 @@ boundThings modname lbinding = PatBind { pat_lhs = lhs } -> patThings lhs [] VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)] AbsBinds { } -> [] -- nothing interesting in a type abstraction + PatSynBind { patsyn_id = id } -> [thing id] where thing = foundOfLName modname patThings lpat tl = let loc = startOfLocated lpat @@ -299,7 +300,7 @@ boundThings modname lbinding = TuplePat ps _ _ -> foldr patThings tl ps PArrPat ps _ -> foldr patThings tl ps ConPatIn _ conargs -> conArgs conargs tl - ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl + ConPatOut{ pat_args = conargs } -> conArgs conargs tl LitPat _ -> tl NPat _ _ _ -> tl -- form of literal pattern? NPlusKPat id _ _ _ -> thing id : tl |