Config.hs

{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-}

module Barrie.Config (Config, defaultConfig, transformConfig,
                      enabledCfg, isEnabled,
                      quitConfig, configQuits,
                      labelConfig, configHasLabel, configLabel,
                      titleConfig, configTitles)
    where

import Data.Typeable

data Config a = Cfg {
           cEnabled :: a -> Bool,
           cQuits   :: Bool,
           cLabel   :: Maybe (a -> String),
           cTitle   :: [String]
           }

instance (Typeable a) => Typeable (Config a) where
    typeOf cfg = mkTyConApp (mkTyCon "Barrie.Config.Config")
                          [typeOf (cEnabled cfg),
                           typeOf (cLabel cfg)]

defaultConfig :: Config a
defaultConfig = Cfg { cEnabled = const True,
                      cQuits = False,
                      cLabel = Nothing,
                      cTitle = []
                    }

transformConfig :: (a -> b) -> Config b -> Config a
transformConfig get cfg = cfg { cEnabled = cEnabled cfg . get,
                                cLabel = label'
                              }
    where label' = case cLabel cfg of
                     Nothing -> Nothing
                     Just f  -> Just $ f . get

enabledCfg :: (a -> Bool) -> Config a -> Config a
enabledCfg f config = config { cEnabled = f }

isEnabled :: Config a -> a -> Bool
isEnabled config state = cEnabled config state

quitConfig :: Bool -> Config a -> Config a
quitConfig q config = config { cQuits = q }

configQuits :: Config a -> Bool
configQuits config = cQuits config

labelConfig :: (a -> String) -> Config a -> Config a
labelConfig f config = config { cLabel = Just f }

configHasLabel :: Config a -> Bool
configHasLabel Cfg { cLabel = Nothing } = False
configHasLabel _ = True

configLabel :: Config a -> a -> String
configLabel Cfg { cLabel = Just f } st = f st
configLabel _ _ =
    error "tried to get a label from a config which has none"

configTitles :: Config a -> [String]
configTitles = cTitle

titleConfig :: [String] -> Config a -> Config a
titleConfig ts config = config { cTitle = ts }