diff --git a/libconfig.cabal b/libconfig.cabal --- a/libconfig.cabal +++ b/libconfig.cabal @@ -1,23 +1,26 @@ name: libconfig -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Haskell bindings to libconfig description: Low-level FFI bindings to the configuration file library. . - This binding is very low-level at the moment, but higher-level safe - interfaces are planned. - . This library only binds to version 1.4.9 of the libconfig library, which is known as @libconfig9@ in Debian-like distributions, including Ubuntu. It will not work with older versions of libconfig, including the @libconfig8@ distributed in Ubuntu 12.04. + . + See below for several flags you can use to reduce + dependencies if this is a problem for you. If you disable + everything, this package will only depend on + @transformers@, @text@, @hashable@ and @deepseq@. license: BSD3 license-file: LICENSE author: Matthew Peddie maintainer: mpeddie@gmail.com +homepage: https://github.com/peddie/libconfig-haskell copyright: 2015 Matthew Peddie category: Language build-type: Simple @@ -25,30 +28,30 @@ source-repository head type: git - location: git@github.com/peddie/libconfig-haskell + location: https://github.com/peddie/libconfig-haskell flag prisms - description: Build prisms along with lenses (adds a dependency on @profunctors@). + description: Build prisms along with lenses (adds a + dependency on the 'profunctors' package). . - If tests are enabled, this also adds a - dependency on @lens@ for the test suite. + If tests are enabled, this flag also adds a + dependency on 'lens' for the test suite. . - If this flag is disabled, no lens tests will be - run. This is suboptimal but simpler than adding - another cabal flag. + If this flag is disabled, no tests for + Language.Libconfig.Optics will be run at all. default: True flag binary description: Provide instances for Data.Binary.Binary from - the @binary@ package. This is done by Generics + the 'binary' package. This is done by Generics and will not work on GHCs older than 7.8, - because they are pinned to binary version 0.5 or + because they ship with binary version 0.5 or older. default: True flag cereal description: Provide instances for Data.Serialize.Serialize - from the @cereal@ package + from the 'cereal' package. default: True library @@ -66,6 +69,7 @@ , hashable >= 1.2 && < 1.3 , deepseq >= 1.3 , transformers >= 0.3 + , transformers-compat >= 0.3 , profunctors >= 4 && < 5 , binary >= 0.5 && < 0.8 , text-binary >= 0.1 @@ -79,6 +83,7 @@ , hashable >= 1.2 && < 1.3 , deepseq >= 1.3 , transformers >= 0.3 + , transformers-compat >= 0.3 , profunctors >= 4 && < 5 , binary >= 0.5 && < 0.8 , text-binary >= 0.1 @@ -90,6 +95,7 @@ , hashable >= 1.2 && < 1.3 , deepseq >= 1.3 , transformers >= 0.3 + , transformers-compat >= 0.3 , profunctors >= 4 && < 5 , cereal >= 0.4 && < 0.5 , cereal-text >= 0.1 @@ -101,6 +107,7 @@ , hashable >= 1.2 && < 1.3 , deepseq >= 1.3 , transformers >= 0.3 + , transformers-compat >= 0.3 , binary >= 0.5 && < 0.8 , text-binary >= 0.1 , cereal >= 0.4 && < 0.5 @@ -113,6 +120,7 @@ , hashable >= 1.2 && < 1.3 , deepseq >= 1.3 , transformers >= 0.3 + , transformers-compat >= 0.3 , profunctors >= 4 && < 5 cpp-options: -DDEFINE_PRISMS else @@ -122,6 +130,7 @@ , hashable >= 1.2 && < 1.3 , deepseq >= 1.3 , transformers >= 0.3 + , transformers-compat >= 0.3 , binary >= 0.5 && < 0.8 , text-binary >= 0.1 cpp-options: -DBINARY_INSTANCES @@ -132,6 +141,7 @@ , hashable >= 1.2 && < 1.3 , deepseq >= 1.3 , transformers >= 0.3 + , transformers-compat >= 0.3 , cereal >= 0.4 && < 0.5 , cereal-text >= 0.1 cpp-options: -DCEREAL_INSTANCES @@ -141,6 +151,7 @@ , hashable >= 1.2 && < 1.3 , deepseq >= 1.3 , transformers >= 0.3 + , transformers-compat >= 0.3 hs-source-dirs: src diff --git a/src/Language/Libconfig.hs b/src/Language/Libconfig.hs --- a/src/Language/Libconfig.hs +++ b/src/Language/Libconfig.hs @@ -24,13 +24,10 @@ -} module Language.Libconfig ( - module Language.Libconfig.Types - , module Language.Libconfig.Decode - , module Language.Libconfig.Encode - , module Language.Libconfig.Optics + module L ) where -import Language.Libconfig.Types -import Language.Libconfig.Decode -import Language.Libconfig.Encode -import Language.Libconfig.Optics +import Language.Libconfig.Types as L +import Language.Libconfig.Decode as L +import Language.Libconfig.Encode as L +import Language.Libconfig.Optics as L diff --git a/src/Language/Libconfig/Bindings.chs b/src/Language/Libconfig/Bindings.chs --- a/src/Language/Libconfig/Bindings.chs +++ b/src/Language/Libconfig/Bindings.chs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-| Module : Language.Libconfig.Bindings @@ -160,6 +162,10 @@ import Control.Monad ((>=>)) import Control.Applicative +import Data.Data (Data) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + -- $setup -- -- All the examples run on the included test file @test/test.conf@, @@ -220,6 +226,7 @@ -- tries to read in a config file. {#enum config_error_t as ConfigErr {underscoreToCase} deriving (Show, Eq) #} + -- | This is a set of possible @libconfig@ types. Many functions will -- return 'Nothing' if you attempt to use a value as the incorrect -- type. See the @libconfig@ manual for more details. @@ -232,7 +239,7 @@ | BoolType | ArrayType | ListType - deriving (Eq, Show, Read, Ord, Enum, Bounded) + deriving (Eq, Show, Read, Ord, Enum, Bounded, Data, Typeable, Generic) -- | Tells whether a 'ConfigType' value is a collection ('ListType', -- 'ArrayType' or 'GroupType'). @@ -275,11 +282,11 @@ -- and the @libconfig@ manual. data ConfigFormat = DefaultFormat | HexFormat - deriving (Eq, Show, Read, Ord, Enum, Bounded) + deriving (Eq, Show, Read, Ord, Enum, Bounded, Data, Typeable, Generic) data ConfigBool = ConfigFalse | ConfigTrue - deriving (Eq, Show, Read, Ord, Enum, Bounded) + deriving (Eq, Show, Read, Ord, Enum, Bounded, Data, Typeable, Generic) {#pointer *config_list_t as ConfigListPtr -> ConfigList #} @@ -1092,15 +1099,23 @@ configSettingSourceFile :: Setting -> IO String configSettingSourceFile (Setting s) = peek s >>= peekCString . file'Setting -configErrorFile :: Configuration -> IO String +configErrorFile :: Configuration -> IO (Maybe String) configErrorFile c = withConfiguration c $ - \p -> peek p >>= peekCString . error_file'Config + \p -> do + filePtr <- error_file'Config <$> peek p + if filePtr == nullPtr + then return Nothing + else Just <$> peekCString filePtr -configErrorText :: Configuration -> IO String +configErrorText :: Configuration -> IO (Maybe String) configErrorText c = withConfiguration c $ - \p -> peek p >>= peekCString . error_text'Config + \p -> do + textPtr <- error_text'Config <$> peek p + if textPtr == nullPtr + then return Nothing + else Just <$> peekCString textPtr configErrorLine :: Configuration -> IO Int configErrorLine = diff --git a/src/Language/Libconfig/Decode.hs b/src/Language/Libconfig/Decode.hs --- a/src/Language/Libconfig/Decode.hs +++ b/src/Language/Libconfig/Decode.hs @@ -1,4 +1,7 @@ {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} {-| Module : Language.Libconfig.Decode @@ -18,96 +21,224 @@ -- * Decoding libconfig native data decode , decodeFrom + -- * Decoding errors + , DecodeError(..) ) where import Control.Applicative import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader +import Data.Data (Data) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) + import qualified Data.Text as T (pack) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import Language.Libconfig.Types -import Language.Libconfig.Bindings (ConfigType(..)) +import Language.Libconfig.Bindings (ConfigType(..), ConfigFormat(..)) import qualified Language.Libconfig.Bindings as C --- TODO(MP): Properly convert integral types depending on the setting --- format. +-- | Any of these problems can occur while decoding a @libconfig@ +-- 'C.Configuration'. +data DecodeError = DecoderRoot -- ^ No root setting was found (possibly this + -- configuration is invalid?) + | Name { + decodeErrSetting :: Text -- ^ This setting had no name + -- but was in a 'Group'. + } + | GetNone { + decodeErrSetting :: Text -- ^ This setting was of type + -- 'NoneType', but it should + -- have a type. + } + | GetIndex { + decodeErrParent :: Text -- ^ Failed to get a child of + -- this 'C.Setting' + , decodeErrIndex :: Int -- ^ This was the index we + -- tried to look up + } + | Parse { + decodeErrFilename :: Text -- ^ The file in which + -- parsing failed + , decodeErrLine :: Word32 -- ^ The line of the file on + -- which parsing failed + , decodeErrDescription :: Text -- ^ @libconfig@'s description + -- of the parsing failure + } + | FileInput { + decodeErrFilename :: Text -- ^ Failed to open this file + } deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) -toScalar :: C.Setting -> MaybeT IO Scalar -toScalar s = MaybeT $ C.configSettingType s >>= go +instance NFData DecodeError + +withErr :: Maybe a -> e -> Either e a +withErr Nothing e = Left e +withErr (Just x) _ = Right x + +decoder :: IO (Either DecodeError a) -> Decoder a +decoder = lift . ExceptT + +throw :: DecodeError -> Decoder a +throw = lift . throwE + +catchD :: (DecodeError -> ExceptT DecodeError IO a) -> Decoder a -> Decoder a +catchD handler action = + ReaderT $ \conf -> catchE (runReaderT action conf) handler + +type Decoder a = ReaderT ConfigFormat (ExceptT DecodeError IO) a + +textToNameErr :: Text -> Name +textToNameErr text = fromMaybe err $ textToName text where - go :: ConfigType -> IO (Maybe Scalar) - go IntType = Just . Integer . fromIntegral <$> C.configSettingGetInt s - go Int64Type = Just . Integer64 . fromIntegral <$> C.configSettingGetInt64 s - go FloatType = Just . Float <$> C.configSettingGetFloat s - go BoolType = Just . Boolean <$> C.configSettingGetBool s - go StringType = Just . String . T.pack <$> C.configSettingGetString s - go _ = return Nothing + err = error $ "Language.Libconfig.Decode.textToNameErr: " ++ + "C library passed an invalid 'Name' value " ++ show text ++ "!" -toList :: C.Setting -> MaybeT IO List -toList s = liftIO (C.configSettingType s) >>= go +toScalar :: C.Setting -> Decoder Scalar +toScalar s = do + ty <- liftIO $ C.configSettingType s + localFormat <- liftIO $ C.configSettingGetFormat s + format <- case localFormat of + HexFormat -> return HexFormat + DefaultFormat -> ask + decoder $ go format ty where - go :: ConfigType -> MaybeT IO List + go :: ConfigFormat -> ConfigType -> IO (Either DecodeError Scalar) + go DefaultFormat IntType = + Right . Integer . fromIntegral <$> C.configSettingGetInt s + go DefaultFormat Int64Type = + Right . Integer64 . fromIntegral <$> C.configSettingGetInt64 s + go HexFormat IntType = + Right . Hex . fromIntegral <$> C.configSettingGetInt s + go HexFormat Int64Type = + Right . Hex64 . fromIntegral <$> C.configSettingGetInt64 s + go _ FloatType = Right . Float <$> C.configSettingGetFloat s + go _ BoolType = Right . Boolean <$> C.configSettingGetBool s + go _ StringType = Right . String . T.pack <$> C.configSettingGetString s + go _ t = + error $ "Language.Libconfig.Decode.toScalar: internal error (bug!): expected " ++ + "a type in [IntType, Int64Type, FloatType, BoolType, StringType], but got '" ++ + show t ++ "'!" + +toList :: C.Setting -> Decoder List +toList s = do + ty <- liftIO $ C.configSettingType s + addParent s $ go ty + where go ListType = do l <- liftIO $ C.configSettingLength s - mapM (\i -> MaybeT (C.configSettingGetElem s i) >>= toValue) [0 .. l - 1] - go _ = MaybeT $ return Nothing + mapM get [0 .. l - 1] + go ty = + error $ "Language.Libconfig.Decode.toList: internal error (bug!): expected " ++ + "a value with 'ListType', but got '" ++ show ty ++ "'!" + get :: Int -> Decoder Value + get i = do + el <- decoder $ (`withErr` GetIndex "" i) <$> C.configSettingGetElem s i + toValue el -toArray :: C.Setting -> MaybeT IO Array -toArray s = liftIO (C.configSettingType s) >>= go +toArray :: C.Setting -> Decoder Array +toArray s = addParent s $ liftIO (C.configSettingType s) >>= go where - go :: ConfigType -> MaybeT IO Array go ArrayType = do l <- liftIO $ C.configSettingLength s - mapM (\i -> MaybeT (C.configSettingGetElem s i) >>= toScalar) [0 .. l - 1] - go _ = MaybeT $ return Nothing + mapM get [0 .. l - 1] + go ty = + error $ "Language.Libconfig.Decode.toArray: internal error (bug!): expected " ++ + "a value with 'ArrayType', but got '" ++ show ty ++ "'!" + get i = do + el <- decoder $ (`withErr` GetIndex "" i) <$> C.configSettingGetElem s i + toScalar el -toGroup :: C.Setting -> MaybeT IO Group -toGroup s = liftIO (C.configSettingType s) >>= go +toGroup :: C.Setting -> Decoder Group +toGroup s = addParent s $ liftIO (C.configSettingType s) >>= go where - go :: ConfigType -> MaybeT IO Group go GroupType = do l <- liftIO $ C.configSettingLength s - mapM (\i -> MaybeT (C.configSettingGetElem s i) >>= decodeSetting) [0 .. l - 1] - go _ = MaybeT $ return Nothing + mapM get [0 .. l - 1] + go ty = + error $ "Language.Libconfig.Decode.toGroup: internal error (bug!): expected " ++ + "a value with 'GroupType', but got '" ++ show ty ++ "'!" + get i = do + el <- decoder $ (`withErr` GetIndex "" i) <$> C.configSettingGetElem s i + decodeSetting el -toValue :: C.Setting -> MaybeT IO Value -toValue s = liftIO (C.configSettingType s) >>= go +toValue :: C.Setting -> Decoder Value +toValue s = addParent s $ liftIO (C.configSettingType s) >>= go where - go :: ConfigType -> MaybeT IO Value - go NoneType = MaybeT $ return Nothing + go NoneType = throw $ GetNone "" go ListType = List <$> toList s go ArrayType = Array <$> toArray s go GroupType = Group <$> toGroup s go _ = Scalar <$> toScalar s -decodeSetting :: C.Setting -> MaybeT IO Setting -decodeSetting s = liftIO (C.configSettingType s) >>= go +addParent :: C.Setting -> Decoder a -> Decoder a +addParent s = catchD handler where - go NoneType = MaybeT $ return Nothing + mapSetting _ e@(Parse{}) = e + mapSetting _ e@(FileInput _) = e + mapSetting f (GetIndex p i) = GetIndex (f p) i + mapSetting f e = e { decodeErrSetting = f (decodeErrSetting e) } + handler e = do + name <- liftIO $ getName s + throwE $ mapSetting ((name <> ".") <>) e + +getName :: C.Setting -> IO Text +getName s = do + name <- C.configSettingName s + return $ case name of + Nothing -> "" + Just x -> T.pack x + +decodeSetting :: C.Setting -> Decoder Setting +decodeSetting s = addParent s $ liftIO (C.configSettingType s) >>= go + where + go NoneType = throw $ GetNone "" go _ = - (:=) <$> fmap T.pack (MaybeT $ C.configSettingName s) <*> toValue s + (:=) <$> + fmap (textToNameErr . T.pack) + (decoder $ (`withErr` Name "") <$> C.configSettingName s) <*> + toValue s -- | Convert a native 'C.Configuration' into a top-level 'Group' of -- 'Setting's. -- -- >>> Just conf <- C.configNew "test/test.conf" -- >>> decode conf --- Just ["version" := Scalar (String "1.0"),"application" := Group ["window" := Group ["title" := Scalar (String "My Application"),"size" := Group ["w" := Scalar (Integer 640),"h" := Scalar (Integer 480)],"pos" := Group ["x" := Scalar (Integer 350),"y" := Scalar (Integer 250)]],"list" := List [List [Scalar (String "abc"),Scalar (Integer 123),Scalar (Boolean True)],Scalar (Float 1.234),List []],"books" := List [Group ["title" := Scalar (String "Treasure Island"),"author" := Scalar (String "Robert Louis Stevenson"),"price" := Scalar (Float 29.95),"qty" := Scalar (Integer 5)],Group ["title" := Scalar (String "Snow Crash"),"author" := Scalar (String "Neal Stephenson"),"price" := Scalar (Float 9.99),"qty" := Scalar (Integer 8)]],"misc" := Group ["pi" := Scalar (Float 3.141592654),"bigint" := Scalar (Integer64 9223372036854775807),"columns" := Array [String "Last Name",String "First Name",String "MI"],"bitmask" := Scalar (Integer 8131)]]] -decode :: C.Configuration -> IO (Maybe Group) +-- Right ["version" := Scalar (String "1.0"),"application" := Group ["window" := Group ["title" := Scalar (String "My Application"),"size" := Group ["w" := Scalar (Integer 640),"h" := Scalar (Integer 480)],"pos" := Group ["x" := Scalar (Integer 350),"y" := Scalar (Integer 250)]],"list" := List [List [Scalar (String "abc"),Scalar (Integer 123),Scalar (Boolean True)],Scalar (Float 1.234),List []],"books" := List [Group ["title" := Scalar (String "Treasure Island"),"author" := Scalar (String "Robert Louis Stevenson"),"price" := Scalar (Float 29.95),"qty" := Scalar (Integer 5)],Group ["title" := Scalar (String "Snow Crash"),"author" := Scalar (String "Neal Stephenson"),"price" := Scalar (Float 9.99),"qty" := Scalar (Integer 8)]],"misc" := Group ["pi" := Scalar (Float 3.141592654),"bigint" := Scalar (Integer64 9223372036854775807),"columns" := Array [String "Last Name",String "First Name",String "MI"],"bitmask" := Scalar (Hex 8131)]]] +decode :: C.Configuration -> IO (Either DecodeError Group) decode c = do - res <- runMaybeT $ MaybeT (C.configRootSetting c) >>= toGroup + format <- C.configGetDefaultFormat c + res <- runExceptT $ runReaderT (getRoot c >>= toGroup) format C.touchConfiguration c return res + where + getRoot cnf = decoder $ (`withErr` DecoderRoot) <$> C.configRootSetting cnf -- | Load the libconfig configuration file at the given path and try -- to convert it to a top-level 'Group' of 'Setting's. -- -- >>> decodeFrom "test/test.conf" --- Just ["version" := Scalar (String "1.0"),"application" := Group ["window" := Group ["title" := Scalar (String "My Application"),"size" := Group ["w" := Scalar (Integer 640),"h" := Scalar (Integer 480)],"pos" := Group ["x" := Scalar (Integer 350),"y" := Scalar (Integer 250)]],"list" := List [List [Scalar (String "abc"),Scalar (Integer 123),Scalar (Boolean True)],Scalar (Float 1.234),List []],"books" := List [Group ["title" := Scalar (String "Treasure Island"),"author" := Scalar (String "Robert Louis Stevenson"),"price" := Scalar (Float 29.95),"qty" := Scalar (Integer 5)],Group ["title" := Scalar (String "Snow Crash"),"author" := Scalar (String "Neal Stephenson"),"price" := Scalar (Float 9.99),"qty" := Scalar (Integer 8)]],"misc" := Group ["pi" := Scalar (Float 3.141592654),"bigint" := Scalar (Integer64 9223372036854775807),"columns" := Array [String "Last Name",String "First Name",String "MI"],"bitmask" := Scalar (Integer 8131)]]] -decodeFrom :: String -> IO (Maybe Group) +-- Right ["version" := Scalar (String "1.0"),"application" := Group ["window" := Group ["title" := Scalar (String "My Application"),"size" := Group ["w" := Scalar (Integer 640),"h" := Scalar (Integer 480)],"pos" := Group ["x" := Scalar (Integer 350),"y" := Scalar (Integer 250)]],"list" := List [List [Scalar (String "abc"),Scalar (Integer 123),Scalar (Boolean True)],Scalar (Float 1.234),List []],"books" := List [Group ["title" := Scalar (String "Treasure Island"),"author" := Scalar (String "Robert Louis Stevenson"),"price" := Scalar (Float 29.95),"qty" := Scalar (Integer 5)],Group ["title" := Scalar (String "Snow Crash"),"author" := Scalar (String "Neal Stephenson"),"price" := Scalar (Float 9.99),"qty" := Scalar (Integer 8)]],"misc" := Group ["pi" := Scalar (Float 3.141592654),"bigint" := Scalar (Integer64 9223372036854775807),"columns" := Array [String "Last Name",String "First Name",String "MI"],"bitmask" := Scalar (Hex 8131)]]] +decodeFrom :: String -> IO (Either DecodeError Group) decodeFrom filename = do - c <- C.configNew filename - case c of - Just conf -> decode conf - Nothing -> return Nothing + c <- C.configInit + red <- C.configReadFile c filename + case red of + Nothing -> do + ty <- C.configErrorType c + fn <- maybe (T.pack filename) T.pack <$> C.configErrorFile c + case ty of + C.ConfigErrFileIo -> return . Left $ FileInput fn + C.ConfigErrParse -> do + err <- Parse fn <$> + (fromIntegral <$> C.configErrorLine c) <*> + (maybe "" T.pack <$> C.configErrorText c) + return $ Left err + _ -> + error "Language.Libconfig.Decode.decodeFrom: something is really broken!" + Just _ -> decode c diff --git a/src/Language/Libconfig/Encode.hs b/src/Language/Libconfig/Encode.hs --- a/src/Language/Libconfig/Encode.hs +++ b/src/Language/Libconfig/Encode.hs @@ -1,4 +1,7 @@ {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} {-| Module : Language.Libconfig.Encode @@ -15,132 +18,241 @@ -} module Language.Libconfig.Encode ( + -- $setup + -- * Encoding libconfig native data encode , encodeAt , encodeValue , encodeTo - -- * Helpers + -- * Encoding errors + , EncodeError(..) + -- * Helpers , 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 (guard, replicateM_) +import Control.Monad.Trans.Except +import Control.Monad (when, replicateM_) -import qualified Data.Text as T (unpack) +import qualified Data.Text as T (unpack, pack, empty) +import Data.Monoid ((<>)) import Language.Libconfig.Types -import Language.Libconfig.Bindings (ConfigType(..)) +import Language.Libconfig.Bindings (ConfigType(..), ConfigFormat(..)) import qualified Language.Libconfig.Bindings as C -- $setup +-- To run these usage examples, you must tell GHC it's allowed to +-- parse string literals as 'Text' values: +-- -- >>> :set -XOverloadedStrings --- >>> let test = ["version" := Scalar (String "1.0"),"application" := Group ["window" := Group ["title" := Scalar (String "My Application"),"size" := Group ["w" := Scalar (Integer 640),"h" := Scalar (Integer 480)],"pos" := Group ["x" := Scalar (Integer 350),"y" := Scalar (Integer 250)]],"list" := List [List [Scalar (String "abc"),Scalar (Integer 123),Scalar (Boolean True)],Scalar (Float 1.234),List []],"books" := List [Group ["title" := Scalar (String "Treasure Island"),"author" := Scalar (String "Robert Louis Stevenson"),"price" := Scalar (Float 29.95),"qty" := Scalar (Integer 5)],Group ["title" := Scalar (String "Snow Crash"),"author" := Scalar (String "Neal Stephenson"),"price" := Scalar (Float 9.99),"qty" := Scalar (Integer 8)]],"misc" := Group ["pi" := Scalar (Float 3.141592654),"bigint" := Scalar (Integer64 9223372036854775807),"columns" := Array [String "Last Name",String "First Name",String "MI"],"bitmask" := Scalar (Integer 8131)]]] - --- | Compute the 'C.ConfigType' of a 'Value' -- --- >>> valueType (Scalar (String "butts")) --- StringType --- >>> valueType (Array [String "butts"]) --- ArrayType -valueType :: Value -> ConfigType -valueType (Scalar s) = scalarType s -valueType (Array _) = ArrayType -valueType (List _) = ListType -valueType (Group _) = GroupType - --- | Compute the 'C.ConfigType' of a 'Scalar' +-- We also pre-define the @test@ 'Group' to be the example from the +-- @libconfig@ manual. -- --- >>> scalarType (String "butts") --- StringType --- >>> scalarType (Boolean False) --- BoolType -scalarType :: Scalar -> ConfigType -scalarType (Boolean _) = BoolType -scalarType (Integer _) = IntType -scalarType (Hex _) = IntType -scalarType (Integer64 _) = Int64Type -scalarType (Hex64 _) = Int64Type -scalarType (Float _) = FloatType -scalarType (String _) = StringType +-- >>> let Just [version, application, window, title, size, w, h, pos, x, y, list, books, author, price, qty, misc, pi, columns, bigint, bitmask] = mapM textToName ["version", "application", "window", "title", "size", "w", "h", "pos", "x", "y", "list", "books", "author", "price", "qty", "misc", "pi", "columns", "bigint", "bitmask"] +-- >>> let test = [version := Scalar (String "1.0"),application := Group [window := Group [title := Scalar (String "My Application"),size := Group [w := Scalar (Integer 640),h := Scalar (Integer 480)],pos := Group [x := Scalar (Integer 350),y := Scalar (Integer 250)]],list := List [List [Scalar (String "abc"),Scalar (Integer 123),Scalar (Boolean True)],Scalar (Float 1.234),List []],books := List [Group [title := Scalar (String "Treasure Island"),author := Scalar (String "Robert Louis Stevenson"),price := Scalar (Float 29.95),qty := Scalar (Integer 5)],Group [title := Scalar (String "Snow Crash"),author := Scalar (String "Neal Stephenson"),price := Scalar (Float 9.99),qty := Scalar (Integer 8)]],misc := Group [pi := Scalar (Float 3.141592654),bigint := Scalar (Integer64 9223372036854775807),columns := Array [String "Last Name",String "First Name",String "MI"],bitmask := Scalar (Hex 8131)]]] -scalarSet :: C.Setting -> Scalar -> MaybeT IO () -scalarSet sp = MaybeT . go +-- | Any of these problems can occur while encoding a @libconfig@ +-- 'C.Configuration'. +data EncodeError = EncoderRoot -- ^ No root setting was found + -- (possibly this configuration is + -- invalid?) + | TypeMismatch { + encodeErrSetting :: Text -- ^ The Haskell structure contained + -- invalid libconfig types for this setting. + } + | FileOutput { + encodeErrFilename :: Text -- ^ Failed to open this file + } + | AddSetting { + encodeErrParent :: Text -- ^ Failed to create a new 'C.Setting' + , encodeErrValue :: Value -- ^ This was the value we + -- were making a spot for + } + | RemoveOldValue { + encodeErrSetting :: Text -- ^ Failed to remove an old value + -- from this setting + } + | SetValue { + encodeErrSetting :: Text -- ^ Failed to assign a value + -- to this 'C.Setting' + , encodeErrValue :: Value -- ^ This was the value we + -- tried to assign + } + | SetIndex { + encodeErrParent :: Text -- ^ Failed to assign an element + -- within this collection + , encodeErrIndex :: Int -- ^ This is the index of the element + , encodeErrValue :: Value -- ^ This is the value we + -- tried to assign + } 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 -> "" + 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 (Hex h) = C.configSettingSetInt sp (fromIntegral h) - go (Hex64 h) = C.configSettingSetInt64 sp (fromIntegral h) 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 :: C.Setting -> Value -> MaybeT IO C.Setting -addValue parent value = do - newset <- MaybeT $ C.configSettingAdd parent "" (valueType value) - setValue newset value +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 -> MaybeT IO C.Setting -addSetting parent (name := value) = do - newset <- MaybeT $ C.configSettingAdd parent (T.unpack name) (valueType value) - setValue newset value - return newset +addSetting :: C.Setting -> Setting -> Encoder C.Setting +addSetting parent (name := value) = + addValue (nameToText name) parent value -setValue :: C.Setting -> Value -> MaybeT IO () +setValue :: C.Setting -> Value -> Encoder () setValue sp (Scalar s) = scalarSet sp s -setValue sp (Array a) = mapM_ (addValue sp . Scalar) a setValue sp (Group g) = mapM_ (addSetting sp) g -setValue sp (List l) = mapM_ (addValue sp) l +setValue sp (List l) = mapM_ (addValue "" sp) l +setValue sp (Array a) = + if arrayCheck a + then mapM_ (addValue "" sp . Scalar) a + else throwE $ TypeMismatch "" -- | Convert a top-level 'Group' of 'Setting's into a native -- 'C.Configuration'. This allocates a new 'C.Configuration'. -- --- >>> Just conf <- runMaybeT $ encode test +-- >>> Right conf <- encode test -- >>> C.configWriteFile conf "/tmp/encode_output_test.conf" -- Just () +-- -- >>> Just newconf <- C.configNew "/tmp/encode_output_test.conf" -encode :: Group -> MaybeT IO C.Configuration -encode g = do +encode :: Group -> IO (Either EncodeError C.Configuration) +encode g = runExceptT $ do conf <- liftIO C.configInit - encodeAt conf g + ExceptT $ encodeAt conf g return conf -- | Convert a top-level 'Group' of 'Setting's into a native -- libconfig structure and output it to the specified file path. -- --- >>> runMaybeT $ encodeTo test "/tmp/encode_output_test_2.conf" --- Just () --- >>> Just newconf <- C.configNew "/tmp/encode_output_test.conf" -encodeTo :: Group -> String -> MaybeT IO () -encodeTo g filename = do - c <- encode g - MaybeT $ C.configWriteFile c filename +-- >>> encodeTo test "/tmp/encode_output_test_2.conf" +-- Right () +-- +-- >>> Just newconf <- C.configNew "/tmp/encode_output_test_2.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 -- | Encode a top-level 'Group' of 'Setting's and write them to the -- specified 'C.Configuration'. -encodeAt :: C.Configuration -> Group -> MaybeT IO () -encodeAt conf g = do - root <- MaybeT $ C.configRootSetting conf +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 -> MaybeT IO () -checkType sp ty = do +checkType :: C.Setting -> C.ConfigType -> Encoder () +checkType sp ty = addTrace sp $ do ty' <- liftIO $ C.configSettingType sp - guard (ty == ty') + when (ty == ty') $ throwE $ TypeMismatch "" -removeKids :: C.Setting -> MaybeT IO () -removeKids sp = do +removeKids :: C.Setting -> Encoder () +removeKids sp = addTrace sp $ do count <- liftIO $ C.configSettingLength sp - replicateM_ count (MaybeT $ C.configSettingRemoveElem sp 0) + replicateM_ count (ExceptT $ (`withErr` RemoveOldValue "") <$> + C.configSettingRemoveElem sp 0) -- | Set the value of the given 'C.Setting' to the provided 'Value' -- (recursively). If this 'C.Setting' is of a collection type, any -- pre-existing children will be removed. -encodeValue :: C.Setting -> Value -> MaybeT IO () -encodeValue sp v = do +encodeValue :: C.Setting -> Value -> IO (Either EncodeError ()) +encodeValue sp v = runExceptT $ do checkType sp (valueType v) removeKids sp setValue sp v + +-- | Compute the 'C.ConfigType' of a 'Value' +-- +-- >>> valueType (Scalar (String "butts")) +-- StringType +-- +-- >>> valueType (Array [String "butts"]) +-- ArrayType +valueType :: Value -> ConfigType +valueType (Scalar s) = scalarType s +valueType (Array _) = ArrayType +valueType (List _) = ListType +valueType (Group _) = GroupType + +-- | Compute the 'C.ConfigType' of a 'Scalar' +-- +-- >>> scalarType (String "butts") +-- StringType +-- +-- >>> scalarType (Boolean False) +-- BoolType +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 diff --git a/src/Language/Libconfig/Optics.hs b/src/Language/Libconfig/Optics.hs --- a/src/Language/Libconfig/Optics.hs +++ b/src/Language/Libconfig/Optics.hs @@ -30,6 +30,7 @@ settingValue , settingName #ifdef DEFINE_PRISMS + , _nameText -- * 'Value' -- | @@ -90,32 +91,39 @@ -- >>> import Control.Lens -- >>> :set -XCPP -- >>> :set -DDEFINE_PRISMS +-- >>> let Just asset = textToName "asset" +-- >>> let Just price = textToName "price" #else -- $setup -- In order to run the usage examples in @ghci@, some setup is required: -- -- >>> :set -XOverloadedStrings -- >>> import Control.Lens +-- >>> let Just asset = textToName "asset" +-- >>> let Just price = textToName "price" #endif -- | --- >>> ("asset" := Scalar (String "butts")) ^. settingValue +-- >>> (asset := Scalar (String "butts")) ^. settingValue -- Scalar (String "butts") -- --- >>> ("asset" := Scalar (String "butts")) & settingValue .~ Scalar (Float 22.2) +-- >>> (asset := Scalar (String "butts")) & settingValue .~ Scalar (Float 22.2) -- "asset" := Scalar (Float 22.2) settingValue :: Lens' Setting Value settingValue f (name := value) = fmap (\value' -> name := value') (f value) -- | --- >>> ("asset" := Scalar (String "butts")) ^. settingName +-- >>> (asset := Scalar (String "butts")) ^. settingName -- "asset" -- --- >>> ("asset" := Scalar (String "butts")) & settingName .~ "shake" +-- >>> let Just shake = textToName "shake" +-- >>> (asset := Scalar (String "butts")) & settingName .~ shake -- "shake" := Scalar (String "butts") -settingName :: Lens' Setting Text -settingName f (name := value) = fmap (\name' -> name' := value) (f name) +settingName :: Lens' Setting Name +settingName f (name := value) = fmap (:= value) (f name) + + #ifdef DEFINE_PRISMS type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) @@ -125,10 +133,34 @@ prism bt seta = dimap seta (either pure (fmap bt)) . right' -- | +-- Here is a 'Prism'' for accessing the string value of a 'Name'. +-- +-- >>> _nameText # asset +-- "asset" +-- +-- >>> "butts" ^? _nameText +-- Just "butts" +-- >>> :t ("butts" :: Text) ^? _nameText +-- ("butts" :: Text) ^? _nameText :: Maybe Name +-- +-- __N.B.__: '_nameText' is partial in the opposite direction to the +-- usual 'Prism's for sum types (e.g. @_Left@, @_Just@). This makes +-- it a bit puzzling to compose. We use @re _nameText@ with @view@: +-- +-- >>> (asset := Scalar (String "butts")) ^. settingName . re _nameText +-- "asset" +-- +-- I don't know how to get it to compose properly for setting. +_nameText :: Prism' Text Name +_nameText = prism nameToText $ \x -> case textToName x of + Nothing -> Left x + Just nm -> Right nm + +-- | -- >>> Scalar (String "butts") ^? _Scalar -- Just (String "butts") -- --- >>> ("asset" := Scalar (String "butts")) & settingValue . _Scalar . _String .~ "money" +-- >>> (asset := Scalar (String "butts")) & settingValue . _Scalar . _String .~ "money" -- "asset" := Scalar (String "money") -- -- >>> _Scalar # String "butts" @@ -142,7 +174,7 @@ -- >>> Array [String "butts"] ^? _Array -- Just [String "butts"] -- --- >>> ("asset" := Array [String "butts"]) & settingValue . _Array . traverse . _String .~ "money" +-- >>> (asset := Array [String "butts"]) & settingValue . _Array . traverse . _String .~ "money" -- "asset" := Array [String "money"] _Array :: Prism' Value Array _Array = prism Array $ \x -> case x of @@ -150,10 +182,10 @@ _ -> Left x -- | --- >>> Group ["asset" := Scalar (String "butts"), "price" := Scalar (Float 22.2)] ^? _Group . ix 0 +-- >>> Group [asset := Scalar (String "butts"), price := Scalar (Float 22.2)] ^? _Group . ix 0 -- Just ("asset" := Scalar (String "butts")) -- --- >>> Group ["asset" := Scalar (String "butts"), "price" := Scalar (Float 22.2)] & _Group . traverse . settingValue . _Scalar . _Float %~ (*2) +-- >>> Group [asset := Scalar (String "butts"), price := Scalar (Float 22.2)] & _Group . traverse . settingValue . _Scalar . _Float %~ (*2) -- Group ["asset" := Scalar (String "butts"),"price" := Scalar (Float 44.4)] _Group :: Prism' Value Group _Group = prism Group $ \x -> case x of diff --git a/src/Language/Libconfig/Types.hs b/src/Language/Libconfig/Types.hs --- a/src/Language/Libconfig/Types.hs +++ b/src/Language/Libconfig/Types.hs @@ -24,7 +24,10 @@ -- $setup -- * Primitive types - Setting(..) + Name + , nameToText + , textToName + , Setting(..) , getSettingName , getSettingValue , Value(..) @@ -34,6 +37,13 @@ , isGroup , isList , Scalar(..) + , isBoolean + , isInteger + , isInteger64 + , isHex + , isHex64 + , isFloat + , isString -- * Collection types , Array , List @@ -50,10 +60,16 @@ import Data.Data (Data) import Data.Typeable (Typeable) -import Data.Text (Text) import Data.Hashable (Hashable) import Control.DeepSeq (NFData) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Monoid ((<>)) + +import Control.Monad (guard) +import Data.Maybe (isJust) + #ifdef BINARY_INSTANCES import Data.Binary (Binary) import Data.Text.Binary () @@ -73,22 +89,75 @@ -- -- >>> :set -XOverloadedStrings + +-- | A @libconfig@ 'Name' is a string of restricted form. It must +-- match the regular expression @[A-Za-z\*][-A-Za-z0-9_\*]*@. +newtype Name = Name { getName :: Text } + deriving (Eq, Ord, Data, Typeable, Generic) + +instance Show Name where + show (Name text) = show text + +instance Read Name where + readsPrec p str = do + (x, moar) <- readsPrec p str + guard (isJust $ textToName x) + return (Name x, moar) + +instance Hashable Name +instance NFData Name + +-- | Convert a 'Text' string to a 'Name'. +-- +-- >>> textToName "robert" +-- Just "robert" +-- +-- >>> textToName "Obi-wan" +-- Just "Obi-wan" +-- +-- If the given string does not match the restrictions on the form of +-- 'Name's, then 'Nothing' is returned. +-- +-- >>> textToName "" +-- Nothing +-- +-- >>> textToName "0bi-wan" +-- Nothing +textToName :: Text -> Maybe Name +textToName t + | t == T.empty = Nothing + | hd `T.isInfixOf` nameFirstLetters && + T.all (\c -> T.singleton c `T.isInfixOf` nameLetters) tl = Just $ Name t + | otherwise = Nothing + where + (hd, tl) = T.splitAt 1 t + nameFirstLetters = T.pack $ ['a'..'z'] ++ ['A'..'Z'] ++ "*" + nameLetters = nameFirstLetters <> T.pack ('_' : '-' : ['0'..'9']) + +-- | Convert a 'Name' to 'Text' +-- +-- >>> let Just robert = textToName "robert" +-- >>> nameToText robert +-- "robert" +nameToText :: Name -> Text +nameToText = getName + infixr 3 := -- | A @libconfig@ 'Setting' is a name-value pair, @name := value@. -data Setting = !Text := !Value +data Setting = !Name := !Value deriving (Eq, Show, Read, Ord, Data, Typeable, Generic) +instance Hashable Setting where +instance NFData Setting where + -- | Get out the name of a 'Setting' -getSettingName :: Setting -> Text +getSettingName :: Setting -> Name getSettingName (n := _) = n -- | Get out the value of a 'Setting' getSettingValue :: Setting -> Value getSettingValue (_ := v) = v -instance Hashable Setting where -instance NFData Setting where - -- | A libconfig 'Value' is either a 'Scalar' value or some type of -- collection. data Value = Scalar !Scalar @@ -97,6 +166,9 @@ | Group !Group deriving (Eq, Show, Read, Ord, Data, Typeable, Generic) +instance Hashable Value where +instance NFData Value where + -- | -- >>> isScalar $ Scalar (String "butts") -- True @@ -141,15 +213,13 @@ -- >>> isGroup $ Array [String "butts"] -- False -- --- >>> isGroup $ Group ["asset" := Scalar (String "butts")] +-- >>> let Just asset = textToName "asset" +-- >>> isGroup $ Group [asset := Scalar (String "butts")] -- True isGroup :: Value -> Bool isGroup (Group _) = True isGroup _ = False -instance Hashable Value where -instance NFData Value where - -- | A libconfig 'Scalar' value is a boolean value, a string or one of -- an assortment of numeric types. data Scalar = Boolean !Bool @@ -161,22 +231,98 @@ | String !Text deriving (Eq, Show, Read, Ord, Data, Typeable, Generic) +-- | +-- >>> isBoolean $ Boolean True +-- True +-- +-- >>> isBoolean $ Float 22.22 +-- False +isBoolean :: Scalar -> Bool +isBoolean (Boolean _) = True +isBoolean _ = False + +-- | +-- >>> isInteger $ Integer 19 +-- True +-- +-- >>> isInteger $ Float 22.22 +-- False +isInteger :: Scalar -> Bool +isInteger (Integer _) = True +isInteger _ = False + +-- | +-- >>> isInteger64 $ Integer64 22222222222 +-- True +-- +-- >>> isInteger64 $ Float 22.22 +-- False +isInteger64 :: Scalar -> Bool +isInteger64 (Integer64 _) = True +isInteger64 _ = False + +-- | +-- >>> isHex $ Hex 0x13 +-- True +-- +-- >>> isHex $ Float 22.22 +-- False +isHex :: Scalar -> Bool +isHex (Hex _) = True +isHex _ = False + + +-- | +-- >>> isHex64 $ Hex64 0x52c8c338e +-- True +-- +-- >>> isHex64 $ Float 22.22 +-- False +isHex64 :: Scalar -> Bool +isHex64 (Hex64 _) = True +isHex64 _ = False + +-- | +-- >>> isFloat $ Float 22.22 +-- True +-- +-- >>> isFloat $ Integer 19 +-- False +isFloat :: Scalar -> Bool +isFloat (Float _) = True +isFloat _ = False + +-- | +-- >>> isString $ String "BUTTS" +-- True +-- +-- >>> isString $ Float 22.22 +-- False +isString :: Scalar -> Bool +isString (String _) = True +isString _ = False + instance Hashable Scalar where instance NFData Scalar where #ifdef BINARY_INSTANCES +instance Binary Name instance Binary Setting instance Binary Value instance Binary Scalar #endif #ifdef CEREAL_INSTANCES +instance Serialize Name instance Serialize Setting instance Serialize Value instance Serialize Scalar #endif --- | libconfig 'Array's can contain any number 'Scalar' values. +-- | libconfig 'Array's can contain any number of 'Scalar' values. +-- These values must be of the same type. This is currently not +-- enforced by the data structure, and violating it may lead to +-- failures to encode. type Array = [Scalar] -- | libconfig 'List's can contain any number of 'Value's.