diff --git a/Configurable.cabal b/Configurable.cabal new file mode 100644 --- /dev/null +++ b/Configurable.cabal @@ -0,0 +1,26 @@ +-- Initial Configurable.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: Configurable +version: 0.1.0.0 +synopsis: Declare types as Configurable then specialize them all in one place +description: Declare types as Configurable then specialize them all in one place +homepage: https://github.com/tel/Configurable +license: MIT +license-file: LICENSE +author: Joseph Abrahamson +maintainer: Joseph Abrahamson +copyright: Joseph Abrahamson, 2012 +category: Control +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Control.Configurable + -- other-modules: + build-depends: base ==4.5.* + hs-source-dirs: src + +source-repository head + type: git + location: https://github.com/tel/Configurable.git diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (C) 2012 Joseph Abrahamson + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Control/Configurable.hs b/src/Control/Configurable.hs new file mode 100644 --- /dev/null +++ b/src/Control/Configurable.hs @@ -0,0 +1,109 @@ +{-# 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