✨ Better interface to smart constructor generation with decapitalized…

… names

grisette.cabal

@@ -153,14 +153,15 @@ library
       Grisette.Internal.SymPrim.SymInteger
       Grisette.Internal.SymPrim.SymTabularFun
       Grisette.Internal.SymPrim.TabularFun
+      Grisette.Internal.TH.Ctor.Common
+      Grisette.Internal.TH.Ctor.SmartConstructor
+      Grisette.Internal.TH.Ctor.UnifiedConstructor
       Grisette.Internal.TH.DeriveBuiltin
       Grisette.Internal.TH.DeriveInstanceProvider
       Grisette.Internal.TH.DerivePredefined
       Grisette.Internal.TH.DeriveTypeParamHandler
       Grisette.Internal.TH.DeriveUnifiedInterface
       Grisette.Internal.TH.DeriveWithHandlers
-      Grisette.Internal.TH.MergeConstructor
-      Grisette.Internal.TH.UnifiedConstructor
       Grisette.Internal.TH.Util
       Grisette.Internal.Utils.Derive
       Grisette.Internal.Utils.Parameterized

src/Grisette/Internal/TH/Ctor/Common.hs

@@ -0,0 +1,61 @@
+-- |
+-- Module      :   Grisette.Internal.TH.Ctor.Common
+-- Copyright   :   (c) Sirui Lu 2024
+-- License     :   BSD-3-Clause (see the LICENSE file)
+--
+-- Maintainer  :   siruilu@cs.washington.edu
+-- Stability   :   Experimental
+-- Portability :   GHC only
+module Grisette.Internal.TH.Ctor.Common
+  ( withNameTransformer,
+    prefixTransformer,
+    decapitalizeTransformer,
+  )
+where
+
+import Control.Monad (unless)
+import Data.Char (isAlphaNum, toLower)
+import Data.Foldable (traverse_)
+import Grisette.Internal.TH.Util (occName)
+import Language.Haskell.TH (Dec, Name, Q)
+import Language.Haskell.TH.Datatype
+  ( ConstructorInfo (constructorName),
+    DatatypeInfo (datatypeCons),
+    reifyDatatype,
+  )
+
+checkName :: String -> Q ()
+checkName name =
+  unless (all (\x -> isAlphaNum x || x == '\'' || x == '_') name) $
+    fail
+      ( "Constructor name contain invalid characters, consider providing a "
+          ++ "custom name: "
+          ++ show name
+      )
+
+-- | Generate smart constructor given a type name, using a name transformer
+-- to transform constructor names.
+withNameTransformer ::
+  -- | A function that generates decs given a list of constructor names and a
+  -- type name
+  ([String] -> Name -> Q [Dec]) ->
+  -- | A function that transforms constructor names
+  (String -> String) ->
+  -- | The type to generate the wrappers for
+  Name ->
+  Q [Dec]
+withNameTransformer namedGen nameTransformer typName = do
+  d <- reifyDatatype typName
+  let constructorNames = occName . constructorName <$> datatypeCons d
+  let transformedNames = nameTransformer <$> constructorNames
+  traverse_ checkName transformedNames
+  namedGen transformedNames typName
+
+-- | A name transformer that prefixes a string to the constructor name
+prefixTransformer :: String -> String -> String
+prefixTransformer = (++)
+
+-- | A name transformer that converts the first character to lowercase
+decapitalizeTransformer :: String -> String
+decapitalizeTransformer (x : xs) = toLower x : xs
+decapitalizeTransformer [] = []

src/Grisette/Internal/TH/MergeConstructor.hs → src/Grisette/Internal/TH/Ctor/SmartConstructor.hs

@@ -3,24 +3,31 @@
 {-# LANGUAGE Trustworthy #-}
 
 -- |
--- Module      :   Grisette.Internal.TH.MergedConstructor
+-- Module      :   Grisette.Internal.TH.Ctor.SmartConstructor
 -- Copyright   :   (c) Sirui Lu 2021-2024
 -- License     :   BSD-3-Clause (see the LICENSE file)
 --
 -- Maintainer  :   siruilu@cs.washington.edu
 -- Stability   :   Experimental
 -- Portability :   GHC only
-module Grisette.Internal.TH.MergeConstructor
-  ( mkMergeConstructor,
-    mkMergeConstructor',
+module Grisette.Internal.TH.Ctor.SmartConstructor
+  ( makeSmartCtorWith,
+    makePrefixedSmartCtor,
+    makeNamedSmartCtor,
+    makeSmartCtor,
   )
 where
 
 import Control.Monad (join, replicateM, when, zipWithM)
 import Data.Bifunctor (Bifunctor (second))
 import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable)
-import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge)
-import Grisette.Internal.TH.Util (constructorInfoToType, occName, putHaddock)
+import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, mrgSingle)
+import Grisette.Internal.TH.Ctor.Common
+  ( decapitalizeTransformer,
+    prefixTransformer,
+    withNameTransformer,
+  )
+import Grisette.Internal.TH.Util (constructorInfoToType, putHaddock)
 import Language.Haskell.TH
   ( Body (NormalB),
     Clause (Clause),
@@ -49,49 +56,75 @@ import Language.Haskell.TH.Datatype.TyVarBndr
   )
 
 -- | Generate constructor wrappers that wraps the result in a container with
--- `TryMerge` with provided names.
+-- `TryMerge` with provided name transformer.
 --
--- > mkMergeConstructor' ["mrgTuple2"] ''(,)
+-- > makeSmartCtorWith (\name -> "mrg" ++ name) ''Maybe
 --
 -- generates
 --
--- > mrgTuple2 :: (Mergeable (a, b), Applicative m, TryMerge m) => a -> b -> u (a, b)
--- > mrgTuple2 = \v1 v2 -> mrgSingle (v1, v2)
-mkMergeConstructor' ::
-  -- | Names for generated wrappers
-  [String] ->
-  -- | The type to generate the wrappers for
-  Name ->
-  Q [Dec]
-mkMergeConstructor' names typName = do
-  d <- reifyDatatype typName
-  let constructors = datatypeCons d
-  when (length names /= length constructors) $
-    fail "Number of names does not match the number of constructors"
-  ds <- zipWithM (mkSingleWrapper d) names constructors
-  return $ join ds
+-- > mrgNothing :: (Mergeable (Maybe a), Applicative m, TryMerge m) => m (Maybe a)
+-- > mrgNothing = mrgSingle Nothing
+makeSmartCtorWith :: (String -> String) -> Name -> Q [Dec]
+makeSmartCtorWith = withNameTransformer makeNamedSmartCtor
 
 -- | Generate constructor wrappers that wraps the result in a container with
 -- `TryMerge`.
 --
--- > mkMergeConstructor "mrg" ''Maybe
+-- > makePrefixedSmartCtor "mrg" ''Maybe
 --
 -- generates
 --
--- > mrgJust :: (Mergeable (Maybe a), Applicative m, TryMerge m) => m (Maybe a)
+-- > mrgNothing :: (Mergeable (Maybe a), Applicative m, TryMerge m) => m (Maybe a)
 -- > mrgNothing = mrgSingle Nothing
 -- > mrgJust :: (Mergeable (Maybe a), Applicative m, TryMerge m) => a -> m (Maybe a)
 -- > mrgJust = \x -> mrgSingle (Just x)
-mkMergeConstructor ::
+makePrefixedSmartCtor ::
   -- | Prefix for generated wrappers
   String ->
   -- | The type to generate the wrappers for
   Name ->
   Q [Dec]
-mkMergeConstructor prefix typName = do
+makePrefixedSmartCtor = makeSmartCtorWith . prefixTransformer
+
+-- | Generate constructor wrappers that wraps the result in a container with
+-- `TryMerge`.
+--
+-- > makeSmartCtor ''Maybe
+--
+-- generates
+--
+-- > nothing :: (Mergeable (Maybe a), Applicative m, TryMerge m) => m (Maybe a)
+-- > nothing = mrgSingle Nothing
+-- > just :: (Mergeable (Maybe a), Applicative m, TryMerge m) => a -> m (Maybe a)
+-- > just = \x -> mrgSingle (Just x)
+makeSmartCtor ::
+  -- | The type to generate the wrappers for
+  Name ->
+  Q [Dec]
+makeSmartCtor = makeSmartCtorWith decapitalizeTransformer
+
+-- | Generate constructor wrappers that wraps the result in a container with
+-- `TryMerge` with provided names.
+--
+-- > makeNamedSmartCtor ["mrgTuple2"] ''(,)
+--
+-- generates
+--
+-- > mrgTuple2 :: (Mergeable (a, b), Applicative m, TryMerge m) => a -> b -> u (a, b)
+-- > mrgTuple2 = \v1 v2 -> mrgSingle (v1, v2)
+makeNamedSmartCtor ::
+  -- | Names for generated wrappers
+  [String] ->
+  -- | The type to generate the wrappers for
+  Name ->
+  Q [Dec]
+makeNamedSmartCtor names typName = do
   d <- reifyDatatype typName
-  let constructorNames = occName . constructorName <$> datatypeCons d
-  mkMergeConstructor' ((prefix ++) <$> constructorNames) typName
+  let constructors = datatypeCons d
+  when (length names /= length constructors) $
+    fail "Number of names does not match the number of constructors"
+  ds <- zipWithM (mkSingleWrapper d) names constructors
+  return $ join ds
 
 augmentNormalCExpr :: Int -> Exp -> Q Exp
 augmentNormalCExpr n f = do

src/Grisette/Internal/TH/UnifiedConstructor.hs → src/Grisette/Internal/TH/Ctor/UnifiedConstructor.hs

@@ -1,21 +1,28 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 -- |
--- Module      :   Grisette.Internal.TH.UnifiedConstructor
+-- Module      :   Grisette.Internal.TH.Ctor.UnifiedConstructor
 -- Copyright   :   (c) Sirui Lu 2024
 -- License     :   BSD-3-Clause (see the LICENSE file)
 --
 -- Maintainer  :   siruilu@cs.washington.edu
 -- Stability   :   Experimental
 -- Portability :   GHC only
-module Grisette.Internal.TH.UnifiedConstructor
-  ( mkUnifiedConstructor,
-    mkUnifiedConstructor',
+module Grisette.Internal.TH.Ctor.UnifiedConstructor
+  ( makeUnifiedCtorWith,
+    makePrefixedUnifiedCtor,
+    makeNamedUnifiedCtor,
+    makeUnifiedCtor,
   )
 where
 
 import Control.Monad (join, replicateM, when, zipWithM)
-import Grisette.Internal.TH.Util (constructorInfoToType, occName, putHaddock)
+import Grisette.Internal.TH.Ctor.Common
+  ( decapitalizeTransformer,
+    prefixTransformer,
+    withNameTransformer,
+  )
+import Grisette.Internal.TH.Util (constructorInfoToType, putHaddock)
 import Grisette.Unified.Internal.EvalModeTag (EvalModeTag)
 import Grisette.Unified.Internal.UnifiedData
   ( GetData,
@@ -45,6 +52,19 @@ import Language.Haskell.TH.Syntax
     newName,
   )
 
+-- | Generate smart constructors to create unified values with provided name
+-- transformer.
+--
+-- For a type @T mode a b c@ with constructors @T1@, @T2@, etc., this function
+-- will generate smart constructors with the name transformed, e.g., given the
+-- name transformer @(\name -> "mk" ++ name)@, it will generate @mkT1@, @mkT2@,
+-- @mkT2@, etc.
+--
+-- The generated smart constructors will contruct values of type
+-- @GetData mode (T mode a b c)@.
+makeUnifiedCtorWith :: (String -> String) -> Name -> Q [Dec]
+makeUnifiedCtorWith = withNameTransformer makeNamedUnifiedCtor
+
 -- | Generate smart constructors to create unified values.
 --
 -- For a type @T mode a b c@ with constructors @T1@, @T2@, etc., this function
@@ -53,16 +73,27 @@ import Language.Haskell.TH.Syntax
 --
 -- The generated smart constructors will contruct values of type
 -- @GetData mode (T mode a b c)@.
-mkUnifiedConstructor ::
+makePrefixedUnifiedCtor ::
   -- | Prefix for generated wrappers
   String ->
   -- | The type to generate the wrappers for
   Name ->
   Q [Dec]
-mkUnifiedConstructor prefix typName = do
-  d <- reifyDatatype typName
-  let constructorNames = occName . constructorName <$> datatypeCons d
-  mkUnifiedConstructor' ((prefix ++) <$> constructorNames) typName
+makePrefixedUnifiedCtor = makeUnifiedCtorWith . prefixTransformer
+
+-- | Generate smart constructors to create unified values.
+--
+-- For a type @T mode a b c@ with constructors @T1@, @T2@, etc., this function
+-- will generate smart constructors with the names decapitalized, e.g.,
+-- @t1@, @t2@, etc.
+--
+-- The generated smart constructors will contruct values of type
+-- @GetData mode (T mode a b c)@.
+makeUnifiedCtor ::
+  -- | The type to generate the wrappers for
+  Name ->
+  Q [Dec]
+makeUnifiedCtor = makeUnifiedCtorWith decapitalizeTransformer
 
 -- | Generate smart constructors to create unified values.
 --
@@ -71,13 +102,13 @@ mkUnifiedConstructor prefix typName = do
 --
 -- The generated smart constructors will contruct values of type
 -- @GetData mode (T mode a b c)@.
-mkUnifiedConstructor' ::
+makeNamedUnifiedCtor ::
   -- | Names for generated wrappers
   [String] ->
   -- | The type to generate the wrappers for
   Name ->
   Q [Dec]
-mkUnifiedConstructor' names typName = do
+makeNamedUnifiedCtor names typName = do
   d <- reifyDatatype typName
   let constructors = datatypeCons d
   when (length names /= length constructors) $

src/Grisette/Lib/Data/Bool.hs

@@ -13,9 +13,8 @@
 -- Portability :   GHC only
 module Grisette.Lib.Data.Bool (mrgTrue, mrgFalse) where
 
-import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle)
-import Grisette.Internal.TH.MergeConstructor
-  ( mkMergeConstructor,
+import Grisette.Internal.TH.Ctor.SmartConstructor
+  ( makePrefixedSmartCtor,
   )
 
-mkMergeConstructor "mrg" ''Bool
+makePrefixedSmartCtor "mrg" ''Bool

src/Grisette/Lib/Data/Either.hs

@@ -13,9 +13,8 @@
 -- Portability :   GHC only
 module Grisette.Lib.Data.Either (mrgLeft, mrgRight) where
 
-import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle)
-import Grisette.Internal.TH.MergeConstructor
-  ( mkMergeConstructor,
+import Grisette.Internal.TH.Ctor.SmartConstructor
+  ( makePrefixedSmartCtor,
   )
 
-mkMergeConstructor "mrg" ''Either
+makePrefixedSmartCtor "mrg" ''Either

src/Grisette/Lib/Data/Functor/Sum.hs

@@ -14,9 +14,8 @@
 module Grisette.Lib.Data.Functor.Sum (mrgInR, mrgInL) where
 
 import Data.Functor.Sum (Sum)
-import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle)
-import Grisette.Internal.TH.MergeConstructor
-  ( mkMergeConstructor,
+import Grisette.Internal.TH.Ctor.SmartConstructor
+  ( makePrefixedSmartCtor,
   )
 
-mkMergeConstructor "mrg" ''Sum
+makePrefixedSmartCtor "mrg" ''Sum

src/Grisette/Lib/Data/Maybe.hs

@@ -13,9 +13,8 @@
 -- Portability :   GHC only
 module Grisette.Lib.Data.Maybe (mrgNothing, mrgJust) where
 
-import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle)
-import Grisette.Internal.TH.MergeConstructor
-  ( mkMergeConstructor,
+import Grisette.Internal.TH.Ctor.SmartConstructor
+  ( makePrefixedSmartCtor,
   )
 
-mkMergeConstructor "mrg" ''Maybe
+makePrefixedSmartCtor "mrg" ''Maybe

src/Grisette/Lib/Data/Tuple.hs

@@ -24,16 +24,15 @@ module Grisette.Lib.Data.Tuple
   )
 where
 
-import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle)
-import Grisette.Internal.TH.MergeConstructor
-  ( mkMergeConstructor',
+import Grisette.Internal.TH.Ctor.SmartConstructor
+  ( makeNamedSmartCtor,
   )
 
-mkMergeConstructor' ["mrgUnit"] ''()
-mkMergeConstructor' ["mrgTuple2"] ''(,)
-mkMergeConstructor' ["mrgTuple3"] ''(,,)
-mkMergeConstructor' ["mrgTuple4"] ''(,,,)
-mkMergeConstructor' ["mrgTuple5"] ''(,,,,)
-mkMergeConstructor' ["mrgTuple6"] ''(,,,,,)
-mkMergeConstructor' ["mrgTuple7"] ''(,,,,,,)
-mkMergeConstructor' ["mrgTuple8"] ''(,,,,,,,)
+makeNamedSmartCtor ["mrgUnit"] ''()
+makeNamedSmartCtor ["mrgTuple2"] ''(,)
+makeNamedSmartCtor ["mrgTuple3"] ''(,,)
+makeNamedSmartCtor ["mrgTuple4"] ''(,,,)
+makeNamedSmartCtor ["mrgTuple5"] ''(,,,,)
+makeNamedSmartCtor ["mrgTuple6"] ''(,,,,,)
+makeNamedSmartCtor ["mrgTuple7"] ''(,,,,,,)
+makeNamedSmartCtor ["mrgTuple8"] ''(,,,,,,,)