{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Toml.Bi.Combinators
(
BiToml
, Env
, St
, EncodeException
, DecodeException
, encode
, decode
, unsafeDecode
, bijectionMaker
, dimapNum
, bool
, int
, integer
, double
, str
, arrayOf
, maybeP
, Valuer (..)
, boolV
, integerV
, doubleV
, strV
, arrV
) where
import Control.Monad.Except (ExceptT, catchError, runExceptT, throwError)
import Control.Monad.Reader (Reader, asks, runReader)
import Control.Monad.State (State, gets, modify, runState)
import Data.Bifunctor (first)
import Data.Text (Text)
import Toml.Bi.Monad (Bi, Bijection (..), dimapBijection)
import Toml.Parser (ParseException, parse)
import Toml.PrefixTree (Key)
import Toml.Printer (prettyToml)
import Toml.Type (AnyValue (..), TOML (..), Value (..), ValueType (..), matchArray, matchBool,
matchDouble, matchInteger, matchText)
import qualified Data.HashMap.Strict as HashMap
data EncodeException
= KeyNotFound Key
| TypeMismatch Text
| ParseError ParseException
deriving (Eq, Show)
type Env = ExceptT EncodeException (Reader TOML)
data DecodeException
= DuplicateKey Key AnyValue
deriving (Eq, Show)
type St = ExceptT DecodeException (State TOML)
type BiToml a = Bi Env St a
encode :: BiToml a -> Text -> Either EncodeException a
encode biToml text = do
toml <- first ParseError (parse text)
runReader (runExceptT $ biRead biToml) toml
decode :: BiToml a -> a -> Either DecodeException Text
decode biToml obj = do
let (result, toml) = runState (runExceptT $ biWrite biToml obj) (TOML mempty mempty)
_ <- result
pure $ prettyToml toml
fromRight :: b -> Either a b -> b
fromRight b (Left _) = b
fromRight _ (Right b) = b
unsafeDecode :: BiToml a -> a -> Text
unsafeDecode biToml text = fromRight (error "Unsafe decode") $ decode biToml text
bijectionMaker :: forall a t .
Text
-> (forall f . Value f -> Maybe a)
-> (a -> Value t)
-> Key
-> BiToml a
bijectionMaker typeTag fromVal toVal key = Bijection input output
where
input :: Env a
input = do
mVal <- asks $ HashMap.lookup key . tomlPairs
case mVal of
Nothing -> throwError $ KeyNotFound key
Just (AnyValue val) -> case fromVal val of
Just v -> pure v
Nothing -> throwError $ TypeMismatch typeTag
output :: a -> St a
output a = do
let val = AnyValue (toVal a)
mVal <- gets $ HashMap.lookup key . tomlPairs
case mVal of
Nothing -> a <$ modify (\(TOML vals nested) -> TOML (HashMap.insert key val vals) nested)
Just _ -> throwError $ DuplicateKey key val
dimapNum :: forall n r w . (Integral n, Functor r, Functor w)
=> Bi r w Integer
-> Bi r w n
dimapNum = dimapBijection toInteger fromIntegral
data Valuer (tag :: ValueType) a = Valuer
{ valFrom :: forall t . Value t -> Maybe a
, valTo :: a -> Value tag
}
boolV :: Valuer 'TBool Bool
boolV = Valuer matchBool Bool
integerV :: Valuer 'TInt Integer
integerV = Valuer matchInteger Int
doubleV :: Valuer 'TFloat Double
doubleV = Valuer matchDouble Float
strV :: Valuer 'TString Text
strV = Valuer matchText String
arrV :: forall a t . Valuer t a -> Valuer 'TArray [a]
arrV Valuer{..} = Valuer (matchArray valFrom) (Array . map valTo)
bool :: Key -> BiToml Bool
bool = bijectionMaker "Boolean" matchBool Bool
integer :: Key -> BiToml Integer
integer = bijectionMaker "Int" matchInteger Int
int :: Key -> BiToml Int
int = dimapNum . integer
double :: Key -> BiToml Double
double = bijectionMaker "Double" matchDouble Float
str :: Key -> BiToml Text
str = bijectionMaker "String" matchText String
arrayOf :: forall a t . Valuer t a -> Key -> BiToml [a]
arrayOf valuer key = Bijection input output
where
input :: Env [a]
input = do
mVal <- asks $ HashMap.lookup key . tomlPairs
case mVal of
Nothing -> throwError $ KeyNotFound key
Just (AnyValue (Array arr)) -> case arr of
[] -> pure []
xs -> case mapM (valFrom valuer) xs of
Nothing -> throwError $ TypeMismatch "Some type of element"
Just vals -> pure vals
Just _ -> throwError $ TypeMismatch "Array of smth"
output :: [a] -> St [a]
output a = do
let val = AnyValue $ Array $ map (valTo valuer) a
mVal <- gets $ HashMap.lookup key . tomlPairs
case mVal of
Nothing -> a <$ modify (\(TOML vals nested) -> TOML (HashMap.insert key val vals) nested)
Just _ -> throwError $ DuplicateKey key val
maybeP :: forall a . (Key -> BiToml a) -> Key -> BiToml (Maybe a)
maybeP converter key = let bi = converter key in Bijection
{ biRead = (Just <$> biRead bi) `catchError` handleNotFound
, biWrite = \case
Nothing -> pure Nothing
Just v -> biWrite bi v >> pure (Just v)
}
where
handleNotFound :: EncodeException -> Env (Maybe a)
handleNotFound (KeyNotFound _) = pure Nothing
handleNotFound e = throwError e