libconfig 0.1.0.0 → 0.2.0.0
raw patch · 9 files changed
+2083/−1042 lines, 9 filesdep +binarydep +cerealdep +cereal-text
Dependencies added: binary, cereal, cereal-text, deepseq, hashable, lens, profunctors, text, text-binary, transformers
Files
- libconfig.cabal +126/−8
- src/Language/Libconfig.chs +0/−1033
- src/Language/Libconfig.hs +36/−0
- src/Language/Libconfig/Bindings.chs +1114/−0
- src/Language/Libconfig/Decode.hs +113/−0
- src/Language/Libconfig/Encode.hs +146/−0
- src/Language/Libconfig/Optics.hs +253/−0
- src/Language/Libconfig/Types.hs +283/−0
- test/doctest.hs +12/−1
libconfig.cabal view
@@ -1,5 +1,5 @@ name: libconfig-version: 0.1.0.0+version: 0.2.0.0 synopsis: Haskell bindings to libconfig description: Low-level FFI bindings to the <http://www.hyperrealm.com/libconfig/ libconfig>@@ -8,7 +8,6 @@ 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@@ -28,11 +27,122 @@ type: git location: git@github.com/peddie/libconfig-haskell +flag prisms+ description: Build prisms along with lenses (adds a dependency on @profunctors@).+ .+ If tests are enabled, this 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.+ default: True++flag binary+ description: Provide instances for Data.Binary.Binary from+ 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+ older.+ default: True++flag cereal+ description: Provide instances for Data.Serialize.Serialize+ from the @cereal@ package+ default: True+ library exposed-modules: Language.Libconfig- -- other-modules:+ , Language.Libconfig.Bindings+ , Language.Libconfig.Types+ , Language.Libconfig.Decode+ , Language.Libconfig.Encode+ , Language.Libconfig.Optics+ extra-libraries: config- build-depends: base >=4.6 && <4.9+ if flag(prisms) && flag(binary) && flag(cereal)+ build-depends: base >=4.6 && <4.9+ , text >= 1.1 && < 1.3+ , hashable >= 1.2 && < 1.3+ , deepseq >= 1.3+ , transformers >= 0.3+ , profunctors >= 4 && < 5+ , binary >= 0.5 && < 0.8+ , text-binary >= 0.1+ , cereal >= 0.4 && < 0.5+ , cereal-text >= 0.1+ cpp-options: -DDEFINE_PRISMS -DBINARY_INSTANCES -DCEREAL_INSTANCES+ else+ if flag(prisms) && flag(binary)+ build-depends: base >=4.6 && <4.9+ , text >= 1.1 && < 1.3+ , hashable >= 1.2 && < 1.3+ , deepseq >= 1.3+ , transformers >= 0.3+ , profunctors >= 4 && < 5+ , binary >= 0.5 && < 0.8+ , text-binary >= 0.1+ cpp-options: -DDEFINE_PRISMS -DBINARY_INSTANCES+ else+ if flag(prisms) && flag(cereal)+ build-depends: base >=4.6 && <4.9+ , text >= 1.1 && < 1.3+ , hashable >= 1.2 && < 1.3+ , deepseq >= 1.3+ , transformers >= 0.3+ , profunctors >= 4 && < 5+ , cereal >= 0.4 && < 0.5+ , cereal-text >= 0.1+ cpp-options: -DDEFINE_PRISMS -DCEREAL_INSTANCES+ else+ if flag(binary) && flag(cereal)+ build-depends: base >=4.6 && <4.9+ , text >= 1.1 && < 1.3+ , hashable >= 1.2 && < 1.3+ , deepseq >= 1.3+ , transformers >= 0.3+ , binary >= 0.5 && < 0.8+ , text-binary >= 0.1+ , cereal >= 0.4 && < 0.5+ , cereal-text >= 0.1+ cpp-options: -DBINARY_INSTANCES -DCEREAL_INSTANCES+ else+ if flag(prisms)+ build-depends: base >=4.6 && <4.9+ , text >= 1.1 && < 1.3+ , hashable >= 1.2 && < 1.3+ , deepseq >= 1.3+ , transformers >= 0.3+ , profunctors >= 4 && < 5+ cpp-options: -DDEFINE_PRISMS+ else+ if flag(binary)+ build-depends: base >=4.6 && <4.9+ , text >= 1.1 && < 1.3+ , hashable >= 1.2 && < 1.3+ , deepseq >= 1.3+ , transformers >= 0.3+ , binary >= 0.5 && < 0.8+ , text-binary >= 0.1+ cpp-options: -DBINARY_INSTANCES+ else+ if flag(cereal)+ build-depends: base >=4.6 && <4.9+ , text >= 1.1 && < 1.3+ , hashable >= 1.2 && < 1.3+ , deepseq >= 1.3+ , transformers >= 0.3+ , cereal >= 0.4 && < 0.5+ , cereal-text >= 0.1+ cpp-options: -DCEREAL_INSTANCES+ else+ build-depends: base >=4.6 && <4.9+ , text >= 1.1 && < 1.3+ , hashable >= 1.2 && < 1.3+ , deepseq >= 1.3+ , transformers >= 0.3++ hs-source-dirs: src build-tools: c2hs default-language: Haskell2010@@ -43,7 +153,15 @@ hs-source-dirs: test ghc-options: -threaded -Wall -O2 main-is: doctest.hs- build-depends: base- , libconfig- , doctest >= 0.9.9- , doctest-prop >= 0.2+ if flag(prisms)+ cpp-options: -DDEFINE_PRISMS+ build-depends: base+ , libconfig+ , doctest >= 0.9.9+ , doctest-prop >= 0.2+ , lens >= 4.7+ else+ build-depends: base+ , libconfig+ , doctest >= 0.9.9+ , doctest-prop >= 0.2
− src/Language/Libconfig.chs
@@ -1,1033 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE RecordWildCards #-}--{-|-Module : Language.Libconfig-Copyright : (c) Matthew Peddie 2014-License : BSD3--Maintainer : mpeddie@gmail.com-Stability : experimental-Portability : GHC--Low-level FFI bindings to the <http://www.hyperrealm.com/libconfig/ libconfig>-configuration file library. Please see the-<http://www.hyperrealm.com/libconfig/libconfig_manual.html libconfig manual>-for documentation on what the various functions actually do and the-underlying model of the libconfig API. The documentation in this-module contains many usage examples which double as tests, but the-focus is only on FFI details and C-vs.-Haskell impedance mismatches.-As a result, there is no explanation of the behavior of many of the-functions.---}--module Language.Libconfig (- -- * Doctest example setup-- -- $setup- -- * Types- Configuration- , Setting- , ConfigErr(..)- , ConfigType(..)- , ConfigFormat(..)- -- * Resource management- , configInit- , configNew- -- * Config I/O- , configReadFile- , configWriteFile- , configReadString- -- * Safe (capable of returning an error) getting of primitive- -- settings from the parent setting, by name.-- -- | These Haskell functions return 'Nothing' if the lookup fails,- -- there is a type mismatch, etc.- , configSettingLookupInt- , configSettingLookupInt64- , configSettingLookupFloat- , configSettingLookupBool- , configSettingLookupString- -- * Unsafe getting of primitives-- -- |- -- These functions are sketchy if used directly, because there is- -- no way to distinguish between a successful result and a failure- -- (at the @libconfig@ level). Take care to only ever use these- -- once you've already checked the 'ConfigType' of the 'Setting'- -- using 'configSettingType'.- , configSettingGetInt- , configSettingGetInt64- , configSettingGetFloat- , configSettingGetBool- , configSettingGetString- -- * Setting of primitives-- -- | These functions return a value of type 'Maybe' @()@, indicating- -- whether the action was successful. (It may fail if, for- -- example, there is a setting type mismatch.)- , configSettingSetInt- , configSettingSetInt64- , configSettingSetFloat- , configSettingSetBool- , configSettingSetString- -- * Unsafe getting of primitives from a collection-- -- |- -- These functions are sketchy if used directly, because there is- -- no way to distinguish between a successful result and a failure- -- (at the @libconfig@ level). Take care to only ever use these- -- once you've already checked the 'ConfigType' of the element- -- using 'configSettingType' or verified it for other elements of- -- an array.- --- -- These functions may be used on collections with type- -- 'GroupType', 'ArrayType' or 'ListType'.- , configSettingGetIntElem- , configSettingGetInt64Elem- , configSettingGetFloatElem- , configSettingGetBoolElem- , configSettingGetStringElem- -- * Setting of primitives within a collection-- -- | In the event of an out-of-bounds index or a type mismatch,- -- these functions return 'Nothing'. If the function succeeds,- -- the Setting that is returned will be either the same 'Setting'- -- that previously existed at that spot or a newly allocated one.- --- -- These functions may be used on collections with type- -- 'ArrayType' or 'ListType' (but __not__ 'GroupType').- , configSettingSetIntElem- , configSettingSetInt64Elem- , configSettingSetFloatElem- , configSettingSetBoolElem- , configSettingSetStringElem- -- * Direct lookup by path-- -- | In the event of a name lookup failure or type mismatch, these- -- functions return 'Nothing'.- , configLookup- , configLookupFrom- , configLookupInt- , configLookupInt64- , configLookupFloat- , configLookupBool- , configLookupString- -- * Collection management- , configSettingIndex- , configSettingLength- , configSettingGetElem- , configSettingGetMember- , configSettingAdd- , configSettingRemove- , configSettingRemoveElem- -- * Miscellaneous- , configSettingName- , configSettingParent- , configSettingIsRoot- , configRootSetting- , configSettingSourceLine- , configSettingSourceFile- -- ** Formatting- , configGetDefaultFormat- , configSetDefaultFormat- , configSettingGetFormat- , configSettingSetFormat- , configGetTabWidth- , configSetTabWidth- -- * Error reporting- , configErrorFile- , configErrorText- , configErrorLine- , configErrorType- -- * Config file type system- , configSettingType- , configSettingIsGroup- , configSettingIsList- , configSettingIsArray- , configSettingIsAggregate- , configSettingIsNumber- , configSettingIsScalar- ) where--import Foreign-import Foreign.C-import Control.Monad ((>=>))-import Control.Applicative---- $setup------ All the examples run on the included test file @test/test.conf@,--- which is provided in the--- <http://www.hyperrealm.com/libconfig/libconfig_manual.html#Configuration-Files libconfig manual>.------ >>> Just conf <- configNew "test/test.conf"--- >>> Just app <- configLookup conf "application"--- >>> Just misc <- configLookupFrom app "misc"--- >>> Just winsize <- configLookupFrom app "window.size"------ @conf'@ is used for modifying values.------ >>> Just conf' <- configNew "test/test.conf"--#include <libconfig.h>---- | This is a set of possible errors that can occur when @libconfig@--- 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.-data ConfigType = NoneType- | GroupType- | IntType- | Int64Type- | FloatType- | StringType- | BoolType- | ArrayType- | ListType- deriving (Eq, Show, Read, Ord, Enum, Bounded)--fromEnumIntegral :: (Enum c, Integral a) => c -> a-fromEnumIntegral = fromIntegral . fromEnum--toEnumIntegral :: (Enum c, Integral a) => a -> c-toEnumIntegral = toEnum . fromIntegral---- | This is used for fine-grained configuration of how integers are--- output when a config file is written. See 'configGetDefaultFormat'--- and the @libconfig@ manual.-data ConfigFormat = DefaultFormat- | HexFormat- deriving (Eq, Show, Read, Ord, Enum, Bounded)--data ConfigBool = ConfigFalse- | ConfigTrue- deriving (Eq, Show, Read, Ord, Enum, Bounded)--{#pointer *config_list_t as ConfigListPtr -> ConfigList #}--{#pointer *config_setting_t as SettingPtr -> Setting' #}--{#pointer *config_t as ConfigPtr -> Config #}--data ConfigList = ConfigList {- length'ConfigList :: CUInt- , elements'ConfigList :: Ptr SettingPtr- }--instance Storable ConfigList where- sizeOf _ = {#sizeof config_list_t #}- alignment _ = {#alignof config_list_t #}- peek p = ConfigList <$>- {#get config_list_t->length #} p <*>- {#get config_list_t->elements #} p- poke p ConfigList{..} = do- {#set config_list_t->length #} p length'ConfigList- {#set config_list_t->elements #} p elements'ConfigList--data ConfigValue = IVal CInt- | LLVal CLLong- | FVal CDouble- | SVal CString- | List ConfigListPtr- | None--configValueType :: ConfigValue -> String-configValueType (IVal _) = "IVal"-configValueType (LLVal _) = "LLVal"-configValueType (FVal _) = "FVal"-configValueType (SVal _) = "SVal"-configValueType (List _) = "List"-configValueType None = "None"--data Setting' = Setting' {- name'Setting :: CString- , type'Setting :: CShort- , format'Setting :: CShort- , value'Setting :: ConfigValue- , parent'Setting :: SettingPtr- , config'Setting :: ConfigPtr- , hook'Setting :: Ptr ()- , line'Setting :: CUInt- , file'Setting :: CString- }--peekConfigValue :: Ptr b -> Int -> ConfigType -> IO ConfigValue-peekConfigValue p n IntType = IVal <$> (peekByteOff p n :: IO CInt)-peekConfigValue p n BoolType = IVal <$> (peekByteOff p n :: IO CInt)-peekConfigValue p n Int64Type = LLVal <$> (peekByteOff p n :: IO CLLong)-peekConfigValue p n FloatType = FVal <$> (peekByteOff p n :: IO CDouble)-peekConfigValue p n StringType = SVal <$> (peekByteOff p n :: IO CString)-peekConfigValue _ _ NoneType = return None--- I hope this applies for all aggregate types . . .-peekConfigValue p n _ = List <$> (peekByteOff p n :: IO (Ptr ConfigList))--pokeConfigValue :: Ptr b -> Int -> ConfigValue -> ConfigType -> IO ()-pokeConfigValue p n (IVal x) IntType = pokeByteOff p n x-pokeConfigValue p n (IVal x) BoolType = pokeByteOff p n x-pokeConfigValue p n (LLVal x) Int64Type = pokeByteOff p n x-pokeConfigValue p n (FVal x) FloatType = pokeByteOff p n x-pokeConfigValue p n (SVal x) StringType = pokeByteOff p n x-pokeConfigValue _ _ None NoneType = return ()-pokeConfigValue p n (List x) ListType = pokeByteOff p n x-pokeConfigValue p n (List x) GroupType = pokeByteOff p n x-pokeConfigValue p n (List x) ArrayType = pokeByteOff p n x-pokeConfigValue _ _ v ty =- error $ "Internal error: libconfig type mismatch between config_value_t '" ++- configValueType v ++ "' and config_setting_t type tag '" ++- show ty ++ "'!"--instance Storable Setting' where- sizeOf _ = {#sizeof config_setting_t #}- alignment _ = {#alignof config_setting_t #}- peek p = do- nm <- {#get config_setting_t->name #} p- ty <- {#get config_setting_t->type #} p- fmt <- {#get config_setting_t->format #} p- val <- peekConfigValue p 8 (toEnumIntegral ty)- Setting' nm ty fmt val <$>- {#get config_setting_t->parent #} p <*>- {#get config_setting_t->config #} p <*>- {#get config_setting_t->hook #} p <*>- {#get config_setting_t->line #} p <*>- {#get config_setting_t->file #} p- poke p Setting'{..} = do- {#set config_setting_t->name #} p name'Setting- {#set config_setting_t->type #} p type'Setting- {#set config_setting_t->format #} p format'Setting- pokeConfigValue p 8 value'Setting (toEnumIntegral type'Setting)- {#set config_setting_t->parent #} p parent'Setting- {#set config_setting_t->config #} p config'Setting- {#set config_setting_t->hook #} p hook'Setting- {#set config_setting_t->line #} p line'Setting- {#set config_setting_t->file #} p file'Setting---- libconfig itself manages all the 'Setting's, including deallocation--- and allocation, so we don't have to use a 'ForeignPtr' or--- 'StablePtr' here. TODO(MP): Ensure that a 'Setting' can't get used--- outside the scope of its parent 'Configuration'---- | Corresponds to a @libconfig@ @config_setting_t@ value; wrapped--- opaquely for pointer safety.-newtype Setting = Setting { getSetting :: Ptr Setting' } deriving (Eq)--data Config = Config {- root'Config :: SettingPtr- , destructor'Config :: FunPtr (Ptr () -> IO ())- , flags'Config :: CUShort- , tab_width'Config :: CUShort- , default_format'Config :: CShort- , include_dir'Config :: CString- , error_text'Config :: CString- , error_file'Config :: CString- , error_line'Config :: CInt- , error_type'Config :: CInt- , filenames'Config :: Ptr CString- , num_filenames'Config :: CUInt- }--instance Storable Config where- sizeOf _ = {#sizeof config_t #}- alignment _ = {#alignof config_t #}- peek p = Config <$>- ({#get config_t->root #} p) <*>- ({#get config_t->destructor #} p) <*>- ({#get config_t->flags #} p) <*>- ({#get config_t->tab_width #} p) <*>- ({#get config_t->default_format #} p) <*>- ({#get config_t->include_dir #} p) <*>- ({#get config_t->error_text #} p) <*>- ({#get config_t->error_file #} p) <*>- ({#get config_t->error_line #} p) <*>- ({#get config_t->error_type #} p) <*>- ({#get config_t->filenames #} p) <*>- ({#get config_t->num_filenames #} p)- poke p Config{..} = do- {#set config_t->root #} p root'Config- {#set config_t->destructor #} p destructor'Config- {#set config_t->flags #} p flags'Config- {#set config_t->tab_width #} p tab_width'Config- {#set config_t->default_format #} p default_format'Config- {#set config_t->include_dir #} p include_dir'Config- {#set config_t->error_text #} p error_text'Config- {#set config_t->error_file #} p error_file'Config- {#set config_t->error_line #} p error_line'Config- {#set config_t->error_type #} p error_type'Config- {#set config_t->filenames #} p filenames'Config- {#set config_t->num_filenames #} p num_filenames'Config--foreign import ccall unsafe "src/Language/Libconfig.chs.h config_init"- configInit' :: Ptr Config -> IO ()--foreign import ccall unsafe "src/Language/Libconfig.chs.h &config_destroy"- configDestroy' :: FunPtr (Ptr Config -> IO ())---- | Top-level configuration value, corresponding to the libconfig--- @config_t@. Wrapped opaquely for pointer-safety.-newtype Configuration = Configuration { getConfiguration :: ForeignPtr Config }- deriving (Eq)---- | This function allocates a new 'Configuration' and initializes it.-configInit :: IO Configuration-configInit = do- c <- mallocForeignPtr- addForeignPtrFinalizer configDestroy' c- withForeignPtr c configInit'- return $ Configuration c--withConfiguration :: Configuration -> (Ptr Config -> IO a) -> IO a-withConfiguration (Configuration c) = withForeignPtr c--modifyConfiguration :: Configuration -> (Config -> Config) -> IO ()-modifyConfiguration (Configuration p) mf = withForeignPtr p $ \cp -> do- c <- peek cp- poke cp $ mf c--onConfiguration :: (Config -> a) -> Configuration -> IO a-onConfiguration f = flip withConfiguration (fmap f . peek)--{- Marshalling -}--checkPtr :: Storable a => Ptr a -> Maybe (Ptr a)-checkPtr p- | nullPtr == p = Nothing- | otherwise = Just p--checkSetting :: Ptr Setting' -> Maybe Setting-checkSetting = fmap Setting . checkPtr--peekIntegral :: (Integral a, Storable a, Num b) => Ptr a -> IO b-peekIntegral = fmap fromIntegral . peek--peekFloat :: (Real a, Storable a, Fractional b) => Ptr a -> IO b-peekFloat = fmap realToFrac . peek--peekBool :: (Eq a, Num a, Storable a) => Ptr a -> IO Bool-peekBool = fmap toBool . peek--peekString :: Ptr CString -> IO String-peekString = peek >=> peekCString--asBool :: Integral a => a -> ConfigBool-asBool = toEnum . fromIntegral--checkBool :: Integral a => a -> Maybe ()-checkBool a = case asBool a of- ConfigTrue -> Just ()- ConfigFalse -> Nothing--checkTuple :: (ConfigBool, a) -> Maybe a-checkTuple (ConfigTrue, x) = Just x-checkTuple _ = Nothing--{- Resource management -}--{- I/O -}---- | Read in a 'Configuration' from the specified configuration file.--- The 'Configuration' should already be initialized with--- 'configInit'.-{#fun unsafe config_read_file as ^- { withConfiguration* `Configuration', `String' } -> `Maybe ()' checkBool #}---- | Create a new 'Configuration' and read in the data from the--- specified configuration file.------ >> configNew s = configInit >>= \c -> configReadFile c s-configNew :: String -> IO (Maybe Configuration)-configNew s = do- c <- configInit- red <- configReadFile c s- return $ case red of- Nothing -> Nothing- Just _ -> Just c---- | Write out a 'Configuration' to the specified configuration file.-{#fun unsafe config_write_file as ^- { withConfiguration* `Configuration', `String' } -> `Maybe ()' checkBool #}---- | Read configuration data from a string.-{#fun unsafe config_read_string as ^- { withConfiguration* `Configuration', `String' } -> `Maybe ()' checkBool #}--{- Unsafe getting -}---- |--- >>> Just appwinwidth <- configLookup conf "application.window.size.w"--- >>> configSettingGetInt appwinwidth--- 640-{#fun unsafe config_setting_get_int as ^ { getSetting `Setting' } -> `Int' #}---- |--- >>> Just miscbigint <- configLookup conf "application.misc.bigint"--- >>> configSettingGetInt64 miscbigint--- 9223372036854775807-{#fun unsafe config_setting_get_int64 as ^ { getSetting `Setting' } -> `Int64' #}---- |--- >>> Just miscpi <- configLookup conf "application.misc.pi"--- >>> configSettingGetFloat miscpi--- 3.141592654-{#fun unsafe config_setting_get_float as ^ { getSetting `Setting' } -> `Double' #}---- |--- >>> Just listbool <- configLookup conf "application.list.[0].[2]"--- >>> configSettingGetBool listbool--- True-{#fun unsafe config_setting_get_bool as ^ { getSetting `Setting' } -> `Bool' toBool #}---- |--- >>> Just wintitle <- configLookup conf "application.window.title"--- >>> configSettingGetString wintitle--- "My Application"-{#fun unsafe config_setting_get_string as ^ { getSetting `Setting' } -> `String' #}--{- Safe getting -}--{#fun unsafe config_setting_lookup_int as configSettingLookupInt'- { getSetting `Setting', `String', alloca- `Int' peekIntegral* } -> `ConfigBool' asBool #}--{#fun unsafe config_setting_lookup_int64 as configSettingLookupInt64'- { getSetting `Setting', `String', alloca- `Int64' peekIntegral* } -> `ConfigBool' asBool #}--{#fun unsafe config_setting_lookup_float as configSettingLookupFloat'- { getSetting `Setting', `String', alloca- `Double' peekFloat* } -> `ConfigBool' asBool #}--{#fun unsafe config_setting_lookup_bool as configSettingLookupBool'- { getSetting `Setting', `String', alloca- `Bool' peekBool* } -> `ConfigBool' asBool #}--{#fun unsafe config_setting_lookup_string as configSettingLookupString'- { getSetting `Setting', `String', alloca- `String' peekString* } -> `ConfigBool' asBool #}---- |--- >>> configSettingLookupInt winsize "w"--- Just 640-configSettingLookupInt :: Setting -> String -> IO (Maybe Int)-configSettingLookupInt s = fmap checkTuple . configSettingLookupInt' s---- |--- >>> configSettingLookupInt64 misc "bigint"--- Just 9223372036854775807-configSettingLookupInt64 :: Setting -> String -> IO (Maybe Int64)-configSettingLookupInt64 s = fmap checkTuple . configSettingLookupInt64' s---- |--- >>> configSettingLookupFloat misc "pi"--- Just 3.141592654-configSettingLookupFloat :: Setting -> String -> IO (Maybe Double)-configSettingLookupFloat s = fmap checkTuple . configSettingLookupFloat' s---- | (The example configuration file does not contain any boolean--- values that are direct children of a @config_setting_t@.)-configSettingLookupBool :: Setting -> String -> IO (Maybe Bool)-configSettingLookupBool s = fmap checkTuple . configSettingLookupBool' s---- |--- >>> Just win <- configLookupFrom app "window"--- >>> configSettingLookupString win "title"--- Just "My Application"-configSettingLookupString :: Setting -> String -> IO (Maybe String)-configSettingLookupString s = fmap checkTuple . configSettingLookupString' s--{- Setting values -}---- |--- >>> Just treasureqty <- configLookup conf' "application.books.[0].qty"--- >>> configSettingSetInt treasureqty 222--- Just ()--- >>> configSettingGetInt treasureqty--- 222-{#fun unsafe config_setting_set_int as ^- { getSetting `Setting', `Int' } -> `Maybe ()' checkBool #}---- |--- >>> Just miscbigint <- configLookup conf' "application.misc.bigint"--- >>> configSettingSetInt64 miscbigint 92233720368547758--- Just ()--- >>> configSettingGetInt64 miscbigint--- 92233720368547758-{#fun unsafe config_setting_set_int64 as ^- { getSetting `Setting', `Int64' } -> `Maybe ()' checkBool #}---- |--- >>> Just treasureprice <- configLookup conf' "application.books.[0].price"--- >>> configSettingSetFloat treasureprice 22.22--- Just ()--- >>> configSettingGetFloat treasureprice--- 22.22-{#fun unsafe config_setting_set_float as ^- { getSetting `Setting', `Double' } -> `Maybe ()' checkBool #}---- |--- >>> Just listbool <- configLookup conf' "application.list.[0].[2]"--- >>> configSettingSetBool listbool False--- Just ()--- >>> configSettingGetBool listbool--- False-{#fun unsafe config_setting_set_bool as ^- { getSetting `Setting', `Bool' } -> `Maybe ()' checkBool #}---- |--- >>> Just treasureauthor <- configLookup conf' "application.books.[0].author"--- >>> configSettingSetString treasureauthor "Robert L. Stevenson"--- Just ()--- >>> configSettingGetString treasureauthor--- "Robert L. Stevenson"-{#fun unsafe config_setting_set_string as ^- { getSetting `Setting', `String' } -> `Maybe ()' checkBool #}--{- Unsafe getting elements in collections -}---- |--- >>> Just treasure <- configLookup conf "application.books.[0]"--- >>> configSettingGetIntElem treasure 3--- 5-{#fun unsafe config_setting_get_int_elem as ^- { getSetting `Setting', `Int' } -> `Int' #}---- |--- >>> Just misc <- configLookup conf "application.misc"--- >>> configSettingGetInt64Elem misc 1--- 9223372036854775807-{#fun unsafe config_setting_get_int64_elem as ^- { getSetting `Setting', `Int' } -> `Int64' #}---- |--- >>> Just list <- configLookup conf "application.list"--- >>> configSettingGetFloatElem list 1--- 1.234-{#fun unsafe config_setting_get_float_elem as ^- { getSetting `Setting', `Int' } -> `Double' #}---- | (The example configuration does not contain any boolean values--- that are direct children of collections of type--- @config_setting_t@).-{#fun unsafe config_setting_get_bool_elem as ^- { getSetting `Setting', `Int' } -> `Bool' toBool #}---- |--- >>> Just win <- configLookup conf "application.window"--- >>> configSettingGetStringElem win 0--- "My Application"-{#fun unsafe config_setting_get_string_elem as ^- { getSetting `Setting', `Int' } -> `String' #}--{- Setting elements in collections -}---- | (This example appends a new value of type 'IntType' to--- @application.list@, because the example file contains no suitable--- example values for us to modify.)------ >>> Just list <- configLookup conf' "application.list"--- >>> Just new3 <- configSettingSetIntElem list (-1) 22--- >>> configSettingGetIntElem list 3--- 22--- >>> configSettingGetInt new3--- 22-{#fun unsafe config_setting_set_int_elem as ^- { getSetting `Setting', `Int', `Int' } -> `Maybe Setting' checkSetting #}---- | (This example appends a new value of type 'Int64Type' to--- @application.list@, because the example file contains no suitable--- example values for us to modify.)------ >>> Just list <- configLookup conf' "application.list"--- >>> Just new3 <- configSettingSetInt64Elem list (-1) 92233720368547758--- >>> configSettingGetInt64Elem list 3--- 92233720368547758--- >>> configSettingGetInt64 new3--- 92233720368547758-{#fun unsafe config_setting_set_int64_elem as ^- { getSetting `Setting', `Int', `Int64' } -> `Maybe Setting' checkSetting #}---- |--- >>> Just list <- configLookup conf' "application.list"--- >>> Just new1 <- configSettingSetFloatElem list 1 0.2222--- >>> configSettingGetFloatElem list 1--- 0.2222--- >>> configSettingGetFloat new1--- 0.2222-{#fun unsafe config_setting_set_float_elem as ^- { getSetting `Setting', `Int', `Double' } -> `Maybe Setting' checkSetting #}---- | (This example appends a new value of type 'BoolType' to--- @application.list@, because the example file contains no suitable--- example values for us to modify.)------ >>> Just list <- configLookup conf' "application.list"--- >>> Just new3 <- configSettingSetBoolElem list (-1) False--- >>> configSettingGetBoolElem list 3--- False--- >>> configSettingGetBool new3--- False-{#fun unsafe config_setting_set_bool_elem as ^- { getSetting `Setting', `Int', `Bool' } -> `Maybe Setting' checkSetting #}---- |--- >>> Just misccols <- configLookup conf' "application.misc.columns"--- >>> Just new0 <- configSettingSetStringElem misccols 0 "butts"--- >>> configSettingGetStringElem misccols 0--- "butts"--- >>> configSettingGetString new0--- "butts"-{#fun unsafe config_setting_set_string_elem as ^- { getSetting `Setting', `Int', `String' } -> `Maybe Setting' checkSetting #}--{- Collection management -}---- |--- >>> Just col0 <- configLookup conf "application.misc.columns.[0]"--- >>> configSettingIndex col0--- 0-{#fun unsafe config_setting_index as ^- { getSetting `Setting' } -> `Int' #}---- |--- >>> Just cols <- configLookup conf "application.misc.columns"--- >>> configSettingLength cols--- 3-{#fun config_setting_length as ^- { getSetting `Setting' } -> `Int' #}---- |--- >>> Just cols <- configLookup conf "application.misc.columns"--- >>> Just col0 <- configSettingGetElem cols 0--- >>> configSettingGetString col0--- "Last Name"-{#fun config_setting_get_elem as ^- { getSetting `Setting', fromIntegral `Int' } -> `Maybe Setting' checkSetting #}---- |--- >>> Just miscpi <- configSettingGetMember misc "pi"--- >>> configSettingGetFloat miscpi--- 3.141592654-{#fun config_setting_get_member as ^- { getSetting `Setting', `String' } -> `Maybe Setting' checkSetting #}---- |--- >>> Just misc' <- configLookup conf' "application.misc"--- >>> Just randSeed <- configSettingAdd misc' "random_seed" IntType--- >>> configSettingSetInt randSeed 55--- Just ()--- >>> configSettingGetInt randSeed--- 55--- >>> configSettingLookupInt misc' "random_seed"--- Just 55--- >>> configSettingGetIntElem misc' 4--- 55-{#fun config_setting_add as ^- { getSetting `Setting', `String', fromEnumIntegral `ConfigType' }- -> `Maybe Setting' checkSetting #}---- |--- >>> Just misc' <- configLookup conf' "application.misc"--- >>> configSettingLength misc'--- 4--- >>> configSettingRemove misc' "bitmask"--- Just ()--- >>> configSettingLength misc'--- 3-{#fun config_setting_remove as ^- { getSetting `Setting', `String' } -> `Maybe ()' checkBool #}---- |--- >>> Just misc' <- configLookup conf' "application.misc"--- >>> configSettingLength misc'--- 4--- >>> configSettingRemoveElem misc' 2--- Just ()--- >>> configSettingLength misc'--- 3--- >>> Just new2 <- configSettingGetElem misc' 2--- >>> configSettingType new2--- IntType--- >>> configSettingGetInt new2--- 8131-{#fun config_setting_remove_elem as ^- { getSetting `Setting', fromIntegral `Int' } -> `Maybe ()' checkBool #}---- I haven't worked out a good way to do this one yet. What's--- necessary is to register a finalizer for 'freeStablePtr xp' with--- the relevant 'Configuration' pointer. Unfortunately, we can't go--- from a 'Setting' to the ForeignPtr contained in a 'Configuration'.------ Punting for now, since I don't even know what you use this for.---- foreign import ccall unsafe "src/Language/Libconfig.chs.h config_setting_set_hook"--- configSettingSetHook' :: Ptr Setting' -> Ptr () -> IO ()---- configSettingSetHook :: Storable a => Setting -> a -> IO ()--- configSettingSetHook (Setting s) x = do--- xp <- newStablePtr x--- cfgp <- config'Setting <$> peek s---- configSettingGetHook :: Storable a => Setting -> IO a--- configSettingGetHook (Setting s) = fmap (castPtr . hook'Setting) (peek s) >>= peek---{- Path search -}---- |--- >>> Just app <- configLookup conf "application"--- >>> configSettingName app--- Just "application"-{#fun config_lookup as ^- { withConfiguration* `Configuration', `String' } -> `Maybe Setting' checkSetting #}---- |--- >>> Just list <- configLookupFrom app "list"--- >>> configSettingName list--- Just "list"-{#fun config_lookup_from as ^- { getSetting `Setting', `String' } -> `Maybe Setting' checkSetting #}--{#fun config_lookup_int as configLookupInt'- { withConfiguration* `Configuration', `String', alloca- `Int' peekIntegral* }- -> `ConfigBool' asBool #}--{#fun config_lookup_int64 as configLookupInt64'- { withConfiguration* `Configuration', `String', alloca- `Int64' peekIntegral* }- -> `ConfigBool' asBool #}--{#fun config_lookup_float as configLookupFloat'- { withConfiguration* `Configuration', `String', alloca- `Double' peekFloat* }- -> `ConfigBool' asBool #}--{#fun config_lookup_bool as configLookupBool'- { withConfiguration* `Configuration', `String', alloca- `Bool' peekBool* }- -> `ConfigBool' asBool #}--{#fun config_lookup_string as configLookupString'- { withConfiguration* `Configuration', `String', alloca- `String' peekString* }- -> `ConfigBool' asBool #}---- |--- >>> Just appwinwidth <- configLookup conf "application.window.size.w"--- >>> configSettingGetFormat appwinwidth--- DefaultFormat-{#fun config_setting_get_format as ^- { getSetting `Setting' }- -> `ConfigFormat' toEnumIntegral #}---- |--- >>> Just appwinwidth' <- configLookup conf' "application.window.size.w"--- >>> configSettingGetFormat appwinwidth'--- DefaultFormat--- >>> configSettingSetFormat appwinwidth' HexFormat--- Just ()--- >>> configSettingGetFormat appwinwidth'--- HexFormat-{#fun config_setting_set_format as ^- { getSetting `Setting', fromEnumIntegral `ConfigFormat' }- -> `Maybe ()' checkBool #}---- |--- >>> configLookupInt conf "application.window.size.w"--- Just 640-configLookupInt :: Configuration -> String -> IO (Maybe Int)-configLookupInt c = fmap checkTuple . configLookupInt' c---- |--- >>> configLookupInt64 conf "application.misc.bigint"--- Just 9223372036854775807-configLookupInt64 :: Configuration -> String -> IO (Maybe Int64)-configLookupInt64 c = fmap checkTuple . configLookupInt64' c---- |--- >>> configLookupFloat conf "application.misc.pi"--- Just 3.141592654-configLookupFloat :: Configuration -> String -> IO (Maybe Double)-configLookupFloat c = fmap checkTuple . configLookupFloat' c---- |--- >>> configLookupBool conf "application.list.[0].[2]"--- Just True-configLookupBool :: Configuration -> String -> IO (Maybe Bool)-configLookupBool c = fmap checkTuple . configLookupBool' c----- |--- >>> configLookupString conf "application.window.title"--- Just "My Application"-configLookupString :: Configuration -> String -> IO (Maybe String)-configLookupString c = fmap checkTuple . configLookupString' c---- |--- >>> Just list <- configLookup conf "application.list"--- >>> configSettingType list--- ListType-configSettingType :: Setting -> IO ConfigType-configSettingType = fmap (toEnumIntegral . type'Setting) . peek . getSetting---- |--- >>> Just grp <- configLookup conf "application.window"--- >>> configSettingIsGroup grp--- True-configSettingIsGroup :: Setting -> IO Bool-configSettingIsGroup = fmap (== GroupType) . configSettingType---- |--- >>> Just arr <- configLookup conf "application.misc.columns"--- >>> configSettingIsArray arr--- True-configSettingIsArray :: Setting -> IO Bool-configSettingIsArray = fmap (== ArrayType) . configSettingType---- |--- >>> Just list <- configLookup conf "application.list"--- >>> configSettingIsList list--- True-configSettingIsList :: Setting -> IO Bool-configSettingIsList = fmap (== ListType) . configSettingType---- |--- >>> Just grp <- configLookup conf "application.window"--- >>> Just arr <- configLookup conf "application.misc.columns"--- >>> Just list <- configLookup conf "application.list"--- >>> Just width <- configLookup conf "application.window.size.w"--- >>> mapM configSettingIsAggregate [grp, arr, list, width]--- [True,True,True,False]-configSettingIsAggregate :: Setting -> IO Bool-configSettingIsAggregate =- fmap (`elem` [ListType, GroupType, ArrayType]) . configSettingType---- |--- >>> Just int <- configLookup conf "application.window.pos.x"--- >>> Just bigint <- configLookup conf "application.misc.bigint"--- >>> Just float <- configLookup conf "application.misc.pi"--- >>> Just grp <- configLookup conf "application.window"--- >>> mapM configSettingIsNumber [int, bigint, float, grp]--- [True,True,True,False]-configSettingIsNumber :: Setting -> IO Bool-configSettingIsNumber =- fmap (`elem` [IntType, Int64Type, FloatType]) . configSettingType---- |--- >>> Just int <- configLookup conf "application.window.pos.x"--- >>> Just bigint <- configLookup conf "application.misc.bigint"--- >>> Just float <- configLookup conf "application.misc.pi"--- >>> Just bool <- configLookup conf "application.list.[0].[2]"--- >>> Just str <- configLookup conf "application.window.title"--- >>> Just grp <- configLookup conf "application.window"--- >>> mapM configSettingIsScalar [int, bigint, float, bool, str, grp]--- [True,True,True,True,True,False]-configSettingIsScalar :: Setting -> IO Bool-configSettingIsScalar =- fmap (`elem` [IntType, Int64Type, FloatType, BoolType, StringType]) .- configSettingType---- |--- >>> Just list <- configLookup conf "application.list"--- >>> configSettingName list--- Just "list"------ >>> Just list1 <- configLookup conf "application.list.[0]"--- >>> configSettingName list1--- Nothing-configSettingName :: Setting -> IO (Maybe String)-configSettingName (Setting sp) = do- s <- peek sp- if (name'Setting s == nullPtr)- then return Nothing- else Just <$> peekCString (name'Setting s)---- |--- >>> Just list <- configLookup conf "application.list"--- >>> Just app <- configSettingParent list--- >>> configSettingName app--- Just "application"-configSettingParent :: Setting -> IO (Maybe Setting)-configSettingParent = fmap (checkSetting . parent'Setting) . peek . getSetting---- |--- >>> configSettingIsRoot app--- False--- >>> Just root <- configRootSetting conf--- >>> configSettingIsRoot root--- True-configSettingIsRoot :: Setting -> IO Bool-configSettingIsRoot = fmap ((==nullPtr) . parent'Setting) . peek . getSetting---- |--- >>> Just root <- configRootSetting conf--- >>> Just version <- configSettingGetMember root "version"--- >>> configSettingGetString version--- "1.0"-configRootSetting :: Configuration -> IO (Maybe Setting)-configRootSetting =- flip withForeignPtr (fmap (checkSetting . root'Config) . peek) . getConfiguration---- |--- >>> configGetDefaultFormat conf'--- DefaultFormat--- >>> configSetDefaultFormat conf' HexFormat--- >>> configGetDefaultFormat conf'--- HexFormat-configSetDefaultFormat :: Configuration -> ConfigFormat -> IO ()-configSetDefaultFormat c' f =- modifyConfiguration c' $- \c -> c { default_format'Config = fromIntegral $ fromEnum f }---- |--- >>> configGetDefaultFormat conf--- DefaultFormat-configGetDefaultFormat :: Configuration -> IO ConfigFormat-configGetDefaultFormat =- onConfiguration (toEnum . fromIntegral . default_format'Config)---- |--- >>> configGetTabWidth conf'--- 2--- >>> configSetTabWidth conf' 8--- >>> configGetTabWidth conf'--- 8-configSetTabWidth :: Configuration -> Int -> IO ()-configSetTabWidth c' w =- modifyConfiguration c' $- \c -> c { tab_width'Config = fromIntegral w }---- |--- >>> configGetTabWidth conf--- 2-configGetTabWidth :: Configuration -> IO Int-configGetTabWidth =- onConfiguration (fromIntegral . tab_width'Config)---- |--- >>> configSettingSourceLine app--- 5-configSettingSourceLine :: Setting -> IO Int-configSettingSourceLine =- fmap (fromIntegral . line'Setting) . peek . getSetting---- |--- >>> configSettingSourceFile app--- "test/test.conf"-configSettingSourceFile :: Setting -> IO String-configSettingSourceFile (Setting s) = peek s >>= peekCString . file'Setting--configErrorFile :: Configuration -> IO String-configErrorFile c =- withConfiguration c $- \p -> peek p >>= peekCString . error_file'Config--configErrorText :: Configuration -> IO String-configErrorText c =- withConfiguration c $- \p -> peek p >>= peekCString . error_text'Config--configErrorLine :: Configuration -> IO Int-configErrorLine =- onConfiguration (fromIntegral . error_line'Config)--configErrorType :: Configuration -> IO ConfigErr-configErrorType =- onConfiguration (toEnum . fromIntegral . error_type'Config)---- TODO(MP): Perhaps a MonadIO m => ConfigT m which both wraps non-IO--- config actions and uses ExceptT or MaybeT to keep track of errors
+ src/Language/Libconfig.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -Wall #-}++{-|+Module : Language.Libconfig+Copyright : (c) Matthew Peddie 2014+License : BSD3++Maintainer : mpeddie@gmail.com+Stability : experimental+Portability : GHC++Top-level tools for working with the+<http://www.hyperrealm.com/libconfig/ libconfig>+configuration file library. Please see the+<http://www.hyperrealm.com/libconfig/libconfig_manual.html libconfig manual>+for documentation on the underlying model of the libconfig API.++This module re-exports everything you need for basic libconfig usage+from Haskell. If you want to do something special and don't mind a+bunch of mutation, you should import the low-level bindings:++> import qualified Language.Libconfig.Bindings as C++-}++module Language.Libconfig (+ module Language.Libconfig.Types+ , module Language.Libconfig.Decode+ , module Language.Libconfig.Encode+ , module Language.Libconfig.Optics+ ) where++import Language.Libconfig.Types+import Language.Libconfig.Decode+import Language.Libconfig.Encode+import Language.Libconfig.Optics
+ src/Language/Libconfig/Bindings.chs view
@@ -0,0 +1,1114 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RecordWildCards #-}++{-|+Module : Language.Libconfig.Bindings+Copyright : (c) Matthew Peddie 2014+License : BSD3++Maintainer : mpeddie@gmail.com+Stability : experimental+Portability : GHC++Low-level FFI bindings to the <http://www.hyperrealm.com/libconfig/ libconfig>+configuration file library. Please see the+<http://www.hyperrealm.com/libconfig/libconfig_manual.html libconfig manual>+for documentation on what the various functions actually do and the+underlying model of the libconfig API. The documentation in this+module contains many usage examples which double as tests, but the+focus is only on FFI details and C-vs.-Haskell impedance mismatches.+As a result, there is no explanation of the behavior of many of the+functions.++-}++module Language.Libconfig.Bindings (+ -- * Doctest example setup++ -- $setup+ -- * Types+ Configuration+ , Setting+ , ConfigErr(..)+ , ConfigType(..)+ , isCollectionType+ , isScalarType+ , ConfigFormat(..)+ -- * Resource management+ , configInit+ , configNew+ , touchConfiguration+ -- * Config I/O+ , configReadFile+ , configWriteFile+ , configReadString+ -- * Safe (capable of returning an error) getting of primitive+ -- settings from the parent setting, by name.++ -- | These Haskell functions return 'Nothing' if the lookup fails,+ -- there is a type mismatch, etc.+ , configSettingLookupInt+ , configSettingLookupInt64+ , configSettingLookupFloat+ , configSettingLookupBool+ , configSettingLookupString+ -- * Unsafe getting of primitives++ -- |+ -- These functions are sketchy if used directly, because there is+ -- no way to distinguish between a successful result and a failure+ -- (at the @libconfig@ level). Take care to only ever use these+ -- once you've already checked the 'ConfigType' of the 'Setting'+ -- using 'configSettingType'.+ , configSettingGetInt+ , configSettingGetInt64+ , configSettingGetFloat+ , configSettingGetBool+ , configSettingGetString+ -- * Setting of primitives++ -- | These functions return a value of type 'Maybe' @()@, indicating+ -- whether the action was successful. (It may fail if, for+ -- example, there is a setting type mismatch.)+ , configSettingSetInt+ , configSettingSetInt64+ , configSettingSetFloat+ , configSettingSetBool+ , configSettingSetString+ -- * Unsafe getting of primitives from a collection++ -- |+ -- These functions are sketchy if used directly, because there is+ -- no way to distinguish between a successful result and a failure+ -- (at the @libconfig@ level). Take care to only ever use these+ -- once you've already checked the 'ConfigType' of the element+ -- using 'configSettingType' or verified it for other elements of+ -- an array.+ --+ -- These functions may be used on collections with type+ -- 'GroupType', 'ArrayType' or 'ListType'.+ , configSettingGetIntElem+ , configSettingGetInt64Elem+ , configSettingGetFloatElem+ , configSettingGetBoolElem+ , configSettingGetStringElem+ -- * Setting of primitives within a collection++ -- | In the event of an out-of-bounds index or a type mismatch,+ -- these functions return 'Nothing'. If the function succeeds,+ -- the Setting that is returned will be either the same 'Setting'+ -- that previously existed at that spot or a newly allocated one.+ --+ -- These functions may be used on collections with type+ -- 'ArrayType' or 'ListType' (but __not__ 'GroupType').+ , configSettingSetIntElem+ , configSettingSetInt64Elem+ , configSettingSetFloatElem+ , configSettingSetBoolElem+ , configSettingSetStringElem+ -- * Direct lookup by path++ -- | In the event of a name lookup failure or type mismatch, these+ -- functions return 'Nothing'.+ , configLookup+ , configLookupFrom+ , configLookupInt+ , configLookupInt64+ , configLookupFloat+ , configLookupBool+ , configLookupString+ -- * Collection management+ , configSettingIndex+ , configSettingLength+ , configSettingGetElem+ , configSettingGetMember+ , configSettingAdd+ , configSettingRemove+ , configSettingRemoveElem+ -- * Miscellaneous+ , configSettingName+ , configSettingParent+ , configSettingIsRoot+ , configRootSetting+ , configSettingSourceLine+ , configSettingSourceFile+ -- ** Formatting+ , configGetDefaultFormat+ , configSetDefaultFormat+ , configSettingGetFormat+ , configSettingSetFormat+ , configGetTabWidth+ , configSetTabWidth+ -- * Error reporting+ , configErrorFile+ , configErrorText+ , configErrorLine+ , configErrorType+ -- * Config file type system+ , configSettingType+ , configSettingIsGroup+ , configSettingIsList+ , configSettingIsArray+ , configSettingIsAggregate+ , configSettingIsNumber+ , configSettingIsScalar+ ) where++import Foreign+import Foreign.C+import Control.Monad ((>=>))+import Control.Applicative++-- $setup+--+-- All the examples run on the included test file @test/test.conf@,+-- which is reproduced here from the+-- <http://www.hyperrealm.com/libconfig/libconfig_manual.html#Configuration-Files libconfig manual>.+--+-- @+-- # Example application configuration file+--+-- version = "1.0";+--+-- application:+-- {+-- window:+-- {+-- title = "My Application";+-- size = { w = 640; h = 480; };+-- pos = { x = 350; y = 250; };+-- };+--+-- list = ( ( "abc", 123, true ), 1.234, ( /* an empty list */) );+--+-- books = ( { title = "Treasure Island";+-- author = "Robert Louis Stevenson";+-- price = 29.95;+-- qty = 5; },+-- { title = "Snow Crash";+-- author = "Neal Stephenson";+-- price = 9.99;+-- qty = 8; } );+--+-- misc:+-- {+-- pi = 3.141592654;+-- bigint = 9223372036854775807L;+-- columns = [ "Last Name", "First Name", "MI" ];+-- bitmask = 0x1FC3;+-- };+-- };+-- @+--+-- The following setup actions are assumed for many of the usage+-- examples below.+--+-- >>> Just conf <- configNew "test/test.conf"+-- >>> Just app <- configLookup conf "application"+-- >>> Just misc <- configLookupFrom app "misc"+-- >>> Just winsize <- configLookupFrom app "window.size"+--+-- @conf'@ is used for modifying values.+--+-- >>> Just conf' <- configNew "test/test.conf"+--++#include <libconfig.h>++-- | This is a set of possible errors that can occur when @libconfig@+-- 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.+data ConfigType = NoneType+ | GroupType+ | IntType+ | Int64Type+ | FloatType+ | StringType+ | BoolType+ | ArrayType+ | ListType+ deriving (Eq, Show, Read, Ord, Enum, Bounded)++-- | Tells whether a 'ConfigType' value is a collection ('ListType',+-- 'ArrayType' or 'GroupType').+--+-- >>> isCollectionType GroupType+-- True+-- >>> isCollectionType BoolType+-- False+isCollectionType :: ConfigType -> Bool+isCollectionType ArrayType = True+isCollectionType ListType = True+isCollectionType GroupType = True+isCollectionType _ = False++-- | Tells whether a 'ConfigType' value is a scalar (i.e. not a+-- collection).+--+-- >>> isScalarType FloatType+-- True+--+-- >>> isScalarType ListType+-- False+--+-- __Note:__+--+-- >>> isScalarType NoneType+-- True+isScalarType :: ConfigType -> Bool+isScalarType = not . isCollectionType+++fromEnumIntegral :: (Enum c, Integral a) => c -> a+fromEnumIntegral = fromIntegral . fromEnum++toEnumIntegral :: (Enum c, Integral a) => a -> c+toEnumIntegral = toEnum . fromIntegral++-- | This is used for fine-grained configuration of how integers are+-- output when a config file is written. See 'configGetDefaultFormat'+-- and the @libconfig@ manual.+data ConfigFormat = DefaultFormat+ | HexFormat+ deriving (Eq, Show, Read, Ord, Enum, Bounded)++data ConfigBool = ConfigFalse+ | ConfigTrue+ deriving (Eq, Show, Read, Ord, Enum, Bounded)++{#pointer *config_list_t as ConfigListPtr -> ConfigList #}++{#pointer *config_setting_t as SettingPtr -> Setting' #}++{#pointer *config_t as ConfigPtr -> Config #}++data ConfigList = ConfigList {+ length'ConfigList :: CUInt+ , elements'ConfigList :: Ptr SettingPtr+ }++instance Storable ConfigList where+ sizeOf _ = {#sizeof config_list_t #}+ alignment _ = {#alignof config_list_t #}+ peek p = ConfigList <$>+ {#get config_list_t->length #} p <*>+ {#get config_list_t->elements #} p+ poke p ConfigList{..} = do+ {#set config_list_t->length #} p length'ConfigList+ {#set config_list_t->elements #} p elements'ConfigList++data ConfigValue = IVal CInt+ | LLVal CLLong+ | FVal CDouble+ | SVal CString+ | List ConfigListPtr+ | None++configValueType :: ConfigValue -> String+configValueType (IVal _) = "IVal"+configValueType (LLVal _) = "LLVal"+configValueType (FVal _) = "FVal"+configValueType (SVal _) = "SVal"+configValueType (List _) = "List"+configValueType None = "None"++data Setting' = Setting' {+ name'Setting :: CString+ , type'Setting :: CShort+ , format'Setting :: CShort+ , value'Setting :: ConfigValue+ , parent'Setting :: SettingPtr+ , config'Setting :: ConfigPtr+ , hook'Setting :: Ptr ()+ , line'Setting :: CUInt+ , file'Setting :: CString+ }++peekConfigValue :: Ptr b -> Int -> ConfigType -> IO ConfigValue+peekConfigValue p n IntType = IVal <$> (peekByteOff p n :: IO CInt)+peekConfigValue p n BoolType = IVal <$> (peekByteOff p n :: IO CInt)+peekConfigValue p n Int64Type = LLVal <$> (peekByteOff p n :: IO CLLong)+peekConfigValue p n FloatType = FVal <$> (peekByteOff p n :: IO CDouble)+peekConfigValue p n StringType = SVal <$> (peekByteOff p n :: IO CString)+peekConfigValue _ _ NoneType = return None+-- I hope this applies for all aggregate types . . .+peekConfigValue p n _ = List <$> (peekByteOff p n :: IO (Ptr ConfigList))++pokeConfigValue :: Ptr b -> Int -> ConfigValue -> ConfigType -> IO ()+pokeConfigValue p n (IVal x) IntType = pokeByteOff p n x+pokeConfigValue p n (IVal x) BoolType = pokeByteOff p n x+pokeConfigValue p n (LLVal x) Int64Type = pokeByteOff p n x+pokeConfigValue p n (FVal x) FloatType = pokeByteOff p n x+pokeConfigValue p n (SVal x) StringType = pokeByteOff p n x+pokeConfigValue _ _ None NoneType = return ()+pokeConfigValue p n (List x) ListType = pokeByteOff p n x+pokeConfigValue p n (List x) GroupType = pokeByteOff p n x+pokeConfigValue p n (List x) ArrayType = pokeByteOff p n x+pokeConfigValue _ _ v ty =+ error $ "Internal error: libconfig type mismatch between config_value_t '" +++ configValueType v ++ "' and config_setting_t type tag '" +++ show ty ++ "'!"++instance Storable Setting' where+ sizeOf _ = {#sizeof config_setting_t #}+ alignment _ = {#alignof config_setting_t #}+ peek p = do+ nm <- {#get config_setting_t->name #} p+ ty <- {#get config_setting_t->type #} p+ fmt <- {#get config_setting_t->format #} p+ val <- peekConfigValue p 8 (toEnumIntegral ty)+ Setting' nm ty fmt val <$>+ {#get config_setting_t->parent #} p <*>+ {#get config_setting_t->config #} p <*>+ {#get config_setting_t->hook #} p <*>+ {#get config_setting_t->line #} p <*>+ {#get config_setting_t->file #} p+ poke p Setting'{..} = do+ {#set config_setting_t->name #} p name'Setting+ {#set config_setting_t->type #} p type'Setting+ {#set config_setting_t->format #} p format'Setting+ pokeConfigValue p 8 value'Setting (toEnumIntegral type'Setting)+ {#set config_setting_t->parent #} p parent'Setting+ {#set config_setting_t->config #} p config'Setting+ {#set config_setting_t->hook #} p hook'Setting+ {#set config_setting_t->line #} p line'Setting+ {#set config_setting_t->file #} p file'Setting++-- libconfig itself manages all the 'Setting's, including deallocation+-- and allocation, so we don't have to use a 'ForeignPtr' or+-- 'StablePtr' here. TODO(MP): Ensure that a 'Setting' can't get used+-- outside the scope of its parent 'Configuration'++-- | Corresponds to a @libconfig@ @config_setting_t@ value; wrapped+-- opaquely for pointer safety.+newtype Setting = Setting { getSetting :: Ptr Setting' } deriving (Eq)++data Config = Config {+ root'Config :: SettingPtr+ , destructor'Config :: FunPtr (Ptr () -> IO ())+ , flags'Config :: CUShort+ , tab_width'Config :: CUShort+ , default_format'Config :: CShort+ , include_dir'Config :: CString+ , error_text'Config :: CString+ , error_file'Config :: CString+ , error_line'Config :: CInt+ , error_type'Config :: CInt+ , filenames'Config :: Ptr CString+ , num_filenames'Config :: CUInt+ }++instance Storable Config where+ sizeOf _ = {#sizeof config_t #}+ alignment _ = {#alignof config_t #}+ peek p = Config <$>+ ({#get config_t->root #} p) <*>+ ({#get config_t->destructor #} p) <*>+ ({#get config_t->flags #} p) <*>+ ({#get config_t->tab_width #} p) <*>+ ({#get config_t->default_format #} p) <*>+ ({#get config_t->include_dir #} p) <*>+ ({#get config_t->error_text #} p) <*>+ ({#get config_t->error_file #} p) <*>+ ({#get config_t->error_line #} p) <*>+ ({#get config_t->error_type #} p) <*>+ ({#get config_t->filenames #} p) <*>+ ({#get config_t->num_filenames #} p)+ poke p Config{..} = do+ {#set config_t->root #} p root'Config+ {#set config_t->destructor #} p destructor'Config+ {#set config_t->flags #} p flags'Config+ {#set config_t->tab_width #} p tab_width'Config+ {#set config_t->default_format #} p default_format'Config+ {#set config_t->include_dir #} p include_dir'Config+ {#set config_t->error_text #} p error_text'Config+ {#set config_t->error_file #} p error_file'Config+ {#set config_t->error_line #} p error_line'Config+ {#set config_t->error_type #} p error_type'Config+ {#set config_t->filenames #} p filenames'Config+ {#set config_t->num_filenames #} p num_filenames'Config++foreign import ccall unsafe "src/Language/Libconfig.chs.h config_init"+ configInit' :: Ptr Config -> IO ()++foreign import ccall unsafe "src/Language/Libconfig.chs.h &config_destroy"+ configDestroy' :: FunPtr (Ptr Config -> IO ())++-- | Top-level configuration value, corresponding to the libconfig+-- @config_t@. Wrapped opaquely for pointer-safety.+newtype Configuration = Configuration { getConfiguration :: ForeignPtr Config }+ deriving (Eq)++-- | This function allocates a new 'Configuration' and initializes it.+configInit :: IO Configuration+configInit = do+ c <- mallocForeignPtr+ addForeignPtrFinalizer configDestroy' c+ withForeignPtr c configInit'+ return $ Configuration c++withConfiguration :: Configuration -> (Ptr Config -> IO a) -> IO a+withConfiguration (Configuration c) = withForeignPtr c++modifyConfiguration :: Configuration -> (Config -> Config) -> IO ()+modifyConfiguration (Configuration p) mf = withForeignPtr p $ \cp -> do+ c <- peek cp+ poke cp $ mf c++-- |+-- @libconfig@ manages storage for all 'Setting' objects via the+-- 'Configuration', so if a 'Configuration' goes out of scope, GHC may+-- get rid of it, and any 'Setting' objects may become invalid. This+-- function can be used to ensure that a 'Configuration' doesn't get+-- automatically garbage-collected too early.+touchConfiguration :: Configuration -> IO ()+touchConfiguration = touchForeignPtr . getConfiguration++onConfiguration :: (Config -> a) -> Configuration -> IO a+onConfiguration f = flip withConfiguration (fmap f . peek)++{- Marshalling -}++checkPtr :: Storable a => Ptr a -> Maybe (Ptr a)+checkPtr p+ | nullPtr == p = Nothing+ | otherwise = Just p++checkSetting :: Ptr Setting' -> Maybe Setting+checkSetting = fmap Setting . checkPtr++peekIntegral :: (Integral a, Storable a, Num b) => Ptr a -> IO b+peekIntegral = fmap fromIntegral . peek++peekFloat :: (Real a, Storable a, Fractional b) => Ptr a -> IO b+peekFloat = fmap realToFrac . peek++peekBool :: (Eq a, Num a, Storable a) => Ptr a -> IO Bool+peekBool = fmap toBool . peek++peekString :: Ptr CString -> IO String+peekString = peek >=> peekCString++asBool :: Integral a => a -> ConfigBool+asBool = toEnum . fromIntegral++checkBool :: Integral a => a -> Maybe ()+checkBool a = case asBool a of+ ConfigTrue -> Just ()+ ConfigFalse -> Nothing++checkTuple :: (ConfigBool, a) -> Maybe a+checkTuple (ConfigTrue, x) = Just x+checkTuple _ = Nothing++{- Resource management -}++{- I/O -}++-- | Read in a 'Configuration' from the specified configuration file.+-- The 'Configuration' should already be initialized with+-- 'configInit'.+{#fun unsafe config_read_file as ^+ { withConfiguration* `Configuration', `String' } -> `Maybe ()' checkBool #}++-- | Create a new 'Configuration' and read in the data from the+-- specified configuration file.+--+-- >> configNew s = configInit >>= \c -> configReadFile c s+configNew :: String -> IO (Maybe Configuration)+configNew s = do+ c <- configInit+ red <- configReadFile c s+ return $ case red of+ Nothing -> Nothing+ Just _ -> Just c++-- | Write out a 'Configuration' to the specified configuration file.+{#fun unsafe config_write_file as ^+ { withConfiguration* `Configuration', `String' } -> `Maybe ()' checkBool #}++-- | Read configuration data from a string.+{#fun unsafe config_read_string as ^+ { withConfiguration* `Configuration', `String' } -> `Maybe ()' checkBool #}++{- Unsafe getting -}++-- |+-- >>> Just appwinwidth <- configLookup conf "application.window.size.w"+-- >>> configSettingGetInt appwinwidth+-- 640+{#fun unsafe config_setting_get_int as ^ { getSetting `Setting' } -> `Int' #}++-- |+-- >>> Just miscbigint <- configLookup conf "application.misc.bigint"+-- >>> configSettingGetInt64 miscbigint+-- 9223372036854775807+{#fun unsafe config_setting_get_int64 as ^ { getSetting `Setting' } -> `Int64' #}++-- |+-- >>> Just miscpi <- configLookup conf "application.misc.pi"+-- >>> configSettingGetFloat miscpi+-- 3.141592654+{#fun unsafe config_setting_get_float as ^ { getSetting `Setting' } -> `Double' #}++-- |+-- >>> Just listbool <- configLookup conf "application.list.[0].[2]"+-- >>> configSettingGetBool listbool+-- True+{#fun unsafe config_setting_get_bool as ^ { getSetting `Setting' } -> `Bool' toBool #}++-- |+-- >>> Just wintitle <- configLookup conf "application.window.title"+-- >>> configSettingGetString wintitle+-- "My Application"+{#fun unsafe config_setting_get_string as ^ { getSetting `Setting' } -> `String' #}++{- Safe getting -}++{#fun unsafe config_setting_lookup_int as configSettingLookupInt'+ { getSetting `Setting', `String', alloca- `Int' peekIntegral* } -> `ConfigBool' asBool #}++{#fun unsafe config_setting_lookup_int64 as configSettingLookupInt64'+ { getSetting `Setting', `String', alloca- `Int64' peekIntegral* } -> `ConfigBool' asBool #}++{#fun unsafe config_setting_lookup_float as configSettingLookupFloat'+ { getSetting `Setting', `String', alloca- `Double' peekFloat* } -> `ConfigBool' asBool #}++{#fun unsafe config_setting_lookup_bool as configSettingLookupBool'+ { getSetting `Setting', `String', alloca- `Bool' peekBool* } -> `ConfigBool' asBool #}++{#fun unsafe config_setting_lookup_string as configSettingLookupString'+ { getSetting `Setting', `String', alloca- `String' peekString* } -> `ConfigBool' asBool #}++-- |+-- >>> configSettingLookupInt winsize "w"+-- Just 640+configSettingLookupInt :: Setting -> String -> IO (Maybe Int)+configSettingLookupInt s = fmap checkTuple . configSettingLookupInt' s++-- |+-- >>> configSettingLookupInt64 misc "bigint"+-- Just 9223372036854775807+configSettingLookupInt64 :: Setting -> String -> IO (Maybe Int64)+configSettingLookupInt64 s = fmap checkTuple . configSettingLookupInt64' s++-- |+-- >>> configSettingLookupFloat misc "pi"+-- Just 3.141592654+configSettingLookupFloat :: Setting -> String -> IO (Maybe Double)+configSettingLookupFloat s = fmap checkTuple . configSettingLookupFloat' s++-- | (The example configuration file does not contain any boolean+-- values that are direct children of a @config_setting_t@.)+configSettingLookupBool :: Setting -> String -> IO (Maybe Bool)+configSettingLookupBool s = fmap checkTuple . configSettingLookupBool' s++-- |+-- >>> Just win <- configLookupFrom app "window"+-- >>> configSettingLookupString win "title"+-- Just "My Application"+configSettingLookupString :: Setting -> String -> IO (Maybe String)+configSettingLookupString s = fmap checkTuple . configSettingLookupString' s++{- Setting values -}++-- |+-- >>> Just treasureqty <- configLookup conf' "application.books.[0].qty"+-- >>> configSettingSetInt treasureqty 222+-- Just ()+-- >>> configSettingGetInt treasureqty+-- 222+{#fun unsafe config_setting_set_int as ^+ { getSetting `Setting', `Int' } -> `Maybe ()' checkBool #}++-- |+-- >>> Just miscbigint <- configLookup conf' "application.misc.bigint"+-- >>> configSettingSetInt64 miscbigint 92233720368547758+-- Just ()+-- >>> configSettingGetInt64 miscbigint+-- 92233720368547758+{#fun unsafe config_setting_set_int64 as ^+ { getSetting `Setting', `Int64' } -> `Maybe ()' checkBool #}++-- |+-- >>> Just treasureprice <- configLookup conf' "application.books.[0].price"+-- >>> configSettingSetFloat treasureprice 22.22+-- Just ()+-- >>> configSettingGetFloat treasureprice+-- 22.22+{#fun unsafe config_setting_set_float as ^+ { getSetting `Setting', `Double' } -> `Maybe ()' checkBool #}++-- |+-- >>> Just listbool <- configLookup conf' "application.list.[0].[2]"+-- >>> configSettingSetBool listbool False+-- Just ()+-- >>> configSettingGetBool listbool+-- False+{#fun unsafe config_setting_set_bool as ^+ { getSetting `Setting', `Bool' } -> `Maybe ()' checkBool #}++-- |+-- >>> Just treasureauthor <- configLookup conf' "application.books.[0].author"+-- >>> configSettingSetString treasureauthor "Robert L. Stevenson"+-- Just ()+-- >>> configSettingGetString treasureauthor+-- "Robert L. Stevenson"+{#fun unsafe config_setting_set_string as ^+ { getSetting `Setting', `String' } -> `Maybe ()' checkBool #}++{- Unsafe getting elements in collections -}++-- |+-- >>> Just treasure <- configLookup conf "application.books.[0]"+-- >>> configSettingGetIntElem treasure 3+-- 5+{#fun unsafe config_setting_get_int_elem as ^+ { getSetting `Setting', `Int' } -> `Int' #}++-- |+-- >>> Just misc <- configLookup conf "application.misc"+-- >>> configSettingGetInt64Elem misc 1+-- 9223372036854775807+{#fun unsafe config_setting_get_int64_elem as ^+ { getSetting `Setting', `Int' } -> `Int64' #}++-- |+-- >>> Just list <- configLookup conf "application.list"+-- >>> configSettingGetFloatElem list 1+-- 1.234+{#fun unsafe config_setting_get_float_elem as ^+ { getSetting `Setting', `Int' } -> `Double' #}++-- | (The example configuration does not contain any boolean values+-- that are direct children of collections of type+-- @config_setting_t@).+{#fun unsafe config_setting_get_bool_elem as ^+ { getSetting `Setting', `Int' } -> `Bool' toBool #}++-- |+-- >>> Just win <- configLookup conf "application.window"+-- >>> configSettingGetStringElem win 0+-- "My Application"+{#fun unsafe config_setting_get_string_elem as ^+ { getSetting `Setting', `Int' } -> `String' #}++{- Setting elements in collections -}++-- | (This example appends a new value of type 'IntType' to+-- @application.list@, because the example file contains no suitable+-- example values for us to modify.)+--+-- >>> Just list <- configLookup conf' "application.list"+-- >>> Just new3 <- configSettingSetIntElem list (-1) 22+-- >>> configSettingGetIntElem list 3+-- 22+-- >>> configSettingGetInt new3+-- 22+{#fun unsafe config_setting_set_int_elem as ^+ { getSetting `Setting', `Int', `Int' } -> `Maybe Setting' checkSetting #}++-- | (This example appends a new value of type 'Int64Type' to+-- @application.list@, because the example file contains no suitable+-- example values for us to modify.)+--+-- >>> Just list <- configLookup conf' "application.list"+-- >>> Just new3 <- configSettingSetInt64Elem list (-1) 92233720368547758+-- >>> configSettingGetInt64Elem list 3+-- 92233720368547758+-- >>> configSettingGetInt64 new3+-- 92233720368547758+{#fun unsafe config_setting_set_int64_elem as ^+ { getSetting `Setting', `Int', `Int64' } -> `Maybe Setting' checkSetting #}++-- |+-- >>> Just list <- configLookup conf' "application.list"+-- >>> Just new1 <- configSettingSetFloatElem list 1 0.2222+-- >>> configSettingGetFloatElem list 1+-- 0.2222+-- >>> configSettingGetFloat new1+-- 0.2222+{#fun unsafe config_setting_set_float_elem as ^+ { getSetting `Setting', `Int', `Double' } -> `Maybe Setting' checkSetting #}++-- | (This example appends a new value of type 'BoolType' to+-- @application.list@, because the example file contains no suitable+-- example values for us to modify.)+--+-- >>> Just list <- configLookup conf' "application.list"+-- >>> Just new3 <- configSettingSetBoolElem list (-1) False+-- >>> configSettingGetBoolElem list 3+-- False+-- >>> configSettingGetBool new3+-- False+{#fun unsafe config_setting_set_bool_elem as ^+ { getSetting `Setting', `Int', `Bool' } -> `Maybe Setting' checkSetting #}++-- |+-- >>> Just misccols <- configLookup conf' "application.misc.columns"+-- >>> Just new0 <- configSettingSetStringElem misccols 0 "butts"+-- >>> configSettingGetStringElem misccols 0+-- "butts"+-- >>> configSettingGetString new0+-- "butts"+{#fun unsafe config_setting_set_string_elem as ^+ { getSetting `Setting', `Int', `String' } -> `Maybe Setting' checkSetting #}++{- Collection management -}++-- |+-- >>> Just col0 <- configLookup conf "application.misc.columns.[0]"+-- >>> configSettingIndex col0+-- 0+{#fun unsafe config_setting_index as ^+ { getSetting `Setting' } -> `Int' #}++-- |+-- >>> Just cols <- configLookup conf "application.misc.columns"+-- >>> configSettingLength cols+-- 3+{#fun config_setting_length as ^+ { getSetting `Setting' } -> `Int' #}++-- |+-- >>> Just cols <- configLookup conf "application.misc.columns"+-- >>> Just col0 <- configSettingGetElem cols 0+-- >>> configSettingGetString col0+-- "Last Name"+{#fun config_setting_get_elem as ^+ { getSetting `Setting', fromIntegral `Int' } -> `Maybe Setting' checkSetting #}++-- |+-- >>> Just miscpi <- configSettingGetMember misc "pi"+-- >>> configSettingGetFloat miscpi+-- 3.141592654+{#fun config_setting_get_member as ^+ { getSetting `Setting', `String' } -> `Maybe Setting' checkSetting #}++-- |+-- >>> Just misc' <- configLookup conf' "application.misc"+-- >>> Just randSeed <- configSettingAdd misc' "random_seed" IntType+-- >>> configSettingSetInt randSeed 55+-- Just ()+-- >>> configSettingGetInt randSeed+-- 55+-- >>> configSettingLookupInt misc' "random_seed"+-- Just 55+-- >>> configSettingGetIntElem misc' 4+-- 55+{#fun config_setting_add as ^+ { getSetting `Setting', `String', fromEnumIntegral `ConfigType' }+ -> `Maybe Setting' checkSetting #}++-- |+-- >>> Just misc' <- configLookup conf' "application.misc"+-- >>> configSettingLength misc'+-- 4+-- >>> configSettingRemove misc' "bitmask"+-- Just ()+-- >>> configSettingLength misc'+-- 3+{#fun config_setting_remove as ^+ { getSetting `Setting', `String' } -> `Maybe ()' checkBool #}++-- |+-- >>> Just misc' <- configLookup conf' "application.misc"+-- >>> configSettingLength misc'+-- 4+-- >>> configSettingRemoveElem misc' 2+-- Just ()+-- >>> configSettingLength misc'+-- 3+-- >>> Just new2 <- configSettingGetElem misc' 2+-- >>> configSettingType new2+-- IntType+-- >>> configSettingGetInt new2+-- 8131+{#fun config_setting_remove_elem as ^+ { getSetting `Setting', fromIntegral `Int' } -> `Maybe ()' checkBool #}++-- I haven't worked out a good way to do this one yet. What's+-- necessary is to register a finalizer for 'freeStablePtr xp' with+-- the relevant 'Configuration' pointer. Unfortunately, we can't go+-- from a 'Setting' to the ForeignPtr contained in a 'Configuration'.+--+-- Punting for now, since I don't even know what you use this for.++-- foreign import ccall unsafe "src/Language/Libconfig.chs.h config_setting_set_hook"+-- configSettingSetHook' :: Ptr Setting' -> Ptr () -> IO ()++-- configSettingSetHook :: Storable a => Setting -> a -> IO ()+-- configSettingSetHook (Setting s) x = do+-- xp <- newStablePtr x+-- cfgp <- config'Setting <$> peek s++-- configSettingGetHook :: Storable a => Setting -> IO a+-- configSettingGetHook (Setting s) = fmap (castPtr . hook'Setting) (peek s) >>= peek+++{- Path search -}++-- |+-- >>> Just app <- configLookup conf "application"+-- >>> configSettingName app+-- Just "application"+{#fun config_lookup as ^+ { withConfiguration* `Configuration', `String' } -> `Maybe Setting' checkSetting #}++-- |+-- >>> Just list <- configLookupFrom app "list"+-- >>> configSettingName list+-- Just "list"+{#fun config_lookup_from as ^+ { getSetting `Setting', `String' } -> `Maybe Setting' checkSetting #}++{#fun config_lookup_int as configLookupInt'+ { withConfiguration* `Configuration', `String', alloca- `Int' peekIntegral* }+ -> `ConfigBool' asBool #}++{#fun config_lookup_int64 as configLookupInt64'+ { withConfiguration* `Configuration', `String', alloca- `Int64' peekIntegral* }+ -> `ConfigBool' asBool #}++{#fun config_lookup_float as configLookupFloat'+ { withConfiguration* `Configuration', `String', alloca- `Double' peekFloat* }+ -> `ConfigBool' asBool #}++{#fun config_lookup_bool as configLookupBool'+ { withConfiguration* `Configuration', `String', alloca- `Bool' peekBool* }+ -> `ConfigBool' asBool #}++{#fun config_lookup_string as configLookupString'+ { withConfiguration* `Configuration', `String', alloca- `String' peekString* }+ -> `ConfigBool' asBool #}++-- |+-- >>> Just appwinwidth <- configLookup conf "application.window.size.w"+-- >>> configSettingGetFormat appwinwidth+-- DefaultFormat+{#fun config_setting_get_format as ^+ { getSetting `Setting' }+ -> `ConfigFormat' toEnumIntegral #}++-- |+-- >>> Just appwinwidth' <- configLookup conf' "application.window.size.w"+-- >>> configSettingGetFormat appwinwidth'+-- DefaultFormat+-- >>> configSettingSetFormat appwinwidth' HexFormat+-- Just ()+-- >>> configSettingGetFormat appwinwidth'+-- HexFormat+{#fun config_setting_set_format as ^+ { getSetting `Setting', fromEnumIntegral `ConfigFormat' }+ -> `Maybe ()' checkBool #}++-- |+-- >>> configLookupInt conf "application.window.size.w"+-- Just 640+configLookupInt :: Configuration -> String -> IO (Maybe Int)+configLookupInt c = fmap checkTuple . configLookupInt' c++-- |+-- >>> configLookupInt64 conf "application.misc.bigint"+-- Just 9223372036854775807+configLookupInt64 :: Configuration -> String -> IO (Maybe Int64)+configLookupInt64 c = fmap checkTuple . configLookupInt64' c++-- |+-- >>> configLookupFloat conf "application.misc.pi"+-- Just 3.141592654+configLookupFloat :: Configuration -> String -> IO (Maybe Double)+configLookupFloat c = fmap checkTuple . configLookupFloat' c++-- |+-- >>> configLookupBool conf "application.list.[0].[2]"+-- Just True+configLookupBool :: Configuration -> String -> IO (Maybe Bool)+configLookupBool c = fmap checkTuple . configLookupBool' c+++-- |+-- >>> configLookupString conf "application.window.title"+-- Just "My Application"+configLookupString :: Configuration -> String -> IO (Maybe String)+configLookupString c = fmap checkTuple . configLookupString' c++-- |+-- >>> Just list <- configLookup conf "application.list"+-- >>> configSettingType list+-- ListType+configSettingType :: Setting -> IO ConfigType+configSettingType = fmap (toEnumIntegral . type'Setting) . peek . getSetting++-- |+-- >>> Just grp <- configLookup conf "application.window"+-- >>> configSettingIsGroup grp+-- True+configSettingIsGroup :: Setting -> IO Bool+configSettingIsGroup = fmap (== GroupType) . configSettingType++-- |+-- >>> Just arr <- configLookup conf "application.misc.columns"+-- >>> configSettingIsArray arr+-- True+configSettingIsArray :: Setting -> IO Bool+configSettingIsArray = fmap (== ArrayType) . configSettingType++-- |+-- >>> Just list <- configLookup conf "application.list"+-- >>> configSettingIsList list+-- True+configSettingIsList :: Setting -> IO Bool+configSettingIsList = fmap (== ListType) . configSettingType++-- |+-- >>> Just grp <- configLookup conf "application.window"+-- >>> Just arr <- configLookup conf "application.misc.columns"+-- >>> Just list <- configLookup conf "application.list"+-- >>> Just width <- configLookup conf "application.window.size.w"+-- >>> mapM configSettingIsAggregate [grp, arr, list, width]+-- [True,True,True,False]+configSettingIsAggregate :: Setting -> IO Bool+configSettingIsAggregate =+ fmap (`elem` [ListType, GroupType, ArrayType]) . configSettingType++-- |+-- >>> Just int <- configLookup conf "application.window.pos.x"+-- >>> Just bigint <- configLookup conf "application.misc.bigint"+-- >>> Just float <- configLookup conf "application.misc.pi"+-- >>> Just grp <- configLookup conf "application.window"+-- >>> mapM configSettingIsNumber [int, bigint, float, grp]+-- [True,True,True,False]+configSettingIsNumber :: Setting -> IO Bool+configSettingIsNumber =+ fmap (`elem` [IntType, Int64Type, FloatType]) . configSettingType++-- |+-- >>> Just int <- configLookup conf "application.window.pos.x"+-- >>> Just bigint <- configLookup conf "application.misc.bigint"+-- >>> Just float <- configLookup conf "application.misc.pi"+-- >>> Just bool <- configLookup conf "application.list.[0].[2]"+-- >>> Just str <- configLookup conf "application.window.title"+-- >>> Just grp <- configLookup conf "application.window"+-- >>> mapM configSettingIsScalar [int, bigint, float, bool, str, grp]+-- [True,True,True,True,True,False]+configSettingIsScalar :: Setting -> IO Bool+configSettingIsScalar =+ fmap (`elem` [IntType, Int64Type, FloatType, BoolType, StringType]) .+ configSettingType++-- |+-- >>> Just list <- configLookup conf "application.list"+-- >>> configSettingName list+-- Just "list"+--+-- >>> Just list1 <- configLookup conf "application.list.[0]"+-- >>> configSettingName list1+-- Nothing+configSettingName :: Setting -> IO (Maybe String)+configSettingName (Setting sp) = do+ s <- peek sp+ if (name'Setting s == nullPtr)+ then return Nothing+ else Just <$> peekCString (name'Setting s)++-- |+-- >>> Just list <- configLookup conf "application.list"+-- >>> Just app <- configSettingParent list+-- >>> configSettingName app+-- Just "application"+configSettingParent :: Setting -> IO (Maybe Setting)+configSettingParent = fmap (checkSetting . parent'Setting) . peek . getSetting++-- |+-- >>> configSettingIsRoot app+-- False+-- >>> Just root <- configRootSetting conf+-- >>> configSettingIsRoot root+-- True+configSettingIsRoot :: Setting -> IO Bool+configSettingIsRoot = fmap ((==nullPtr) . parent'Setting) . peek . getSetting++-- |+-- >>> Just root <- configRootSetting conf+-- >>> Just version <- configSettingGetMember root "version"+-- >>> configSettingGetString version+-- "1.0"+configRootSetting :: Configuration -> IO (Maybe Setting)+configRootSetting =+ flip withForeignPtr (fmap (checkSetting . root'Config) . peek) . getConfiguration++-- |+-- >>> configGetDefaultFormat conf'+-- DefaultFormat+-- >>> configSetDefaultFormat conf' HexFormat+-- >>> configGetDefaultFormat conf'+-- HexFormat+configSetDefaultFormat :: Configuration -> ConfigFormat -> IO ()+configSetDefaultFormat c' f =+ modifyConfiguration c' $+ \c -> c { default_format'Config = fromIntegral $ fromEnum f }++-- |+-- >>> configGetDefaultFormat conf+-- DefaultFormat+configGetDefaultFormat :: Configuration -> IO ConfigFormat+configGetDefaultFormat =+ onConfiguration (toEnum . fromIntegral . default_format'Config)++-- |+-- >>> configGetTabWidth conf'+-- 2+-- >>> configSetTabWidth conf' 8+-- >>> configGetTabWidth conf'+-- 8+configSetTabWidth :: Configuration -> Int -> IO ()+configSetTabWidth c' w =+ modifyConfiguration c' $+ \c -> c { tab_width'Config = fromIntegral w }++-- |+-- >>> configGetTabWidth conf+-- 2+configGetTabWidth :: Configuration -> IO Int+configGetTabWidth =+ onConfiguration (fromIntegral . tab_width'Config)++-- |+-- >>> configSettingSourceLine app+-- 5+configSettingSourceLine :: Setting -> IO Int+configSettingSourceLine =+ fmap (fromIntegral . line'Setting) . peek . getSetting++-- |+-- >>> configSettingSourceFile app+-- "test/test.conf"+configSettingSourceFile :: Setting -> IO String+configSettingSourceFile (Setting s) = peek s >>= peekCString . file'Setting++configErrorFile :: Configuration -> IO String+configErrorFile c =+ withConfiguration c $+ \p -> peek p >>= peekCString . error_file'Config++configErrorText :: Configuration -> IO String+configErrorText c =+ withConfiguration c $+ \p -> peek p >>= peekCString . error_text'Config++configErrorLine :: Configuration -> IO Int+configErrorLine =+ onConfiguration (fromIntegral . error_line'Config)++configErrorType :: Configuration -> IO ConfigErr+configErrorType =+ onConfiguration (toEnum . fromIntegral . error_type'Config)++-- TODO(MP): Perhaps a MonadIO m => ConfigT m which both wraps non-IO+-- config actions and uses ExceptT or MaybeT to keep track of errors
+ src/Language/Libconfig/Decode.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS_GHC -Wall #-}++{-|+Module : Language.Libconfig.Decode+Copyright : (c) Matthew Peddie 2014+License : BSD3++Maintainer : mpeddie@gmail.com+Stability : experimental+Portability : GHC++Converting libconfig native data into friendly Haskell structures from+"Language.Libconfig.Types".++-}++module Language.Libconfig.Decode (+ -- * Decoding libconfig native data+ decode+ , decodeFrom+ ) where++import Control.Applicative+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Maybe++import qualified Data.Text as T (pack)++import Language.Libconfig.Types+import Language.Libconfig.Bindings (ConfigType(..))+import qualified Language.Libconfig.Bindings as C++-- TODO(MP): Properly convert integral types depending on the setting+-- format.++toScalar :: C.Setting -> MaybeT IO Scalar+toScalar s = MaybeT $ C.configSettingType s >>= go+ 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++toList :: C.Setting -> MaybeT IO List+toList s = liftIO (C.configSettingType s) >>= go+ where+ go :: ConfigType -> MaybeT IO List+ go ListType = do+ l <- liftIO $ C.configSettingLength s+ mapM (\i -> MaybeT (C.configSettingGetElem s i) >>= toValue) [0 .. l - 1]+ go _ = MaybeT $ return Nothing++toArray :: C.Setting -> MaybeT IO Array+toArray 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++toGroup :: C.Setting -> MaybeT IO Group+toGroup 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++toValue :: C.Setting -> MaybeT IO Value+toValue s = liftIO (C.configSettingType s) >>= go+ where+ go :: ConfigType -> MaybeT IO Value+ go NoneType = MaybeT $ return Nothing+ 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+ where+ go NoneType = MaybeT $ return Nothing+ go _ =+ (:=) <$> fmap T.pack (MaybeT $ 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)+decode c = do+ res <- runMaybeT $ MaybeT (C.configRootSetting c) >>= toGroup+ C.touchConfiguration c+ return res++-- | 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)+decodeFrom filename = do+ c <- C.configNew filename+ case c of+ Just conf -> decode conf+ Nothing -> return Nothing
+ src/Language/Libconfig/Encode.hs view
@@ -0,0 +1,146 @@+{-# OPTIONS_GHC -Wall #-}++{-|+Module : Language.Libconfig.Encode+Copyright : (c) Matthew Peddie 2014+License : BSD3++Maintainer : mpeddie@gmail.com+Stability : experimental+Portability : GHC++Converting from "Language.Libconfig.Types" structures to native+libconfig 'C.Configuration's.++-}++module Language.Libconfig.Encode (+ -- * Encoding libconfig native data+ encode+ , encodeAt+ , encodeValue+ , encodeTo+ -- * Helpers+ , valueType+ , scalarType+ ) where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Maybe+import Control.Monad (guard, replicateM_)++import qualified Data.Text as T (unpack)++import Language.Libconfig.Types+import Language.Libconfig.Bindings (ConfigType(..))+import qualified Language.Libconfig.Bindings as C++-- $setup+-- >>> :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'+--+-- >>> 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++scalarSet :: C.Setting -> Scalar -> MaybeT IO ()+scalarSet sp = MaybeT . go+ 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)++addValue :: C.Setting -> Value -> MaybeT IO C.Setting+addValue parent value = do+ newset <- MaybeT $ C.configSettingAdd parent "" (valueType value)+ setValue newset value+ return newset++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++setValue :: C.Setting -> Value -> MaybeT IO ()+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++-- | Convert a top-level 'Group' of 'Setting's into a native+-- 'C.Configuration'. This allocates a new 'C.Configuration'.+--+-- >>> Just conf <- runMaybeT $ 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+ conf <- liftIO C.configInit+ 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++-- | 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+ setValue root (Group g)++checkType :: C.Setting -> C.ConfigType -> MaybeT IO ()+checkType sp ty = do+ ty' <- liftIO $ C.configSettingType sp+ guard (ty == ty')++removeKids :: C.Setting -> MaybeT IO ()+removeKids sp = do+ count <- liftIO $ C.configSettingLength sp+ replicateM_ count (MaybeT $ 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+ checkType sp (valueType v)+ removeKids sp+ setValue sp v
+ src/Language/Libconfig/Optics.hs view
@@ -0,0 +1,253 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}++{-|+Module : Language.Libconfig.Optics+Copyright : (c) Matthew Peddie 2014+License : BSD3++Maintainer : mpeddie@gmail.com+Stability : experimental+Portability : GHC++Optics for the libconfig types in "Language.Libconfig.Types".+++-}++module Language.Libconfig.Optics (+ -- $prismnote+ -- * A note on examples++ -- $setup++ -- * 'Setting'++ -- |+ -- These @Lens@es are first-class references into the parts of a+ -- 'Setting'.+ settingValue+ , settingName+#ifdef DEFINE_PRISMS+ -- * 'Value'++ -- |+ -- These @Prisms@ provide @Traversal@s for tweaking the relevant+ -- part of a 'Value'. They can also be turned around to obtain+ -- the embedding into the relevant constructor.+ --+ , _Scalar+ , _Array+ , _List+ , _Group+ -- * 'Scalar'+ --+ -- |+ -- These @Prisms@ provide @Traversal@s for tweaking the relevant+ -- part of a 'Scalar'. They can also be turned around to obtain+ -- the embedding into the relevant constructor.+ --+ , _Boolean+ , _Integer+ , _Integer64+ , _Hex+ , _Hex64+ , _Float+ , _String+#endif+ ) where++#ifdef DEFINE_PRISMS+import Data.Profunctor+import Control.Applicative+#endif++import Language.Libconfig.Types++#ifndef DEFINE_PRISMS+-- $prismnote+--+-- This package was built with the non-default cabal configuration flag+-- @-f -prisms@ and hence contains no @Prism@s for the 'Value' and+-- 'Scalar' sum types. If you want @Prism@s, please rebuild this package+-- with the default configuration value of @-f prisms@. Rebuilding will+-- incur a dependency on the @profunctors@ package (but __not__ on the+-- @lens@ package).+#else+-- $prismnote+#endif++type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t++type Lens' s a = Lens s s a a++#ifdef DEFINE_PRISMS+-- $setup+-- In order to run the usage examples in @ghci@, some setup is required:+--+-- >>> :set -XOverloadedStrings+-- >>> import Control.Lens+-- >>> :set -XCPP+-- >>> :set -DDEFINE_PRISMS+#else+-- $setup+-- In order to run the usage examples in @ghci@, some setup is required:+--+-- >>> :set -XOverloadedStrings+-- >>> import Control.Lens+#endif++-- |+-- >>> ("asset" := Scalar (String "butts")) ^. settingValue+-- Scalar (String "butts")+--+-- >>> ("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"+--+-- >>> ("asset" := Scalar (String "butts")) & settingName .~ "shake"+-- "shake" := Scalar (String "butts")+settingName :: Lens' Setting Text+settingName f (name := value) = fmap (\name' -> name' := 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)++type Prism' s a = Prism s s a a++prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+prism bt seta = dimap seta (either pure (fmap bt)) . right'++-- |+-- >>> Scalar (String "butts") ^? _Scalar+-- Just (String "butts")+--+-- >>> ("asset" := Scalar (String "butts")) & settingValue . _Scalar . _String .~ "money"+-- "asset" := Scalar (String "money")+--+-- >>> _Scalar # String "butts"+-- Scalar (String "butts")+_Scalar :: Prism' Value Scalar+_Scalar = prism Scalar $ \x -> case x of+ (Scalar s) -> Right s+ _ -> Left x++-- |+-- >>> Array [String "butts"] ^? _Array+-- Just [String "butts"]+--+-- >>> ("asset" := Array [String "butts"]) & settingValue . _Array . traverse . _String .~ "money"+-- "asset" := Array [String "money"]+_Array :: Prism' Value Array+_Array = prism Array $ \x -> case x of+ (Array a) -> Right a+ _ -> Left x++-- |+-- >>> 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 44.4)]+_Group :: Prism' Value Group+_Group = prism Group $ \x -> case x of+ (Group a) -> Right a+ _ -> Left x+-- |+-- >>> List [Scalar (String "butts"), Scalar (Float 22.2)] ^? _List . ix 0+-- Just (Scalar (String "butts"))+--+-- >>> List [Scalar (String "butts"), Scalar (Float 22.2)] & _List . traverse . _Scalar . _Float %~ (*2)+-- List [Scalar (String "butts"),Scalar (Float 44.4)]+_List :: Prism' Value List+_List = prism List $ \x -> case x of+ (List a) -> Right a+ _ -> Left x++-- |+-- >>> Boolean False ^? _Boolean+-- Just False+--+-- >>> Scalar (Boolean False) & _Scalar . _Boolean %~ not+-- Scalar (Boolean True)+_Boolean :: Prism' Scalar Bool+_Boolean = prism Boolean $ \x -> case x of+ (Boolean b) -> Right b+ _ -> Left x++-- |+-- >>> Integer 22 ^? _Integer+-- Just 22+--+-- >>> Scalar (Integer 22) & _Scalar . _Integer %~ (*2)+-- Scalar (Integer 44)+_Integer :: Prism' Scalar Int32+_Integer = prism Integer $ \x -> case x of+ (Integer b) -> Right b+ _ -> Left x+-- |+-- >>> Integer64 2222222222 ^? _Integer64+-- Just 2222222222+--+-- >>> Scalar (Integer64 2222222222) & _Scalar . _Integer64 %~ (*2)+-- Scalar (Integer64 4444444444)+_Integer64 :: Prism' Scalar Int64+_Integer64 = prism Integer64 $ \x -> case x of+ (Integer64 b) -> Right b+ _ -> Left x++-- |+-- >>> Hex 22 ^? _Hex+-- Just 22+--+-- >>> Scalar (Hex 22) & _Scalar . _Hex %~ (*2)+-- Scalar (Hex 44)+_Hex :: Prism' Scalar Word32+_Hex = prism Hex $ \x -> case x of+ (Hex b) -> Right b+ _ -> Left x++-- |+-- >>> Hex64 2222222222 ^? _Hex64+-- Just 2222222222+--+-- >>> Scalar (Hex64 2222222222) & _Scalar . _Hex64 %~ (*2)+-- Scalar (Hex64 4444444444)+_Hex64 :: Prism' Scalar Word64+_Hex64 = prism Hex64 $ \x -> case x of+ (Hex64 b) -> Right b+ _ -> Left x++-- |+-- >>> Float 22.22 ^? _Float+-- Just 22.22+--+-- >>> Scalar (Float 22.22) & _Scalar . _Float %~ (*2)+-- Scalar (Float 44.44)+_Float :: Prism' Scalar Double+_Float = prism Float $ \x -> case x of+ (Float b) -> Right b+ _ -> Left x++-- |+-- >>> String "butts" ^? _String+-- Just "butts"+--+-- >>> Float 22.22 ^? _String+-- Nothing+--+-- >>> import Data.Monoid ((<>))+-- >>> Scalar (String "butts") & _Scalar . _String %~ ("hello " <>)+-- Scalar (String "hello butts")+_String :: Prism' Scalar Text+_String = prism String $ \x -> case x of+ (String b) -> Right b+ _ -> Left x++#endif
+ src/Language/Libconfig/Types.hs view
@@ -0,0 +1,283 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}++{-|+Module : Language.Libconfig.Types+Copyright : (c) Matthew Peddie 2014+License : BSD3++Maintainer : mpeddie@gmail.com+Stability : experimental+Portability : GHC++Core types for configuration file data.++-}++module Language.Libconfig.Types (+ -- $intro++ -- ** A note about the examples++ -- $setup++ -- * Primitive types+ Setting(..)+ , getSettingName+ , getSettingValue+ , Value(..)+ , isScalar+ , isCollection+ , isArray+ , isGroup+ , isList+ , Scalar(..)+ -- * Collection types+ , Array+ , List+ , Group+ -- * Re-exports+ , Int32+ , Int64+ , Word32+ , Word64+ , Text+ ) where++import GHC.Generics (Generic)+import Data.Data (Data)+import Data.Typeable (Typeable)++import Data.Text (Text)+import Data.Hashable (Hashable)+import Control.DeepSeq (NFData)++#ifdef BINARY_INSTANCES+import Data.Binary (Binary)+import Data.Text.Binary ()+#endif+#ifdef CEREAL_INSTANCES+import Data.Serialize (Serialize)+import Data.Serialize.Text ()+#endif++import Data.Int (Int32, Int64)+import Data.Word (Word32, Word64)++-- $setup+--+-- To run these usage examples, you must tell GHC it's allowed to+-- parse string literals as 'Text' values:+--+-- >>> :set -XOverloadedStrings++infixr 3 :=+-- | A @libconfig@ 'Setting' is a name-value pair, @name := value@.+data Setting = !Text := !Value+ deriving (Eq, Show, Read, Ord, Data, Typeable, Generic)++-- | Get out the name of a 'Setting'+getSettingName :: Setting -> Text+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+ | Array !Array+ | List !List+ | Group !Group+ deriving (Eq, Show, Read, Ord, Data, Typeable, Generic)++-- |+-- >>> isScalar $ Scalar (String "butts")+-- True+--+-- >>> isScalar $ Array [String "butts"]+-- False+isScalar :: Value -> Bool+isScalar (Scalar _) = True+isScalar _ = False++-- | @isCollection = not . isScalar@+--+-- >>> isCollection $ Scalar (String "butts")+-- False+--+-- >>> isCollection $ Array [String "butts"]+-- True+isCollection :: Value -> Bool+isCollection = not . isScalar++-- |+-- >>> isArray $ Array [String "butts"]+-- True+--+-- >>> isArray $ List [Scalar $ String "butts"]+-- False+isArray :: Value -> Bool+isArray (Array _) = True+isArray _ = False++-- |+-- >>> isList $ Array [String "butts"]+-- False+--+-- >>> isList $ List [Scalar $ String "butts"]+-- True+isList :: Value -> Bool+isList (List _) = True+isList _ = False++-- |+-- >>> isGroup $ Array [String "butts"]+-- False+--+-- >>> 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+ | Integer !Int32+ | Integer64 !Int64+ | Hex !Word32+ | Hex64 !Word64+ | Float !Double+ | String !Text+ deriving (Eq, Show, Read, Ord, Data, Typeable, Generic)++instance Hashable Scalar where+instance NFData Scalar where++#ifdef BINARY_INSTANCES+instance Binary Setting+instance Binary Value+instance Binary Scalar+#endif++#ifdef CEREAL_INSTANCES+instance Serialize Setting+instance Serialize Value+instance Serialize Scalar+#endif++-- | libconfig 'Array's can contain any number 'Scalar' values.+type Array = [Scalar]++-- | libconfig 'List's can contain any number of 'Value's.+type List = [Value]++-- | libconfig 'Group's are like 'List's, except that each element in the+-- 'Group' is a 'Setting' with its own unique name, not just an+-- unlabeled 'Value'.+type Group = [Setting]++-- $intro+--+-- Here is the example configuration file @test/test.conf@ from the+-- <http://www.hyperrealm.com/libconfig/libconfig_manual.html#Configuration-Files libconfig manual>.+--+-- @+-- # Example application configuration file+--+-- version = "1.0";+--+-- application:+-- {+-- window:+-- {+-- title = "My Application";+-- size = { w = 640; h = 480; };+-- pos = { x = 350; y = 250; };+-- };+--+-- list = ( ( "abc", 123, true ), 1.234, ( /* an empty list */) );+--+-- books = ( { title = "Treasure Island";+-- author = "Robert Louis Stevenson";+-- price = 29.95;+-- qty = 5; },+-- { title = "Snow Crash";+-- author = "Neal Stephenson";+-- price = 9.99;+-- qty = 8; } );+--+-- misc:+-- {+-- pi = 3.141592654;+-- bigint = 9223372036854775807L;+-- columns = [ "Last Name", "First Name", "MI" ];+-- bitmask = 0x1FC3;+-- };+-- };+-- @+--+-- The 'Language.Libconfig.Decode.decode' function renders this as the+-- following structure:+--+-- @+-- [+-- "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)+-- ]+-- ]+-- ]+-- @
test/doctest.hs view
@@ -1,7 +1,18 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+ module Main where import Test.DocTest -- Bit of a hack, this . . . main :: IO ()-main = doctest [ "-lconfig", "dist/build/Language/Libconfig.hs" ]+main = do+ doctest [ "-lconfig" , "dist/build/Language/Libconfig/Bindings.hs" ]+ doctest [ "-lconfig" , "-isrc", "src/Language/Libconfig/Types.hs" ]+ doctest [ "-lconfig" , "-isrc", "-idist/build", "src/Language/Libconfig/Decode.hs" ]+ doctest [ "-lconfig" , "-isrc", "-idist/build", "src/Language/Libconfig/Encode.hs" ]+#ifdef DEFINE_PRISMS+ doctest [ "-lconfig" , "-isrc", "-DDEFINE_PRISMS", "src/Language/Libconfig/Optics.hs" ]+#else+#endif