Implement pattern synonyms
authorDr. ERDI Gergo <gergo@erdi.hu>
Mon, 13 Jan 2014 12:12:34 +0000 (20:12 +0800)
committerAustin Seipp <austin@well-typed.com>
Mon, 20 Jan 2014 17:30:22 +0000 (11:30 -0600)
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:
compiler/basicTypes/BasicTypes.lhs
compiler/basicTypes/ConLike.lhs [new file with mode: 0644]
compiler/basicTypes/DataCon.lhs-boot
compiler/basicTypes/OccName.lhs
compiler/basicTypes/PatSyn.lhs [new file with mode: 0644]
compiler/basicTypes/PatSyn.lhs-boot [new file with mode: 0644]
compiler/deSugar/Check.lhs
compiler/deSugar/Coverage.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMonad.lhs
compiler/deSugar/DsUtils.lhs
compiler/deSugar/Match.lhs
compiler/deSugar/MatchCon.lhs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsPat.lhs-boot
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/DynFlags.hs
compiler/main/HscMain.hs
compiler/main/HscStats.hs
compiler/main/HscTypes.lhs
compiler/main/PprTyThing.hs
compiler/main/TidyPgm.lhs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/prelude/TysWiredIn.lhs
compiler/rename/RnBinds.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnPat.lhs
compiler/rename/RnSource.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcGenGenerics.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcPatSyn.lhs [new file with mode: 0644]
compiler/typecheck/TcPatSyn.lhs-boot [new file with mode: 0644]
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/types/TypeRep.lhs
compiler/utils/UniqFM.lhs
compiler/utils/UniqSet.lhs
ghc/GhciTags.hs
testsuite/tests/driver/T4437.hs
testsuite/tests/ghc-api/T6145.hs
testsuite/tests/patsyn/Makefile [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/.gitignore [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/Makefile [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/all.T [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/bidir.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/ex-num.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/ex-prov.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/ex-view.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/ex.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/incomplete.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/num.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/overlap.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/univ.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/Makefile [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/all.T [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/mono.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/mono.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/unidir.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/unidir.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_run/.gitignore [new file with mode: 0644]
testsuite/tests/patsyn/should_run/Makefile [new file with mode: 0644]
testsuite/tests/patsyn/should_run/all.T [new file with mode: 0644]
testsuite/tests/patsyn/should_run/eval.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_run/eval.stdout [new file with mode: 0644]
testsuite/tests/patsyn/should_run/ex-prov-run.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_run/ex-prov-run.stdout [new file with mode: 0644]
testsuite/tests/patsyn/should_run/match.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_run/match.stdout [new file with mode: 0644]
utils/ghctags/Main.hs

index 71dc6c7..cb90fc9 100644 (file)
@@ -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 (file)
index 0000000..de10d0f
--- /dev/null
@@ -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}
index 6f9a385..08920cc 100644 (file)
@@ -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}
index 9c31612..6dbae4b 100644 (file)
@@ -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 (file)
index 0000000..9285b3c
--- /dev/null
@@ -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 (file)
index 0000000..0bb85e9
--- /dev/null
@@ -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}
index 76a8c01..960475c 100644 (file)
@@ -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
 
index e3e2bfc..0ac7de8 100644 (file)
@@ -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))
index 7ef407b..e13767f 100644 (file)
@@ -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,
index f507f19..cd683ba 100644 (file)
@@ -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
index 1fda49b..546a198 100644 (file)
@@ -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) }
index 0ee963e..56fba14 100644 (file)
@@ -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:
index e97ab4e..b590f4b 100644 (file)
@@ -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}
index 55eefc7..2ad70c6 100644 (file)
@@ -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
index 7a90510..0433d87 100644 (file)
@@ -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]
index f2bff1e..2b51638 100644 (file)
@@ -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
index 70f7c16..a5d9785 100644 (file)
@@ -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
index 3d0a981..0a18713 100644 (file)
@@ -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 \
index 216ab22..9996e62 100644 (file)
@@ -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)
index 139f5bf..e904633 100644 (file)
@@ -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}
index bb91790..4c0c955 100644 (file)
@@ -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")
index bf44505..9d458b7 100644 (file)
@@ -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}
-
index 85664af..0e7a0e0 100644 (file)
@@ -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}
index 2aaa76d..28c6a2b 100644 (file)
@@ -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
index 218a452..abc4758 100644 (file)
@@ -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
index c4c1bcd..9fd0c33 100644 (file)
@@ -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
index 38bb930..e412d7e 100644 (file)
@@ -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}
 
 
index f693999..b582305 100644 (file)
@@ -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
index 9aad5ff..379b39d 100644 (file)
@@ -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
index 7376169..20adfe5 100644 (file)
@@ -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}
-
index 2d0165b..615fdbb 100644 (file)
@@ -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]
index d2fa195..04b0823 100644 (file)
@@ -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,
index 2e60965..715ee81 100644 (file)
@@ -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)
 
index c61c8ec..b8ecc10 100644 (file)
@@ -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}
 
 %************************************************************************
index 38b28e9..27e7390 100644 (file)
@@ -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
index 91d0035..7ab6d56 100644 (file)
@@ -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
index 8eeab6b..3d02393 100644 (file)
@@ -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
index 92e4bd5..1715f6c 100644 (file)
@@ -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)) }
index 79d2d96..b1e177a 100644 (file)
@@ -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)
index 2830ca2..bf1907d 100644 (file)
@@ -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
index 9f9fd38..ed1343f 100644 (file)
@@ -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
 
index d29c3f3..1028d08 100644 (file)
@@ -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 }
index 8231233..56ee969 100644 (file)
@@ -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}
index fc62ed2..639ab51 100644 (file)
@@ -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
index 82ca29d..f3b4d91 100644 (file)
@@ -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
index b3b1a3f..47d45ae 100644 (file)
@@ -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")
index 835043a..f61f48e 100644 (file)
@@ -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
index dababa1..db79061 100644 (file)
@@ -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
index 1ac649b..a2df338 100644 (file)
@@ -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
        }
index 1c355f6..409a230 100644 (file)
@@ -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 ()
index 63eb020..26af2c5 100644 (file)
@@ -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)
index 0040be2..3852106 100644 (file)
@@ -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}
 
index 2387625..564cd9e 100644 (file)
@@ -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)]
index 2af4d8e..1c9ac57 100644 (file)
@@ -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)
 
index b526f9f..eed9068 100644 (file)
@@ -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
index f57a419..21af9a6 100644 (file)
@@ -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
index 416f7ce..ab6d7bd 100644 (file)
@@ -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 (file)
index 0000000..a126f0f
--- /dev/null
@@ -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 (file)
index 0000000..d0420c0
--- /dev/null
@@ -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}
index 59dc175..dad2c67 100644 (file)
@@ -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))
index c5c1c30..b3d37f6 100644 (file)
@@ -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
index 5a8fb13..44dc3fa 100644 (file)
@@ -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}
-
index b6186b8..b7e2699 100644 (file)
@@ -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
index 47d970d..1fbdbb2 100644 (file)
@@ -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
index a843be3..906989a 100644 (file)
@@ -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}
 
index 7fde82a..52cd3dd 100644 (file)
@@ -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''}
 %*                                                                      *
 %************************************************************************
index 1653f2d..fae5dda 100644 (file)
@@ -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''}
index 2815a74..b250637 100644 (file)
@@ -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
index e816f8a..40ddb4b 100644 (file)
@@ -33,7 +33,8 @@ expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
-                             "JavaScriptFFI"]
+                             "JavaScriptFFI",
+                             "PatternSynonyms"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
index 0332b05..98e8bd0 100644 (file)
@@ -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 (file)
index 0000000..9a36a1c
--- /dev/null
@@ -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 (file)
index 0000000..492f1e7
--- /dev/null
@@ -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 (file)
index 0000000..9101fbd
--- /dev/null
@@ -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 (file)
index 0000000..84b231c
--- /dev/null
@@ -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 (file)
index 0000000..16f435c
--- /dev/null
@@ -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 (file)
index 0000000..ff0bf2c
--- /dev/null
@@ -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 (file)
index 0000000..9225cf2
--- /dev/null
@@ -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 (file)
index 0000000..e317274
--- /dev/null
@@ -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 (file)
index 0000000..717fe42
--- /dev/null
@@ -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 (file)
index 0000000..6f43c7c
--- /dev/null
@@ -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 (file)
index 0000000..a75ebdd
--- /dev/null
@@ -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 (file)
index 0000000..c3c9387
--- /dev/null
@@ -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 (file)
index 0000000..ea7898e
--- /dev/null
@@ -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 (file)
index 0000000..9101fbd
--- /dev/null
@@ -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 (file)
index 0000000..e1708d2
--- /dev/null
@@ -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 (file)
index 0000000..ef83668
--- /dev/null
@@ -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 (file)
index 0000000..db54f0b
--- /dev/null
@@ -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 (file)
index 0000000..020fc12
--- /dev/null
@@ -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 (file)
index 0000000..ea019bc
--- /dev/null
@@ -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 (file)
index 0000000..7380291
--- /dev/null
@@ -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 (file)
index 0000000..9101fbd
--- /dev/null
@@ -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 (file)
index 0000000..f5936c6
--- /dev/null
@@ -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 (file)
index 0000000..a36dc0b
--- /dev/null
@@ -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 (file)
index 0000000..302d62b
--- /dev/null
@@ -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 (file)
index 0000000..846ca90
--- /dev/null
@@ -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 (file)
index 0000000..1cc8b5e
--- /dev/null
@@ -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 (file)
index 0000000..830c99f
--- /dev/null
@@ -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 (file)
index 0000000..2d90204
--- /dev/null
@@ -0,0 +1,5 @@
+1
+0
+4
+3
+4
index 0f9886f..9fffd52 100644 (file)
@@ -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