Introduce valBind, and add HasPatBind. (#25)

Another follow-up fix for #13:
- Don't allow pattern bindings in class or instance declarations
- Add `valBind` which *is* allowed in let and where clauses
- Add `valBindRhs` and `patBindRhs`.

src/GHC/SourceGen/Binds.hs

@@ -6,14 +6,21 @@
 
 -- | This module provides combinators for constructing Haskell declarations.
 module GHC.SourceGen.Binds
-    (  -- * Overloaded constructors
+    (  -- * Bindings
       HsBind'
-    , HasValBind(..)
-    , Sig'
+    , HasValBind
+      -- * Type signatures
     , typeSig
     , typeSigs
+      -- * Functions
     , funBind
     , funBinds
+      -- * Values
+    , valBindRhs
+    , valBind
+    -- ** Patterns
+    , HasPatBind
+    , patBindRhs
     , patBind
     -- * Matches
     -- $rawMatch
@@ -40,7 +47,6 @@ module GHC.SourceGen.Binds
 import BasicTypes (LexicalFixity(..))
 import HsBinds
 import HsExpr
-import HsDecls
 import HsTypes
 import TcEvidence (HsWrapper(WpHole))
 
@@ -50,7 +56,7 @@ import GHC.SourceGen.Name.Internal
 import GHC.SourceGen.Syntax.Internal
 import GHC.SourceGen.Type.Internal (sigWcType)
 
--- | Declare that a multiple functions or values have a type:
+-- | Declares the type of multiple functions or values.
 --
 -- > f, g :: A
 -- > =====
@@ -60,7 +66,7 @@ typeSigs names t =
     sigB $ noExt TypeSig (map (typeRdrName . unqual) names)
         $ sigWcType t
 
--- | Declare that a function or value has a type:
+-- | Declares the type of a single function or value.
 --
 -- > f :: A
 -- > =====
@@ -68,7 +74,7 @@ typeSigs names t =
 typeSig :: HasValBind t => OccNameStr -> HsType' -> t
 typeSig n = typeSigs [n]
 
--- | Define a function or value.
+-- | Defines a function or value.
 --
 -- > f = x
 -- > =====
@@ -85,13 +91,13 @@ typeSig n = typeSigs [n]
 -- >   [ matchRhs [conP "True" []] (var "False")
 -- >   , matchRhs [conP "False" []] (var "True")
 -- >   ]
-funBinds :: HasValBind t => RdrNameStr -> [RawMatch] -> t
+funBinds :: HasValBind t => OccNameStr -> [RawMatch] -> t
 funBinds name matches = bindB $ withPlaceHolder
         (noExt FunBind name'
             (matchGroup context matches) WpHole)
         []
   where
-    name' = valueRdrName name
+    name' = valueRdrName $ unqual name
     context = FunRhs name' Prefix NoSrcStrict
 
 -- | Defines a function that has a single case.
@@ -104,14 +110,40 @@ funBinds name matches = bindB $ withPlaceHolder
 -- > =====
 -- > funBind "id" $ matchRhs [var "x"] (var "x")
 --
-funBind :: HasValBind t => RdrNameStr -> RawMatch -> t
+funBind :: HasValBind t => OccNameStr -> RawMatch -> t
 funBind name m = funBinds name [m]
 
--- | A pattern binding.
+-- | Defines a value consisting of multiple guards.
+--
+-- The resulting syntax is the same as a function with no arguments.
 --
 -- > x = y
 -- > =====
--- > patBind (var "x") $ rhs $ var "y"
+-- > valBind "x" $ rhs $ var "y"
+--
+-- > x
+-- >   | test = 1
+-- >   | otherwise = 2
+-- > =====
+-- > valBind "x"
+-- >   $ guardedRhs
+-- >     [ var "test" `guard` int 1
+-- >     , var "otherwise" `guard` int 2
+-- >     ]
+valBind :: HasValBind t => OccNameStr -> RawGRHSs -> t
+valBind name = funBind name . match []
+
+-- | Defines a value without any guards.
+--
+-- The resulting syntax is the same as a function with no arguments.
+--
+-- > x = y
+-- > =====
+-- > valBindRhs "x" $ var "y"
+valBindRhs :: HasValBind t => OccNameStr -> HsExpr' -> t
+valBindRhs name = valBind name . rhs
+
+-- | Defines a pattern binding consisting of multiple guards.
 --
 -- > (x, y) = e
 -- > =====
@@ -126,7 +158,7 @@ funBind name m = funBinds name [m]
 -- >       [ var "test" `guard` tuple [int 1, int 2]
 -- >       , var "otherwise" `guard` [int 2, int 3]
 -- >       ]
-patBind :: HasValBind t => Pat' -> RawGRHSs -> t
+patBind :: HasPatBind t => Pat' -> RawGRHSs -> t
 patBind p g =
     bindB
         $ withPlaceHolder
@@ -134,6 +166,14 @@ patBind p g =
                 (noExt PatBind (builtPat p) (mkGRHSs g)))
         $ ([],[])
 
+-- | Defines a pattern binding without any guards.
+--
+-- > (x, y) = e
+-- > =====
+-- > patBindRhs (tuple [var "x", var "y"]) e
+patBindRhs :: HasPatBind t => Pat' -> HsExpr' -> t
+patBindRhs p = patBind p . rhs
+
 {- $rawMatch
 
 A function definition is made up of one or more 'RawMatch' terms.  Each
@@ -182,7 +222,7 @@ matchRhs ps = match ps . rhs
 -- > funBind "x"
 -- >   $ match [var "x"]
 -- >   $ rhs (var "y")
--- >      `where` [patBind (var "y") $ rhs $ var "x']
+-- >      `where` [valueRhs (var "y") $ var "x']
 where' :: RawGRHSs -> [RawValBind] -> RawGRHSs
 where' r vbs = r { rawGRHSWhere = rawGRHSWhere r ++ vbs }
 
@@ -236,19 +276,12 @@ stmt e =
 p <-- e = withPlaceHolder $ noExt BindStmt (builtPat p) (builtLoc e) noSyntaxExpr noSyntaxExpr
 infixl 1 <--
 
--- | Syntax types which can declare/define functions.  For example:
--- declarations, or the body of a class declaration or class instance.
+-- | Syntax types which can declare/define pattern bindings.
+-- For example: declarations at the top-level or in let/where clauses.
 --
--- Use 'typeSig' or 'typeSigs' to declare that functions or values have
--- types, and use 'funBind', 'funBinds' or 'patBind' to give them definitions.
-class HasValBind t where
-    sigB :: Sig' -> t
-    bindB :: HsBind' -> t
+-- Note: this class is more restrictive than 'HasValBind' since pattern
+-- bindings cannot be used in class or instance declarations.
+class HasValBind t => HasPatBind t where
 
-instance HasValBind RawValBind where
-    sigB = SigV
-    bindB = BindV
-
-instance HasValBind HsDecl' where
-    sigB = noExt SigD
-    bindB = noExt ValD
+instance HasPatBind RawValBind where
+instance HasPatBind HsDecl' where

src/GHC/SourceGen/Binds/Internal.hs

@@ -10,6 +10,7 @@ module GHC.SourceGen.Binds.Internal where
 import BasicTypes (Origin(Generated))
 import Bag (listToBag)
 import HsBinds
+import HsDecls
 import HsExpr (MatchGroup(..), Match(..), GRHSs(..))
 import SrcLoc (Located)
 
@@ -104,3 +105,25 @@ mkGRHSs g = noExt GRHSs
 -- > | otherwise = ()
 type GuardedExpr = GRHS' (Located HsExpr')
 
+-- | Syntax types which can declare/define functions.  For example:
+-- declarations, or the body of a class declaration or class instance.
+--
+-- To declare the type of a function or value, use
+-- 'GHC.SourceGen.Binds.typeSig' or 'GHC.SourceGen.Binds.typeSigs'.
+--
+-- To define a function, use 
+-- 'GHC.SourceGen.Binds.funBind' or 'GHC.SourceGen.Binds.funBinds'.
+--
+-- To define a value, use
+-- 'GHC.SourceGen.Binds.valBind' or 'GHC.SourceGen.Binds.valBindRhs'.
+class HasValBind t where
+    sigB :: Sig' -> t
+    bindB :: HsBind' -> t
+
+instance HasValBind HsDecl' where
+    sigB = noExt SigD
+    bindB = noExt ValD
+
+instance HasValBind RawValBind where
+    sigB = SigV
+    bindB = BindV

src/GHC/SourceGen/Decl.hs

@@ -67,7 +67,7 @@ import HsExtension (NoExt(NoExt))
 import PlaceHolder (PlaceHolder(..))
 #endif
 
-import GHC.SourceGen.Binds hiding (patBind)
+import GHC.SourceGen.Binds.Internal
 import GHC.SourceGen.Lit.Internal (noSourceText)
 import GHC.SourceGen.Name
 import GHC.SourceGen.Name.Internal

src/GHC/SourceGen/Syntax/Internal.hs

@@ -169,6 +169,7 @@ type HsExpr' = HsExpr RdrName
 -- Instances:
 --
 -- * 'GHC.SourceGen.Binds.HasValBind'
+-- * 'GHC.SourceGen.Binds.HasPatBind'
 #if MIN_VERSION_ghc(8,4,0)
 type HsDecl' = HsDecl GhcPs
 #else

tests/pprint_test.hs

@@ -174,6 +174,16 @@ declsTest dflags = testGroup "Decls"
                         unit
                     ]
         ]
+    , test "valBind"
+        [ "x = y" :~ valBind "x" $ rhs $ var "y"
+        , "x = y" :~ valBindRhs "x" $ var "y"
+        , "x | test = 1\n  | otherwise = 2" :~
+            valBind "x"
+            $ guardedRhs
+                [ var "test" `guard` int 1
+                , var "otherwise" `guard` int 2
+                ]
+        ]
     , test "funBind"
         [ "not True = False\nnot False = True" :~
              funBinds "not"