{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
#if MIN_VERSION_base(4,8,0)
{-# LANGUAGE DeriveAnyClass #-}
#endif
module Lens.Micro.Aeson
(
AsNumber(..)
, _Integral
, nonNull
, Primitive(..)
, AsPrimitive(..)
, AsValue(..)
, key, members
, nth, values
, AsJSON(..)
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Traversable (traverse)
#endif
import Data.Aeson
import Data.Aeson.Parser (value)
import Data.Attoparsec.ByteString.Lazy (maybeResult, parse)
import qualified Data.ByteString as Strict
import Data.ByteString.Lazy.Char8 as Lazy
import Data.HashMap.Strict (HashMap)
import Data.Scientific (Scientific)
import qualified Data.Scientific as Scientific
import Data.Text as Text
import qualified Data.Text.Encoding as StrictText
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyText
import Data.Vector (Vector)
import GHC.Generics
import Lens.Micro
import Lens.Micro.Aeson.Internal ()
import Prelude
#if MIN_VERSION_base(4,8,0)
import Data.Hashable
#endif
class AsNumber t where
_Number :: Traversal' t Scientific
default _Number :: AsPrimitive t => Traversal' t Scientific
_Number = _Primitive . _Number
{-# INLINE _Number #-}
_Double :: Traversal' t Double
_Double = _Number . lens Scientific.toRealFloat (const realToFrac)
{-# INLINE _Double #-}
_Integer :: Traversal' t Integer
_Integer = _Number . lens floor (const fromIntegral)
{-# INLINE _Integer #-}
instance AsNumber Value where
_Number f (Number n) = Number <$> f n
_Number _ v = pure v
{-# INLINE _Number #-}
instance AsNumber Scientific where
_Number = id
{-# INLINE _Number #-}
instance AsNumber Strict.ByteString
instance AsNumber Lazy.ByteString
instance AsNumber Text
instance AsNumber LazyText.Text
instance AsNumber String
_Integral :: (AsNumber t, Integral a) => Traversal' t a
_Integral = _Number . lens floor (const fromIntegral)
{-# INLINE _Integral #-}
data Primitive
= StringPrim !Text
| NumberPrim !Scientific
| BoolPrim !Bool
| NullPrim
#if !MIN_VERSION_base(4,8,0)
deriving (Eq, Ord, Show, Generic)
#endif
#if MIN_VERSION_base(4,8,0)
deriving (Eq, Ord, Show, Generic, Hashable)
#endif
instance AsNumber Primitive where
_Number f (NumberPrim n) = NumberPrim <$> f n
_Number _ p = pure p
{-# INLINE _Number #-}
class AsNumber t => AsPrimitive t where
_Primitive :: Traversal' t Primitive
default _Primitive :: AsValue t => Traversal' t Primitive
_Primitive = _Value . _Primitive
{-# INLINE _Primitive #-}
_String :: Traversal' t Text
_String = _Primitive . trav
where trav f (StringPrim s) = StringPrim <$> f s
trav _ x = pure x
{-# INLINE _String #-}
_Bool :: Traversal' t Bool
_Bool = _Primitive . trav
where trav f (BoolPrim b) = BoolPrim <$> f b
trav _ x = pure x
{-# INLINE _Bool #-}
_Null :: Traversal' t ()
_Null = _Primitive . trav
where trav f NullPrim = NullPrim <$ f ()
trav _ x = pure x
{-# INLINE _Null #-}
fromPrim :: Primitive -> Value
fromPrim (StringPrim s) = String s
fromPrim (NumberPrim n) = Number n
fromPrim (BoolPrim b) = Bool b
fromPrim NullPrim = Null
{-# INLINE fromPrim #-}
instance AsPrimitive Value where
_Primitive f (String s) = fromPrim <$> f (StringPrim s)
_Primitive f (Number n) = fromPrim <$> f (NumberPrim n)
_Primitive f (Bool b) = fromPrim <$> f (BoolPrim b)
_Primitive f Null = fromPrim <$> f NullPrim
_Primitive _ v = pure v
{-# INLINE _Primitive #-}
_String f (String s) = String <$> f s
_String _ v = pure v
{-# INLINE _String #-}
_Bool f (Bool b) = Bool <$> f b
_Bool _ v = pure v
{-# INLINE _Bool #-}
_Null f Null = Null <$ f ()
_Null _ v = pure v
{-# INLINE _Null #-}
instance AsPrimitive Strict.ByteString
instance AsPrimitive Lazy.ByteString
instance AsPrimitive Text.Text
instance AsPrimitive LazyText.Text
instance AsPrimitive String
instance AsPrimitive Primitive where
_Primitive = id
{-# INLINE _Primitive #-}
nonNull :: Traversal' Value Value
nonNull _ Null = pure Null
nonNull f v = _Value f v
{-# INLINE nonNull #-}
class AsPrimitive t => AsValue t where
_Value :: Traversal' t Value
_Object :: Traversal' t (HashMap Text Value)
_Object = _Value . trav
where trav f (Object o) = Object <$> f o
trav _ v = pure v
{-# INLINE _Object #-}
_Array :: Traversal' t (Vector Value)
_Array = _Value . trav
where trav f (Array a) = Array <$> f a
trav _ v = pure v
{-# INLINE _Array #-}
instance AsValue Value where
_Value = id
{-# INLINE _Value #-}
instance AsValue Strict.ByteString where
_Value = _JSON
{-# INLINE _Value #-}
instance AsValue Lazy.ByteString where
_Value = _JSON
{-# INLINE _Value #-}
instance AsValue String where
_Value = strictUtf8 . _JSON
{-# INLINE _Value #-}
instance AsValue Text where
_Value = strictTextUtf8 . _JSON
{-# INLINE _Value #-}
instance AsValue LazyText.Text where
_Value = lazyTextUtf8 . _JSON
{-# INLINE _Value #-}
key :: AsValue t => Text -> Traversal' t Value
key i = _Object . ix i
{-# INLINE key #-}
members :: AsValue t => Traversal' t Value
members = _Object . traverse
{-# INLINE members #-}
nth :: AsValue t => Int -> Traversal' t Value
nth i = _Array . ix i
{-# INLINE nth #-}
values :: AsValue t => Traversal' t Value
values = _Array . traverse
{-# INLINE values #-}
strictUtf8 :: Lens' String Strict.ByteString
strictUtf8 = lens Text.pack (const Text.unpack) . strictTextUtf8
lazyUtf8 :: Lens' Strict.ByteString Lazy.ByteString
lazyUtf8 = lens Lazy.fromStrict (const Lazy.toStrict)
strictTextUtf8 :: Lens' Text.Text Strict.ByteString
strictTextUtf8 = lens StrictText.encodeUtf8 (const StrictText.decodeUtf8)
lazyTextUtf8 :: Lens' LazyText.Text Lazy.ByteString
lazyTextUtf8 = lens LazyText.encodeUtf8 (const LazyText.decodeUtf8)
class AsJSON t where
_JSON :: (FromJSON a, ToJSON a) => Traversal' t a
instance AsJSON Strict.ByteString where
_JSON = lazyUtf8 . _JSON
{-# INLINE _JSON #-}
instance AsJSON Lazy.ByteString where
_JSON f b = maybe (pure b) (fmap encode . f) v
where v = maybeResult (parse value b) >>= \x -> case fromJSON x of
Success x' -> Just x'
_ -> Nothing
{-# INLINE _JSON #-}
instance AsJSON String where
_JSON = strictUtf8 . _JSON
{-# INLINE _JSON #-}
instance AsJSON Text where
_JSON = strictTextUtf8 . _JSON
{-# INLINE _JSON #-}
instance AsJSON LazyText.Text where
_JSON = lazyTextUtf8 . _JSON
{-# INLINE _JSON #-}
instance AsJSON Value where
_JSON f v = case fromJSON v of
Success v' -> toJSON <$> f v'
_ -> pure v
{-# INLINE _JSON #-}