module Language.Libconfig.Decode (
decode
, decodeFrom
, DecodeError(..)
) where
import Control.Applicative
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Data.Data (Data)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Control.DeepSeq (NFData)
import qualified Data.Text as T (pack)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Language.Libconfig.Types
import Language.Libconfig.Bindings (ConfigType(..), ConfigFormat(..))
import qualified Language.Libconfig.Bindings as C
data DecodeError = DecoderRoot
| Name {
decodeErrSetting :: Text
}
| GetNone {
decodeErrSetting :: Text
}
| GetIndex {
decodeErrParent :: Text
, decodeErrIndex :: Int
}
| Parse {
decodeErrFilename :: Text
, decodeErrLine :: Word32
, decodeErrDescription :: Text
}
| FileInput {
decodeErrFilename :: Text
} deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)
instance NFData DecodeError
withErr :: Maybe a -> e -> Either e a
withErr Nothing e = Left e
withErr (Just x) _ = Right x
decoder :: IO (Either DecodeError a) -> Decoder a
decoder = lift . ExceptT
throw :: DecodeError -> Decoder a
throw = lift . throwE
catchD :: (DecodeError -> ExceptT DecodeError IO a) -> Decoder a -> Decoder a
catchD handler action =
ReaderT $ \conf -> catchE (runReaderT action conf) handler
type Decoder a = ReaderT ConfigFormat (ExceptT DecodeError IO) a
textToNameErr :: Text -> Name
textToNameErr text = fromMaybe err $ textToName text
where
err = error $ "Language.Libconfig.Decode.textToNameErr: " ++
"C library passed an invalid 'Name' value " ++ show text ++ "!"
toScalar :: C.Setting -> Decoder Scalar
toScalar s = do
ty <- liftIO $ C.configSettingType s
localFormat <- liftIO $ C.configSettingGetFormat s
format <- case localFormat of
HexFormat -> return HexFormat
DefaultFormat -> ask
decoder $ go format ty
where
go :: ConfigFormat -> ConfigType -> IO (Either DecodeError Scalar)
go DefaultFormat IntType =
Right . Integer . fromIntegral <$> C.configSettingGetInt s
go DefaultFormat Int64Type =
Right . Integer64 . fromIntegral <$> C.configSettingGetInt64 s
go HexFormat IntType =
Right . Hex . fromIntegral <$> C.configSettingGetInt s
go HexFormat Int64Type =
Right . Hex64 . fromIntegral <$> C.configSettingGetInt64 s
go _ FloatType = Right . Float <$> C.configSettingGetFloat s
go _ BoolType = Right . Boolean <$> C.configSettingGetBool s
go _ StringType = Right . String . T.pack <$> C.configSettingGetString s
go _ t =
error $ "Language.Libconfig.Decode.toScalar: internal error (bug!): expected " ++
"a type in [IntType, Int64Type, FloatType, BoolType, StringType], but got '" ++
show t ++ "'!"
toList :: C.Setting -> Decoder List
toList s = do
ty <- liftIO $ C.configSettingType s
addParent s $ go ty
where
go ListType = do
l <- liftIO $ C.configSettingLength s
mapM get [0 .. l 1]
go ty =
error $ "Language.Libconfig.Decode.toList: internal error (bug!): expected " ++
"a value with 'ListType', but got '" ++ show ty ++ "'!"
get :: Int -> Decoder Value
get i = do
el <- decoder $ (`withErr` GetIndex "" i) <$> C.configSettingGetElem s i
toValue el
toArray :: C.Setting -> Decoder Array
toArray s = addParent s $ liftIO (C.configSettingType s) >>= go
where
go ArrayType = do
l <- liftIO $ C.configSettingLength s
mapM get [0 .. l 1]
go ty =
error $ "Language.Libconfig.Decode.toArray: internal error (bug!): expected " ++
"a value with 'ArrayType', but got '" ++ show ty ++ "'!"
get i = do
el <- decoder $ (`withErr` GetIndex "" i) <$> C.configSettingGetElem s i
toScalar el
toGroup :: C.Setting -> Decoder Group
toGroup s = addParent s $ liftIO (C.configSettingType s) >>= go
where
go GroupType = do
l <- liftIO $ C.configSettingLength s
mapM get [0 .. l 1]
go ty =
error $ "Language.Libconfig.Decode.toGroup: internal error (bug!): expected " ++
"a value with 'GroupType', but got '" ++ show ty ++ "'!"
get i = do
el <- decoder $ (`withErr` GetIndex "" i) <$> C.configSettingGetElem s i
decodeSetting el
toValue :: C.Setting -> Decoder Value
toValue s = addParent s $ liftIO (C.configSettingType s) >>= go
where
go NoneType = throw $ GetNone ""
go ListType = List <$> toList s
go ArrayType = Array <$> toArray s
go GroupType = Group <$> toGroup s
go _ = Scalar <$> toScalar s
addParent :: C.Setting -> Decoder a -> Decoder a
addParent s = catchD handler
where
mapSetting _ e@(Parse{}) = e
mapSetting _ e@(FileInput _) = e
mapSetting f (GetIndex p i) = GetIndex (f p) i
mapSetting f e = e { decodeErrSetting = f (decodeErrSetting e) }
handler e = do
name <- liftIO $ getName s
throwE $ mapSetting ((name <> ".") <>) e
getName :: C.Setting -> IO Text
getName s = do
name <- C.configSettingName s
return $ case name of
Nothing -> "<no name>"
Just x -> T.pack x
decodeSetting :: C.Setting -> Decoder Setting
decodeSetting s = addParent s $ liftIO (C.configSettingType s) >>= go
where
go NoneType = throw $ GetNone ""
go _ =
(:=) <$>
fmap (textToNameErr . T.pack)
(decoder $ (`withErr` Name "") <$> C.configSettingName s) <*>
toValue s
decode :: C.Configuration -> IO (Either DecodeError Group)
decode c = do
format <- C.configGetDefaultFormat c
res <- runExceptT $ runReaderT (getRoot c >>= toGroup) format
C.touchConfiguration c
return res
where
getRoot cnf = decoder $ (`withErr` DecoderRoot) <$> C.configRootSetting cnf
decodeFrom :: String -> IO (Either DecodeError Group)
decodeFrom filename = do
c <- C.configInit
red <- C.configReadFile c filename
case red of
Nothing -> do
ty <- C.configErrorType c
fn <- maybe (T.pack filename) T.pack <$> C.configErrorFile c
case ty of
C.ConfigErrFileIo -> return . Left $ FileInput fn
C.ConfigErrParse -> do
err <- Parse fn <$>
(fromIntegral <$> C.configErrorLine c) <*>
(maybe "" T.pack <$> C.configErrorText c)
return $ Left err
_ ->
error "Language.Libconfig.Decode.decodeFrom: something is really broken!"
Just _ -> decode c