libconfig 0.2.0.0 → 0.3.0.0
raw patch · 7 files changed
+608/−164 lines, 7 filesdep +transformers-compat
Dependencies added: transformers-compat
Files
- libconfig.cabal +25/−14
- src/Language/Libconfig.hs +5/−8
- src/Language/Libconfig/Bindings.chs +22/−7
- src/Language/Libconfig/Decode.hs +176/−45
- src/Language/Libconfig/Encode.hs +180/−68
- src/Language/Libconfig/Optics.hs +42/−10
- src/Language/Libconfig/Types.hs +158/−12
libconfig.cabal view
@@ -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 <http://www.hyperrealm.com/libconfig/ libconfig> 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 <mpeddie@gmail.com> 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
src/Language/Libconfig.hs view
@@ -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
src/Language/Libconfig/Bindings.chs view
@@ -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 =
src/Language/Libconfig/Decode.hs view
@@ -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 -> "<no name>"+ 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
src/Language/Libconfig/Encode.hs view
@@ -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 -> "<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 (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
src/Language/Libconfig/Optics.hs view
@@ -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
src/Language/Libconfig/Types.hs view
@@ -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.