Draft: T580

singletons-th/src/Data/Singletons/TH/Options.hs

@@ -18,6 +18,8 @@ module Data.Singletons.TH.Options
     Options, defaultOptions
     -- ** Options record selectors
   , genQuotedDecs
+  , genDefunSymsAndInsts
+  , genSingIInsts
   , genSingKindInsts
   , promotedDataTypeOrConName
   , promotedClassName
@@ -56,6 +58,10 @@ data Options = Options
     -- ^ If 'True', then quoted declarations will be generated alongside their
     --   promoted and singled counterparts. If 'False', then quoted
     --   declarations will be discarded.
+  , genDefunSymsAndInsts :: Bool
+    -- ^ TODO RGS: Docs
+  , genSingIInsts :: Bool
+    -- ^ TODO RGS: Docs
   , genSingKindInsts :: Bool
     -- ^ If 'True', then 'SingKind' instances will be generated. If 'False',
     --   they will be omitted entirely. This can be useful in scenarios where
@@ -133,6 +139,8 @@ data Options = Options
 defaultOptions :: Options
 defaultOptions = Options
   { genQuotedDecs             = True
+  , genDefunSymsAndInsts      = True
+  , genSingIInsts             = True
   , genSingKindInsts          = True
   , promotedDataTypeOrConName = promoteDataTypeOrConName
   , promotedClassName         = promoteClassName

singletons-th/src/Data/Singletons/TH/Promote/Defun.hs

@@ -183,26 +183,30 @@ defunctionalize :: Name
                 -> DefunKindInfo
                 -> PrM [DDec]
 defunctionalize name m_fixity defun_ki = do
-  case defun_ki of
-    DefunSAK sak ->
-      -- Even if a declaration has a SAK, its kind may not be vanilla.
-      case unravelVanillaDType_either sak of
-        -- If the kind isn't vanilla, use the fallback approach.
-        -- See Note [Defunctionalization game plan],
-        -- Wrinkle 2: Non-vanilla kinds.
-        Left _ -> defun_fallback [] (Just sak)
-        -- Otherwise, proceed with defun_vanilla_sak.
-        Right (sak_tvbs, _sak_cxt, sak_arg_kis, sak_res_ki)
-               -> defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki
-    -- If a declaration lacks a SAK, it likely has a partial kind.
-    -- See Note [Defunctionalization game plan], Wrinkle 1: Partial kinds.
-    DefunNoSAK tvbs m_res -> defun_fallback tvbs m_res
+  opts <- getOptions
+  if genDefunSymsAndInsts opts
+    then
+      case defun_ki of
+        DefunSAK sak ->
+          -- Even if a declaration has a SAK, its kind may not be vanilla.
+          case unravelVanillaDType_either sak of
+            -- If the kind isn't vanilla, use the fallback approach.
+            -- See Note [Defunctionalization game plan],
+            -- Wrinkle 2: Non-vanilla kinds.
+            Left _ -> defun_fallback opts [] (Just sak)
+            -- Otherwise, proceed with defun_vanilla_sak.
+            Right (sak_tvbs, _sak_cxt, sak_arg_kis, sak_res_ki)
+                   -> defun_vanilla_sak opts sak_tvbs sak_arg_kis sak_res_ki
+        -- If a declaration lacks a SAK, it likely has a partial kind.
+        -- See Note [Defunctionalization game plan], Wrinkle 1: Partial kinds.
+        DefunNoSAK tvbs m_res -> defun_fallback opts tvbs m_res
+    else
+      pure []
   where
     -- Generate defunctionalization symbols for things with vanilla SAKs.
     -- The symbols themselves will also be given SAKs.
-    defun_vanilla_sak :: [DTyVarBndrSpec] -> [DKind] -> DKind -> PrM [DDec]
-    defun_vanilla_sak sak_tvbs sak_arg_kis sak_res_ki = do
-      opts <- getOptions
+    defun_vanilla_sak :: Options -> [DTyVarBndrSpec] -> [DKind] -> DKind -> PrM [DDec]
+    defun_vanilla_sak opts sak_tvbs sak_arg_kis sak_res_ki = do
       extra_name <- qNewName "arg"
       let sak_arg_n = length sak_arg_kis
       -- Use noExactName below to avoid GHC#17537.
@@ -282,9 +286,8 @@ defunctionalize name m_fixity defun_ki = do
     -- (see Note [Defunctionalization game plan], Wrinkle 1: Partial kinds)
     -- or a non-vanilla kind
     -- (see Note [Defunctionalization game plan], Wrinkle 2: Non-vanilla kinds).
-    defun_fallback :: [DTyVarBndrVis] -> Maybe DKind -> PrM [DDec]
-    defun_fallback tvbs' m_res' = do
-      opts <- getOptions
+    defun_fallback :: Options -> [DTyVarBndrVis] -> Maybe DKind -> PrM [DDec]
+    defun_fallback opts tvbs' m_res' = do
       extra_name <- qNewName "arg"
       -- Use noExactTyVars below to avoid GHC#11812.
       -- See also Note [Pitfalls of NameU/NameL] in Data.Singletons.TH.Util.

singletons-th/src/Data/Singletons/TH/Single/Data.hs

@@ -212,8 +212,9 @@ singCtor dataName (DCon con_tvbs cxt name fields rty)
         | otherwise
         = Nothing
 
-  -- SingI instance for data constructor
-  emitDecs $ mapMaybe mb_SingI_dec [0, 1, 2]
+  -- SingI instances for data constructor
+  when (genSingIInsts opts) $
+    emitDecs $ mapMaybe mb_SingI_dec [0, 1, 2]
   -- SingI instances for defunctionalization symbols. Note that we don't
   -- support contexts in constructors at the moment, so it's fine for now to
   -- just assume that the context is always ().

singletons-th/src/Data/Singletons/TH/Single/Defun.hs

@@ -66,12 +66,17 @@ singDefuns n ns ty_ctxt mb_ty_args mb_ty_res =
   case mb_ty_args of
     [] -> pure [] -- If a function has no arguments, then it has no
                   -- defunctionalization symbols, so there's nothing to be done.
-    _  -> do opts     <- getOptions
-             sty_ctxt <- mapM singPred ty_ctxt
-             names    <- replicateM (length mb_ty_args) $ qNewName "d"
-             let tvbs = zipWith inferMaybeKindTV names mb_ty_args
-             (_, insts) <- go opts 0 sty_ctxt [] tvbs
-             pure insts
+    _  -> do
+      opts     <- getOptions
+      if genDefunSymsAndInsts opts && genSingIInsts opts
+          then do
+            sty_ctxt <- mapM singPred ty_ctxt
+            names    <- replicateM (length mb_ty_args) $ qNewName "d"
+            let tvbs = zipWith inferMaybeKindTV names mb_ty_args
+            (_, insts) <- go opts 0 sty_ctxt [] tvbs
+            pure insts
+          else
+            pure []
   where
     num_ty_args :: Int
     num_ty_args = length mb_ty_args