diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Matthew Peddie + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Matthew Peddie nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/libconfig.cabal b/libconfig.cabal new file mode 100644 --- /dev/null +++ b/libconfig.cabal @@ -0,0 +1,49 @@ +name: libconfig +version: 0.1.0.0 +synopsis: Haskell bindings to libconfig +description: + Low-level FFI bindings to the + configuration file library. + . + This binding is very low-level at the moment, but higher-level safe + interfaces are planned. + . + + This library only binds to version 1.4.9 of the libconfig + library, which is known as @libconfig9@ in Debian-like + distributions, including Ubuntu. It will not work with + older versions of libconfig, including the @libconfig8@ + distributed in Ubuntu 12.04. + +license: BSD3 +license-file: LICENSE +author: Matthew Peddie +maintainer: mpeddie@gmail.com +copyright: 2015 Matthew Peddie +category: Language +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: git@github.com/peddie/libconfig-haskell + +library + exposed-modules: Language.Libconfig + -- other-modules: + extra-libraries: config + build-depends: base >=4.6 && <4.9 + hs-source-dirs: src + build-tools: c2hs + default-language: Haskell2010 + +test-suite doctest + type: exitcode-stdio-1.0 + default-language: Haskell2010 + 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 diff --git a/src/Language/Libconfig.chs b/src/Language/Libconfig.chs new file mode 100644 --- /dev/null +++ b/src/Language/Libconfig.chs @@ -0,0 +1,1033 @@ +{-# 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 +configuration file library. Please see the + +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 +-- . +-- +-- >>> 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 + +-- | 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 diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.DocTest + +-- Bit of a hack, this . . . +main :: IO () +main = doctest [ "-lconfig", "dist/build/Language/Libconfig.hs" ]