module System.Console.Options
(
Configuration(set)
, Setting
, apply
, create
, Type(ConT)
) where
import Data.Char (toUpper)
import Data.List (foldl')
import Language.Haskell.TH
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))
setName = 'set
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