{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
-- | 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
        k b
k2' <- forall (f :: * -> *) (g :: * -> *) a.
(Typeable f, Typeable g) =>
f a -> Maybe (g a)
cast1 k b
k2
        forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
geq k a
k1 k b
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 forall a. Ord a => a -> a -> Ordering
compare TypeRep
t1 TypeRep
t2 of
            Ordering
LT -> forall {k} (a :: k) (b :: k). GOrdering a b
GLT
            Ordering
EQ -> forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
typeErr forall a b. (a -> b) -> a -> b
$ do
                k b
k2'  <- forall (f :: * -> *) (g :: * -> *) a.
(Typeable f, Typeable g) =>
f a -> Maybe (g a)
cast1 k b
k2
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
gcompare k a
k1 k b
k2')
            Ordering
GT -> forall {k} (a :: k) (b :: k). GOrdering a b
GGT
        where
            t1 :: TypeRep
t1 = forall (t :: * -> *) a. Typeable t => t a -> TypeRep
typeOf1 k a
k1
            t2 :: TypeRep
t2 = forall (t :: * -> *) a. Typeable t => t a -> TypeRep
typeOf1 k b
k2

            typeErr :: a
typeErr = 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
    Name
tyName      <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper [Char]
nameStr)
    Name
conName     <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper [Char]
nameStr)
    let patchNames :: Name -> Name
        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
decs <- (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Name -> Name
patchNames) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [d| data TyName a = a ~ $(tyQ) => ConName deriving Typeable

            keyName :: Config $(tyQ)
            keyName = Config ConName $(defValQ) $(mergeQ) |]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ forall (m :: * -> *) a. Monad m => a -> m a
return Decs
decs
        , forall t. DeriveGEQ t => t -> Q Decs
deriveGEq (forall a. [a] -> a
head Decs
decs)
        , forall t. DeriveGCompare t => t -> Q Decs
deriveGCompare (forall a. [a] -> a
head Decs
decs)
        ]