    {-# LANGUAGE CPP #-}
    {-# LANGUAGE GADTs #-}
    {-# LANGUAGE ViewPatterns #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeOperators #-}
    -- | Extensible configuration system for lambdabot
    --
    -- TODO: there's notthing lambdabot-specific about this, it could be a useful standalone library.
    module Lambdabot.Config
        ( Config
        , getConfigDefault
        , mergeConfig

        , MonadConfig(..)

        , config
        , configWithMerge
        ) where

    import Control.Applicative
    import Control.Monad.Identity
    import Control.Monad.Reader
    import Control.Monad.Writer
    import Control.Monad.State
    import Data.Char
    import Data.GADT.Compare
    import Data.GADT.Compare.TH
    import Data.Maybe
    import Data.Typeable
    import Data.Generics (everywhere, mkT)
    import Language.Haskell.TH

    data Config t where Config :: (Typeable k, GCompare k) => !(k t) -> t -> (t -> t -> t) -> Config t

    cast1 :: (Typeable f, Typeable g) => f a -> Maybe (g a)
    cast1 :: forall (f :: * -> *) (g :: * -> *) a.
    (Typeable f, Typeable g) =>
    f a -> Maybe (g a)
    cast1 = (Identity (g a) -> g a) -> Maybe (Identity (g a)) -> Maybe (g a)
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Identity (g a) -> g a
    forall a. Identity a -> a
    runIdentity (Maybe (Identity (g a)) -> Maybe (g a))
    -> (f a -> Maybe (Identity (g a))) -> f a -> Maybe (g a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Identity (f a) -> Maybe (Identity (g a))
    forall {k1} {k2} (c :: k1 -> *) (t :: k2 -> k1) (t' :: k2 -> k1)
           (a :: k2).
    (Typeable t, Typeable t') =>
    c (t a) -> Maybe (c (t' a))
    gcast1 (Identity (f a) -> Maybe (Identity (g a)))
    -> (f a -> Identity (f a)) -> f a -> Maybe (Identity (g a))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . f a -> Identity (f a)
    forall a. a -> Identity a
    Identity

    instance GEq Config where
        geq :: forall a b. Config a -> Config b -> Maybe (a :~: b)
    geq (Config k a
    k1 a
    _ a -> a -> a
    _) (Config k b
    k2 b
    _ b -> b -> b
    _) = do
            k2' <- k b -> Maybe (k b)
    forall (f :: * -> *) (g :: * -> *) a.
    (Typeable f, Typeable g) =>
    f a -> Maybe (g a)
    cast1 k b
    k2
            geq k1 k2'

    instance GCompare Config where
        gcompare :: forall a b. Config a -> Config b -> GOrdering a b
    gcompare (Config k a
    k1 a
    _ a -> a -> a
    _) (Config k b
    k2 b
    _ b -> b -> b
    _) =
            case TypeRep -> TypeRep -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare TypeRep
    t1 TypeRep
    t2 of
                Ordering
    LT -> GOrdering a b
    forall {k} (a :: k) (b :: k). GOrdering a b
    GLT
                Ordering
    EQ -> GOrdering a b -> Maybe (GOrdering a b) -> GOrdering a b
    forall a. a -> Maybe a -> a
    fromMaybe GOrdering a b
    forall {a}. a
    typeErr (Maybe (GOrdering a b) -> GOrdering a b)
    -> Maybe (GOrdering a b) -> GOrdering a b
    forall a b. (a -> b) -> a -> b
    $ do
                    k2'  <- k b -> Maybe (k b)
    forall (f :: * -> *) (g :: * -> *) a.
    (Typeable f, Typeable g) =>
    f a -> Maybe (g a)
    cast1 k b
    k2
                    return (gcompare k1 k2')
                Ordering
    GT -> GOrdering a b
    forall {k} (a :: k) (b :: k). GOrdering a b
    GGT
            where
                t1 :: TypeRep
    t1 = k a -> TypeRep
    forall (t :: * -> *) a. Typeable t => t a -> TypeRep
    typeOf1 k a
    k1
                t2 :: TypeRep
    t2 = k b -> TypeRep
    forall (t :: * -> *) a. Typeable t => t a -> TypeRep
    typeOf1 k b
    k2

                typeErr :: a
    typeErr = [Char] -> a
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "TypeReps claim to be equal but cast failed"

    getConfigDefault :: Config t -> t
    getConfigDefault :: forall t. Config t -> t
    getConfigDefault (Config k t
    _ t
    def t -> t -> t
    _) = t
    def

    mergeConfig :: Config t -> t -> t -> t
    mergeConfig :: forall t. Config t -> t -> t -> t
    mergeConfig (Config k t
    _ t
    _ t -> t -> t
    f) = t -> t -> t
    f

    class Monad m => MonadConfig m where
        getConfig :: Config a -> m a

    instance  MonadConfig m            => MonadConfig (ReaderT r m) where getConfig :: forall a. Config a -> ReaderT r m a
    getConfig = m a -> ReaderT r m a
    forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (m a -> ReaderT r m a)
    -> (Config a -> m a) -> Config a -> ReaderT r m a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Config a -> m a
    forall a. Config a -> m a
    forall (m :: * -> *) a. MonadConfig m => Config a -> m a
    getConfig
    instance (MonadConfig m, Monoid w) => MonadConfig (WriterT w m) where getConfig :: forall a. Config a -> WriterT w m a
    getConfig = m a -> WriterT w m a
    forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (m a -> WriterT w m a)
    -> (Config a -> m a) -> Config a -> WriterT w m a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Config a -> m a
    forall a. Config a -> m a
    forall (m :: * -> *) a. MonadConfig m => Config a -> m a
    getConfig
    instance  MonadConfig m            => MonadConfig (StateT  s m) where getConfig :: forall a. Config a -> StateT s m a
    getConfig = m a -> StateT s m a
    forall (m :: * -> *) a. Monad m => m a -> StateT s m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (m a -> StateT s m a)
    -> (Config a -> m a) -> Config a -> StateT s m a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Config a -> m a
    forall a. Config a -> m a
    forall (m :: * -> *) a. MonadConfig m => Config a -> m a
    getConfig

    -- |Define a new configuration key with the specified name, type and
    -- default value
    --
    -- You should probably also provide an explicit export list for any
    -- module that defines config keys, because the definition introduces
    -- a few extra types that will clutter up the export list otherwise.
    config :: String -> TypeQ -> ExpQ -> Q [Dec]
    config :: [Char] -> TypeQ -> ExpQ -> Q Decs
    config = ExpQ -> [Char] -> TypeQ -> ExpQ -> Q Decs
    configWithMerge [| flip const |]

    -- |Like 'config', but also allowing you to specify a \"merge rule\"
    -- that will be used to combine multiple bindings of the same key.
    --
    -- For example, in "Lambdabot.Config.Core", 'onStartupCmds' is
    -- defined as a list of commands to execute on startup.  Its default
    -- value is ["offlinerc"], so if a user invokes the default lambdabot
    -- executable without arguments, they will get a REPL.  Each instance
    -- of "-e" on the command-line adds a binding of the form:
    --
    -- > onStartupCmds :=> [command]
    --
    -- So if they give one "-e", it replaces the default (note that it
    -- is _not_ merged with the default - the default is discarded), and
    -- if they give more than one they are merged using the specified
    -- operation (in this case, `(++)`).
    configWithMerge :: ExpQ -> String -> TypeQ -> ExpQ -> Q [Dec]
    configWithMerge :: ExpQ -> [Char] -> TypeQ -> ExpQ -> Q Decs
    configWithMerge ExpQ
    mergeQ [Char]
    nameStr TypeQ
    tyQ ExpQ
    defValQ = do
        let keyName :: Name
    keyName = [Char] -> Name
    mkName [Char]
    nameStr
        tyName      <- [Char] -> Q Name
    forall (m :: * -> *). Quote m => [Char] -> m Name
    newName ((Char -> Char) -> [Char] -> [Char]
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toUpper [Char]
    nameStr)
        conName     <- newName (map toUpper nameStr)
        let patchNames :: Name -> Name
            patchNames (Name -> [Char]
    nameBase -> [Char]
    "keyName") = Name
    keyName
            patchNames (Name -> [Char]
    nameBase -> [Char]
    "TyName")  = Name
    tyName
            patchNames (Name -> [Char]
    nameBase -> [Char]
    "ConName") = Name
    conName
            patchNames Name
    d = Name
    d
        decs <- everywhere (mkT patchNames) <$>
            [d| data TyName a = a ~ $(tyQ) => ConName deriving Typeable

                keyName :: Config $(tyQ)
                keyName = Config ConName $(defValQ) $(mergeQ) |]
        concat <$> sequence
            [ return decs
            , deriveGEq (head decs)
            , deriveGCompare (head decs)
            ]