{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
module AesonDecode
(
Decoder (..), defaultDecoder, is
, Path (..), here, at, only
, text, textIs
, integer, integerIs
, bool, boolIs, true, false
, listOf
, vectorOf
, ordMapOf
, hashMapOf
, null
) where
import Data.Aeson (FromJSON, Value (..))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Control.Applicative (Alternative (..))
import Control.Monad (guard, (>=>))
import Data.Foldable (toList)
import Data.Semigroup (Semigroup (..))
import Data.String (IsString (..))
import Prelude hiding (null)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Default as Def
import Data.Text (Text)
import qualified Data.Text as Text
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import Data.Vector (Vector)
newtype Decoder a = Decoder { decodeMaybe :: Value -> Maybe a }
instance Functor Decoder
where
fmap f (Decoder d) = Decoder $ (fmap . fmap) f d
instance Applicative Decoder
where
pure x = Decoder $ (pure . pure) x
Decoder ff <*> Decoder fx = Decoder $ \v ->
ff v >>= \f -> fx v >>= \x -> Just (f x)
instance Monad Decoder
where
Decoder f >>= df = Decoder $ \v ->
f v >>= \x -> let Decoder g = df x in g v
instance Alternative Decoder
where
empty = Decoder $ const Nothing
Decoder a <|> Decoder b = Decoder $ \v -> a v <|> b v
instance FromJSON a => Def.Default (Decoder a)
where
def = defaultDecoder
defaultDecoder :: FromJSON a => Decoder a
defaultDecoder = Decoder $ \v -> Aeson.parseMaybe Aeson.parseJSON v
is :: (Eq a, FromJSON a) => a -> Decoder ()
is x = defaultDecoder >>= \y -> guard (x == y)
newtype Path = Path { getAt :: Value -> Maybe Value }
instance Semigroup Path
where
Path a <> Path b = Path (a >=> b)
instance Monoid Path
where
mappend = (<>)
mempty = here
instance IsString Path
where
fromString x = Path $ \case
Object m -> HashMap.lookup (Text.pack x) m
_ -> Nothing
here :: Path
here = Path Just
at :: Path -> Decoder a -> Decoder a
at (Path f1) (Decoder f2) = Decoder (f1 >=> f2)
only :: Path
only = Path $ \case
Array (toList -> [x]) -> Just x
_ -> Nothing
null :: Decoder ()
null = Decoder $ \case
Null -> Just ()
_ -> Nothing
text :: Decoder Text
text = defaultDecoder
textIs :: Text -> Decoder ()
textIs = is
integer :: Decoder Integer
integer = defaultDecoder
integerIs :: Integer -> Decoder ()
integerIs = is
bool :: Decoder Bool
bool = defaultDecoder
boolIs :: Bool -> Decoder ()
boolIs = is
true :: Decoder ()
true = is True
false :: Decoder ()
false = is False
vectorOf :: Decoder a -> Decoder (Vector a)
vectorOf d = Decoder $ \case
Array xs -> traverse (decodeMaybe d) xs
_ -> Nothing
listOf :: Decoder a -> Decoder [a]
listOf d = toList <$> vectorOf d
hashMapOf :: Decoder a -> Decoder (HashMap Text a)
hashMapOf d = Decoder $ \case
Object xs -> traverse (decodeMaybe d) xs
_ -> Nothing
ordMapOf :: Decoder a -> Decoder (Map Text a)
ordMapOf d = Map.fromList . HashMap.toList <$> hashMapOf d