Add genQuotedDecs option, generate fixity decs for infix names if False

This patch:

* Introduces a `genQuotedDecs :: Bool` option that controls whether
  the `q [Dec]` arguments in the `promote` and `singletons` functions
  should be generated as part of their output.
* Refactor `promote{Only}` and `singletons{Only}` to use
  `genQuotedDecs`.
* Changes `D.S.Promote.promoteInfixDecl` so that it _does_ promote
  fixity declarations for infix names when `genQuotedDecs` is
  `False`. (See the updated
  `Note [singletons and fixity declarations]` in `D.S.Single.Fixity`,
  wrinkle 1, for a more detailed explanation.) This fixes #326 in a
  much more robust way than the previous hacky workaround in commit
  40c736f.

CHANGES.md

@@ -8,10 +8,10 @@ Changelog for singletons project
   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.
+    * `Options`' record selectors. Currently, these include options to toggle
+      generating quoted declarations, 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
@@ -45,6 +45,8 @@ Changelog for singletons project
     for type synonym or type family names.
   * A bug that caused fixity declarations for certain defunctionalization
     symbols not to be generated has been fixed.
+  * `promoteOnly` and `singletonsOnly` will now produce fixity declarations
+    for values with infix names.
 
 2.6
 ---

src/Data/Singletons/Prelude/Base.hs

@@ -108,9 +108,3 @@ $(singletonsOnly [d|
   seq _ x = x
   infixr 0 `seq`
  |])
-
--- Workaround for #326
-infixr 5 ++
-infixr 9 .
-infixr 0 $
-infixr 0 $!

src/Data/Singletons/Prelude/Function.hs

@@ -114,6 +114,3 @@ $(singletonsOnly [d|
   x & f = f x
   infixl 1 &
   |])
-
--- Workaround for #326
-infixl 1 &

src/Data/Singletons/Prelude/Functor.hs

@@ -200,8 +200,3 @@ $(singletonsOnly [d|
   deriving instance Functor ((,) a)
   deriving instance Functor Down
   |])
-
--- Workaround for #326
-infixl 4 <$>
-infixl 4 $>
-infixl 1 <&>

src/Data/Singletons/Prelude/List/Internal.hs

@@ -588,10 +588,6 @@ $(singletonsOnly [d|
 
   |])
 
--- Workaround for #326
-infix 5 \\      -- This comment is necessary so CPP doesn't treat the
-infixl 9 !!
-
 -- The following functions are supported for promotion only.
 $(promoteOnly [d|
 

src/Data/Singletons/Prelude/Monad.hs

@@ -292,7 +292,3 @@ $(singletonsOnly [d|
   instance Monad Down where
     Down a >>= k = k a
   |])
-
--- Workaround for #326
-infixr 1 <=<, >=>
-infixl 4 <$!>

src/Data/Singletons/Prelude/Monad/Internal.hs

@@ -425,13 +425,6 @@ $(singletonsOnly [d|
      mplus = (<|>)
   |])
 
--- Workaround for #326
-infixl 4 <$
-infixl 4 <*>, <*, *>, <**>
-infixl 1 >>, >>=
-infixr 1 =<<
-infixl 3 <|>
-
 $(singletonsOnly [d|
   -------------------------------------------------------------------------------
   -- Instances

src/Data/Singletons/Prelude/Num.hs

@@ -73,6 +73,9 @@ $(singletonsOnly [d|
 
       negate x            = 0 - x
 
+  subtract :: Num a => a -> a -> a
+  subtract x y = y - x
+
   -- deriving newtype instance Num a => Num (Down a)
   instance Num a => Num (Down a) where
       Down a + Down b = Down (a + b)
@@ -84,11 +87,6 @@ $(singletonsOnly [d|
       fromInteger n   = Down (fromInteger n)
   |])
 
--- Workaround for #326
-infixl 6 +
-infixl 6 -
-infixl 7 *
-
 -- PNum instance
 type family SignumNat (a :: Nat) :: Nat where
   SignumNat 0 = 0
@@ -139,8 +137,3 @@ instance SNum Nat where
       Disproved _ -> unsafeCoerce (sing :: Sing 1)
 
   sFromInteger x = x
-
-$(singletonsOnly [d|
-  subtract :: Num a => a -> a -> a
-  subtract x y = y - x
-  |])

src/Data/Singletons/Prelude/Ord.hs

@@ -88,12 +88,6 @@ $(singletonsOnly [d|
   comparing p x y = compare (p x) (p y)
   |])
 
--- Workaround for #326
-infix 4 <=
-infix 4 <
-infix 4 >
-infix 4 >=
-
 $(genSingletons [''Down])
 
 $(singletonsOnly [d|

src/Data/Singletons/Prelude/Semigroup/Internal.hs

@@ -147,9 +147,6 @@ $(singletonsOnly [d|
     Down a <> Down b = Down (a <> b)
   |])
 
--- Workaround for #326
-infixr 6 <>
-
 $(genSingletons       $ ''Option : semigroupBasicTypes)
 $(singBoundedInstances             semigroupBasicTypes)
 $(singEqInstances     $ ''Option : semigroupBasicTypes)

src/Data/Singletons/Promote.hs

@@ -43,33 +43,64 @@ import qualified Data.Map.Strict as Map
 import Data.Map.Strict ( Map )
 import qualified GHC.LanguageExtensions.Type as LangExt
 
+{-
+Note [Disable genQuotedDecs in genPromotions and genSingletons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Somewhat curiously, the genPromotions and genSingletons functions set the
+genQuotedDecs option to False, despite neither function accepting quoted
+declarations as arguments in the first place. There is a good reason for doing
+this, however. Imagine this code:
+
+  class C a where
+    infixl 9 <%%>
+    (<%%>) :: a -> a -> a
+  $(genPromotions [''C])
+
+If genQuotedDecs is set to True, then the (<%%>) type family will not receive
+a fixity declaration (see
+Note [singletons and fixity declarations] in D.S.Single.Fixity, wrinkle 1 for
+more details on this point). Therefore, we set genQuotedDecs to False to avoid
+this problem.
+-}
+
 -- | Generate promoted definitions from a type that is already defined.
 -- This is generally only useful with classes.
 genPromotions :: OptionsMonad q => [Name] -> q [Dec]
 genPromotions names = do
-  checkForRep names
-  infos <- mapM reifyWithLocals names
-  dinfos <- mapM dsInfo infos
-  ddecs <- promoteM_ [] $ mapM_ promoteInfo dinfos
-  return $ decsToTH ddecs
+  opts <- getOptions
+  -- See Note [Disable genQuotedDecs in genPromotions and genSingletons]
+  withOptions opts{genQuotedDecs = False} $ do
+    checkForRep names
+    infos <- mapM reifyWithLocals names
+    dinfos <- mapM dsInfo infos
+    ddecs <- promoteM_ [] $ mapM_ promoteInfo dinfos
+    return $ decsToTH ddecs
 
 -- | Promote every declaration given to the type level, retaining the originals.
 promote :: OptionsMonad q => q [Dec] -> q [Dec]
-promote qdec = do
-  decls <- qdec
-  ddecls <- withLocalDeclarations decls $ dsDecs decls
-  promDecls <- promoteM_ decls $ promoteDecs ddecls
-  return $ decls ++ decsToTH promDecls
+promote qdecs = do
+  opts <- getOptions
+  withOptions opts{genQuotedDecs = True} $ promote' $ lift qdecs
 
 -- | Promote each declaration, discarding the originals. Note that a promoted
 -- datatype uses the same definition as an original datatype, so this will
 -- not work with datatypes. Classes, instances, and functions are all fine.
 promoteOnly :: OptionsMonad q => q [Dec] -> q [Dec]
-promoteOnly qdec = do
-  decls  <- qdec
-  ddecls <- dsDecs decls
-  promDecls <- promoteM_ decls $ promoteDecs ddecls
-  return $ decsToTH promDecls
+promoteOnly qdecs = do
+  opts <- getOptions
+  withOptions opts{genQuotedDecs = False} $ promote' $ lift qdecs
+
+-- The workhorse for 'promote' and 'promoteOnly'. The difference between the
+-- two functions is whether 'genQuotedDecs' is set to 'True' or 'False'.
+promote' :: OptionsMonad q => q [Dec] -> q [Dec]
+promote' qdecs = do
+  opts     <- getOptions
+  decs     <- qdecs
+  ddecs    <- withLocalDeclarations decs $ dsDecs decs
+  promDecs <- promoteM_ decs $ promoteDecs ddecs
+  let origDecs | genQuotedDecs opts = decs
+               | otherwise          = []
+  return $ origDecs ++ decsToTH promDecs
 
 -- | Generate defunctionalization symbols for existing type families.
 --
@@ -603,10 +634,9 @@ promoteInfixDecl mb_let_uniq name fixity = do
   opts  <- getOptions
   mb_ns <- reifyNameSpace name
   case mb_ns of
-    -- If we can't find the Name for some odd reason,
-    -- fall back to promote_infix_val
-    Nothing        -> promote_infix_val
-    Just VarName   -> promote_infix_val
+    -- If we can't find the Name for some odd reason, fall back to promote_val
+    Nothing        -> promote_val
+    Just VarName   -> promote_val
     Just DataName  -> never_mind
     Just TcClsName -> do
       mb_info <- dsReify name
@@ -622,18 +652,21 @@ promoteInfixDecl mb_let_uniq name fixity = do
     -- Don't produce a fixity declaration at all. This happens when promoting a
     -- fixity declaration for a name whose promoted counterpart is the same as
     -- the original name.
-    -- See [singletons and fixity declarations] in D.S.Single.Fixity, wrinkle 1.
+    -- See Note [singletons and fixity declarations] in D.S.Single.Fixity, wrinkle 1.
     never_mind :: q (Maybe DDec)
     never_mind = pure Nothing
 
-    -- Certain function names do not change when promoted (e.g., infix names),
-    -- so don't bother with them.
-    promote_infix_val :: q (Maybe DDec)
-    promote_infix_val = do
+    -- Certain value names do not change when promoted (e.g., infix names).
+    -- Therefore, don't bother promoting their fixity declarations if
+    -- 'genQuotedDecs' is set to 'True', since that will run the risk of
+    -- generating duplicate fixity declarations.
+    -- See Note [singletons and fixity declarations] in D.S.Single.Fixity, wrinkle 1.
+    promote_val :: q (Maybe DDec)
+    promote_val = do
       opts <- getOptions
       let promoted_name :: Name
           promoted_name = promotedValueName opts name mb_let_uniq
-      if nameBase name == nameBase promoted_name
+      if nameBase name == nameBase promoted_name && genQuotedDecs opts
          then never_mind
          else finish promoted_name
 

src/Data/Singletons/Single.hs

@@ -43,6 +43,7 @@ import Data.Map.Strict ( Map )
 import Data.Maybe
 import qualified Data.Set as Set
 import Control.Monad
+import Control.Monad.Trans.Class
 import Data.List
 import qualified GHC.LanguageExtensions.Type as LangExt
 
@@ -88,27 +89,43 @@ contract constructors. This is the point of buildDataLets.
 -- to generate singletons for Prelude types.
 genSingletons :: OptionsMonad q => [Name] -> q [Dec]
 genSingletons names = do
-  checkForRep names
-  ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithLocals) names
-  return $ decsToTH ddecs
+  opts <- getOptions
+  -- See Note [Disable genQuotedDecs in genPromotions and genSingletons]
+  -- in D.S.Promote
+  withOptions opts{genQuotedDecs = False} $ do
+    checkForRep names
+    ddecs <- concatMapM (singInfo <=< dsInfo <=< reifyWithLocals) names
+    return $ decsToTH ddecs
 
 -- | Make promoted and singleton versions of all declarations given, retaining
 -- the original declarations.
 -- See <https://github.com/goldfirere/singletons/blob/master/README.md> for
 -- further explanation.
 singletons :: OptionsMonad q => q [Dec] -> q [Dec]
 singletons qdecs = do
-  decs <- qdecs
-  ddecs <- withLocalDeclarations decs $ dsDecs decs
-  singDecs <- singTopLevelDecs decs ddecs
-  return (decs ++ decsToTH singDecs)
+  opts <- getOptions
+  withOptions opts{genQuotedDecs = True} $ singletons' $ lift qdecs
 
 -- | Make promoted and singleton versions of all declarations given, discarding
 -- the original declarations. Note that a singleton based on a datatype needs
 -- the original datatype, so this will fail if it sees any datatype declarations.
 -- Classes, instances, and functions are all fine.
 singletonsOnly :: OptionsMonad q => q [Dec] -> q [Dec]
-singletonsOnly = (>>= wrapDesugar singTopLevelDecs)
+singletonsOnly qdecs = do
+  opts <- getOptions
+  withOptions opts{genQuotedDecs = False} $ singletons' $ lift qdecs
+
+-- The workhorse for 'singletons' and 'singletonsOnly'. The difference between
+-- the two functions is whether 'genQuotedDecs' is set to 'True' or 'False'.
+singletons' :: OptionsMonad q => q [Dec] -> q [Dec]
+singletons' qdecs = do
+  opts     <- getOptions
+  decs     <- qdecs
+  ddecs    <- withLocalDeclarations decs $ dsDecs decs
+  singDecs <- singTopLevelDecs decs ddecs
+  let origDecs | genQuotedDecs opts = decs
+               | otherwise          = []
+  return $ origDecs ++ decsToTH singDecs
 
 -- | Create instances of 'SEq' and type-level @(==)@ for each type in the list
 singEqInstances :: OptionsMonad q => [Name] -> q [Dec]

src/Data/Singletons/Single/Fixity.hs

@@ -80,12 +80,47 @@ Rules are meant to be broken, and the general rule above is no exception. There
 are certain cases where singletons does *not* produce promoted or singled
 versions of fixity declarations:
 
-* During promotion, fixity declarations for data types, type synonyms,
-  type families, data constructors, and infix functions will not receive a
-  promoted counterpart. This is because the promoted versions of these names
-  are the same as the originals, so generating an extra fixity declaration for
-  them would run the risk of having duplicates, which GHC would reject with an
-  error. (See #326 for the drawback to this approach.)
+* During promotion, fixity declarations for the following sorts of names will
+  not receive promoted counterparts:
+
+  - Data types
+  - Type synonyms
+  - Type families
+  - Data constructors
+  - Infix values
+
+  We exclude the first four because the promoted versions of these names are
+  the same as the originals, so generating an extra fixity declaration for them
+  would run the risk of having duplicates, which GHC would reject with an error.
+
+  We exclude infix value because while their promoted versions are different,
+  they share the same name base. In concrete terms, this:
+
+    $(promote [d|
+      infixl 4 ###
+      (###) :: a -> a -> a
+      |])
+
+  Is promoted to the following:
+
+    type family (###) (x :: a) (y :: a) :: a where ...
+
+  So giving the type-level (###) a fixity declaration would clash with the
+  existing one for the value-level (###).
+
+  There *is* a scenario where we should generate a fixity declaration for the
+  type-level (###), however. Imagine the above example used the `promoteOnly`
+  function instead of `promote`. Then the type-level (###) would lack a fixity
+  declaration altogether because the original fixity declaration was discarded
+  by `promoteOnly`! The same problem would arise if one had to choose between
+  the `singletons` and `singletonsOnly` functions.
+
+  The difference between `promote` and `promoteOnly` (as well as `singletons`
+  and `singletonsOnly`) is whether the `genQuotedDecs` option is set to `True`
+  or `False`, respectively. Therefore, if `genQuotedDecs` is set to `False`
+  when promoting the fixity declaration for an infix value, we opt to generate
+  a fixity declaration (with the same name base) so that the type-level version
+  of that value gets one.
 
 * During singling, the following things will not have their fixity declarations
   singled: