diff --git a/libconfig.cabal b/libconfig.cabal --- a/libconfig.cabal +++ b/libconfig.cabal @@ -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 @@ -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 diff --git a/src/Language/Libconfig.chs b/src/Language/Libconfig.chs deleted file mode 100644 --- a/src/Language/Libconfig.chs +++ /dev/null @@ -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 -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/src/Language/Libconfig.hs b/src/Language/Libconfig.hs new file mode 100644 --- /dev/null +++ b/src/Language/Libconfig.hs @@ -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 + +configuration file library. Please see the + +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 diff --git a/src/Language/Libconfig/Bindings.chs b/src/Language/Libconfig/Bindings.chs new file mode 100644 --- /dev/null +++ b/src/Language/Libconfig/Bindings.chs @@ -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 +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.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 +-- . +-- +-- @ +-- # 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 + +-- | 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 diff --git a/src/Language/Libconfig/Decode.hs b/src/Language/Libconfig/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Language/Libconfig/Decode.hs @@ -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 diff --git a/src/Language/Libconfig/Encode.hs b/src/Language/Libconfig/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Language/Libconfig/Encode.hs @@ -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 diff --git a/src/Language/Libconfig/Optics.hs b/src/Language/Libconfig/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Language/Libconfig/Optics.hs @@ -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 diff --git a/src/Language/Libconfig/Types.hs b/src/Language/Libconfig/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Libconfig/Types.hs @@ -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 +-- . +-- +-- @ +-- # 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) +-- ] +-- ] +-- ] +-- @ diff --git a/test/doctest.hs b/test/doctest.hs --- a/test/doctest.hs +++ b/test/doctest.hs @@ -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