{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.TH.Options
-- Copyright   :  (C) 2019 Ryan Scott
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module defines 'Options' that control finer details of how the Template
-- Haskell machinery works, as well as an @mtl@-like 'OptionsMonad' class
-- and an 'OptionsM' monad transformer.
--
----------------------------------------------------------------------------

module Data.Singletons.TH.Options
  ( -- * Options
    Options, defaultOptions
    -- ** Options record selectors
  , genQuotedDecs
  , genSingKindInsts
  , promotedDataTypeOrConName
  , promotedClassName
  , promotedValueName
  , singledDataTypeName
  , singledClassName
  , singledDataConName
  , singledValueName
  , defunctionalizedName
    -- ** Derived functions over Options
  , promotedTopLevelValueName
  , promotedLetBoundValueName
  , defunctionalizedName0

    -- * OptionsMonad
  , OptionsMonad(..), OptionsM, withOptions
  ) where

import Control.Applicative
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (ReaderT(..), ask)
import Control.Monad.RWS (RWST)
import Control.Monad.State (StateT)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Writer (WriterT)
import Data.Singletons.TH.Names
import Data.Singletons.TH.Util
import Language.Haskell.TH.Desugar
import Language.Haskell.TH.Instances () -- To obtain a Quote instance for ReaderT
import Language.Haskell.TH.Syntax hiding (Lift(..))

-- | Options that control the finer details of how @singletons-th@'s Template
-- Haskell machinery works.
data Options = Options
  { Options -> Bool
genQuotedDecs :: Bool
    -- ^ If 'True', then quoted declarations will be generated alongside their
    --   promoted and singled counterparts. If 'False', then quoted
    --   declarations will be discarded.
  , Options -> Bool
genSingKindInsts :: Bool
    -- ^ If 'True', then 'SingKind' instances will be generated. If 'False',
    --   they will be omitted entirely. This can be useful in scenarios where
    --   TH-generated 'SingKind' instances do not typecheck (for instance,
    --   when generating singletons for GADTs).
  , Options -> Name -> Name
promotedDataTypeOrConName :: Name -> Name
    -- ^ Given the name of the original data type or data constructor, produces
    --   the name of the promoted equivalent. Unlike the singling-related
    --   options, in which there are separate 'singledDataTypeName' and
    --   'singledDataConName' functions, we combine the handling of promoted
    --   data types and data constructors into a single option. This is because
    --   the names of promoted data types and data constructors can be
    --   difficult to distinguish in certain contexts without expensive
    --   compile-time checks.
    --
    --   Because of the @DataKinds@ extension, most data type and data
    --   constructor names can be used in promoted contexts without any
    --   changes. As a result, this option will act like the identity function
    --   99% of the time. There are some situations where it can be useful to
    --   override this option, however, as it can be used to promote primitive
    --   data types that do not have proper type-level equivalents, such as
    --   'Natural' and 'Text'. See the
    --   \"Arrows, 'Nat', 'Symbol', and literals\" section of the @singletons@
    --   @<https://github.com/goldfirere/singletons/blob/master/README.md README>@
    --   for more details.
  , Options -> Name -> Name
promotedClassName :: Name -> Name
    -- ^ Given the name of the original, unrefined class, produces the name of
    --   the promoted equivalent of the class.
  , Options -> Name -> Maybe Uniq -> Name
promotedValueName :: Name -> Maybe Uniq -> Name
    -- ^ Given the name of the original, unrefined value, produces the name of
    --   the promoted equivalent of the value. This is used for both top-level
    --   and @let@-bound names, and the difference is encoded in the
    --   @'Maybe' 'Uniq'@ argument. If promoting a top-level name, the argument
    --   is 'Nothing'. If promoting a @let@-bound name, the argument is
    --   @Just uniq@, where @uniq@ is a globally unique number that can be used
    --   to distinguish the name from other local definitions of the same name
    --   (e.g., if two functions both use @let x = ... in x@).
  , Options -> Name -> Name
singledDataTypeName :: Name -> Name
    -- ^ Given the name of the original, unrefined data type, produces the name
    --   of the corresponding singleton type.
  , Options -> Name -> Name
singledClassName :: Name -> Name
    -- ^ Given the name of the original, unrefined class, produces the name of
    --   the singled equivalent of the class.
  , Options -> Name -> Name
singledDataConName :: Name -> Name
    -- ^ Given the name of the original, unrefined data constructor, produces
    --   the name of the corresponding singleton data constructor.
  , Options -> Name -> Name
singledValueName :: Name -> Name
    -- ^ Given the name of the original, unrefined value, produces the name of
    --   the singled equivalent of the value.
  , Options -> Name -> Int -> Name
defunctionalizedName :: Name -> Int -> Name
    -- ^ Given the original name and the number of parameters it is applied to
    --   (the 'Int' argument), produces a type-level function name that can be
    --   partially applied when given the same number of parameters.
    --
    --   Note that defunctionalization works over both term-level names
    --   (producing symbols for the promoted name) and type-level names
    --   (producing symbols directly for the name itself). As a result, this
    --   callback is used for names in both the term and type namespaces.
  }

-- | Sensible default 'Options'.
--
-- 'genQuotedDecs' defaults to 'True'.
-- That is, quoted declarations are generated alongside their promoted and
-- singled counterparts.
--
-- 'genSingKindInsts' defaults to 'True'.
-- That is, 'SingKind' instances are generated.
--
-- The default behaviors for 'promotedClassName', 'promotedValueNamePrefix',
-- 'singledDataTypeName', 'singledClassName', 'singledDataConName',
-- 'singledValueName', and 'defunctionalizedName' are described in the
-- \"On names\" section of the @singletons@
-- @<https://github.com/goldfirere/singletons/blob/master/README.md README>@.
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options :: Bool
-> Bool
-> (Name -> Name)
-> (Name -> Name)
-> (Name -> Maybe Uniq -> Name)
-> (Name -> Name)
-> (Name -> Name)
-> (Name -> Name)
-> (Name -> Name)
-> (Name -> Int -> Name)
-> Options
Options
  { genQuotedDecs :: Bool
genQuotedDecs             = Bool
True
  , genSingKindInsts :: Bool
genSingKindInsts          = Bool
True
  , promotedDataTypeOrConName :: Name -> Name
promotedDataTypeOrConName = Name -> Name
promoteDataTypeOrConName
  , promotedClassName :: Name -> Name
promotedClassName         = Name -> Name
promoteClassName
  , promotedValueName :: Name -> Maybe Uniq -> Name
promotedValueName         = Name -> Maybe Uniq -> Name
promoteValNameLhs
  , singledDataTypeName :: Name -> Name
singledDataTypeName       = Name -> Name
singTyConName
  , singledClassName :: Name -> Name
singledClassName          = Name -> Name
singClassName
  , singledDataConName :: Name -> Name
singledDataConName        = Name -> Name
singDataConName
  , singledValueName :: Name -> Name
singledValueName          = Name -> Name
singValName
  , defunctionalizedName :: Name -> Int -> Name
defunctionalizedName      = Name -> Int -> Name
promoteTySym
  }

-- | Given the name of the original, unrefined, top-level value, produces the
-- name of the promoted equivalent of the value.
promotedTopLevelValueName :: Options -> Name -> Name
promotedTopLevelValueName :: Options -> Name -> Name
promotedTopLevelValueName Options
opts Name
name = Options -> Name -> Maybe Uniq -> Name
promotedValueName Options
opts Name
name Maybe Uniq
forall a. Maybe a
Nothing

-- | Given the name of the original, unrefined, @let@-bound value and its
-- globally unique number, produces the name of the promoted equivalent of the
-- value.
promotedLetBoundValueName :: Options -> Name -> Uniq -> Name
promotedLetBoundValueName :: Options -> Name -> Uniq -> Name
promotedLetBoundValueName Options
opts Name
name = Options -> Name -> Maybe Uniq -> Name
promotedValueName Options
opts Name
name (Maybe Uniq -> Name) -> (Uniq -> Maybe Uniq) -> Uniq -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uniq -> Maybe Uniq
forall a. a -> Maybe a
Just

-- | Given the original name of a function (term- or type-level), produces a
-- type-level function name that can be partially applied even without being
-- given any arguments (i.e., @0@ arguments).
defunctionalizedName0 :: Options -> Name -> Name
defunctionalizedName0 :: Options -> Name -> Name
defunctionalizedName0 Options
opts Name
name = Options -> Name -> Int -> Name
defunctionalizedName Options
opts Name
name Int
0

-- | Class that describes monads that contain 'Options'.
class DsMonad m => OptionsMonad m where
  getOptions :: m Options

instance OptionsMonad Q where
  getOptions :: Q Options
getOptions = Options -> Q Options
forall (f :: * -> *) a. Applicative f => a -> f a
pure Options
defaultOptions

instance OptionsMonad m => OptionsMonad (DsM m) where
  getOptions :: DsM m Options
getOptions = m Options -> DsM m Options
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions

instance (OptionsMonad q, Monoid m) => OptionsMonad (QWithAux m q) where
  getOptions :: QWithAux m q Options
getOptions = q Options -> QWithAux m q Options
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions

instance OptionsMonad m => OptionsMonad (ReaderT r m) where
  getOptions :: ReaderT r m Options
getOptions = m Options -> ReaderT r m Options
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions

instance OptionsMonad m => OptionsMonad (StateT s m) where
  getOptions :: StateT s m Options
getOptions = m Options -> StateT s m Options
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions

instance (OptionsMonad m, Monoid w) => OptionsMonad (WriterT w m) where
  getOptions :: WriterT w m Options
getOptions = m Options -> WriterT w m Options
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions

instance (OptionsMonad m, Monoid w) => OptionsMonad (RWST r w s m) where
  getOptions :: RWST r w s m Options
getOptions = m Options -> RWST r w s m Options
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions

-- | A convenient implementation of the 'OptionsMonad' class. Use by calling
-- 'withOptions'.
newtype OptionsM m a = OptionsM (ReaderT Options m a)
  deriving ( (forall a b. (a -> b) -> OptionsM m a -> OptionsM m b)
-> (forall a b. a -> OptionsM m b -> OptionsM m a)
-> Functor (OptionsM m)
forall a b. a -> OptionsM m b -> OptionsM m a
forall a b. (a -> b) -> OptionsM m a -> OptionsM m b
forall (m :: * -> *) a b.
Functor m =>
a -> OptionsM m b -> OptionsM m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> OptionsM m a -> OptionsM m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> OptionsM m b -> OptionsM m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> OptionsM m b -> OptionsM m a
fmap :: forall a b. (a -> b) -> OptionsM m a -> OptionsM m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> OptionsM m a -> OptionsM m b
Functor, Functor (OptionsM m)
Functor (OptionsM m)
-> (forall a. a -> OptionsM m a)
-> (forall a b.
    OptionsM m (a -> b) -> OptionsM m a -> OptionsM m b)
-> (forall a b c.
    (a -> b -> c) -> OptionsM m a -> OptionsM m b -> OptionsM m c)
-> (forall a b. OptionsM m a -> OptionsM m b -> OptionsM m b)
-> (forall a b. OptionsM m a -> OptionsM m b -> OptionsM m a)
-> Applicative (OptionsM m)
forall a. a -> OptionsM m a
forall a b. OptionsM m a -> OptionsM m b -> OptionsM m a
forall a b. OptionsM m a -> OptionsM m b -> OptionsM m b
forall a b. OptionsM m (a -> b) -> OptionsM m a -> OptionsM m b
forall a b c.
(a -> b -> c) -> OptionsM m a -> OptionsM m b -> OptionsM m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall {m :: * -> *}. Applicative m => Functor (OptionsM m)
forall (m :: * -> *) a. Applicative m => a -> OptionsM m a
forall (m :: * -> *) a b.
Applicative m =>
OptionsM m a -> OptionsM m b -> OptionsM m a
forall (m :: * -> *) a b.
Applicative m =>
OptionsM m a -> OptionsM m b -> OptionsM m b
forall (m :: * -> *) a b.
Applicative m =>
OptionsM m (a -> b) -> OptionsM m a -> OptionsM m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> OptionsM m a -> OptionsM m b -> OptionsM m c
<* :: forall a b. OptionsM m a -> OptionsM m b -> OptionsM m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
OptionsM m a -> OptionsM m b -> OptionsM m a
*> :: forall a b. OptionsM m a -> OptionsM m b -> OptionsM m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
OptionsM m a -> OptionsM m b -> OptionsM m b
liftA2 :: forall a b c.
(a -> b -> c) -> OptionsM m a -> OptionsM m b -> OptionsM m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> OptionsM m a -> OptionsM m b -> OptionsM m c
<*> :: forall a b. OptionsM m (a -> b) -> OptionsM m a -> OptionsM m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
OptionsM m (a -> b) -> OptionsM m a -> OptionsM m b
pure :: forall a. a -> OptionsM m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> OptionsM m a
Applicative, Applicative (OptionsM m)
Applicative (OptionsM m)
-> (forall a b.
    OptionsM m a -> (a -> OptionsM m b) -> OptionsM m b)
-> (forall a b. OptionsM m a -> OptionsM m b -> OptionsM m b)
-> (forall a. a -> OptionsM m a)
-> Monad (OptionsM m)
forall a. a -> OptionsM m a
forall a b. OptionsM m a -> OptionsM m b -> OptionsM m b
forall a b. OptionsM m a -> (a -> OptionsM m b) -> OptionsM m b
forall {m :: * -> *}. Monad m => Applicative (OptionsM m)
forall (m :: * -> *) a. Monad m => a -> OptionsM m a
forall (m :: * -> *) a b.
Monad m =>
OptionsM m a -> OptionsM m b -> OptionsM m b
forall (m :: * -> *) a b.
Monad m =>
OptionsM m a -> (a -> OptionsM m b) -> OptionsM m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> OptionsM m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> OptionsM m a
>> :: forall a b. OptionsM m a -> OptionsM m b -> OptionsM m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
OptionsM m a -> OptionsM m b -> OptionsM m b
>>= :: forall a b. OptionsM m a -> (a -> OptionsM m b) -> OptionsM m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
OptionsM m a -> (a -> OptionsM m b) -> OptionsM m b
Monad, (forall (m :: * -> *) a. Monad m => m a -> OptionsM m a)
-> MonadTrans OptionsM
forall (m :: * -> *) a. Monad m => m a -> OptionsM m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> OptionsM m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> OptionsM m a
MonadTrans
           , Monad (OptionsM m)
Monad (OptionsM m)
-> (String -> OptionsM m Name) -> Quote (OptionsM m)
String -> OptionsM m Name
forall (m :: * -> *). Monad m -> (String -> m Name) -> Quote m
forall {m :: * -> *}. Quote m => Monad (OptionsM m)
forall (m :: * -> *). Quote m => String -> OptionsM m Name
newName :: String -> OptionsM m Name
$cnewName :: forall (m :: * -> *). Quote m => String -> OptionsM m Name
Quote, MonadFail (OptionsM m)
MonadIO (OptionsM m)
OptionsM m [Extension]
OptionsM m Loc
Bool -> String -> OptionsM m (Maybe Name)
Bool -> String -> OptionsM m ()
String -> OptionsM m String
String -> OptionsM m Name
String -> OptionsM m ()
[Dec] -> OptionsM m ()
Q () -> OptionsM m ()
Name -> OptionsM m [DecidedStrictness]
Name -> OptionsM m [Role]
Name -> OptionsM m (Maybe Fixity)
Name -> OptionsM m Type
Name -> OptionsM m Info
Name -> [Type] -> OptionsM m [Dec]
MonadIO (OptionsM m)
-> MonadFail (OptionsM m)
-> (String -> OptionsM m Name)
-> (Bool -> String -> OptionsM m ())
-> (forall a. OptionsM m a -> OptionsM m a -> OptionsM m a)
-> (Bool -> String -> OptionsM m (Maybe Name))
-> (Name -> OptionsM m Info)
-> (Name -> OptionsM m (Maybe Fixity))
-> (Name -> OptionsM m Type)
-> (Name -> [Type] -> OptionsM m [Dec])
-> (Name -> OptionsM m [Role])
-> (forall a. Data a => AnnLookup -> OptionsM m [a])
-> (Module -> OptionsM m ModuleInfo)
-> (Name -> OptionsM m [DecidedStrictness])
-> OptionsM m Loc
-> (forall a. IO a -> OptionsM m a)
-> (String -> OptionsM m ())
-> (String -> OptionsM m String)
-> ([Dec] -> OptionsM m ())
-> (ForeignSrcLang -> String -> OptionsM m ())
-> (Q () -> OptionsM m ())
-> (String -> OptionsM m ())
-> (forall a. Typeable a => OptionsM m (Maybe a))
-> (forall a. Typeable a => a -> OptionsM m ())
-> (Extension -> OptionsM m Bool)
-> OptionsM m [Extension]
-> Quasi (OptionsM m)
Extension -> OptionsM m Bool
ForeignSrcLang -> String -> OptionsM m ()
Module -> OptionsM m ModuleInfo
forall a. Data a => AnnLookup -> OptionsM m [a]
forall a. Typeable a => OptionsM m (Maybe a)
forall a. Typeable a => a -> OptionsM m ()
forall a. IO a -> OptionsM m a
forall a. OptionsM m a -> OptionsM m a -> OptionsM m a
forall (m :: * -> *).
MonadIO m
-> MonadFail m
-> (String -> m Name)
-> (Bool -> String -> m ())
-> (forall a. m a -> m a -> m a)
-> (Bool -> String -> m (Maybe Name))
-> (Name -> m Info)
-> (Name -> m (Maybe Fixity))
-> (Name -> m Type)
-> (Name -> [Type] -> m [Dec])
-> (Name -> m [Role])
-> (forall a. Data a => AnnLookup -> m [a])
-> (Module -> m ModuleInfo)
-> (Name -> m [DecidedStrictness])
-> m Loc
-> (forall a. IO a -> m a)
-> (String -> m ())
-> (String -> m String)
-> ([Dec] -> m ())
-> (ForeignSrcLang -> String -> m ())
-> (Q () -> m ())
-> (String -> m ())
-> (forall a. Typeable a => m (Maybe a))
-> (forall a. Typeable a => a -> m ())
-> (Extension -> m Bool)
-> m [Extension]
-> Quasi m
forall {m :: * -> *}. Quasi m => MonadFail (OptionsM m)
forall {m :: * -> *}. Quasi m => MonadIO (OptionsM m)
forall (m :: * -> *). Quasi m => OptionsM m [Extension]
forall (m :: * -> *). Quasi m => OptionsM m Loc
forall (m :: * -> *).
Quasi m =>
Bool -> String -> OptionsM m (Maybe Name)
forall (m :: * -> *). Quasi m => Bool -> String -> OptionsM m ()
forall (m :: * -> *). Quasi m => String -> OptionsM m String
forall (m :: * -> *). Quasi m => String -> OptionsM m Name
forall (m :: * -> *). Quasi m => String -> OptionsM m ()
forall (m :: * -> *). Quasi m => [Dec] -> OptionsM m ()
forall (m :: * -> *). Quasi m => Q () -> OptionsM m ()
forall (m :: * -> *).
Quasi m =>
Name -> OptionsM m [DecidedStrictness]
forall (m :: * -> *). Quasi m => Name -> OptionsM m [Role]
forall (m :: * -> *). Quasi m => Name -> OptionsM m (Maybe Fixity)
forall (m :: * -> *). Quasi m => Name -> OptionsM m Type
forall (m :: * -> *). Quasi m => Name -> OptionsM m Info
forall (m :: * -> *). Quasi m => Name -> [Type] -> OptionsM m [Dec]
forall (m :: * -> *). Quasi m => Extension -> OptionsM m Bool
forall (m :: * -> *).
Quasi m =>
ForeignSrcLang -> String -> OptionsM m ()
forall (m :: * -> *). Quasi m => Module -> OptionsM m ModuleInfo
forall (m :: * -> *) a.
(Quasi m, Data a) =>
AnnLookup -> OptionsM m [a]
forall (m :: * -> *) a.
(Quasi m, Typeable a) =>
OptionsM m (Maybe a)
forall (m :: * -> *) a. (Quasi m, Typeable a) => a -> OptionsM m ()
forall (m :: * -> *) a. Quasi m => IO a -> OptionsM m a
forall (m :: * -> *) a.
Quasi m =>
OptionsM m a -> OptionsM m a -> OptionsM m a
qExtsEnabled :: OptionsM m [Extension]
$cqExtsEnabled :: forall (m :: * -> *). Quasi m => OptionsM m [Extension]
qIsExtEnabled :: Extension -> OptionsM m Bool
$cqIsExtEnabled :: forall (m :: * -> *). Quasi m => Extension -> OptionsM m Bool
qPutQ :: forall a. Typeable a => a -> OptionsM m ()
$cqPutQ :: forall (m :: * -> *) a. (Quasi m, Typeable a) => a -> OptionsM m ()
qGetQ :: forall a. Typeable a => OptionsM m (Maybe a)
$cqGetQ :: forall (m :: * -> *) a.
(Quasi m, Typeable a) =>
OptionsM m (Maybe a)
qAddCorePlugin :: String -> OptionsM m ()
$cqAddCorePlugin :: forall (m :: * -> *). Quasi m => String -> OptionsM m ()
qAddModFinalizer :: Q () -> OptionsM m ()
$cqAddModFinalizer :: forall (m :: * -> *). Quasi m => Q () -> OptionsM m ()
qAddForeignFilePath :: ForeignSrcLang -> String -> OptionsM m ()
$cqAddForeignFilePath :: forall (m :: * -> *).
Quasi m =>
ForeignSrcLang -> String -> OptionsM m ()
qAddTopDecls :: [Dec] -> OptionsM m ()
$cqAddTopDecls :: forall (m :: * -> *). Quasi m => [Dec] -> OptionsM m ()
qAddTempFile :: String -> OptionsM m String
$cqAddTempFile :: forall (m :: * -> *). Quasi m => String -> OptionsM m String
qAddDependentFile :: String -> OptionsM m ()
$cqAddDependentFile :: forall (m :: * -> *). Quasi m => String -> OptionsM m ()
qRunIO :: forall a. IO a -> OptionsM m a
$cqRunIO :: forall (m :: * -> *) a. Quasi m => IO a -> OptionsM m a
qLocation :: OptionsM m Loc
$cqLocation :: forall (m :: * -> *). Quasi m => OptionsM m Loc
qReifyConStrictness :: Name -> OptionsM m [DecidedStrictness]
$cqReifyConStrictness :: forall (m :: * -> *).
Quasi m =>
Name -> OptionsM m [DecidedStrictness]
qReifyModule :: Module -> OptionsM m ModuleInfo
$cqReifyModule :: forall (m :: * -> *). Quasi m => Module -> OptionsM m ModuleInfo
qReifyAnnotations :: forall a. Data a => AnnLookup -> OptionsM m [a]
$cqReifyAnnotations :: forall (m :: * -> *) a.
(Quasi m, Data a) =>
AnnLookup -> OptionsM m [a]
qReifyRoles :: Name -> OptionsM m [Role]
$cqReifyRoles :: forall (m :: * -> *). Quasi m => Name -> OptionsM m [Role]
qReifyInstances :: Name -> [Type] -> OptionsM m [Dec]
$cqReifyInstances :: forall (m :: * -> *). Quasi m => Name -> [Type] -> OptionsM m [Dec]
qReifyType :: Name -> OptionsM m Type
$cqReifyType :: forall (m :: * -> *). Quasi m => Name -> OptionsM m Type
qReifyFixity :: Name -> OptionsM m (Maybe Fixity)
$cqReifyFixity :: forall (m :: * -> *). Quasi m => Name -> OptionsM m (Maybe Fixity)
qReify :: Name -> OptionsM m Info
$cqReify :: forall (m :: * -> *). Quasi m => Name -> OptionsM m Info
qLookupName :: Bool -> String -> OptionsM m (Maybe Name)
$cqLookupName :: forall (m :: * -> *).
Quasi m =>
Bool -> String -> OptionsM m (Maybe Name)
qRecover :: forall a. OptionsM m a -> OptionsM m a -> OptionsM m a
$cqRecover :: forall (m :: * -> *) a.
Quasi m =>
OptionsM m a -> OptionsM m a -> OptionsM m a
qReport :: Bool -> String -> OptionsM m ()
$cqReport :: forall (m :: * -> *). Quasi m => Bool -> String -> OptionsM m ()
qNewName :: String -> OptionsM m Name
$cqNewName :: forall (m :: * -> *). Quasi m => String -> OptionsM m Name
Quasi, Monad (OptionsM m)
Monad (OptionsM m)
-> (forall a. String -> OptionsM m a) -> MonadFail (OptionsM m)
forall a. String -> OptionsM m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall {m :: * -> *}. MonadFail m => Monad (OptionsM m)
forall (m :: * -> *) a. MonadFail m => String -> OptionsM m a
fail :: forall a. String -> OptionsM m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> OptionsM m a
MonadFail, Monad (OptionsM m)
Monad (OptionsM m)
-> (forall a. IO a -> OptionsM m a) -> MonadIO (OptionsM m)
forall a. IO a -> OptionsM m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (OptionsM m)
forall (m :: * -> *) a. MonadIO m => IO a -> OptionsM m a
liftIO :: forall a. IO a -> OptionsM m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> OptionsM m a
MonadIO, MonadFail (OptionsM m)
Quasi (OptionsM m)
OptionsM m [Dec]
Quasi (OptionsM m)
-> MonadFail (OptionsM m)
-> OptionsM m [Dec]
-> DsMonad (OptionsM m)
forall (m :: * -> *).
Quasi m -> MonadFail m -> m [Dec] -> DsMonad m
forall {m :: * -> *}. DsMonad m => MonadFail (OptionsM m)
forall {m :: * -> *}. DsMonad m => Quasi (OptionsM m)
forall (m :: * -> *). DsMonad m => OptionsM m [Dec]
localDeclarations :: OptionsM m [Dec]
$clocalDeclarations :: forall (m :: * -> *). DsMonad m => OptionsM m [Dec]
DsMonad )

-- | Turn any 'DsMonad' into an 'OptionsMonad'.
instance DsMonad m => OptionsMonad (OptionsM m) where
  getOptions :: OptionsM m Options
getOptions = ReaderT Options m Options -> OptionsM m Options
forall (m :: * -> *) a. ReaderT Options m a -> OptionsM m a
OptionsM ReaderT Options m Options
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Declare the 'Options' that a TH computation should use.
withOptions :: Options -> OptionsM m a -> m a
withOptions :: forall (m :: * -> *) a. Options -> OptionsM m a -> m a
withOptions Options
opts (OptionsM ReaderT Options m a
x) = ReaderT Options m a -> Options -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Options m a
x Options
opts

-- Used when a value name appears in a pattern context.
-- Works only for proper variables (lower-case names).
--
-- If the Maybe Uniq argument is Nothing, then the name is top-level (and
-- thus globally unique on its own).
-- If the Maybe Uniq argument is `Just uniq`, then the name is let-bound and
-- should use `uniq` to make the promoted name globally unique.
promoteValNameLhs :: Name -> Maybe Uniq -> Name
promoteValNameLhs :: Name -> Maybe Uniq -> Name
promoteValNameLhs Name
n Maybe Uniq
mb_let_uniq
    -- We can't promote promote idenitifers beginning with underscores to
    -- type names, so we work around the issue by prepending "US" at the
    -- front of the name (#229).
  | Just (String
us, String
rest) <- String -> Maybe (String, String)
splitUnderscores (Name -> String
nameBase Name
n)
  = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
alpha String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"US" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
us String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest

  | Bool
otherwise
  = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ (String, String) -> Name -> String
toUpcaseStr (String, String)
pres Name
n
  where
    pres :: (String, String)
pres = (String, String)
-> (Uniq -> (String, String)) -> Maybe Uniq -> (String, String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String, String)
noPrefix (String -> String -> Uniq -> (String, String)
uniquePrefixes String
"Let" String
"<<<") Maybe Uniq
mb_let_uniq
    (String
alpha, String
_) = (String, String)
pres

-- generates type-level symbol for a given name. Int parameter represents
-- saturation: 0 - no parameters passed to the symbol, 1 - one parameter
-- passed to the symbol, and so on. Works on both promoted and unpromoted
-- names.
promoteTySym :: Name -> Int -> Name
promoteTySym :: Name -> Int -> Name
promoteTySym Name
name Int
sat
      -- We can't promote promote idenitifers beginning with underscores to
      -- type names, so we work around the issue by prepending "US" at the
      -- front of the name (#229).
    | Just (String
us, String
rest) <- String -> Maybe (String, String)
splitUnderscores (Name -> String
nameBase Name
name)
    = Name -> Name
default_case (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"US" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
us String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest)

    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nilName
    = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"NilSym" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
sat)

       -- Treat unboxed tuples like tuples.
       -- See Note [Promoting and singling unboxed tuples].
    | Just Int
degree <- Name -> Maybe Int
tupleNameDegree_maybe Name
name Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                     Name -> Maybe Int
unboxedTupleNameDegree_maybe Name
name
    = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"Tuple" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
degree String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Sym" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sat

    | Bool
otherwise
    = Name -> Name
default_case Name
name
  where
    default_case :: Name -> Name
    default_case :: Name -> Name
default_case Name
name' =
      let capped :: String
capped = (String, String) -> Name -> String
toUpcaseStr (String, String)
noPrefix Name
name' in
      if Char -> Bool
isHsLetter (String -> Char
forall a. [a] -> a
head String
capped)
      then String -> Name
mkName (String
capped String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Sym" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
sat))
      else String -> Name
mkName (String
capped String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"@#@" -- See Note [Defunctionalization symbol suffixes]
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
sat Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Char
'$'))

promoteClassName :: Name -> Name
promoteClassName :: Name -> Name
promoteClassName = String -> String -> Name -> Name
prefixName String
"P" String
"#"

promoteDataTypeOrConName :: Name -> Name
promoteDataTypeOrConName :: Name -> Name
promoteDataTypeOrConName Name
nm
  | Name -> String
nameBase Name
nm String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> String
nameBase Name
repName = Name
typeKindName
    -- See Note [Promoting and singling unboxed tuples]
  | Just Int
degree <- Name -> Maybe Int
unboxedTupleNameDegree_maybe Name
nm
  = if Name -> Bool
isDataName Name
nm then Int -> Name
tupleDataName Int
degree else Int -> Name
tupleTypeName Int
degree
  | Bool
otherwise = Name
nm
  where
    -- Is this name a data constructor name? A 'False' answer means "unsure".
    isDataName :: Name -> Bool
    isDataName :: Name -> Bool
isDataName (Name OccName
_ (NameG NameSpace
DataName PkgName
_ ModName
_)) = Bool
True
    isDataName Name
_                             = Bool
False

-- Singletons

singDataConName :: Name -> Name
singDataConName :: Name -> Name
singDataConName Name
nm
  | Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nilName                                  = String -> Name
mkName String
"SNil"
  | Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
consName                                 = String -> Name
mkName String
"SCons"
  | Just Int
degree <- Name -> Maybe Int
tupleNameDegree_maybe Name
nm        = Int -> Name
mkTupleName Int
degree
    -- See Note [Promoting and singling unboxed tuples]
  | Just Int
degree <- Name -> Maybe Int
unboxedTupleNameDegree_maybe Name
nm = Int -> Name
mkTupleName Int
degree
  | Bool
otherwise                                      = String -> String -> Name -> Name
prefixConName String
"S" String
"%" Name
nm

singTyConName :: Name -> Name
singTyConName :: Name -> Name
singTyConName Name
name
  | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
listName                                 = String -> Name
mkName String
"SList"
  | Just Int
degree <- Name -> Maybe Int
tupleNameDegree_maybe Name
name        = Int -> Name
mkTupleName Int
degree
    -- See Note [Promoting and singling unboxed tuples]
  | Just Int
degree <- Name -> Maybe Int
unboxedTupleNameDegree_maybe Name
name = Int -> Name
mkTupleName Int
degree
  | Bool
otherwise                                        = String -> String -> Name -> Name
prefixName String
"S" String
"%" Name
name

mkTupleName :: Int -> Name
mkTupleName :: Int -> Name
mkTupleName Int
n = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"STuple" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n

singClassName :: Name -> Name
singClassName :: Name -> Name
singClassName = Name -> Name
singTyConName

singValName :: Name -> Name
singValName :: Name -> Name
singValName Name
n
     -- Push the 's' past the underscores, as this lets us avoid some unused
     -- variable warnings (#229).
  | Just (String
us, String
rest) <- String -> Maybe (String, String)
splitUnderscores (Name -> String
nameBase Name
n)
  = String -> String -> Name -> Name
prefixName (String
us String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s") String
"%" (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
rest
  | Bool
otherwise
  = String -> String -> Name -> Name
prefixName String
"s" String
"%" (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Name
upcase Name
n

{-
Note [Promoting and singling unboxed tuples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unfortunately, today's GHC is not quite up to the task of promoting types
involving unboxed tuples. Consider this example:

  swapperino :: (# a, b #) -> (# b, a #)

What would this look like when promoted? Presumably, it would have a kind
signature like this:

  type Swapperino :: (# a, b #) -> (# b, a #)

Surprisingly, this won't kindcheck:

  error:
      • Expecting a lifted type, but ‘(# a, b #)’ is unlifted
      • In a standalone kind signature for ‘Swapperino’:
          (# a, b #) -> (# b, a #)

Even though (->) is levity polymorphic, this levity polymorphism only kicks in
for types, not kinds. In other words, the (->) in the kind of Swapperino is
completely levity monomorphic and only accepts Type-kinded arguments. This
oddity is tracked upstream as GHC#14180. Until that is fixed, there is no hope
of using promoted unboxed tuples freely in kinds.

However, we don't have to give up quite yet. As a crude-but-effective
workaround, we can simply promote value-level unboxed tuples to type-level boxed
tuples. In other words, we would promote swapperino to this:

  type Swapperino :: (a, b) -> (b, a)

This trick is enough to make many (but not all) uses of unboxed tuples
Just Work™ when promoted. We use a similar trick when singling unboxed tuples
as well.
-}