From bed038cd283d7ccd566998a84a0ae0834c135bd6 Mon Sep 17 00:00:00 2001
From: Judah Jacobson <judah@users.noreply.github.com>
Date: Fri, 30 Aug 2019 20:40:17 -0700
Subject: [PATCH] Implement basic prefix pattern synonyms. (#43)

Progress on #28.  Still need several variants such as unidirectional,
explicit bididirectonal, records, and infix operators.
---
 src/GHC/SourceGen/Decl.hs | 27 +++++++++++++++++++++++++++
 tests/pprint_test.hs      |  8 ++++++++
 2 files changed, 35 insertions(+)

diff --git a/src/GHC/SourceGen/Decl.hs b/src/GHC/SourceGen/Decl.hs
index f874604..17f5075 100644
--- a/src/GHC/SourceGen/Decl.hs
+++ b/src/GHC/SourceGen/Decl.hs
@@ -39,6 +39,10 @@ module GHC.SourceGen.Decl
     , RawInstDecl
     , HasTyFamInst(..)
     , tyFamInst
+      -- * Pattern synonyms
+    , patSynSigs
+    , patSynSig
+    , patSynBind
     ) where
 
 import BasicTypes (LexicalFixity(Prefix))
@@ -46,6 +50,7 @@ import BasicTypes (LexicalFixity(Prefix))
 import BasicTypes (DerivStrategy(..))
 #endif
 import Bag (listToBag)
+import HsBinds
 import HsDecls
 import HsTypes
     ( ConDeclField(..)
@@ -407,3 +412,25 @@ derivingAnyclass = derivingWay (Just AnyclassStrategy)
 derivingVia :: HsType' -> [HsType'] -> HsDerivingClause'
 derivingVia t = derivingWay (Just $ ViaStrategy $ sigType t)
 #endif
+
+patSynSigs :: [OccNameStr] -> HsType' -> HsDecl'
+patSynSigs names t =
+    sigB $ noExt PatSynSig (map (typeRdrName . unqual) names)
+        $ sigType t
+
+patSynSig :: OccNameStr -> HsType' -> HsDecl'
+patSynSig n = patSynSigs [n]
+
+-- TODO: patSynBidi, patSynUni
+patSynBind :: OccNameStr -> [OccNameStr] -> Pat' -> HsDecl'
+patSynBind n ns p = bindB $ noExt PatSynBind
+                    $ withPlaceHolder (noExt PSB (valueRdrName $ unqual n))
+#if MIN_VERSION_ghc(8,4,0)
+                        (PrefixCon
+#else
+                        (PrefixPatSyn
+#endif
+                            (map (valueRdrName . unqual) ns))
+                        (builtPat p)
+                        ImplicitBidirectional
+
diff --git a/tests/pprint_test.hs b/tests/pprint_test.hs
index 4db1f8b..6c0d0a8 100644
--- a/tests/pprint_test.hs
+++ b/tests/pprint_test.hs
@@ -258,6 +258,14 @@ declsTest dflags = testGroup "Decls"
             :~ instance' (var "Container" @@ var "String")
                 [tyFamInst "Elt" [var "String"] (var "Char")]
         ]
+    , test "patSynSigs"
+        [ "pattern F, G :: T" :~ patSynSigs ["F", "G"] $ var "T"
+        , "pattern F :: T" :~ patSynSig "F" $ var "T"
+        ]
+    , test "patSynBind"
+        [ "pattern F a b = G b a"
+            :~ patSynBind "F" ["a", "b"] $ conP "G" [var "b", var "a"]
+        ]
     ]
   where
     test = testDecls dflags