module Language.Libconfig.Encode (
encode
, encodeAt
, encodeValue
, encodeTo
, EncodeError(..)
, valueType
, scalarType
) where
import Control.Applicative
import Data.Data (Data)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Control.DeepSeq (NFData)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Except
import Control.Monad (when, replicateM_)
import qualified Data.Text as T (unpack, pack, empty)
import Data.Monoid ((<>))
import Language.Libconfig.Types
import Language.Libconfig.Bindings (ConfigType(..), ConfigFormat(..))
import qualified Language.Libconfig.Bindings as C
data EncodeError = EncoderRoot
| TypeMismatch {
encodeErrSetting :: Text
}
| FileOutput {
encodeErrFilename :: Text
}
| AddSetting {
encodeErrParent :: Text
, encodeErrValue :: Value
}
| RemoveOldValue {
encodeErrSetting :: Text
}
| SetValue {
encodeErrSetting :: Text
, encodeErrValue :: Value
}
| SetIndex {
encodeErrParent :: Text
, encodeErrIndex :: Int
, encodeErrValue :: Value
} deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)
instance NFData EncodeError
type Encoder a = ExceptT EncodeError IO a
withErr :: Maybe a -> e -> Either e a
withErr Nothing e = Left e
withErr (Just x) _ = Right x
addTrace :: C.Setting -> Encoder a -> Encoder a
addTrace s = flip catchE handler
where
mapSetting _ e@(FileOutput _) = e
mapSetting f (SetIndex p i v) = SetIndex (f p) i v
mapSetting f (AddSetting p v) = AddSetting (f p) v
mapSetting f e = e { encodeErrSetting = f (encodeErrSetting e) }
repair name path
| path == T.empty = name
| otherwise = name <> "." <> path
handler e = do
name <- liftIO $ getName s
throwE $ mapSetting (repair name) e
getName :: C.Setting -> IO Text
getName s = do
name <- C.configSettingName s
return $ case name of
Nothing -> "<no name>"
Just x -> T.pack x
scalarSet :: C.Setting -> Scalar -> Encoder ()
scalarSet sp v = addTrace sp $
ExceptT $ (`withErr` SetValue "" (Scalar v)) <$> go v
where
go (Boolean b) = C.configSettingSetBool sp b
go (Integer i) = C.configSettingSetInt sp (fromIntegral i)
go (Integer64 i) = C.configSettingSetInt64 sp i
go (Float f) = C.configSettingSetFloat sp f
go (String s) = C.configSettingSetString sp (T.unpack s)
go (Hex h) = runMaybeT $ do
MaybeT $ C.configSettingSetFormat sp HexFormat
MaybeT $ C.configSettingSetInt sp (fromIntegral h)
go (Hex64 h) = runMaybeT $ do
MaybeT $ C.configSettingSetFormat sp HexFormat
MaybeT $ C.configSettingSetInt64 sp (fromIntegral h)
addValue :: Text -> C.Setting -> Value -> Encoder C.Setting
addValue nm parent value = do
newset <- ExceptT $ (`withErr` AddSetting "" value) <$> add
addTrace newset $ setValue newset value
return newset
where
add = C.configSettingAdd parent (T.unpack nm) (valueType value)
addSetting :: C.Setting -> Setting -> Encoder C.Setting
addSetting parent (name := value) =
addValue (nameToText name) parent value
setValue :: C.Setting -> Value -> Encoder ()
setValue sp (Scalar s) = scalarSet sp s
setValue sp (Group g) = mapM_ (addSetting sp) g
setValue sp (List l) = mapM_ (addValue "" sp) l
setValue sp (Array a) =
if arrayCheck a
then mapM_ (addValue "" sp . Scalar) a
else throwE $ TypeMismatch ""
encode :: Group -> IO (Either EncodeError C.Configuration)
encode g = runExceptT $ do
conf <- liftIO C.configInit
ExceptT $ encodeAt conf g
return conf
encodeTo :: Group -> String -> IO (Either EncodeError ())
encodeTo g filename = runExceptT $ do
c <- ExceptT $ encode g
ExceptT $ (`withErr` FileOutput (T.pack filename)) <$>
C.configWriteFile c filename
encodeAt :: C.Configuration -> Group -> IO (Either EncodeError ())
encodeAt conf g = runExceptT $ do
root <- ExceptT $ (`withErr` EncoderRoot) <$> C.configRootSetting conf
setValue root (Group g)
checkType :: C.Setting -> C.ConfigType -> Encoder ()
checkType sp ty = addTrace sp $ do
ty' <- liftIO $ C.configSettingType sp
when (ty == ty') $ throwE $ TypeMismatch ""
removeKids :: C.Setting -> Encoder ()
removeKids sp = addTrace sp $ do
count <- liftIO $ C.configSettingLength sp
replicateM_ count (ExceptT $ (`withErr` RemoveOldValue "") <$>
C.configSettingRemoveElem sp 0)
encodeValue :: C.Setting -> Value -> IO (Either EncodeError ())
encodeValue sp v = runExceptT $ do
checkType sp (valueType v)
removeKids sp
setValue sp v
valueType :: Value -> ConfigType
valueType (Scalar s) = scalarType s
valueType (Array _) = ArrayType
valueType (List _) = ListType
valueType (Group _) = GroupType
scalarType :: Scalar -> ConfigType
scalarType (Boolean _) = BoolType
scalarType (Integer _) = IntType
scalarType (Hex _) = IntType
scalarType (Integer64 _) = Int64Type
scalarType (Hex64 _) = Int64Type
scalarType (Float _) = FloatType
scalarType (String _) = StringType
arrayCheck :: Array -> Bool
arrayCheck [] = True
arrayCheck (Boolean _:arr) = all isBoolean arr
arrayCheck (Integer _:arr) = all isInteger arr
arrayCheck (Integer64 _:arr) = all isInteger64 arr
arrayCheck (Hex _:arr) = all isHex arr
arrayCheck (Hex64 _:arr) = all isHex64 arr
arrayCheck (Float _:arr) = all isFloat arr
arrayCheck (String _:arr) = all isString arr