Options.hs

{-# LANGUAGE TypeFamilies,TemplateHaskell,ScopedTypeVariables #-}
module System.Console.Options
  (
    Options
  , Setting(set)
  , 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 @s@ of 'Setting' has as values /partial/ sets of option assignments,
 -- as given by the user in a configuration file or command line options.
 -- @'Options' s@ is the associated type of complete configurations, as the
 -- program needs.
class Setting s where
  type Options s
  set :: s -> Options s -> Options s

setName = 'set

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

{-
instance Setting (Endo a) where
  type Options (Endo a) = a
  set (Endo f) = f
-}

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