Config.hs

{-# 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 :: (Typeable1 k, GCompare k) => !(k t) -> t -> (t -> t -> t) -> Config t

cast1 :: (Typeable1 f, Typeable1 g) => f a -> Maybe (g a)
cast1 = fmap runIdentity . gcast1 . Identity

instance GEq Config where
    geq (Config k1 _ _) (Config k2 _ _) = do
        k2' <- cast1 k2
        geq k1 k2'

instance GCompare Config where
    gcompare (Config k1 _ _) (Config k2 _ _) =
        case compare t1 t2 of
            LT -> GLT
            EQ -> fromMaybe typeErr $ do
                k2'  <- cast1 k2
                return (gcompare k1 k2')
            GT -> GGT
        where
            t1 = typeOf1 k1
            t2 = typeOf1 k2

            typeErr = error "TypeReps claim to be equal but cast failed"

getConfigDefault :: Config t -> t
getConfigDefault (Config _ def _) = def

mergeConfig :: Config t -> t -> t -> t
mergeConfig (Config _ _ f) = f

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

instance  MonadConfig m            => MonadConfig (ReaderT r m) where getConfig = lift . getConfig
instance (MonadConfig m, Monoid w) => MonadConfig (WriterT w m) where getConfig = lift . getConfig
instance  MonadConfig m            => MonadConfig (StateT  s m) where getConfig = lift . 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 = 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 mergeQ nameStr tyQ defValQ = do
    let keyName = mkName nameStr
    tyName      <- newName (map toUpper nameStr)
    conName     <- newName (map toUpper nameStr)
    let patchNames :: Name -> Name
        patchNames (nameBase -> "keyName") = keyName
        patchNames (nameBase -> "TyName")  = tyName
        patchNames (nameBase -> "ConName") = conName
        patchNames d = 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)
        ]