Configurable.hs

{-# LANGUAGE ExistentialQuantification,
             DeriveDataTypeable,
             MultiParamTypeClasses,
             FunctionalDependencies,
             ScopedTypeVariables,
             TupleSections #-}

module Control.Configurable (
  Configurable (..),
  Configuration,
  ConfiguredBy (..),
  ConfigMethod,
  doConfig, unsafeDoConfig, toConfigure, configureDefault
  ) where

import Data.Data
import Data.Monoid

-- | A 'Configurable' type is any type which should be specialized
-- from runtime configuration information. For instance, a record type
-- containing usernames and passwords for a database is probably
-- 'Configurable'. In principle, 'Configurable' types should be
-- distinguished from the functions/types/'ConfiguredBy' instances
-- they provide for.
class (Typeable a, Show a, Monoid a) => Configurable a where
  toConfiguration :: a -> Configuration
  toConfiguration = Configuration
  fromConfiguration :: Configuration -> Maybe a
  fromConfiguration (Configuration a) = cast a

  -- | A wildcard deconstructor on lists of 'Configuration's. After a
  -- list of 'Configuration's has been generated by either 'doConfig'
  -- or 'unsafeDoConfig', 'getConfig' is a typesafe destructor which
  -- can be used to filter the result for application to other
  -- functions. The default implementation relies on the 'Monoid'
  -- instance of the 'Configurable' to combine configurations.
  getConfig :: [Configuration] -> Maybe a
  getConfig cs = mconcat (map fromConfiguration cs)

-- | A 'Configuration' is an opaque wrapper around an existentially
-- typed 'Configurable'. 
data Configuration = forall a. Configurable a => Configuration a
                   deriving Typeable

instance Show Configuration where
  showsPrec p (Configuration a) = showsPrec p a

instance Configurable ()

-- | The default 'Monoid' instance of 'Configuration' is simply
-- left-annihilation. The 'mempty' just wraps the '()' type.
instance Monoid Configuration where
  mempty      = Configuration ()
  mappend a _ = a

-- | 'ConfiguredBy' is a convenience class allowing specification of
-- which kinds of 'Configurable's are needed for other types.
class Configurable b => ConfiguredBy a b | a -> b where
  -- | The default implementation relies on the functional dependency
  -- in the type and the 'Monoid' instance method 'mempty' of the
  -- 'Configurable'.
  confs :: a -> [Configuration]
  confs _ = [toConfiguration (mempty :: b)]

-- | 'ConfigMethod' is an opaque wrapper for methods to specialize
-- 'Configurations'.
data ConfigMethod = ConfigMethod { unConfigM :: [(Configuration, Bool)] }

-- | 'toConfigure' allows you to specify a specialization function for
-- any particular 'Configurable'. These are combinated together into a
-- large specialization routine which is then run via 'doConfig' or
-- 'unsafeDoConfig'.
toConfigure :: Configurable a => (a -> a) -> ConfigMethod -> ConfigMethod
toConfigure f = ConfigMethod . map ff . unConfigM
  where ff (z, configured) =
          case fromConfiguration z of
            Just a  -> (toConfiguration (f a), True)
            Nothing -> (z, configured)

-- | Introduce a new 'Configurable' based on its 'mempty' method.
configureDefault :: Configurable a => (a -> a) -> Configuration
configureDefault f = toConfiguration (f mempty)

-- | Given some 'Configuration' goals, use 'ConfigMethod's to
-- specialize a '[Configuration]'
doConfig :: [[Configuration]]
            -> (ConfigMethod -> ConfigMethod)
            -> Either [Configuration] [Configuration]
doConfig = flip runConfig

-- | An auxilary function for definine 'doConfig'.
runConfig :: (ConfigMethod -> ConfigMethod)
            -> [[Configuration]]
            -> Either [Configuration] [Configuration]
runConfig f = ret . unConfigM . f . ConfigMethod .  map (,False) . concat
  where ret cs = let unconfigured = filter (not . snd) cs
                 in if null unconfigured
                    then Right (map fst cs)
                    else Left (map fst unconfigured)

-- | Given some 'Configuration' goals, use 'ConfigMethod's to
-- specialize a '[Configuration]', but if any goals are never
-- specialized then fail immediately!
unsafeDoConfig :: [[Configuration]] -> (ConfigMethod -> ConfigMethod) -> [Configuration]
unsafeDoConfig cs f = go cs
  where
    go = map check . unConfigM . f . ConfigMethod .  map (,False) . concat
    check (c, True) = c
    check (c, False) = error $ "Required " ++ show c