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, 165 insertions, 65 deletions

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 9f9fd38f47..ed1343f23d 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -35,8 +35,9 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
 import HsSyn
 import TcRnMonad
 import TcEvidence     ( emptyTcEvBinds )
-import RnTypes        ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch )
+import RnTypes        ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch, rnContext )
 import RnPat
+import RnNames
 import RnEnv
 import DynFlags
 import Module
@@ -46,7 +47,7 @@ import NameSet
 import RdrName          ( RdrName, rdrNameOcc )
 import SrcLoc
 import ListSetOps	( findDupsEq )
-import BasicTypes	( RecFlag(..) )
+import BasicTypes	( RecFlag(..), Origin )
 import Digraph		( SCC(..) )
 import Bag
 import Outputable
@@ -274,7 +275,7 @@ rnValBindsLHS :: NameMaker
               -> HsValBinds RdrName
               -> RnM (HsValBindsLR Name RdrName)
 rnValBindsLHS topP (ValBindsIn mbinds sigs)
-  = do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
+  = do { mbinds' <- mapBagM (wrapOriginLocM (rnBindLHS topP doc)) mbinds
        ; return $ ValBindsIn mbinds' sigs }
   where
     bndrs = collectHsBindsBinders mbinds
@@ -292,7 +293,7 @@ rnValBindsRHS :: HsSigCtxt
 
 rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
   = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
-       ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds
+       ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds
        ; case depAnalBinds binds_w_dus of
            (anal_binds, anal_dus) -> return (valbind', valbind'_dus)
               where
@@ -413,39 +414,50 @@ dupFixityDecl loc rdr_name
 
 rnBindLHS :: NameMaker
           -> SDoc 
-          -> LHsBind RdrName
+          -> HsBind RdrName
           -- returns the renamed left-hand side,
           -- and the FreeVars *of the LHS*
           -- (i.e., any free variables of the pattern)
-          -> RnM (LHsBindLR Name RdrName)
+          -> RnM (HsBindLR Name RdrName)
 
-rnBindLHS name_maker _ (L loc bind@(PatBind { pat_lhs = pat }))
-  = setSrcSpan loc $ do
+rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
+  = do
       -- we don't actually use the FV processing of rnPatsAndThen here
       (pat',pat'_fvs) <- rnBindPat name_maker pat
-      return (L loc (bind { pat_lhs = pat', bind_fvs = pat'_fvs }))
+      return (bind { pat_lhs = pat', bind_fvs = pat'_fvs })
                 -- We temporarily store the pat's FVs in bind_fvs;
                 -- gets updated to the FVs of the whole bind
                 -- when doing the RHS below
-                            
-rnBindLHS name_maker _ (L loc bind@(FunBind { fun_id = name@(L nameLoc _) }))
-  = setSrcSpan loc $ 
-    do { newname <- applyNameMaker name_maker name
-       ; return (L loc (bind { fun_id = L nameLoc newname })) } 
 
-rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b)
+rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) })
+  = do { newname <- applyNameMaker name_maker name
+       ; return (bind { fun_id = L nameLoc newname }) } 
+
+rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) })
+  = do { addLocM checkConName rdrname
+       ; name <- applyNameMaker name_maker rdrname
+       ; return (bind{ patsyn_id = L nameLoc name }) }
+
+rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
+
+rnLBind :: (Name -> [Name])		-- Signature tyvar function
+        -> (Origin, LHsBindLR Name RdrName)
+        -> RnM ((Origin, LHsBind Name), [Name], Uses)
+rnLBind sig_fn (origin, (L loc bind))
+  = setSrcSpan loc $
+    do { (bind', bndrs, dus) <- rnBind sig_fn bind
+       ; return ((origin, L loc bind'), bndrs, dus) }
 
 -- assumes the left-hands-side vars are in scope
 rnBind :: (Name -> [Name])		-- Signature tyvar function
-       -> LHsBindLR Name RdrName
-       -> RnM (LHsBind Name, [Name], Uses)
-rnBind _ (L loc bind@(PatBind { pat_lhs = pat
-                              , pat_rhs = grhss 
-                                      -- pat fvs were stored in bind_fvs
-                                      -- after processing the LHS
-                              , bind_fvs = pat_fvs }))
-  = setSrcSpan loc $ 
-    do	{ mod <- getModule
+       -> HsBindLR Name RdrName
+       -> RnM (HsBind Name, [Name], Uses)
+rnBind _ bind@(PatBind { pat_lhs = pat
+                       , pat_rhs = grhss 
+                                   -- pat fvs were stored in bind_fvs
+                                   -- after processing the LHS
+                       , bind_fvs = pat_fvs })
+  = do	{ mod <- getModule
         ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
 
 		-- No scoped type variables for pattern bindings
@@ -470,14 +482,13 @@ rnBind _ (L loc bind@(PatBind { pat_lhs = pat
           addWarn $ unusedPatBindWarn bind'
 
 	; fvs' `seq` -- See Note [Free-variable space leak]
-          return (L loc bind', bndrs, all_fvs) }
+          return (bind', bndrs, all_fvs) }
 
-rnBind sig_fn (L loc bind@(FunBind { fun_id = name 
-                            	   , fun_infix = is_infix 
-                            	   , fun_matches = matches })) 
+rnBind sig_fn bind@(FunBind { fun_id = name 
+                            , fun_infix = is_infix 
+                            , fun_matches = matches }) 
        -- invariant: no free vars here when it's a FunBind
-  = setSrcSpan loc $
-    do	{ let plain_name = unLoc name
+  = do	{ let plain_name = unLoc name
 
 	; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
 				-- bindSigTyVars tests for Opt_ScopedTyVars
@@ -491,11 +502,62 @@ rnBind sig_fn (L loc bind@(FunBind { fun_id = name
 		-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
 
 	; fvs' `seq` -- See Note [Free-variable space leak]
-          return (L loc (bind { fun_matches = matches'
-			      , bind_fvs   = fvs' }), 
+          return (bind { fun_matches = matches'
+	               , bind_fvs   = fvs' },
 		  [plain_name], rhs_fvs)
       }
 
+rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name
+                                , patsyn_args = details
+                                , patsyn_def = pat
+                                , patsyn_dir = dir })
+       -- invariant: no free vars here when it's a FunBind
+  = do	{ pattern_synonym_ok <- xoptM Opt_PatternSynonyms
+        ; unless pattern_synonym_ok (addErr patternSynonymErr)
+
+        ; ((pat', details'), fvs) <- rnPat PatSyn pat $ \pat' -> do
+         -- We check the 'RdrName's instead of the 'Name's
+         -- so that the binding locations are reported
+         -- from the left-hand side
+        { (details', fvs) <- case details of
+               PrefixPatSyn vars ->
+                   do { checkDupRdrNames vars
+                      ; names <- mapM lookupVar vars
+                      ; return (PrefixPatSyn names, mkFVs (map unLoc names)) }
+               InfixPatSyn var1 var2 ->
+                   do { checkDupRdrNames [var1, var2]
+                      ; name1 <- lookupVar var1
+                      ; name2 <- lookupVar var2
+                      -- ; checkPrecMatch -- TODO
+                      ; return (InfixPatSyn name1 name2, mkFVs (map unLoc [name1, name2])) }
+        ; return ((pat', details'), fvs) }
+        ; dir' <- case dir of
+            Unidirectional -> return Unidirectional
+            ImplicitBidirectional -> return ImplicitBidirectional
+
+        ; mod <- getModule
+        ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs
+	        -- Keep locally-defined Names
+		-- As well as dependency analysis, we need these for the
+		-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
+
+        ; let bind' = bind{ patsyn_args = details'
+                          , patsyn_def = pat'
+                          , patsyn_dir = dir'
+                          , bind_fvs = fvs' }
+
+        ; fvs' `seq` -- See Note [Free-variable space leak]
+          return (bind', [name], fvs)
+      }
+  where
+    lookupVar = wrapLocM lookupOccRn
+
+    patternSynonymErr :: SDoc
+    patternSynonymErr
+      = hang (ptext (sLit "Illegal pattern synonym declaration"))
+           2 (ptext (sLit "Use -XPatternSynonyms to enable this extension"))
+
+
 rnBind _ b = pprPanic "rnBind" (ppr b)
 
 {-
@@ -512,7 +574,7 @@ trac ticket #1136.
 -}
 
 ---------------------
-depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
+depAnalBinds :: Bag ((Origin, LHsBind Name), [Name], Uses)
 	     -> ([(RecFlag, LHsBinds Name)], DefUses)
 -- Dependency analysis; this is important so that 
 -- unused-binding reporting is accurate
@@ -597,9 +659,10 @@ rnMethodBinds cls sig_fn binds
        ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
   where 
     meth_names  = collectMethodBinders binds
-    do_one (binds,fvs) bind 
+    do_one (binds,fvs) (origin,bind)
        = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
-	    ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
+            ; let bind'' = mapBag (\bind -> (origin,bind)) bind'
+	    ; return (binds `unionBags` bind'', fvs_bind `plusFV` fvs) }
 
 rnMethodBind :: Name
 	      -> (Name -> [Name])
@@ -720,6 +783,24 @@ renameSig ctxt sig@(MinimalSig bf)
   = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
        return (MinimalSig new_bf, emptyFVs)
 
+renameSig ctxt sig@(PatSynSig v args ty prov req)
+  = do	v' <- lookupSigOccRn ctxt sig v
+        let doc = quotes (ppr v)
+            rn_type = rnHsSigType doc
+        (ty', fvs1) <- rn_type ty
+        (args', fvs2) <- case args of
+            PrefixPatSyn tys ->
+                do (tys, fvs) <- unzip <$> mapM rn_type tys
+                   return (PrefixPatSyn tys, plusFVs fvs)
+            InfixPatSyn left right ->
+                do (left', fvs1) <- rn_type left
+                   (right', fvs2) <- rn_type right
+                   return (InfixPatSyn left' right', fvs1 `plusFV` fvs2)
+        (prov', fvs3) <- rnContext (TypeSigCtx doc) prov
+        (req', fvs4) <- rnContext (TypeSigCtx doc) req
+        let fvs = plusFVs [fvs1, fvs2, fvs3, fvs4]
+        return (PatSynSig v' args' ty' prov' req', fvs)
+
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
 
@@ -731,6 +812,9 @@ okHsSig ctxt (L _ sig)
 
      (TypeSig {}, _)              -> True
 
+     (PatSynSig {}, TopSigCtxt{}) -> True
+     (PatSynSig {}, _)            -> False
+
      (FixSig {}, InstDeclCtxt {}) -> False
      (FixSig {}, _)               -> True
 
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index d29c3f3b9a..1028d08f03 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -60,6 +60,7 @@ import NameEnv
 import Avail
 import Module
 import UniqFM
+import ConLike
 import DataCon          ( dataConFieldLabels, dataConTyCon )
 import TyCon            ( isTupleTyCon, tyConArity )
 import PrelNames        ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR )
@@ -233,9 +234,9 @@ lookupExactOcc :: Name -> RnM Name
 lookupExactOcc name
   | Just thing <- wiredInNameTyThing_maybe name
   , Just tycon <- case thing of
-                    ATyCon tc   -> Just tc
-                    ADataCon dc -> Just (dataConTyCon dc)
-                    _           -> Nothing
+                    ATyCon tc                 -> Just tc
+                    AConLike (RealDataCon dc) -> Just (dataConTyCon dc)
+                    _                         -> Nothing
   , isTupleTyCon tycon
   = do { checkTupSize (tyConArity tycon)
        ; return name }
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 823123309b..56ee969aed 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -9,6 +9,7 @@ module RnNames (
         rnExports, extendGlobalRdrEnvRn,
         gresFromAvails,
         reportUnusedNames,
+        checkConName
     ) where
 
 #include "HsVersions.h"
@@ -1689,4 +1690,21 @@ moduleWarn mod (DeprecatedTxt txt)
 packageImportErr :: SDoc
 packageImportErr
   = ptext (sLit "Package-qualified imports are not enabled; use PackageImports")
+
+-- This data decl will parse OK
+--      data T = a Int
+-- treating "a" as the constructor.
+-- It is really hard to make the parser spot this malformation.
+-- So the renamer has to check that the constructor is legal
+--
+-- We can get an operator as the constructor, even in the prefix form:
+--      data T = :% Int Int
+-- from interface files, which always print in prefix form
+
+checkConName :: RdrName -> TcRn ()
+checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
+
+badDataCon :: RdrName -> SDoc
+badDataCon name
+   = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
 \end{code}
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index fc62ed24d5..639ab51101 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -52,6 +52,7 @@ import RnTypes
 import DynFlags
 import PrelNames
 import TyCon               ( tyConName )
+import ConLike
 import DataCon             ( dataConTyCon )
 import TypeRep             ( TyThing(..) )
 import Name
@@ -135,13 +136,14 @@ wrapSrcSpanCps fn (L loc a)
 lookupConCps :: Located RdrName -> CpsRn (Located Name)
 lookupConCps con_rdr 
   = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr
-                    ; k con_name })
-    -- We do not add the constructor name to the free vars
-    -- See Note [Patterns are not uses]
+                    ; (r, fvs) <- k con_name
+                    ; return (r, addOneFV fvs (unLoc con_name)) })
+    -- We add the constructor name to the free vars
+    -- See Note [Patterns are uses]
 \end{code}
 
-Note [Patterns are not uses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Patterns are uses]
+~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
   module Foo( f, g ) where
   data T = T1 | T2
@@ -154,6 +156,18 @@ Consider
 Arguaby we should report T2 as unused, even though it appears in a
 pattern, because it never occurs in a constructed position.  See
 Trac #7336.
+However, implementing this in the face of pattern synonyms would be
+less straightforward, since given two pattern synonyms
+
+  pattern P1 <- P2
+  pattern P2 <- ()
+
+we need to observe the dependency between P1 and P2 so that type
+checking can be done in the correct order (just like for value
+bindings). Dependencies between bindings is analyzed in the renamer,
+where we don't know yet whether P2 is a constructor or a pattern
+synonym. So for now, we do report conid occurances in patterns as
+uses.
 
 %*********************************************************
 %*                                                      *
@@ -603,7 +617,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
     -- That is, the parent of the data constructor.  
     -- That's the parent to use for looking up record fields.
     find_tycon env con 
-      | Just (ADataCon dc) <- wiredInNameTyThing_maybe con
+      | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con
       = tyConName (dataConTyCon dc)   -- Special case for [], which is built-in syntax
                                       -- and not in the GlobalRdrEnv (Trac #8448)
       | [GRE { gre_par = ParentIs p }] <- lookupGRE_Name env con
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 82ca29d9d3..f3b4d9178d 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -35,7 +35,7 @@ import NameEnv
 import Avail
 import Outputable
 import Bag
-import BasicTypes       ( RuleName )
+import BasicTypes       ( RuleName, Origin(..) )
 import FastString
 import SrcLoc
 import DynFlags
@@ -617,8 +617,8 @@ type variable environment iff -fglasgow-exts
 
 \begin{code}
 extendTyVarEnvForMethodBinds :: [Name]
-                             -> RnM (Bag (LHsBind Name), FreeVars)
-                             -> RnM (Bag (LHsBind Name), FreeVars)
+                             -> RnM (LHsBinds Name, FreeVars)
+                             -> RnM (LHsBinds Name, FreeVars)
 extendTyVarEnvForMethodBinds ktv_names thing_inside
   = do  { scoped_tvs <- xoptM Opt_ScopedTypeVariables
         ; if scoped_tvs then
@@ -1342,23 +1342,6 @@ deprecRecSyntax decl
 
 badRecResTy :: SDoc -> SDoc
 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
-
--- This data decl will parse OK
---      data T = a Int
--- treating "a" as the constructor.
--- It is really hard to make the parser spot this malformation.
--- So the renamer has to check that the constructor is legal
---
--- We can get an operator as the constructor, even in the prefix form:
---      data T = :% Int Int
--- from interface files, which always print in prefix form
-
-checkConName :: RdrName -> TcRn ()
-checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
-
-badDataCon :: RdrName -> SDoc
-badDataCon name
-   = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
 \end{code}
 
 Note [Infix GADT constructors]
@@ -1535,7 +1518,7 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
   = tycls { group_roles = d : roles } : rest
 
 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
-add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
+add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` (FromSource, b)) sigs
 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
 
 add_sig :: LSig a -> HsValBinds a -> HsValBinds a