{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

-----------------------------------------------------------------------------
-- |
-- 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
  , 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.Names ( consName, listName, nilName
                             , mk_name_tc, mkTupleDataName, mkTupleTypeName
                             , sconsName, sListName, snilName
                             , splitUnderscores
                             )
import Data.Singletons.Util
import Language.Haskell.TH.Desugar
import Language.Haskell.TH.Syntax hiding (Lift(..))

-- | Options that control the finer details of how @singletons@' 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
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 -> 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
  , 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 ( a -> OptionsM m b -> OptionsM m a
(a -> b) -> OptionsM m a -> OptionsM m b
(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
<$ :: a -> OptionsM m b -> OptionsM m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> OptionsM m b -> OptionsM m a
fmap :: (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)
a -> OptionsM m a
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)
OptionsM m a -> OptionsM m b -> OptionsM m b
OptionsM m a -> OptionsM m b -> OptionsM m a
OptionsM m (a -> b) -> OptionsM m a -> OptionsM m b
(a -> b -> c) -> OptionsM m a -> OptionsM m b -> OptionsM m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> OptionsM m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> OptionsM m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (OptionsM m)
Applicative, Applicative (OptionsM m)
a -> OptionsM m a
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)
OptionsM m a -> (a -> OptionsM m b) -> OptionsM m b
OptionsM m a -> OptionsM m b -> OptionsM m b
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 :: a -> OptionsM m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> OptionsM m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (OptionsM m)
Monad, m a -> OptionsM m a
(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 :: m a -> OptionsM m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> OptionsM m a
MonadTrans
           , MonadFail (OptionsM m)
MonadIO (OptionsM m)
OptionsM m [Extension]
OptionsM m (Maybe a)
OptionsM m Loc
a -> OptionsM m ()
Bool -> String -> OptionsM m (Maybe Name)
Bool -> String -> OptionsM m ()
String -> OptionsM m String
String -> OptionsM m Name
String -> OptionsM m ()
[Dec] -> OptionsM m ()
IO a -> OptionsM m a
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
AnnLookup -> OptionsM m [a]
OptionsM m a -> OptionsM m a -> OptionsM m a
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 :: a -> OptionsM m ()
$cqPutQ :: forall (m :: * -> *) a. (Quasi m, Typeable a) => a -> OptionsM m ()
qGetQ :: 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 :: 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 :: 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 :: 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
$cp2Quasi :: forall (m :: * -> *). Quasi m => MonadFail (OptionsM m)
$cp1Quasi :: forall (m :: * -> *). Quasi m => MonadIO (OptionsM m)
Quasi, Monad (OptionsM m)
Monad (OptionsM m)
-> (forall a. String -> OptionsM m a) -> MonadFail (OptionsM m)
String -> OptionsM m a
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 :: String -> OptionsM m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> OptionsM m a
$cp1MonadFail :: forall (m :: * -> *). MonadFail m => Monad (OptionsM m)
MonadFail, Monad (OptionsM m)
Monad (OptionsM m)
-> (forall a. IO a -> OptionsM m a) -> MonadIO (OptionsM m)
IO a -> OptionsM m a
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 :: IO a -> OptionsM m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> OptionsM m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (OptionsM m)
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]
$cp2DsMonad :: forall (m :: * -> *). DsMonad m => MonadFail (OptionsM m)
$cp1DsMonad :: forall (m :: * -> *). DsMonad m => Quasi (OptionsM m)
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 :: 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
    | 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 -> String -> Name
mk_name_tc String
"Data.Singletons.Prelude.Instances" (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
"#"

-- Singletons

singDataConName :: Name -> Name
singDataConName :: Name -> Name
singDataConName Name
nm
  | Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nilName                                  = Name
snilName
  | Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
consName                                 = Name
sconsName
  | Just Int
degree <- Name -> Maybe Int
tupleNameDegree_maybe Name
nm        = Int -> Name
mkTupleDataName Int
degree
  | Just Int
degree <- Name -> Maybe Int
unboxedTupleNameDegree_maybe Name
nm = Int -> Name
mkTupleDataName 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                                 = Name
sListName
  | Just Int
degree <- Name -> Maybe Int
tupleNameDegree_maybe Name
name        = Int -> Name
mkTupleTypeName Int
degree
  | Just Int
degree <- Name -> Maybe Int
unboxedTupleNameDegree_maybe Name
name = Int -> Name
mkTupleTypeName Int
degree
  | Bool
otherwise                                        = String -> String -> Name -> Name
prefixName String
"S" String
"%" Name
name

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