Introduce Options and OptionsMonad

CHANGES.md

@@ -1,9 +1,28 @@
 Changelog for singletons project
 ================================
 
-next
-----
+2.7
+---
 * Require GHC 8.10.
+* The Template Haskell machinery now supports fine-grained configuration in
+  the way of an `Options` data type, which lives in the new
+  `Data.Singletons.TH.Options` module. Besides `Options`, this module also
+  contains:
+    * `Options`' record selectors. Currently, these include ways to toggle
+      generating `SingKind` instances and configure how `singletons` generates
+      the names of promoted or singled types. In the future, there may be
+      additional options.
+    * A `defaultOptions` value.
+    * An `mtl`-like `OptionsMonad` class for monads that support carrying
+      `Option`s. This includes `Q`, which uses `defaultOptions` if it is the
+      top of the monad transformer stack.
+    * An `OptionM` monad transformer that turns any `DsMonad` into an
+      `OptionsMonad`.
+    * A `withOptions` function which allows passing `Options` to TH functions
+      (e.g., `promote` or `singletons`). See the `README` for a full example
+      of how to use `withOptions`.
+  Most TH functions are now polymorphic over `OptionsMonad` instead of
+  `DsMonad`.
 * `singletons` now does a much better job of preserving the order of type
   variables when singling the type signatures of top-level functions and data
   constructors. See the `Support for TypeApplications` section of the `README`

Makefile

@@ -1,4 +1,4 @@
-version=2.6
+version=2.7
 source=src/Data/Singletons.hs src/Data/Singletons/*.hs src/Data/Singletons/Prelude/* src/Data/Singletons/Promote/* src/Data/Singletons/Single/* src/Data/Promotion/* src/Data/Promotion/Prelude/*
 test-suite=tests/SingletonsTestSuite.hs tests/SingletonsTestSuiteUtils.hs
 test-byhand=tests/ByHand.hs tests/ByHandAux.hs

README.md

@@ -1,4 +1,4 @@
-singletons 2.6
+singletons 2.7
 ==============
 
 [![Hackage](https://img.shields.io/hackage/v/singletons.svg)](http://hackage.haskell.org/package/singletons)
@@ -545,6 +545,23 @@ treatment):
 
    All functions that begin with leading underscores are treated similarly.
 
+If desired, you can pick your own naming conventions by using the
+`Data.Singletons.TH.Options` module. Here is an example of how this module can
+be used to prefix a singled data constructor with `MyS` instead of `S`:
+
+```hs
+import Control.Monad.Trans.Class
+import Data.Singletons.TH
+import Data.Singletons.TH.Options
+import Language.Haskell.TH (Name, mkName, nameBase)
+
+$(let myPrefix :: Name -> Name
+      myPrefix name = mkName ("MyS" ++ nameBase name) in
+
+      withOptions defaultOptions{singledDataConName = myPrefix} $
+      singletons $ lift [d| data T = MkT |])
+```
+
 Supported Haskell constructs
 ----------------------------
 
@@ -780,3 +797,9 @@ Known bugs
     method :: [a]
     method = []
   ```
+* Singling GADTs is likely to fail due to the generated `SingKind` instances
+  not typechecking. (See
+  [#150](https://github.com/goldfirere/singletons/issues/150)).
+  However, one can often work around the issue by suppressing the generation
+  of `SingKind` instances by using custom `Options`. See the `T150` test case
+  for an example.

singletons.cabal

@@ -1,5 +1,5 @@
 name:           singletons
-version:        2.6
+version:        2.7
                 -- Remember to bump version in the Makefile as well
 cabal-version:  >= 1.10
 synopsis:       A framework for generating singleton types
@@ -38,7 +38,7 @@ description:
 source-repository this
   type:     git
   location: https://github.com/goldfirere/singletons.git
-  tag:      v2.6
+  tag:      v2.7
 
 source-repository head
   type:     git
@@ -73,6 +73,7 @@ library
                       Data.Singletons.CustomStar
                       Data.Singletons.TypeRepTYPE
                       Data.Singletons.TH
+                      Data.Singletons.TH.Options
                       Data.Singletons.Prelude
                       Data.Singletons.Prelude.Applicative
                       Data.Singletons.Prelude.Base

src/Data/Singletons/CustomStar.hs

@@ -37,6 +37,7 @@ import Data.Singletons.Single
 import Data.Singletons.Syntax
 import Data.Singletons.Names
 import Data.Singletons.TH
+import Data.Singletons.TH.Options
 import Control.Monad
 import Data.Maybe
 import Language.Haskell.TH.Desugar
@@ -70,7 +71,7 @@ import Data.Singletons.Prelude.Bool
 -- @Bool@, and @Maybe@, not just promoted data constructors.
 --
 -- Please note that this function is /very/ experimental. Use at your own risk.
-singletonStar :: DsMonad q
+singletonStar :: OptionsMonad q
               => [Name]        -- ^ A list of Template Haskell @Name@s for types
               -> q [Dec]
 singletonStar names = do

src/Data/Singletons/Deriving/Show.hs

@@ -20,6 +20,7 @@ module Data.Singletons.Deriving.Show (
 import Language.Haskell.TH.Syntax hiding (showName)
 import Language.Haskell.TH.Desugar
 import Data.Singletons.Names
+import Data.Singletons.TH.Options
 import Data.Singletons.Util
 import Data.Singletons.Syntax
 import Data.Singletons.Deriving.Infer
@@ -28,7 +29,7 @@ import Data.Maybe (fromMaybe)
 import GHC.Lexeme (startsConSym, startsVarSym)
 import GHC.Show (appPrec, appPrec1)
 
-mkShowInstance :: DsMonad q => ShowMode -> DerivDesc q
+mkShowInstance :: OptionsMonad q => ShowMode -> DerivDesc q
 mkShowInstance mode mb_ctxt ty (DataDecl _ _ cons) = do
   clauses <- mk_showsPrec mode cons
   constraints <- inferConstraintsDef (fmap (mkShowSingContext mode) mb_ctxt)
@@ -41,127 +42,131 @@ mkShowInstance mode mb_ctxt ty (DataDecl _ _ cons) = do
                     , id_sigs  = mempty
                     , id_meths = [ (showsPrecName, UFunction clauses) ] }
 
-mk_showsPrec :: DsMonad q => ShowMode -> [DCon] -> q [DClause]
+mk_showsPrec :: OptionsMonad q => ShowMode -> [DCon] -> q [DClause]
 mk_showsPrec mode cons = do
     p <- newUniqueName "p" -- The precedence argument (not always used)
     if null cons
        then do v <- newUniqueName "v"
                pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])]
        else mapM (mk_showsPrec_clause mode p) cons
 
-mk_showsPrec_clause :: forall q. DsMonad q
+mk_showsPrec_clause :: forall q. OptionsMonad q
                     => ShowMode -> Name -> DCon
                     -> q DClause
 mk_showsPrec_clause mode p (DCon _ _ con_name con_fields _) = go con_fields
   where
-    con_name' :: Name
-    con_name' = case mode of
-                  ForPromotion  -> con_name
-                  ForShowSing{} -> singDataConName con_name
-
     go :: DConFields -> q DClause
-
-    -- No fields: print just the constructor name, with no parentheses
-    go (DNormalC _ []) = return $
-      DClause [DWildP, DConP con_name' []] $
-        DVarE showStringName `DAppE` dStringE (parenInfixConName con_name' "")
-
-    -- Infix constructors have special Show treatment.
-    go (DNormalC True tys@[_, _])
-        -- Although the (:) constructor is infix, its singled counterpart SCons
-        -- is not, which matters if we're deriving a ShowSing instance.
-        -- Unless we remove this special case (see #234), we will simply
-        -- shunt it along as if we were dealing with a prefix constructor.
-      | ForShowSing{} <- mode
-      , con_name == consName
-      = go (DNormalC False tys)
-
-      | otherwise
-      = do argL   <- newUniqueName "argL"
-           argR   <- newUniqueName "argR"
-           argTyL <- newUniqueName "argTyL"
-           argTyR <- newUniqueName "argTyR"
-           fi <- fromMaybe defaultFixity <$> reifyFixityWithLocals con_name'
-           let con_prec = case fi of Fixity prec _ -> prec
-               op_name  = nameBase con_name'
-               infixOpE = DAppE (DVarE showStringName) . dStringE $
-                            if isInfixDataCon op_name
-                               then " "  ++ op_name ++ " "
-                               -- Make sure to handle infix data constructors
-                               -- like (Int `Foo` Int)
-                               else " `" ++ op_name ++ "` "
-           return $ DClause [ DVarP p
-                            , DConP con_name' $
-                              zipWith (mk_Show_arg_pat mode) [argL, argR] [argTyL, argTyR]
-                            ] $
-             mk_Show_rhs_sig mode [argTyL, argTyR] $
-             (DVarE showParenName `DAppE` (DVarE gtName `DAppE` DVarE p
-                                                        `DAppE` dIntegerE con_prec))
-               `DAppE` (DVarE composeName
-                          `DAppE` showsPrecE (con_prec + 1) argL
-                          `DAppE` (DVarE composeName
-                                     `DAppE` infixOpE
-                                     `DAppE` showsPrecE (con_prec + 1) argR))
-
-    go (DNormalC _ tys) = do
-      args   <- mapM (const $ newUniqueName "arg")   tys
-      argTys <- mapM (const $ newUniqueName "argTy") tys
-      let show_args     = map (showsPrecE appPrec1) args
-          composed_args = foldr1 (\v q -> DVarE composeName
-                                           `DAppE` v
-                                           `DAppE` (DVarE composeName
-                                                     `DAppE` DVarE showSpaceName
-                                                     `DAppE` q)) show_args
-          named_args = DVarE composeName
-                         `DAppE` (DVarE showStringName
-                                   `DAppE` dStringE (parenInfixConName con_name' " "))
-                         `DAppE` composed_args
-      return $ DClause [ DVarP p
-                       , DConP con_name' $
-                         zipWith (mk_Show_arg_pat mode) args argTys
-                       ] $
-        mk_Show_rhs_sig mode argTys $
-        DVarE showParenName
-          `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
-          `DAppE` named_args
-
-    -- We show a record constructor with no fields the same way we'd show a
-    -- normal constructor with no fields.
-    go (DRecC []) = go (DNormalC False [])
-
-    go (DRecC tys) = do
-      args   <- mapM (const $ newUniqueName "arg")   tys
-      argTys <- mapM (const $ newUniqueName "argTy") tys
-      let show_args =
-            concatMap (\((arg_name, _, _), arg) ->
-                        let arg_name'    = case mode of
-                                             ForPromotion  -> arg_name
-                                             ForShowSing{} -> singValName arg_name
-                            arg_nameBase = nameBase arg_name'
-                            infix_rec    = showParen (isSym arg_nameBase)
-                                                     (showString arg_nameBase) ""
-                        in [ DVarE showStringName `DAppE` dStringE (infix_rec ++ " = ")
-                           , showsPrecE 0 arg
-                           , DVarE showCommaSpaceName
-                           ])
-                      (zip tys args)
-          brace_comma_args =   (DVarE showCharName `DAppE` dCharE mode '{')
-                             : take (length show_args - 1) show_args
-          composed_args = foldr (\x y -> DVarE composeName `DAppE` x `DAppE` y)
-                                (DVarE showCharName `DAppE` dCharE mode '}')
-                                brace_comma_args
-          named_args = DVarE composeName
-                         `DAppE` (DVarE showStringName
-                                   `DAppE` dStringE (parenInfixConName con_name' " "))
-                         `DAppE` composed_args
-      return $ DClause [ DVarP p
-                       , DConP con_name' $
-                         zipWith (mk_Show_arg_pat mode) args argTys
-                       ] $
-        mk_Show_rhs_sig mode argTys $
-        DVarE showParenName
-          `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
-          `DAppE` named_args
+    go con_fields' = do
+      opts <- getOptions
+
+      let con_name' :: Name
+          con_name' = case mode of
+                        ForPromotion  -> con_name
+                        ForShowSing{} -> singledDataConName opts con_name
+
+      case con_fields' of
+
+        -- No fields: print just the constructor name, with no parentheses
+        DNormalC _ [] -> return $
+          DClause [DWildP, DConP con_name' []] $
+            DVarE showStringName `DAppE` dStringE (parenInfixConName con_name' "")
+
+        -- Infix constructors have special Show treatment.
+        DNormalC True tys@[_, _]
+            -- Although the (:) constructor is infix, its singled counterpart SCons
+            -- is not, which matters if we're deriving a ShowSing instance.
+            -- Unless we remove this special case (see #234), we will simply
+            -- shunt it along as if we were dealing with a prefix constructor.
+          |  ForShowSing{} <- mode
+          ,  con_name == consName
+          -> go (DNormalC False tys)
+
+          |  otherwise
+          -> do argL   <- newUniqueName "argL"
+                argR   <- newUniqueName "argR"
+                argTyL <- newUniqueName "argTyL"
+                argTyR <- newUniqueName "argTyR"
+                fi <- fromMaybe defaultFixity <$> reifyFixityWithLocals con_name'
+                let con_prec = case fi of Fixity prec _ -> prec
+                    op_name  = nameBase con_name'
+                    infixOpE = DAppE (DVarE showStringName) . dStringE $
+                                 if isInfixDataCon op_name
+                                    then " "  ++ op_name ++ " "
+                                    -- Make sure to handle infix data constructors
+                                    -- like (Int `Foo` Int)
+                                    else " `" ++ op_name ++ "` "
+                return $ DClause [ DVarP p
+                                 , DConP con_name' $
+                                   zipWith (mk_Show_arg_pat mode) [argL, argR] [argTyL, argTyR]
+                                 ] $
+                  mk_Show_rhs_sig mode [argTyL, argTyR] $
+                  (DVarE showParenName `DAppE` (DVarE gtName `DAppE` DVarE p
+                                                             `DAppE` dIntegerE con_prec))
+                    `DAppE` (DVarE composeName
+                               `DAppE` showsPrecE (con_prec + 1) argL
+                               `DAppE` (DVarE composeName
+                                          `DAppE` infixOpE
+                                          `DAppE` showsPrecE (con_prec + 1) argR))
+
+        DNormalC _ tys -> do
+          args   <- mapM (const $ newUniqueName "arg")   tys
+          argTys <- mapM (const $ newUniqueName "argTy") tys
+          let show_args     = map (showsPrecE appPrec1) args
+              composed_args = foldr1 (\v q -> DVarE composeName
+                                               `DAppE` v
+                                               `DAppE` (DVarE composeName
+                                                         `DAppE` DVarE showSpaceName
+                                                         `DAppE` q)) show_args
+              named_args = DVarE composeName
+                             `DAppE` (DVarE showStringName
+                                       `DAppE` dStringE (parenInfixConName con_name' " "))
+                             `DAppE` composed_args
+          return $ DClause [ DVarP p
+                           , DConP con_name' $
+                             zipWith (mk_Show_arg_pat mode) args argTys
+                           ] $
+            mk_Show_rhs_sig mode argTys $
+            DVarE showParenName
+              `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
+              `DAppE` named_args
+
+        -- We show a record constructor with no fields the same way we'd show a
+        -- normal constructor with no fields.
+        DRecC [] -> go (DNormalC False [])
+
+        DRecC tys -> do
+          args   <- mapM (const $ newUniqueName "arg")   tys
+          argTys <- mapM (const $ newUniqueName "argTy") tys
+          let show_args =
+                concatMap (\((arg_name, _, _), arg) ->
+                            let arg_name'    = case mode of
+                                                 ForPromotion  -> arg_name
+                                                 ForShowSing{} -> singledValueName opts arg_name
+                                arg_nameBase = nameBase arg_name'
+                                infix_rec    = showParen (isSym arg_nameBase)
+                                                         (showString arg_nameBase) ""
+                            in [ DVarE showStringName `DAppE` dStringE (infix_rec ++ " = ")
+                               , showsPrecE 0 arg
+                               , DVarE showCommaSpaceName
+                               ])
+                          (zip tys args)
+              brace_comma_args =   (DVarE showCharName `DAppE` dCharE mode '{')
+                                 : take (length show_args - 1) show_args
+              composed_args = foldr (\x y -> DVarE composeName `DAppE` x `DAppE` y)
+                                    (DVarE showCharName `DAppE` dCharE mode '}')
+                                    brace_comma_args
+              named_args = DVarE composeName
+                             `DAppE` (DVarE showStringName
+                                       `DAppE` dStringE (parenInfixConName con_name' " "))
+                             `DAppE` composed_args
+          return $ DClause [ DVarP p
+                           , DConP con_name' $
+                             zipWith (mk_Show_arg_pat mode) args argTys
+                           ] $
+            mk_Show_rhs_sig mode argTys $
+            DVarE showParenName
+              `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
+              `DAppE` named_args
 
 -- | Parenthesize an infix constructor name if it is being applied as a prefix
 -- function (e.g., data Amp a = (:&) a a)
@@ -218,14 +223,15 @@ mk_Show_name :: ShowMode -> Name
 mk_Show_name ForPromotion  = showName
 mk_Show_name ForShowSing{} = showSingName
 
--- If we're creating a 'Show' instance for a singleon type, decorate the type
+-- If we're creating a 'Show' instance for a singleton type, decorate the type
 -- appropriately (e.g., turn @Maybe a@ into @SMaybe (z :: Maybe a)@).
 -- Otherwise, return the type (@Maybe a@) unchanged.
-mk_Show_inst_ty :: Quasi q => ShowMode -> DType -> q DType
+mk_Show_inst_ty :: OptionsMonad q => ShowMode -> DType -> q DType
 mk_Show_inst_ty ForPromotion           ty = pure ty
 mk_Show_inst_ty (ForShowSing ty_tycon) ty = do
+  opts <- getOptions
   z <- qNewName "z"
-  pure $ DConT (singTyConName ty_tycon) `DAppT` (DVarT z `DSigT` ty)
+  pure $ DConT (singledDataTypeName opts ty_tycon) `DAppT` (DVarT z `DSigT` ty)
 
 -- If we're creating a 'Show' instance for a singleton type, create a pattern
 -- of the form @(sx :: Sing x)@. Otherwise, simply return the pattern @sx@.