diff --git a/singletons-th/src/Data/Singletons/TH/Options.hs b/singletons-th/src/Data/Singletons/TH/Options.hs index 7119446b..2e9d2e69 100644 --- a/singletons-th/src/Data/Singletons/TH/Options.hs +++ b/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 diff --git a/singletons-th/src/Data/Singletons/TH/Promote/Defun.hs b/singletons-th/src/Data/Singletons/TH/Promote/Defun.hs index 1ae165ab..3ed735bf 100644 --- a/singletons-th/src/Data/Singletons/TH/Promote/Defun.hs +++ b/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. diff --git a/singletons-th/src/Data/Singletons/TH/Single/Data.hs b/singletons-th/src/Data/Singletons/TH/Single/Data.hs index 21a769e7..297b0a20 100644 --- a/singletons-th/src/Data/Singletons/TH/Single/Data.hs +++ b/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 (). diff --git a/singletons-th/src/Data/Singletons/TH/Single/Defun.hs b/singletons-th/src/Data/Singletons/TH/Single/Defun.hs index fd9603d8..0f1bb260 100644 --- a/singletons-th/src/Data/Singletons/TH/Single/Defun.hs +++ b/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