{-# 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 :: f a -> Maybe (g a)
cast1 = (Identity (g a) -> g a) -> Maybe (Identity (g a)) -> Maybe (g a)
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 :: 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' <- k b -> Maybe (k b)
forall (f :: * -> *) (g :: * -> *) a.
(Typeable f, Typeable g) =>
f a -> Maybe (g a)
cast1 k b
k2
        k a -> k b -> Maybe (a :~: b)
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 :: 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
                k b
k2'  <- k b -> Maybe (k b)
forall (f :: * -> *) (g :: * -> *) a.
(Typeable f, Typeable g) =>
f a -> Maybe (g a)
cast1 k b
k2
                GOrdering a b -> Maybe (GOrdering a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (k a -> k b -> GOrdering a b
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 -> 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 :: Config t -> t
getConfigDefault (Config k t
_ t
def t -> t -> t
_) = t
def

mergeConfig :: Config t -> t -> t -> t
mergeConfig :: 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 :: Config a -> ReaderT r m a
getConfig = 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 (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig
instance (MonadConfig m, Monoid w) => MonadConfig (WriterT w m) where getConfig :: Config a -> WriterT w m a
getConfig = 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 (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig
instance  MonadConfig m            => MonadConfig (StateT  s m) where getConfig :: Config a -> StateT s m a
getConfig = 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 (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 [Dec]
config = ExpQ -> [Char] -> TypeQ -> ExpQ -> Q [Dec]
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 [Dec]
configWithMerge ExpQ
mergeQ [Char]
nameStr TypeQ
tyQ ExpQ
defValQ = do
    let keyName :: Name
keyName = [Char] -> Name
mkName [Char]
nameStr
    Name
tyName      <- [Char] -> Q Name
newName ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper [Char]
nameStr)
    Name
conName     <- [Char] -> Q Name
newName ((Char -> Char) -> [Char] -> [Char]
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
    [Dec]
decs <- (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Name -> Name) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Name -> Name
patchNames) ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
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) |]
    [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
decs
        , Dec -> Q [Dec]
forall t. DeriveGEQ t => t -> Q [Dec]
deriveGEq ([Dec] -> Dec
forall a. [a] -> a
head [Dec]
decs)
        , Dec -> Q [Dec]
forall t. DeriveGCompare t => t -> Q [Dec]
deriveGCompare ([Dec] -> Dec
forall a. [a] -> a
head [Dec]
decs)
        ]