Implement pattern synonyms

This patch implements Pattern Synonyms (enabled by -XPatternSynonyms),
allowing y ou to assign names to a pattern and abstract over it.

The rundown is this:

  * Named patterns are introduced by the new 'pattern' keyword, and can
    be either *unidirectional* or *bidirectional*. A unidirectional
    pattern is, in the simplest sense, simply an 'alias' for a pattern,
    where the LHS may mention variables to occur in the RHS. A
    bidirectional pattern synonym occurs when a pattern may also be used
    in expression context.

  * Unidirectional patterns are declared like thus:

        pattern P x <- x:_

    The synonym 'P' may only occur in a pattern context:

        foo :: [Int] -> Maybe Int
        foo (P x) = Just x
        foo _     = Nothing

  * Bidirectional patterns are declared like thus:

        pattern P x y = [x, y]

    Here, P may not only occur as a pattern, but also as an expression
    when given values for 'x' and 'y', i.e.

        bar :: Int -> [Int]
        bar x = P x 10

  * Patterns can't yet have their own type signatures; signatures are inferred.

  * Pattern synonyms may not be recursive, c.f. type synonyms.

  * Pattern synonyms are also exported/imported using the 'pattern'
    keyword in an import/export decl, i.e.

        module Foo (pattern Bar) where ...

    Note that pattern synonyms share the namespace of constructors, so
    this disambiguation is required as a there may also be a 'Bar'
    type in scope as well as the 'Bar' pattern.

  * The semantics of a pattern synonym differ slightly from a typical
    pattern: when using a synonym, the pattern itself is matched,
    followed by all the arguments. This means that the strictness
    differs slightly:

        pattern P x y <- [x, y]

        f (P True True) = True
        f _             = False

        g [True, True] = True
        g _            = False

    In the example, while `g (False:undefined)` evaluates to False,
    `f (False:undefined)` results in undefined as both `x` and `y`
    arguments are matched to `True`.

For more information, see the wiki:

    https://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms
    https://ghc.haskell.org/trac/ghc/wiki/PatternSynonyms/Implementation

Reviewed-by: Simon Peyton Jones <simonpj@microsoft.com>
Signed-off-by: Austin Seipp <austin@well-typed.com>

10 files changed, 303 insertions, 147 deletions

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 76a8c0136b..960475cedd 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -14,7 +14,9 @@ import TcHsSyn
 import DsUtils
 import MatchLit
 import Id
+import ConLike
 import DataCon
+import PatSyn
 import Name
 import TysWiredIn
 import PrelNames
@@ -310,6 +312,7 @@ same constructor.
 \begin{code}
 split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
 split_by_constructor qs
+  | null used_cons      = ([], mkUniqSet $ map fst qs)
   | notNull unused_cons = need_default_case used_cons unused_cons qs
   | otherwise           = no_need_default_case used_cons qs
                        where
@@ -410,8 +413,11 @@ make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
   = takeList (tail pats) (repeat nlWildPat)
 
 compare_cons :: Pat Id -> Pat Id -> Bool
-compare_cons (ConPatOut{ pat_con = L _ id1 }) (ConPatOut { pat_con = L _ id2 }) = id1 == id2
-compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut"
+compare_cons (ConPatOut{ pat_con = L _ con1 }) (ConPatOut{ pat_con = L _ con2 })
+  = case (con1, con2) of
+    (RealDataCon id1, RealDataCon id2) -> id1 == id2
+    _ -> False
+compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut with RealDataCon"
 
 remove_dups :: [Pat Id] -> [Pat Id]
 remove_dups []     = []
@@ -423,8 +429,8 @@ get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,
                                       isConPatOut pat]
 
 isConPatOut :: Pat Id -> Bool
-isConPatOut (ConPatOut {}) = True
-isConPatOut _              = False
+isConPatOut ConPatOut{ pat_con = L _ RealDataCon{} } = True
+isConPatOut _                                        = False
 
 remove_dups' :: [HsLit] -> [HsLit]
 remove_dups' []                   = []
@@ -461,7 +467,7 @@ get_unused_cons :: [Pat Id] -> [DataCon]
 get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
      where
        used_set :: UniqSet DataCon
-       used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ d} <- used_cons]
+       used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons]
        (ConPatOut { pat_ty = ty }) = head used_cons
        Just (ty_con, inst_tys) = splitTyConApp_maybe ty
        unused_cons = filterOut is_used (tyConDataCons ty_con)
@@ -512,10 +518,10 @@ is_var :: Pat Id -> Bool
 is_var (WildPat _) = True
 is_var _           = False
 
-is_var_con :: DataCon -> Pat Id -> Bool
-is_var_con _   (WildPat _)                                 = True
-is_var_con con (ConPatOut{ pat_con = L _ id }) | id == con = True
-is_var_con _   _                                           = False
+is_var_con :: ConLike -> Pat Id -> Bool
+is_var_con _   (WildPat _)                     = True
+is_var_con con (ConPatOut{ pat_con = L _ id }) = id == con
+is_var_con _   _                               = False
 
 is_var_lit :: HsLit -> Pat Id -> Bool
 is_var_lit _   (WildPat _)   = True
@@ -582,12 +588,12 @@ make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing
 make_list _ _               = panic "Check.make_list: Invalid argument"
 
 make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
-make_con (ConPatOut{ pat_con = L _ id }) (lp:lq:ps, constraints)
+make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)
      | return_list id q = (noLoc (make_list lp q) : ps, constraints)
      | isInfixCon id    = (nlInfixConPat (getName id) lp lq : ps, constraints)
    where q  = unLoc lq
 
-make_con (ConPatOut{ pat_con = L _ id, pat_args = PrefixCon pats, pat_ty = ty }) (ps, constraints)
+make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_ty = ty }) (ps, constraints)
       | isTupleTyCon tc  = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints)
       | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)           : rest_pats, constraints)
       | otherwise        = (nlConPat name pats_con      : rest_pats, constraints)
@@ -640,6 +646,7 @@ might_fail_pat :: Pat Id -> Bool
 -- that is not covered by the checking algorithm.  Specifically:
 --         NPlusKPat
 --         ViewPat (if refutable)
+--         ConPatOut of a PatSynCon
 
 -- First the two special cases
 might_fail_pat (NPlusKPat {})                = True
@@ -654,7 +661,10 @@ might_fail_pat (ListPat _ _ (Just _))      = True
 might_fail_pat (TuplePat ps _ _)             = any might_fail_lpat ps
 might_fail_pat (PArrPat ps _)                = any might_fail_lpat ps
 might_fail_pat (BangPat p)                   = might_fail_lpat p
-might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs ps)
+might_fail_pat (ConPatOut { pat_con = con, pat_args = ps })
+  = case unLoc con of
+    RealDataCon _dcon -> any might_fail_lpat (hsConPatArgs ps)
+    PatSynCon _psyn -> True
 
 -- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
 might_fail_pat (LazyPat _)                   = False -- Always succeeds
@@ -686,9 +696,11 @@ tidy_pat (CoPat _ pat _)  = tidy_pat pat
 tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
 tidy_pat (ViewPat _ _ ty)     = WildPat ty
 tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty
+tidy_pat (ConPatOut { pat_con = L _ PatSynCon{}, pat_ty = ty })
+  = WildPat ty
 
-tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps })
-  = pat { pat_args = tidy_con id ps }
+tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps })
+  = pat { pat_args = tidy_con con ps }
 
 tidy_pat (ListPat ps ty Nothing)
   = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
@@ -729,16 +741,22 @@ tidy_lit_pat lit
   = tidyLitPat lit
 
 -----------------
-tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id
+tidy_con :: ConLike -> HsConPatDetails Id -> HsConPatDetails Id
 tidy_con _   (PrefixCon ps)   = PrefixCon (map tidy_lpat ps)
 tidy_con _   (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2]
 tidy_con con (RecCon (HsRecFields fs _))
-  | null fs   = PrefixCon [nlWildPat | _ <- dataConOrigArgTys con]
+  | null fs   = PrefixCon (replicate arity nlWildPat)
                 -- Special case for null patterns; maybe not a record at all
   | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats)
   where
+    arity = case con of
+        RealDataCon dcon -> dataConSourceArity dcon
+        PatSynCon psyn -> patSynArity psyn
+
      -- pad out all the missing fields with WildPats.
-    field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
+    field_pats = case con of
+        RealDataCon dc -> map (\ f -> (f, nlWildPat)) (dataConFieldLabels dc)
+        PatSynCon{}    -> panic "Check.tidy_con: pattern synonym with record syntax"
     all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
                      field_pats fs
 
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index e3e2bfc915..0ac7de8022 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -117,7 +117,7 @@ guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
 guessSourceFile binds orig_file =
      -- Try look for a file generated from a .hsc file to a
      -- .hs file, by peeking ahead.
-     let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
+     let top_pos = catMaybes $ foldrBag (\ (_, (L pos _)) rest ->
                                  srcSpanFileName_maybe pos : rest) [] binds
      in
      case top_pos of
@@ -229,7 +229,11 @@ shouldTickPatBind density top_lev
 -- Adding ticks to bindings
 
 addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
-addTickLHsBinds binds = mapBagM addTickLHsBind binds
+addTickLHsBinds binds = mapBagM addTick binds
+  where
+    addTick (origin, bind) = do
+        bind' <- addTickLHsBind bind
+        return (origin, bind')
 
 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
 addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
@@ -325,6 +329,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
 
 -- Only internal stuff, not from source, uses VarBind, so we ignore it.
 addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
+addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
 
 
 bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 7ef407b10c..e13767ff59 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -21,6 +21,7 @@ import FamInstEnv
 import InstEnv
 import Class
 import Avail
+import PatSyn
 import CoreSyn
 import CoreSubst
 import PprCore
@@ -45,6 +46,8 @@ import OrdList
 import Data.List
 import Data.IORef
 import Control.Monad( when )
+import Data.Maybe ( mapMaybe )
+import UniqFM
 \end{code}
 
 %************************************************************************
@@ -80,6 +83,7 @@ deSugar hsc_env
                             tcg_fords        = fords,
                             tcg_rules        = rules,
                             tcg_vects        = vects,
+                            tcg_patsyns      = patsyns,
                             tcg_tcs          = tcs,
                             tcg_insts        = insts,
                             tcg_fam_insts    = fam_insts,
@@ -115,21 +119,27 @@ deSugar hsc_env
                           ; let hpc_init
                                   | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty
+                          ; let patsyn_defs = [(patSynId ps, ps) | ps <- patsyns]
                           ; return ( ds_ev_binds
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
                                    , spec_rules ++ ds_rules, ds_vects
-                                   , ds_fords `appendStubC` hpc_init ) }
+                                   , ds_fords `appendStubC` hpc_init
+                                   , patsyn_defs) }
 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;
-           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) ->
+           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, patsyn_defs) -> do
 
      do {       -- Add export flags to bindings
           keep_alive <- readIORef keep_var
         ; let (rules_for_locals, rules_for_imps)
                    = partition isLocalRule all_rules
+              final_patsyns = addExportFlagsAndRules target export_set keep_alive [] patsyn_defs
+              exp_patsyn_wrappers = mapMaybe (patSynWrapper . snd) final_patsyns
+              exp_patsyn_matchers = map (patSynMatcher . snd) final_patsyns
+              keep_alive' = addListToUFM keep_alive (map (\x -> (x, getName x)) (exp_patsyn_wrappers ++ exp_patsyn_matchers))
               final_prs = addExportFlagsAndRules target
-                              export_set keep_alive rules_for_locals (fromOL all_prs)
+                              export_set keep_alive' rules_for_locals (fromOL all_prs)
 
               final_pgm = combineEvBinds ds_ev_binds final_prs
         -- Notice that we put the whole lot in a big Rec, even the foreign binds
@@ -173,6 +183,7 @@ deSugar hsc_env
                 mg_fam_insts    = fam_insts,
                 mg_inst_env     = inst_env,
                 mg_fam_inst_env = fam_inst_env,
+                mg_patsyns      = map snd . filter (isExportedId . fst) $ final_patsyns,
                 mg_rules        = ds_rules_for_imps,
                 mg_binds        = ds_binds,
                 mg_foreign      = ds_fords,
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index f507f19fc9..cd683ba365 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -95,9 +95,13 @@ ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
 ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
                         ; return (foldBag appOL id nilOL ds_bs) }
 
-dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
-dsLHsBind (L loc bind)
-  = putSrcSpanDs loc $ dsHsBind bind
+dsLHsBind :: (Origin, LHsBind Id) -> DsM (OrdList (Id,CoreExpr))
+dsLHsBind (origin, L loc bind)
+  = handleWarnings $ putSrcSpanDs loc $ dsHsBind bind
+  where
+    handleWarnings = if isGenerated origin
+                     then discardWarningsDs
+                     else id
 
 dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
 
@@ -211,6 +215,8 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
     add_inline :: Id -> Id    -- tran
     add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id
 
+dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"
+
 ------------------------
 makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
 makeCorePair dflags gbl_id is_default_method dict_arity rhs
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 1fda49b567..546a198ca8 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -47,6 +47,7 @@ import Id
 import Module
 import VarSet
 import VarEnv
+import ConLike
 import DataCon
 import TysWiredIn
 import BasicTypes
@@ -98,7 +99,7 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
 -- a tuple and doing selections.
 -- Silently ignore INLINE and SPECIALISE pragmas...
 ds_val_bind (NonRecursive, hsbinds) body
-  | [L loc bind] <- bagToList hsbinds,
+  | [(_, L loc bind)] <- bagToList hsbinds,
         -- Non-recursive, non-overloaded bindings only come in ones
         -- ToDo: in some bizarre case it's conceivable that there
         --       could be dict binds in the 'binds'.  (See the notes
@@ -132,7 +133,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
                , abs_binds = binds }) body
   = do { let body1 = foldr bind_export body exports
              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
-       ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) 
+       ; body2 <- foldlBagM (\body (_, bind) -> dsStrictBind (unLoc bind) body)
                             body1 binds 
        ; ds_binds <- dsTcEvBinds ev_binds
        ; return (mkCoreLets ds_binds body2) }
@@ -163,7 +164,7 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 ----------------------
 strictMatchOnly :: HsBind Id -> Bool
 strictMatchOnly (AbsBinds { abs_binds = binds })
-  = anyBag (strictMatchOnly . unLoc) binds
+  = anyBag (strictMatchOnly . unLoc . snd) binds
 strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
   =  isUnLiftedType ty 
   || isBangLPat lpat   
@@ -542,11 +543,13 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
                  wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
                                        | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ]
 
-                 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
+                 pat = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon con)
+                                         , pat_tvs = ex_tvs
                                          , pat_dicts = eqs_vars ++ theta_vars
                                          , pat_binds = emptyTcEvBinds
                                          , pat_args = PrefixCon $ map nlVarPat arg_ids
-                                         , pat_ty = in_ty }
+                                         , pat_ty = in_ty
+                                         , pat_wrap = idHsWrapper }
            ; let wrapped_rhs | null eq_spec = rhs
                              | otherwise    = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs
            ; return (mkSimpleMatch [pat] wrapped_rhs) }
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 0ee963ec44..56fba1434f 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1196,7 +1196,7 @@ rep_binds binds = do { binds_w_locs <- rep_binds' binds
                      ; return (de_loc (sort_by_loc binds_w_locs)) }
 
 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_binds' binds = mapM rep_bind (bagToList binds)
+rep_binds' binds = mapM (rep_bind . snd) (bagToList binds)
 
 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 -- Assumes: all the binders of the binding are alrady in the meta-env
@@ -1238,7 +1238,7 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
         ; return (srcLocSpan (getSrcLoc v), ans) }
 
 rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
-
+rep_bind (L _ (PatSynBind {})) = panic "rep_bind: PatSynBind"
 -----------------------------------------------------------------------------
 -- Since everything in a Bind is mutually recursive we need rename all
 -- all the variables simultaneously. For example:
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index e97ab4e8bd..b590f4b2d2 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -29,7 +29,7 @@ module DsMonad (
         DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
 
         -- Warnings
-        DsWarning, warnDs, failWithDs,
+        DsWarning, warnDs, failWithDs, discardWarningsDs,
 
         -- Data types
         DsMatchContext(..),
@@ -495,3 +495,19 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 dsExtendMetaEnv menv thing_inside
   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 \end{code}
+
+\begin{code}
+discardWarningsDs :: DsM a -> DsM a
+-- Ignore warnings inside the thing inside;
+-- used to ignore inaccessable cases etc. inside generated code
+discardWarningsDs thing_inside
+  = do  { env <- getGblEnv
+        ; old_msgs <- readTcRef (ds_msgs env)
+
+        ; result <- thing_inside
+
+        -- Revert messages to old_msgs
+        ; writeTcRef (ds_msgs env) old_msgs
+
+        ; return result }
+\end{code}
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 55eefc70f7..2ad70c67d3 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -20,13 +20,13 @@ module DsUtils (
 	EquationInfo(..), 
 	firstPat, shiftEqns,
 
-	MatchResult(..), CanItFail(..), 
+	MatchResult(..), CanItFail(..), CaseAlt(..),
 	cantFailMatchResult, alwaysFailMatchResult,
 	extractMatchResult, combineMatchResults, 
 	adjustMatchResult,  adjustMatchResultDs,
 	mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, 
 	matchCanFail, mkEvalMatchResult,
-	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
+	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
 	wrapBind, wrapBinds,
 
 	mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
@@ -52,6 +52,7 @@ import TcHsSyn
 import TcType( tcSplitTyConApp )
 import CoreSyn
 import DsMonad
+import {-# SOURCE #-} DsExpr ( dsLExpr )
 
 import CoreUtils
 import MkCore
@@ -59,7 +60,9 @@ import MkId
 import Id
 import Literal
 import TyCon
+import ConLike
 import DataCon
+import PatSyn
 import Type
 import Coercion
 import TysPrim
@@ -75,6 +78,8 @@ import Util
 import DynFlags
 import FastString
 
+import TcEvidence
+
 import Control.Monad    ( zipWithM )
 \end{code}
 
@@ -272,72 +277,43 @@ mkCoPrimCaseMatchResult var ty match_alts
          do body <- body_fn fail
             return (LitAlt lit, [], body)
 
+data CaseAlt a = MkCaseAlt{ alt_pat :: a,
+                            alt_bndrs :: [CoreBndr],
+                            alt_wrapper :: HsWrapper,
+                            alt_result :: MatchResult }
 
 mkCoAlgCaseMatchResult 
   :: DynFlags
-  -> Id					   -- Scrutinee
-  -> Type                                  -- Type of exp
-  -> [(DataCon, [CoreBndr], MatchResult)]  -- Alternatives (bndrs *include* tyvars, dicts)
+  -> Id                 -- Scrutinee
+  -> Type               -- Type of exp
+  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
   -> MatchResult
 mkCoAlgCaseMatchResult dflags var ty match_alts 
-  | isNewTyCon tycon		-- Newtype case; use a let
+  | isNewtype  -- Newtype case; use a let
   = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
 
-  | isPArrFakeAlts match_alts	-- Sugared parallel array; use a literal case 
-  = MatchResult CanFail mk_parrCase
-
-  | otherwise			-- Datatype case; use a case
-  = MatchResult fail_flag mk_case
+  | isPArrFakeAlts match_alts
+  = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts)
+  | otherwise
+  = mkDataConCase var ty match_alts
   where
-    tycon = dataConTyCon con1
+    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))
+
 	-- [Interesting: because of GADTs, we can't rely on the type of 
 	--  the scrutinised Id to be sufficiently refined to have a TyCon in it]
 
-	-- Stuff for newtype
-    (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
-    arg_id1 	= ASSERT( notNull arg_ids1 ) head arg_ids1
-    var_ty      = idType var
+    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }
+      = ASSERT( notNull match_alts ) head match_alts
+    -- Stuff for newtype
+    arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1
+    var_ty        = idType var
     (tc, ty_args) = tcSplitTyConApp var_ty	-- Don't look through newtypes
     	 	    		    		-- (not that splitTyConApp does, these days)
     newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
-		
-	-- Stuff for data types
-    data_cons      = tyConDataCons tycon
-    match_results  = [match_result | (_,_,match_result) <- match_alts]
-
-    fail_flag | exhaustive_case
-	      = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
-	      | otherwise
-	      = CanFail
-
-    sorted_alts  = sortWith get_tag match_alts
-    get_tag (con, _, _) = dataConTag con
-    mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
-                      return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
-
-    mk_alt fail (con, args, MatchResult _ body_fn)
-      = do { body <- body_fn fail
-           ; case dataConBoxer con of {
-                Nothing -> return (DataAlt con, args, body) ;
-                Just (DCB boxer) -> 
-        do { us <- newUniqueSupply
-           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
-           ; return (DataAlt con, rep_ids, mkLets binds body) } } }
-
-    mk_default fail | exhaustive_case = []
-		    | otherwise       = [(DEFAULT, [], fail)]
-
-    un_mentioned_constructors
-        = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
-    exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 
-	-- Stuff for parallel arrays
-	-- 
-	--  * the following is to desugar cases over fake constructors for
-	--   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
-	--   case
-	--
+        --- Stuff for parallel arrays
+        --
 	-- Concerning `isPArrFakeAlts':
 	--
 	--  * it is *not* sufficient to just check the type of the type
@@ -354,47 +330,127 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
 	--	  earlier and raise a proper error message, but it can really
 	--	  only happen in `PrelPArr' anyway.
 	--
-    isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
-    isPArrFakeAlts ((dcon, _, _):alts) = 
-      case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
+
+    isPArrFakeAlts :: [CaseAlt DataCon] -> Bool
+    isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt)
+    isPArrFakeAlts (alt:alts) =
+      case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of
         (True , True ) -> True
         (False, False) -> False
         _              -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
     isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
+
+mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
+mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
+
+\end{code}
+
+\begin{code}
+sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]
+sort_alts = sortWith (dataConTag . alt_pat)
+
+mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
+mkPatSynCase var ty alt fail = do
+    matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
+    let MatchResult _ mkCont = match_result
+    cont <- mkCoreLams bndrs <$> mkCont fail
+    return $ mkCoreAppsDs matcher [Var var, cont, fail]
+  where
+    MkCaseAlt{ alt_pat = psyn,
+               alt_bndrs = bndrs,
+               alt_wrapper = wrapper,
+               alt_result = match_result} = alt
+    matcher = patSynMatcher psyn
+
+mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
+mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"
+mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
+  where
+    con1          = alt_pat alt1
+    tycon         = dataConTyCon con1
+    data_cons     = tyConDataCons tycon
+    match_results = map alt_result alts
+
+    sorted_alts :: [CaseAlt DataCon]
+    sorted_alts  = sort_alts alts
+
+    var_ty       = idType var
+    (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
+                                          -- (not that splitTyConApp does, these days)
+
+    mk_case :: CoreExpr -> DsM CoreExpr
+    mk_case fail = do
+        alts <- mapM (mk_alt fail) sorted_alts
+        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)
+
+    mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
+    mk_alt fail MkCaseAlt{ alt_pat = con,
+                           alt_bndrs = args,
+                           alt_result = MatchResult _ body_fn }
+      = do { body <- body_fn fail
+           ; case dataConBoxer con of {
+                Nothing -> return (DataAlt con, args, body) ;
+                Just (DCB boxer) ->
+        do { us <- newUniqueSupply
+           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
+           ; return (DataAlt con, rep_ids, mkLets binds body) } } }
+
+    mk_default :: CoreExpr -> [CoreAlt]
+    mk_default fail | exhaustive_case = []
+                    | otherwise       = [(DEFAULT, [], fail)]
+
+    fail_flag :: CanItFail
+    fail_flag | exhaustive_case
+              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
+              | otherwise
+              = CanFail
+
+    mentioned_constructors = mkUniqSet $ map alt_pat alts
+    un_mentioned_constructors
+        = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
+    exhaustive_case = isEmptyUniqSet un_mentioned_constructors
+
+--- Stuff for parallel arrays
+--
+--  * the following is to desugar cases over fake constructors for
+--   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
+--   case
+--
+mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr
+mkPArrCase dflags var ty sorted_alts fail = do
+    lengthP <- dsDPHBuiltin lengthPVar
+    alt <- unboxAlt
+    return (mkWildCase (len lengthP) intTy ty [alt])
+  where
+    elemTy      = case splitTyConApp (idType var) of
+        (_, [elemTy]) -> elemTy
+        _             -> panic panicMsg
+    panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
+    len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
     --
-    mk_parrCase fail = do
-      lengthP <- dsDPHBuiltin lengthPVar
-      alt <- unboxAlt
-      return (mkWildCase (len lengthP) intTy ty [alt])
+    unboxAlt = do
+        l      <- newSysLocalDs intPrimTy
+        indexP <- dsDPHBuiltin indexPVar
+        alts   <- mapM (mkAlt indexP) sorted_alts
+        return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
       where
-	elemTy      = case splitTyConApp (idType var) of
-		        (_, [elemTy]) -> elemTy
-		        _	        -> panic panicMsg
-        panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
-	len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
-	--
-	unboxAlt = do
-	  l      <- newSysLocalDs intPrimTy
-	  indexP <- dsDPHBuiltin indexPVar
-	  alts   <- mapM (mkAlt indexP) sorted_alts
-	  return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
-          where
-	    dft  = (DEFAULT, [], fail)
-	--
-	-- each alternative matches one array length (corresponding to one
-	-- fake array constructor), so the match is on a literal; each
-	-- alternative's body is extended by a local binding for each
-	-- constructor argument, which are bound to array elements starting
-	-- with the first
-	--
-	mkAlt indexP (con, args, MatchResult _ bodyFun) = do
-	  body <- bodyFun fail
-	  return (LitAlt lit, [], mkCoreLets binds body)
-	  where
-	    lit   = MachInt $ toInteger (dataConSourceArity con)
-	    binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
-	    --
-	    indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]
+        dft  = (DEFAULT, [], fail)
+
+    --
+    -- each alternative matches one array length (corresponding to one
+    -- fake array constructor), so the match is on a literal; each
+    -- alternative's body is extended by a local binding for each
+    -- constructor argument, which are bound to array elements starting
+    -- with the first
+    --
+    mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do
+        body <- bodyFun fail
+        return (LitAlt lit, [], mkCoreLets binds body)
+      where
+        lit   = MachInt $ toInteger (dataConSourceArity (alt_pat alt))
+        binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)]
+        --
+        indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]
 \end{code}
 
 %************************************************************************
@@ -621,8 +677,10 @@ mkSelectorBinds ticks pat val_expr
     is_simple_lpat p = is_simple_pat (unLoc p)
 
     is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
-    is_simple_pat pat@(ConPatOut{})     =  isProductTyCon (dataConTyCon (unLoc (pat_con pat)))
-                                        && all is_triv_lpat (hsConPatArgs (pat_args pat))
+    is_simple_pat pat@(ConPatOut{})     = case unLoc (pat_con pat) of
+        RealDataCon con -> isProductTyCon (dataConTyCon con)
+                           && all is_triv_lpat (hsConPatArgs (pat_args pat))
+        PatSynCon _     -> False
     is_simple_pat (VarPat _)                   = True
     is_simple_pat (ParPat p)                   = is_simple_lpat p
     is_simple_pat _                                    = False
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 7a905104a2..0433d873d5 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -27,7 +27,9 @@ import DsBinds
 import DsGRHSs
 import DsUtils
 import Id
+import ConLike
 import DataCon
+import PatSyn
 import MatchCon
 import MatchLit
 import Type
@@ -91,6 +93,7 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
     incomplete_flag RecUpd        = wopt Opt_WarnIncompletePatternsRecUpd dflags
 
     incomplete_flag ThPatSplice   = False
+    incomplete_flag PatSyn        = False
     incomplete_flag ThPatQuote    = False
     incomplete_flag (StmtCtxt {}) = False  -- Don't warn about incomplete patterns
                                            -- in list comprehensions, pattern guards
@@ -314,6 +317,7 @@ match vars@(v:_) ty eqns    -- Eqns *can* be empty
     match_group eqns@((group,_) : _)
         = case group of
             PgCon _    -> matchConFamily  vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
+            PgSyn _    -> matchPatSyn     vars ty (dropGroup eqns)
             PgLit _    -> matchLiterals   vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
             PgAny      -> matchVariables  vars ty (dropGroup eqns)
             PgN _      -> matchNPats      vars ty (dropGroup eqns)
@@ -831,6 +835,7 @@ data PatGroup
   = PgAny               -- Immediate match: variables, wildcards,
                         --                  lazy patterns
   | PgCon DataCon       -- Constructor patterns (incl list, tuple)
+  | PgSyn PatSyn
   | PgLit Literal       -- Literal patterns
   | PgN   Literal       -- Overloaded literals
   | PgNpK Literal       -- n+k patterns
@@ -886,6 +891,7 @@ sameGroup :: PatGroup -> PatGroup -> Bool
 sameGroup PgAny      PgAny      = True
 sameGroup PgBang     PgBang     = True
 sameGroup (PgCon _)  (PgCon _)  = True          -- One case expression
+sameGroup (PgSyn p1) (PgSyn p2) = p1==p2
 sameGroup (PgLit _)  (PgLit _)  = True          -- One case expression
 sameGroup (PgN l1)   (PgN l2)   = l1==l2        -- Order is significant
 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2        -- See Note [Grouping overloaded literal patterns]
@@ -1004,16 +1010,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     eq_co _ _ = False
 
 patGroup :: DynFlags -> Pat Id -> PatGroup
-patGroup _      (WildPat {})                 = PgAny
-patGroup _      (BangPat {})                 = PgBang
-patGroup _      (ConPatOut { pat_con = dc }) = PgCon (unLoc dc)
-patGroup dflags (LitPat lit)                 = PgLit (hsLitKey dflags lit)
-patGroup _      (NPat olit mb_neg _)         = PgN   (hsOverLitKey olit (isJust mb_neg))
-patGroup _      (NPlusKPat _ olit _ _)       = PgNpK (hsOverLitKey olit False)
-patGroup _      (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern
-patGroup _      (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))
-patGroup _      (ListPat _ _ (Just _))       = PgOverloadedList
-patGroup _      pat = pprPanic "patGroup" (ppr pat)
+patGroup _      (WildPat {})                  = PgAny
+patGroup _      (BangPat {})                  = PgBang
+patGroup _      (ConPatOut { pat_con = con }) = case unLoc con of
+    RealDataCon dcon -> PgCon dcon
+    PatSynCon psyn -> PgSyn psyn
+patGroup dflags (LitPat lit)                  = PgLit (hsLitKey dflags lit)
+patGroup _      (NPat olit mb_neg _)          = PgN   (hsOverLitKey olit (isJust mb_neg))
+patGroup _      (NPlusKPat _ olit _ _)        = PgNpK (hsOverLitKey olit False)
+patGroup _      (CoPat _ p _)                 = PgCo  (hsPatType p) -- Type of innelexp pattern
+patGroup _      (ViewPat expr p _)            = PgView expr (hsPatType (unLoc p))
+patGroup _      (ListPat _ _ (Just _))        = PgOverloadedList
+patGroup _      pat                           = pprPanic "patGroup" (ppr pat)
 \end{code}
 
 Note [Grouping overloaded literal patterns]
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index f2bff1e5cd..2b51638bf3 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -13,7 +13,7 @@ Pattern-matching constructors
 --     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 -- for details
 
-module MatchCon ( matchConFamily ) where
+module MatchCon ( matchConFamily, matchPatSyn ) where
 
 #include "HsVersions.h"
 
@@ -21,7 +21,9 @@ import {-# SOURCE #-} Match	( match )
 
 import HsSyn
 import DsBinds
+import ConLike
 import DataCon
+import PatSyn
 import TcType
 import DsMonad
 import DsUtils
@@ -94,17 +96,34 @@ matchConFamily :: [Id]
 -- Each group of eqns is for a single constructor
 matchConFamily (var:vars) ty groups
   = do dflags <- getDynFlags
-       alts <- mapM (matchOneCon vars ty) groups
+       alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
        return (mkCoAlgCaseMatchResult dflags var ty alts)
+  where
+    toRealAlt alt = case alt_pat alt of
+        RealDataCon dcon -> alt{ alt_pat = dcon }
+        _ -> panic "matchConFamily: not RealDataCon"
 matchConFamily [] _ _ = panic "matchConFamily []"
 
-type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id))
-
-matchOneCon :: [Id]
+matchPatSyn :: [Id]
             -> Type
             -> [EquationInfo]
-            -> DsM (DataCon, [Var], MatchResult)
-matchOneCon vars ty (eqn1 : eqns)	-- All eqns for a single constructor
+            -> DsM MatchResult
+matchPatSyn (var:vars) ty eqns
+  = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns
+       return (mkCoSynCaseMatchResult var ty alt)
+  where
+    toSynAlt alt = case alt_pat alt of
+        PatSynCon psyn -> alt{ alt_pat = psyn }
+        _ -> panic "matchPatSyn: not PatSynCon"
+matchPatSyn _ _ _ = panic "matchPatSyn []"
+
+type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id))
+
+matchOneConLike :: [Id]
+                -> Type
+                -> [EquationInfo]
+                -> DsM (CaseAlt ConLike)
+matchOneConLike vars ty (eqn1 : eqns)	-- All eqns for a single constructor
   = do	{ arg_vars <- selectConMatchVars arg_tys args1
 	 	-- Use the first equation as a source of 
 		-- suggestions for the new variables
@@ -116,20 +135,32 @@ matchOneCon vars ty (eqn1 : eqns)	-- All eqns for a single constructor
 
 	; match_results <- mapM (match_group arg_vars) groups
 
-      	; return (con1, tvs1 ++ dicts1 ++ arg_vars, 
-		  foldr1 combineMatchResults match_results) }
+        ; return $ MkCaseAlt{ alt_pat = con1,
+                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
+                              alt_wrapper = wrapper1,
+                              alt_result = foldr1 combineMatchResults match_results } }
   where
-    ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1,
+    ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, pat_wrap = wrapper1,
 	        pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
 	      = firstPat eqn1
-    fields1 = dataConFieldLabels con1
-	
-    arg_tys  = dataConInstOrigArgTys con1 inst_tys
+    fields1 = case con1 of
+        RealDataCon dcon1 -> dataConFieldLabels dcon1
+	PatSynCon{} -> []
+
+    arg_tys  = inst inst_tys
+      where
+        inst = case con1 of
+            RealDataCon dcon1 -> dataConInstOrigArgTys dcon1
+            PatSynCon psyn1 -> patSynInstArgTys psyn1
     inst_tys = tcTyConAppArgs pat_ty1 ++ 
-	       mkTyVarTys (takeList (dataConExTyVars con1) tvs1)
+	       mkTyVarTys (takeList exVars tvs1)
 	-- Newtypes opaque, hence tcTyConAppArgs
 	-- dataConInstOrigArgTys takes the univ and existential tyvars
 	-- and returns the types of the *value* args, which is what we want
+      where
+        exVars = case con1 of
+            RealDataCon dcon1 -> dataConExTyVars dcon1
+            PatSynCon psyn1 -> patSynExTyVars psyn1
 
     match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
     -- All members of the group have compatible ConArgPats
@@ -167,7 +198,7 @@ matchOneCon vars ty (eqn1 : eqns)	-- All eqns for a single constructor
 	lookup_fld rpat = lookupNameEnv_NF fld_var_env 
 		   	  		   (idName (unLoc (hsRecFieldId rpat)))
     select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
-matchOneCon _ _ [] = panic "matchOneCon []"
+matchOneConLike _ _ [] = panic "matchOneCon []"
 
 -----------------
 compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool