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