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>

6 files changed, 123 insertions, 43 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 2d0165be8c..615fdbb08b 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -581,6 +581,7 @@ data ExtensionFlag
    | Opt_MultiWayIf
    | Opt_NegativeLiterals
    | Opt_EmptyCase
+   | Opt_PatternSynonyms
    deriving (Eq, Enum, Show)
 
 -- | Contains not only a collection of 'GeneralFlag's but also a plethora of
@@ -2861,7 +2862,8 @@ xFlags = [
   ( "IncoherentInstances",              Opt_IncoherentInstances, nop ),
   ( "PackageImports",                   Opt_PackageImports, nop ),
   ( "NegativeLiterals",                 Opt_NegativeLiterals, nop ),
-  ( "EmptyCase",                        Opt_EmptyCase, nop )
+  ( "EmptyCase",                        Opt_EmptyCase, nop ),
+  ( "PatternSynonyms",                  Opt_PatternSynonyms, nop )
   ]
 
 defaultFlags :: Settings -> [GeneralFlag]
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index d2fa195e98..04b0823db4 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1569,6 +1569,7 @@ mkModGuts mod safe binds =
         mg_tcs          = [],
         mg_insts        = [],
         mg_fam_insts    = [],
+        mg_patsyns      = [],
         mg_rules        = [],
         mg_vect_decls   = [],
         mg_binds        = binds,
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index 2e60965159..715ee8130c 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -48,6 +48,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
              ("GenericSigs      ", generic_sigs),
              ("ValBinds         ", val_bind_ds),
              ("FunBinds         ", fn_bind_ds),
+             ("PatSynBinds      ", patsyn_ds),
              ("InlineMeths      ", method_inlines),
              ("InlineBinds      ", bind_inlines),
              ("SpecialisedMeths ", method_specs),
@@ -84,24 +85,25 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     export_ds    = n_exports - export_ms
     export_all   = case exports of { Nothing -> 1; _ -> 0 }
 
-    (val_bind_ds, fn_bind_ds)
-        = foldr add2 (0,0) (map count_bind val_decls)
+    (val_bind_ds, fn_bind_ds, patsyn_ds)
+        = sum3 (map count_bind val_decls)
 
     (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding)
-        = foldr add7 (0,0,0,0,0,0,0) (map import_info imports)
+        = sum7 (map import_info imports)
     (data_constrs, data_derivs)
-        = foldr add2 (0,0) (map data_info tycl_decls)
+        = sum2 (map data_info tycl_decls)
     (class_method_ds, default_method_ds)
-        = foldr add2 (0,0) (map class_info tycl_decls)
+        = sum2 (map class_info tycl_decls)
     (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
-        = foldr add5 (0,0,0,0,0) (map inst_info inst_decls)
+        = sum5 (map inst_info inst_decls)
 
-    count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0)
-    count_bind (PatBind {})                           = (0,1)
-    count_bind (FunBind {})                           = (0,1)
+    count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0)
+    count_bind (PatBind {})                           = (0,1,0)
+    count_bind (FunBind {})                           = (0,1,0)
+    count_bind (PatSynBind {})                        = (0,0,1)
     count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
 
-    count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs)
+    count_sigs sigs = sum5 (map sig_info sigs)
 
     sig_info (FixSig _)       = (1,0,0,0,0)
     sig_info (TypeSig _ _)    = (0,1,0,0,0)
@@ -128,9 +130,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     data_info _ = (0,0)
 
     class_info decl@(ClassDecl {})
-        = case count_sigs (map unLoc (tcdSigs decl)) of
-            (_,classops,_,_,_) ->
-               (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
+        = (classops, addpr (sum3 (map count_bind methods)))
+      where
+        methods = map (unLoc . snd) $ bagToList (tcdMeths decl)
+        (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))
     class_info _ = (0,0)
 
     inst_info (TyFamInstD {}) = (0,0,0,1,0)
@@ -141,17 +144,31 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
                                                  , cid_datafam_insts = adts } })
         = case count_sigs (map unLoc inst_sigs) of
             (_,_,ss,is,_) ->
-                  (addpr (foldr add2 (0,0) 
-                           (map (count_bind.unLoc) (bagToList inst_meths))), 
+                  (addpr (sum3 (map count_bind methods)),
                    ss, is, length ats, length adts)
+      where
+        methods = map (unLoc . snd) $ bagToList inst_meths
+
+    -- TODO: use Sum monoid
+    addpr :: (Int,Int,Int) -> Int
+    sum2 :: [(Int, Int)] -> (Int, Int)
+    sum3 :: [(Int, Int, Int)] -> (Int, Int, Int)
+    sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)
+    sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int)
+    add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int)
+         -> (Int, Int, Int, Int, Int, Int, Int)
+
+    addpr (x,y,z) = x+y+z
+    sum2 = foldr add2 (0,0)
+      where
+        add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
+    sum3 = foldr add3 (0,0,0)
+      where
+        add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
+    sum5 = foldr add5 (0,0,0,0,0)
+      where
+        add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
+    sum7 = foldr add7 (0,0,0,0,0,0,0)
 
-    addpr :: (Int,Int) -> Int
-    add2  :: (Int,Int) -> (Int,Int) -> (Int, Int)
-    add5  :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
-    add7  :: (Int,Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int, Int)
-
-    addpr (x,y) = x+y
-    add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
-    add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
     add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
 
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index c61c8ec56d..b8ecc109d0 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -70,8 +70,10 @@ module HscTypes (
 
         TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
         typeEnvFromEntities, mkTypeEnvWithImplicits,
-        extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
-        typeEnvElts, typeEnvTyCons, typeEnvIds,
+        extendTypeEnv, extendTypeEnvList,
+        extendTypeEnvWithIds, extendTypeEnvWithPatSyns,
+        lookupTypeEnv,
+        typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns,
         typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,
 
         -- * MonadThings
@@ -143,7 +145,9 @@ import Annotations      ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )
 import Class
 import TyCon
 import CoAxiom
+import ConLike
 import DataCon
+import PatSyn
 import PrelNames        ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule )
 import Packages hiding  ( Version(..) )
 import DynFlags
@@ -996,6 +1000,7 @@ data ModGuts
         mg_insts     :: ![ClsInst],      -- ^ Class instances declared in this module
         mg_fam_insts :: ![FamInst],
                                          -- ^ Family instances declared in this module
+        mg_patsyns   :: ![PatSyn],       -- ^ Pattern synonyms declared in this module
         mg_rules     :: ![CoreRule],     -- ^ Before the core pipeline starts, contains
                                          -- See Note [Overall plumbing for rules] in Rules.lhs
         mg_binds     :: !CoreProgram,    -- ^ Bindings for this module
@@ -1496,8 +1501,15 @@ implicitTyThings :: TyThing -> [TyThing]
 implicitTyThings (AnId _)       = []
 implicitTyThings (ACoAxiom _cc) = []
 implicitTyThings (ATyCon tc)    = implicitTyConThings tc
-implicitTyThings (ADataCon dc)  = map AnId (dataConImplicitIds dc)
-    -- For data cons add the worker and (possibly) wrapper
+implicitTyThings (AConLike cl)  = case cl of
+    RealDataCon dc ->
+        -- For data cons add the worker and (possibly) wrapper
+        map AnId (dataConImplicitIds dc)
+    PatSynCon ps ->
+        -- For bidirectional pattern synonyms, add the wrapper
+        case patSynWrapper ps of
+            Nothing -> []
+            Just id -> [AnId id]
 
 implicitClassThings :: Class -> [TyThing]
 implicitClassThings cl
@@ -1520,7 +1532,7 @@ implicitTyConThings tc
 
       -- for each data constructor in order,
       --   the contructor, worker, and (possibly) wrapper
-    concatMap (extras_plus . ADataCon) (tyConDataCons tc)
+    concatMap (extras_plus . AConLike . RealDataCon) (tyConDataCons tc)
       -- NB. record selectors are *not* implicit, they have fully-fledged
       -- bindings that pass through the compilation pipeline as normal.
   where
@@ -1545,7 +1557,9 @@ implicitCoTyCon tc
 -- of some other declaration, or it is generated implicitly by some
 -- other declaration.
 isImplicitTyThing :: TyThing -> Bool
-isImplicitTyThing (ADataCon {}) = True
+isImplicitTyThing (AConLike cl) = case cl of
+    RealDataCon{}  -> True
+    PatSynCon ps   -> isImplicitId (patSynId ps)
 isImplicitTyThing (AnId id)     = isImplicitId id
 isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc
 isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax
@@ -1557,7 +1571,9 @@ isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax
 -- but the tycon could be the associated type of a class, so it in turn
 -- might have a parent.
 tyThingParent_maybe :: TyThing -> Maybe TyThing
-tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
+tyThingParent_maybe (AConLike cl) = case cl of
+    RealDataCon dc  -> Just (ATyCon (dataConTyCon dc))
+    PatSynCon{}     -> Nothing
 tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of
                                       Just cls -> Just (ATyCon (classTyCon cls))
                                       Nothing  -> Nothing
@@ -1572,7 +1588,9 @@ tyThingsTyVars tts =
     unionVarSets $ map ttToVarSet tts
     where
         ttToVarSet (AnId id)     = tyVarsOfType $ idType id
-        ttToVarSet (ADataCon dc) = tyVarsOfType $ dataConRepType dc
+        ttToVarSet (AConLike cl) = case cl of
+            RealDataCon dc  -> tyVarsOfType $ dataConRepType dc
+            PatSynCon{}     -> emptyVarSet
         ttToVarSet (ATyCon tc)
           = case tyConClass_maybe tc of
               Just cls -> (mkVarSet . fst . classTvsFds) cls
@@ -1611,6 +1629,7 @@ typeEnvElts     :: TypeEnv -> [TyThing]
 typeEnvTyCons   :: TypeEnv -> [TyCon]
 typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]
 typeEnvIds      :: TypeEnv -> [Id]
+typeEnvPatSyns  :: TypeEnv -> [PatSyn]
 typeEnvDataCons :: TypeEnv -> [DataCon]
 typeEnvClasses  :: TypeEnv -> [Class]
 lookupTypeEnv   :: TypeEnv -> Name -> Maybe TyThing
@@ -1620,7 +1639,8 @@ typeEnvElts     env = nameEnvElts env
 typeEnvTyCons   env = [tc | ATyCon tc   <- typeEnvElts env]
 typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]
 typeEnvIds      env = [id | AnId id     <- typeEnvElts env]
-typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env]
+typeEnvPatSyns  env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env]
+typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env]
 typeEnvClasses  env = [cl | tc <- typeEnvTyCons env,
                             Just cl <- [tyConClass_maybe tc]]
 
@@ -1656,6 +1676,16 @@ extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
 extendTypeEnvWithIds env ids
   = extendNameEnvList env [(getName id, AnId id) | id <- ids]
 
+extendTypeEnvWithPatSyns :: TypeEnv -> [PatSyn] -> TypeEnv
+extendTypeEnvWithPatSyns env patsyns
+  = extendNameEnvList env $ concatMap pat_syn_things patsyns
+  where
+    pat_syn_things :: PatSyn -> [(Name, TyThing)]
+    pat_syn_things ps = (getName ps, AConLike (PatSynCon ps)):
+                        case patSynWrapper ps of
+                            Just wrap_id -> [(getName wrap_id, AnId wrap_id)]
+                            Nothing -> []
+
 \end{code}
 
 \begin{code}
@@ -1704,14 +1734,14 @@ tyThingCoAxiom other         = pprPanic "tyThingCoAxiom" (pprTyThing other)
 
 -- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise
 tyThingDataCon :: TyThing -> DataCon
-tyThingDataCon (ADataCon dc) = dc
-tyThingDataCon other         = pprPanic "tyThingDataCon" (pprTyThing other)
+tyThingDataCon (AConLike (RealDataCon dc)) = dc
+tyThingDataCon other                       = pprPanic "tyThingDataCon" (pprTyThing other)
 
 -- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise
 tyThingId :: TyThing -> Id
-tyThingId (AnId id)     = id
-tyThingId (ADataCon dc) = dataConWrapId dc
-tyThingId other         = pprPanic "tyThingId" (pprTyThing other)
+tyThingId (AnId id)                   = id
+tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc
+tyThingId other                       = pprPanic "tyThingId" (pprTyThing other)
 \end{code}
 
 %************************************************************************
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index 38b28e9c38..27e739009d 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -23,13 +23,16 @@ module PprTyThing (
   ) where
 
 import TypeRep ( TyThing(..) )
+import ConLike
 import DataCon
+import PatSyn
 import Id
 import TyCon
 import Class
 import Coercion( pprCoAxiom, pprCoAxBranch )
 import CoAxiom( CoAxiom(..), brListMap )
 import HscTypes( tyThingParent_maybe )
+import HsBinds( pprPatSynSig )
 import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy )
 import Kind( synTyConResKind )
 import TypeRep( pprTvBndrs, pprForAll, suppressKinds )
@@ -41,6 +44,7 @@ import StaticFlags( opt_PprStyle_Debug )
 import DynFlags
 import Outputable
 import FastString
+import Data.Maybe
 
 -- -----------------------------------------------------------------------------
 -- Pretty-printing entities that we get from the GHC API
@@ -97,14 +101,18 @@ pprTyThingInContextLoc tyThing
 -- and classes it prints only the header part of the declaration.
 pprTyThingHdr :: TyThing -> SDoc
 pprTyThingHdr (AnId id)          = pprId         id
-pprTyThingHdr (ADataCon dataCon) = pprDataConSig dataCon
+pprTyThingHdr (AConLike conLike) = case conLike of
+    RealDataCon dataCon -> pprDataConSig dataCon
+    PatSynCon patSyn    -> pprPatSyn     patSyn
 pprTyThingHdr (ATyCon tyCon)     = pprTyConHdr   tyCon
 pprTyThingHdr (ACoAxiom ax)      = pprCoAxiom ax
 
 ------------------------
 ppr_ty_thing :: ShowSub -> TyThing -> SDoc
 ppr_ty_thing _  (AnId id)          = pprId         id
-ppr_ty_thing _  (ADataCon dataCon) = pprDataConSig dataCon
+ppr_ty_thing _  (AConLike conLike) = case conLike of
+    RealDataCon dataCon -> pprDataConSig dataCon
+    PatSynCon patSyn    -> pprPatSyn     patSyn
 ppr_ty_thing ss (ATyCon tyCon)     = pprTyCon      ss tyCon
 ppr_ty_thing _  (ACoAxiom ax)      = pprCoAxiom    ax
 
@@ -155,6 +163,23 @@ pprId ident
   = hang (ppr_bndr ident <+> dcolon)
 	 2 (pprTypeForUser (idType ident))
 
+pprPatSyn :: PatSyn -> SDoc
+pprPatSyn patSyn
+  = pprPatSynSig ident is_bidir args (pprTypeForUser rhs_ty) prov req
+  where
+    ident = patSynId patSyn
+    is_bidir = isJust $ patSynWrapper patSyn
+
+    args = fmap pprParendType (patSynTyDetails patSyn)
+    prov = pprThetaOpt prov_theta
+    req = pprThetaOpt req_theta
+
+    pprThetaOpt [] = Nothing
+    pprThetaOpt theta = Just $ pprTheta theta
+
+    (_univ_tvs, _ex_tvs, (prov_theta, req_theta)) = patSynSig patSyn
+    rhs_ty = patSynType patSyn
+
 pprTypeForUser :: Type -> SDoc
 -- We do two things here.
 -- a) We tidy the type, regardless
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 91d0035b1b..7ab6d569bc 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -139,7 +139,8 @@ mkBootModDetailsTc hsc_env
               ; dfun_ids   = map instanceDFunId insts'
               ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
                                 (typeEnvIds type_env) tcs fam_insts
-              ; type_env'  = extendTypeEnvWithIds type_env1 dfun_ids
+              ; type_env2  = extendTypeEnvWithPatSyns type_env1 (typeEnvPatSyns type_env)
+              ; type_env'  = extendTypeEnvWithIds type_env2 dfun_ids
               }
         ; return (ModDetails { md_types     = type_env'
                              , md_insts     = insts'
@@ -296,6 +297,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_insts     = insts
                               , mg_fam_insts = fam_insts
                               , mg_binds     = binds
+                              , mg_patsyns   = patsyns
                               , mg_rules     = imp_rules
                               , mg_vect_info = vect_info
                               , mg_anns      = anns
@@ -331,9 +333,12 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
 
         ; let { final_ids  = [ id | id <- bindersOfBinds tidy_binds,
                                     isExternalName (idName id)]
+              ; final_patsyns = filter (isExternalName . getName) patsyns
 
-              ; tidy_type_env = tidyTypeEnv omit_prags
-                                      (extendTypeEnvWithIds type_env final_ids)
+              ; type_env' = extendTypeEnvWithIds type_env final_ids
+              ; type_env'' = extendTypeEnvWithPatSyns type_env' final_patsyns
+
+              ; tidy_type_env = tidyTypeEnv omit_prags type_env''
 
               ; tidy_insts    = map (tidyClsInstDFun (lookup_dfun tidy_type_env)) insts
                 -- A DFunId will have a binding in tidy_binds, and so