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>

5 files changed, 214 insertions, 8 deletions

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index c4c1bcd69e..9fd0c33423 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -20,6 +20,7 @@ module BinIface (
 
 import TcRnMonad
 import TyCon
+import ConLike
 import DataCon    (dataConName, dataConWorkId, dataConTyCon)
 import PrelInfo   (wiredInThings, basicKnownKeyNames)
 import Id         (idName, isDataConWorkId_maybe)
@@ -318,7 +319,7 @@ putName _dict BinSymbolTable{
   = case wiredInNameTyThing_maybe name of
      Just (ATyCon tc)
        | isTupleTyCon tc             -> putTupleName_ bh tc 0
-     Just (ADataCon dc)
+     Just (AConLike (RealDataCon dc))
        | let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 1
      Just (AnId x)
        | Just dc <- isDataConWorkId_maybe x, let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 2
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 38bb930e13..e412d7ef30 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -15,6 +15,7 @@ module BuildTyCl (
         buildSynTyCon,
         buildAlgTyCon, 
         buildDataCon,
+        buildPatSyn, mkPatSynMatcherId, mkPatSynWrapperId,
         TcMethInfo, buildClass,
         distinctAbstractTyConRhs, totallyAbstractTyConRhs,
         mkNewTyConRhs, mkDataTyConRhs, 
@@ -26,6 +27,7 @@ module BuildTyCl (
 import IfaceEnv
 import FamInstEnv( FamInstEnvs )
 import DataCon
+import PatSyn
 import Var
 import VarSet
 import BasicTypes
@@ -34,6 +36,9 @@ import MkId
 import Class
 import TyCon
 import Type
+import TypeRep
+import TcType
+import Id
 import Coercion
 
 import DynFlags
@@ -176,6 +181,70 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
     arg_tyvars      = tyVarsOfTypes arg_tys
     in_arg_tys pred = not $ isEmptyVarSet $ 
 		      tyVarsOfType pred `intersectVarSet` arg_tyvars
+
+
+------------------------------------------------------
+buildPatSyn :: Name -> Bool -> Bool
+            -> [Var]
+            -> [TyVar] -> [TyVar]     -- Univ and ext
+            -> ThetaType -> ThetaType -- Prov and req
+            -> Type                  -- Result type
+            -> TyVar
+            -> TcRnIf m n PatSyn
+buildPatSyn src_name declared_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
+  = do	{ (matcher, _, _) <- mkPatSynMatcherId src_name args
+                                              univ_tvs ex_tvs
+                                              prov_theta req_theta
+                                              pat_ty tv
+        ; wrapper <- case has_wrapper of
+            False -> return Nothing
+            True -> fmap Just $
+                    mkPatSynWrapperId src_name args
+                                      (univ_tvs ++ ex_tvs) (prov_theta ++ req_theta)
+                                      pat_ty
+        ; return $ mkPatSyn src_name declared_infix
+                            args
+                            univ_tvs ex_tvs
+                            prov_theta req_theta
+                            pat_ty
+                            matcher
+                            wrapper }
+
+mkPatSynMatcherId :: Name
+                  -> [Var]
+                  -> [TyVar]
+                  -> [TyVar]
+                  -> ThetaType -> ThetaType
+                  -> Type
+                  -> TyVar
+                  -> TcRnIf n m (Id, Type, Type)
+mkPatSynMatcherId name args univ_tvs ex_tvs prov_theta req_theta pat_ty res_tv
+  = do { matcher_name <- newImplicitBinder name mkMatcherOcc
+
+       ; let res_ty = TyVarTy res_tv
+             cont_ty = mkSigmaTy ex_tvs prov_theta $
+                       mkFunTys (map varType args) res_ty
+
+       ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
+             matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
+             matcher_id = mkVanillaGlobal matcher_name matcher_sigma
+       ; return (matcher_id, res_ty, cont_ty) }
+
+mkPatSynWrapperId :: Name
+                  -> [Var]
+                  -> [TyVar]
+                  -> ThetaType
+                  -> Type
+                  -> TcRnIf n m Id
+mkPatSynWrapperId name args qtvs theta pat_ty
+  = do { wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
+
+       ; let wrapper_tau = mkFunTys (map varType args) pat_ty
+             wrapper_sigma = mkSigmaTy qtvs theta wrapper_tau
+
+       ; let wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma
+       ; return wrapper_id }
+
 \end{code}
 
 
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index f693999390..b582305434 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -118,6 +118,16 @@ data IfaceDecl
                                                 -- beyond .NET
                    ifExtName :: Maybe FastString }
 
+  | IfacePatSyn { ifName          :: OccName,           -- Name of the pattern synonym
+                  ifPatHasWrapper :: Bool,
+                  ifPatIsInfix    :: Bool,
+                  ifPatUnivTvs    :: [IfaceTvBndr],
+                  ifPatExTvs      :: [IfaceTvBndr],
+                  ifPatProvCtxt   :: IfaceContext,
+                  ifPatReqCtxt    :: IfaceContext,
+                  ifPatArgs       :: [IfaceIdBndr],
+                  ifPatTy         :: IfaceType }
+
 -- A bit of magic going on here: there's no need to store the OccName
 -- for a decl on the disk, since we can infer the namespace from the
 -- context; however it is useful to have the OccName in the IfaceDecl
@@ -175,6 +185,18 @@ instance Binary IfaceDecl where
         put_ bh a3
         put_ bh a4
 
+    put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9) = do
+        putByte bh 6
+        put_ bh (occNameFS name)
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+        put_ bh a5
+        put_ bh a6
+        put_ bh a7
+        put_ bh a8
+        put_ bh a9
+
     get bh = do
         h <- getByte bh
         case h of
@@ -215,12 +237,24 @@ instance Binary IfaceDecl where
                     a9 <- get bh
                     occ <- return $! mkOccNameFS clsName a2
                     return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9)
-            _ -> do a1 <- get bh
+            5 -> do a1 <- get bh
                     a2 <- get bh
                     a3 <- get bh
                     a4 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
                     return (IfaceAxiom occ a2 a3 a4)
+            6 -> do a1 <- get bh
+                    a2 <- get bh
+                    a3 <- get bh
+                    a4 <- get bh
+                    a5 <- get bh
+                    a6 <- get bh
+                    a7 <- get bh
+                    a8 <- get bh
+                    a9 <- get bh
+                    occ <- return $! mkOccNameFS dataName a1
+                    return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9)
+            _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
 
 data IfaceSynTyConRhs
   = IfaceOpenSynFamilyTyCon
@@ -980,6 +1014,11 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
     dc_occ = mkClassDataConOcc cls_tc_occ
     is_newtype = n_sigs + n_ctxt == 1 -- Sigh
 
+ifaceDeclImplicitBndrs (IfacePatSyn{ ifName = ps_occ, ifPatHasWrapper = has_wrapper })
+  = [wrap_occ | has_wrapper]
+  where
+    wrap_occ = mkDataConWrapperOcc ps_occ  -- Id namespace
+
 ifaceDeclImplicitBndrs _ = []
 
 -- -----------------------------------------------------------------------------
@@ -1063,6 +1102,30 @@ pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branche
   = hang (ptext (sLit "axiom") <+> ppr name <> colon)
        2 (vcat $ map (pprAxBranch $ Just tycon) branches)
 
+pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap,
+                            ifPatIsInfix = is_infix,
+                            ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
+                            ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
+                            ifPatArgs = args,
+                            ifPatTy = ty })
+  = hang (text "pattern" <+> header)
+       4 details
+  where
+    header = ppr name <+> dcolon <+>
+             (pprIfaceForAllPart univ_tvs req_ctxt $
+              pprIfaceForAllPart ex_tvs prov_ctxt $
+              pp_tau)
+
+    details = sep [ if is_infix then text "Infix" else empty
+                  , if has_wrap then text "HasWrapper" else empty
+                  ]
+
+    pp_tau = case map pprParendIfaceType (arg_tys ++ [ty]) of
+        (t:ts) -> fsep (t : map (arrow <+>) ts)
+        []     -> panic "pp_tau"
+
+    arg_tys = map snd args
+
 pprCType :: Maybe CType -> SDoc
 pprCType Nothing = ptext (sLit "No C type associated")
 pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType
@@ -1332,6 +1395,13 @@ freeNamesIfDecl d@IfaceClass{} =
 freeNamesIfDecl d@IfaceAxiom{} =
   freeNamesIfTc (ifTyCon d) &&&
   fnList freeNamesIfAxBranch (ifAxBranches d)
+freeNamesIfDecl d@IfacePatSyn{} =
+  freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
+  freeNamesIfTvBndrs (ifPatExTvs d) &&&
+  freeNamesIfContext (ifPatProvCtxt d) &&&
+  freeNamesIfContext (ifPatReqCtxt d) &&&
+  fnList freeNamesIfType (map snd (ifPatArgs d)) &&&
+  freeNamesIfType (ifPatTy d)
 
 freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
 freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 9aad5ffea2..379b39de58 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -73,7 +73,9 @@ import Class
 import Kind
 import TyCon
 import CoAxiom
+import ConLike
 import DataCon
+import PatSyn
 import Type
 import TcType
 import InstEnv
@@ -1458,8 +1460,9 @@ tyThingToIfaceDecl :: TyThing -> IfaceDecl
 tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id
 tyThingToIfaceDecl (ATyCon tycon) = tyConToIfaceDecl emptyTidyEnv tycon
 tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax
-tyThingToIfaceDecl (ADataCon dc)  = pprPanic "toIfaceDecl" (ppr dc)
-                                    -- Should be trimmed out earlier
+tyThingToIfaceDecl (AConLike cl)  = case cl of
+    RealDataCon dc -> pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
+    PatSynCon ps   -> patSynToIfaceDecl ps
 
 --------------------------
 idToIfaceDecl :: Id -> IfaceDecl
@@ -1473,6 +1476,29 @@ idToIfaceDecl id
               ifIdDetails = toIfaceIdDetails (idDetails id),
               ifIdInfo    = toIfaceIdInfo (idInfo id) }
 
+--------------------------
+patSynToIfaceDecl :: PatSyn -> IfaceDecl
+patSynToIfaceDecl ps
+  = IfacePatSyn { ifName          = getOccName . getName $ ps
+                , ifPatHasWrapper = isJust $ patSynWrapper ps
+                , ifPatIsInfix    = patSynIsInfix ps
+                , ifPatUnivTvs    = toIfaceTvBndrs univ_tvs'
+                , ifPatExTvs      = toIfaceTvBndrs ex_tvs'
+                , ifPatProvCtxt   = tidyToIfaceContext env2 prov_theta
+                , ifPatReqCtxt    = tidyToIfaceContext env2 req_theta
+                , ifPatArgs       = map toIfaceArg args
+                , ifPatTy         = tidyToIfaceType env2 rhs_ty
+                }
+  where
+    toIfaceArg var = (occNameFS (getOccName var),
+                      tidyToIfaceType env2 (varType var))
+
+    (univ_tvs, ex_tvs, (prov_theta, req_theta)) = patSynSig ps
+    args = patSynArgs ps
+    rhs_ty = patSynType ps
+    (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
+    (env2, ex_tvs')   = tidyTyVarBndrs env1 ex_tvs
+
 
 --------------------------
 coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 737616990c..20adfe5896 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -43,6 +43,7 @@ import IdInfo
 import Class
 import TyCon
 import CoAxiom
+import ConLike
 import DataCon
 import PrelNames
 import TysWiredIn
@@ -582,6 +583,32 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
                              , co_ax_implicit = False }
        ; return (ACoAxiom axiom) }
 
+tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
+                              , ifPatHasWrapper = has_wrapper
+                              , ifPatIsInfix = is_infix
+                              , ifPatUnivTvs = univ_tvs
+                              , ifPatExTvs = ex_tvs
+                              , ifPatProvCtxt = prov_ctxt
+                              , ifPatReqCtxt = req_ctxt
+                              , ifPatArgs = args
+                              , ifPatTy = pat_ty })
+  = do { name <- lookupIfaceTop occ_name
+       ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
+       ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
+       { bindIfaceTyVars ex_tvs $ \ex_tvs -> do
+       { bindIfaceIdVars args $ \args -> do
+       { ~(prov_theta, req_theta, pat_ty) <- forkM (mk_doc name) $
+             do { prov_theta <- tcIfaceCtxt prov_ctxt
+                ; req_theta  <- tcIfaceCtxt req_ctxt
+                ; pat_ty     <- tcIfaceType pat_ty
+                ; return (prov_theta, req_theta, pat_ty) }
+       ; bindIfaceTyVar (fsLit "r", toIfaceKind liftedTypeKind) $ \tv -> do
+       { patsyn <- buildPatSyn name is_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
+       ; return (AConLike (PatSynCon patsyn)) }}}}}
+  where
+     mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
+
+
 tc_ax_branches :: TyCon -> [IfaceAxBranch] -> IfL [CoAxBranch]
 tc_ax_branches tc if_branches = foldlM (tc_ax_branch (tyConKind tc)) [] if_branches
 
@@ -1435,8 +1462,8 @@ tcIfaceTyCon (IfaceTc name)
   = do { thing <- tcIfaceGlobal name
        ; case thing of    -- A "type constructor" can be a promoted data constructor
                           --           c.f. Trac #5881
-           ATyCon   tc -> return tc
-           ADataCon dc -> return (promoteDataCon dc)
+           ATyCon   tc               -> return tc
+           AConLike (RealDataCon dc) -> return (promoteDataCon dc)
            _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) }
 
 tcIfaceKindCon :: IfaceTyCon -> IfL TyCon
@@ -1459,7 +1486,7 @@ tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
 tcIfaceDataCon :: Name -> IfL DataCon
 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
                          ; case thing of
-                                ADataCon dc -> return dc
+                                AConLike (RealDataCon dc) -> return dc
                                 _       -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
 
 tcIfaceExtId :: Name -> IfL Id
@@ -1521,6 +1548,20 @@ bindIfaceTyVars bndrs thing_inside
   where
     (occs,kinds) = unzip bndrs
 
+bindIfaceIdVar :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
+bindIfaceIdVar (occ, ty) thing_inside
+  = do  { name <- newIfaceName (mkVarOccFS occ)
+        ; ty' <- tcIfaceType ty
+        ; let id = mkLocalId name ty'
+        ; extendIfaceIdEnv [id] (thing_inside id) }
+
+bindIfaceIdVars :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
+bindIfaceIdVars []     thing_inside = thing_inside []
+bindIfaceIdVars (v:vs) thing_inside
+  = bindIfaceIdVar v     $ \ v' ->
+    bindIfaceIdVars vs   $ \ vs' ->
+    thing_inside (v':vs')
+
 isSuperIfaceKind :: IfaceKind -> Bool
 isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName
 isSuperIfaceKind _ = False
@@ -1547,4 +1588,3 @@ bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
          bindIfaceTyVars_AT bs $ \bs' ->
          thing_inside (b':bs') }
 \end{code}
-