{-# OPTIONS_GHC -Wno-duplicate-exports #-}
{-# LANGUAGE TypeOperators, ScopedTypeVariables, DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverloadedStrings #-}
{-# LANGUAGE TypeApplications, AllowAmbiguousTypes, DataKinds, TypeFamilies #-}
{-# LANGUAGE ConstraintKinds, UndecidableInstances, UndecidableSuperClasses #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Data.Tini.Configurable
(
Configurable (defaultConfig, sectionName)
, fromIni, toIni
, readConfigFile, readConfigFileWith, writeConfigFile, updateConfigFile
, Configurable (..)
, ConfigInvariants
, Generic
) where
import Control.Exception (SomeException (..), try)
import Control.Monad ((>=>))
import Data.Kind (Constraint)
import Data.Proxy (Proxy (..))
import GHC.Generics
import GHC.TypeLits
import System.IO
import Data.Tini
import Data.Tini.Types
readConfigFile :: Configurable a => FilePath -> IO a
readConfigFile = readConfigFileWith defaultConfig
readConfigFileWith :: Configurable a => a -> FilePath -> IO a
readConfigFileWith c = fmap (flip updateConfig c . maybe empty id) . readIniFile
updateConfigFile :: Configurable a => FilePath -> a -> IO ()
updateConfigFile f cfg = do
old <- try $ withFile f ReadMode $ hGetContents >=> (pure $!) . parseIni
case old :: Either SomeException (Maybe Ini) of
Right (Just ini) -> writeIniFile f (updateIni cfg ini)
_ -> writeIniFile f (toIni cfg)
writeConfigFile :: Configurable a => FilePath -> a -> IO ()
writeConfigFile file = writeIniFile file . toIni
fromIni :: Configurable a => Ini -> a
fromIni = flip updateConfig defaultConfig
toIni :: Configurable a => a -> Ini
toIni = flip updateIni empty
type ConfigInvariants a =
( FieldsOf a (ExcludedFields a)
, SymList (ExcludedFields a)
)
class ConfigInvariants a => Configurable a where
updateConfig :: Ini -> a -> a
default updateConfig :: (Generic a, GConfigurable (Rep a)) => Ini -> a -> a
updateConfig i =
to . gUpdate (lower @(ExcludedFields a)) (sectionName @a) Nothing i . from
updateIni :: a -> Ini -> Ini
default updateIni :: (Generic a, GConfigurable (Rep a)) => a -> Ini -> Ini
updateIni = gUpdIni (lower @(ExcludedFields a)) (sectionName @a) Nothing . from
type ExcludedFields a :: [Symbol]
type ExcludedFields a = '[]
sectionName :: SectionName
sectionName = ""
defaultConfig :: a
{-# MINIMAL defaultConfig #-}
type family Member (x :: Symbol) (f :: * -> *) :: Nat where
Member x (M1 S ('MetaSel ('Just x) u s d) f) = 1
Member x (M1 i c f) = Member x f
Member x (a :*: b) = Member x a + Member x b
Member x a = 0
type family FailUnless (p :: Nat) (f :: Symbol) (a :: *) :: Constraint where
FailUnless 1 f a = ()
FailUnless n f a = TypeError
( 'Text "Type '" ':<>: 'ShowType a ':<>: 'Text "' has no field named "
':<>: 'ShowType f ':<>: 'Text ", in declaration of 'ExcludedFields "
':<>: 'ShowType a ':<>: 'Text "'."
)
type family FieldsOf a (xs :: [Symbol]) :: Constraint where
FieldsOf a (f ': fs) = (FailUnless (Member f (Rep a)) f a, FieldsOf a fs)
FieldsOf a '[] = ()
class GConfigurable f where
gUpdate :: [String] -> SectionName -> Maybe Key -> Ini -> f a -> f a
gUpdIni :: [String] -> SectionName -> Maybe Key -> f a -> Ini -> Ini
class SymList (a :: [Symbol]) where
lower :: [String]
instance (KnownSymbol x, SymList xs) => SymList (x ': xs) where
lower = symbolVal (Proxy @x) : lower @xs
instance SymList '[] where
lower = []
instance (GConfigurable f, Selector c) => GConfigurable (M1 S c f) where
gUpdate exclude s _ ini (M1 m)
| sel `elem` exclude = M1 $ gUpdate exclude s Nothing ini m
| otherwise = M1 $ gUpdate exclude s (Just (Key s sel)) ini m
where sel = selName (undefined :: M1 s c f a)
gUpdIni exclude s _ (M1 m)
| sel `elem` exclude = gUpdIni exclude s Nothing m
| otherwise = gUpdIni exclude s (Just (Key s sel)) m
where sel = selName (undefined :: M1 s c f a)
instance {-# OVERLAPPABLE #-} GConfigurable f => GConfigurable (M1 i c f) where
gUpdate e s key ini (M1 m) = M1 $ gUpdate e s key ini m
gUpdIni e s k (M1 m) = gUpdIni e s k m
instance IniValue a => GConfigurable (K1 i a) where
gUpdate _ _ (Just key) ini k@(K1 _) = maybe k K1 (get ini key)
gUpdate _ _ _ _ k = k
gUpdIni _ _ (Just key) (K1 x) ini = set ini key x
gUpdIni _ _ _ _ ini = ini
instance (GConfigurable a, GConfigurable b) => GConfigurable (a :*: b) where
gUpdate e s _ ini (a:*:b) = gUpdate e s Nothing ini a :*: gUpdate e s Nothing ini b
gUpdIni e s _ (a:*:b) = gUpdIni e s Nothing b . gUpdIni e s Nothing a