Options.hs

{-# LANGUAGE TypeFamilies,TemplateHaskell,ScopedTypeVariables #-}
-- | This module defines a class for dealing with configurations and settings.
-- It also exports a Template Haskell function to easily create datatypes
-- to deal with the configuration of your program.
-- 
-- For an example using this module, see the file \"Examples/Options.hs\" in
-- the package tarball.
module System.Console.Options
  (
    Configuration(set)
  , Setting
  , apply
  
  , create
  
  , Type(ConT) -- Useful for passing types of settings to 'create'.
  ) where


import           Data.Char (toUpper)
import           Data.List (foldl')
import           Language.Haskell.TH


-- | An instance @c@ of 'Configuration' has as values complete configurations,
-- as the program peruses. @'Setting' s@ is the associated type of a single
-- setting, or option assignments, as given by the user in a configuration
-- file or command line options.
class Configuration c where
  type Setting c
  set :: Setting c -> c -> c

instance Configuration () where
  type Setting () = ()
  set _ _ = ()

apply :: forall c. (Configuration c) => [Setting c] -> c -> c
apply = flip (foldl' (flip set))

-- Necessary to avoid TH staging error.
setName = 'set

-- | 'create' is a template haskell computation. Given names for the
-- \"configuration\" type and the \"settings\" type, and a list of settings
-- (pairs of their names and types), it creates those datatypes, and an
-- instance of the 'Configuration' class.
create :: String -> String -> [(String,Type)] -> Q [Dec]
create configurationName settingName settings = do
  x <- newName "x"
  y <- newName "y"
  s <- newName "set"
  let configurationType = DataD [] (mkName configurationName) [] [RecC (mkName configurationName) $ flip map settings $ \ (n,t) -> (mkName $ n ++ "_",NotStrict,t)] []
  let settingType = DataD [] (mkName settingName) [] (flip map settings $ \ (n,t) -> NormalC (mkName $ capitalise n) [(NotStrict,t)]) []
  let setFunction = FunD s $ flip map settings $ \ (n,_) -> Clause
        [ConP (mkName $ capitalise n) [VarP x],VarP y]
        (NormalB $ RecUpdE (VarE y) [(mkName $ n ++ "_",VarE x)]  )
        []
  let configurationInstance = InstanceD [] (ConT ''Configuration `AppT` ConT (mkName configurationName))
        [
          TySynInstD ''Setting [ConT $ mkName configurationName] (ConT $ mkName settingName)
        , FunD setName [Clause [] (NormalB $ VarE s) []]
        ]
  return $ configurationType : settingType : setFunction : configurationInstance : []
 where
  capitalise :: String -> String
  capitalise []       = []
  capitalise (x : xs) = toUpper x : xs