{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HaskellWorks.Data.Json.Lens where
import Control.Applicative
import Control.Arrow (first)
import Control.Lens
import Data.Data
import Data.Scientific (Scientific)
import GHC.Base
import HaskellWorks.Data.Json.PartialValue as J
import HaskellWorks.Data.ListMap (ListMap, fromList, toList)
import Prelude hiding (null)
import qualified Data.Scientific as Scientific
import qualified Data.Text as T
class AsNumber t where
_Number :: Prism' t Scientific
#ifndef HLINT
default _Number :: AsPrimitive t => Prism' t Scientific
_Number = _Primitive._Number
{-# INLINE _Number #-}
#endif
_Double :: Prism' t Double
_Double = _Number.iso Scientific.toRealFloat realToFrac
{-# INLINE _Double #-}
_Integer :: Prism' t Integer
_Integer = _Number.iso floor fromIntegral
{-# INLINE _Integer #-}
instance AsNumber JsonPartialValue where
_Number = prism (JsonPartialNumber . realToFrac) $ \v -> case v of
JsonPartialNumber n -> Right (Scientific.fromFloatDigits n)
_ -> Left v
{-# INLINE _Number #-}
instance AsNumber Scientific where
_Number = id
{-# INLINE _Number #-}
_Integral :: (AsNumber t, Integral a) => Prism' t a
_Integral = _Number . iso floor fromIntegral
{-# INLINE _Integral #-}
data Primitive
= StringPrim !String
| NumberPrim !Scientific
| BoolPrim !Bool
| NullPrim
deriving (Eq,Ord,Show,Data,Typeable)
instance AsNumber Primitive where
_Number = prism NumberPrim $ \v -> case v of NumberPrim s -> Right s; _ -> Left v
{-# INLINE _Number #-}
class AsNumber t => AsPrimitive t where
_Primitive :: Prism' t Primitive
#ifndef HLINT
default _Primitive :: AsValue t => Prism' t Primitive
_Primitive = _Value._Primitive
{-# INLINE _Primitive #-}
#endif
_String :: Prism' t String
_String = _Primitive.prism StringPrim (\v -> case v of StringPrim s -> Right s; _ -> Left v)
{-# INLINE _String #-}
_Bool :: Prism' t Bool
_Bool = _Primitive.prism BoolPrim (\v -> case v of BoolPrim b -> Right b; _ -> Left v)
{-# INLINE _Bool #-}
_Null :: Prism' t ()
_Null = _Primitive.prism (const NullPrim) (\v -> case v of NullPrim -> Right (); _ -> Left v)
{-# INLINE _Null #-}
instance AsPrimitive JsonPartialValue where
_Primitive = prism fromPrim toPrim
where toPrim (JsonPartialString s) = Right $ StringPrim (T.unpack s)
toPrim (JsonPartialNumber n) = Right $ NumberPrim (Scientific.fromFloatDigits n)
toPrim (JsonPartialBool b) = Right $ BoolPrim b
toPrim JsonPartialNull = Right NullPrim
toPrim v = Left v
{-# INLINE toPrim #-}
fromPrim (StringPrim s) = JsonPartialString (T.pack s)
fromPrim (NumberPrim n) = JsonPartialNumber (realToFrac n)
fromPrim (BoolPrim b) = JsonPartialBool b
fromPrim NullPrim = JsonPartialNull
{-# INLINE fromPrim #-}
{-# INLINE _Primitive #-}
_String = prism (JsonPartialString . T.pack) $ \v -> case v of JsonPartialString s -> Right (T.unpack s); _ -> Left v
{-# INLINE _String #-}
_Bool = prism JsonPartialBool (\v -> case v of JsonPartialBool b -> Right b; _ -> Left v)
{-# INLINE _Bool #-}
_Null = prism (const JsonPartialNull) (\v -> case v of JsonPartialNull -> Right (); _ -> Left v)
{-# INLINE _Null #-}
instance AsPrimitive Primitive where
_Primitive = id
{-# INLINE _Primitive #-}
nonNull :: Prism' JsonPartialValue JsonPartialValue
nonNull = prism id (\v -> if isn't _Null v then Right v else Left v)
{-# INLINE nonNull #-}
class AsPrimitive t => AsValue t where
_Value :: Prism' t JsonPartialValue
_Object :: Prism' t (ListMap JsonPartialValue)
_Object = _Value.prism (JsonPartialObject . fmap (first T.pack) . toList) (\v -> case v of
JsonPartialObject o -> Right (fromList (fmap (first T.unpack) o))
_ -> Left v)
{-# INLINE _Object #-}
_Array :: Prism' t [JsonPartialValue]
_Array = _Value.prism JsonPartialArray (\v -> case v of
JsonPartialArray a -> Right a
_ -> Left v)
{-# INLINE _Array #-}
instance AsValue JsonPartialValue where
_Value = id
{-# INLINE _Value #-}
key :: AsValue t => String -> Traversal' t JsonPartialValue
key i = _Object . ix i
{-# INLINE key #-}
members :: AsValue t => IndexedTraversal' String t JsonPartialValue
members = _Object . itraversed
{-# INLINE members #-}
nth :: AsValue t => Int -> Traversal' t JsonPartialValue
nth i = _Array . ix i
{-# INLINE nth #-}
values :: AsValue t => IndexedTraversal' Int t JsonPartialValue
values = _Array . traversed
{-# INLINE values #-}
type instance Index JsonPartialValue = String
type instance IxValue JsonPartialValue = JsonPartialValue
instance Ixed JsonPartialValue where
ix i f (JsonPartialObject o) = (JsonPartialObject . fmap (first T.pack) . toList) <$> ix i f (fromList (fmap (first T.unpack) o))
ix _ _ v = pure v
{-# INLINE ix #-}
instance Plated JsonPartialValue where
plate f (JsonPartialObject o) = (JsonPartialObject . fmap (first T.pack) . toList) <$> traverse f (fromList (fmap (first T.unpack) o))
plate f (JsonPartialArray a) = JsonPartialArray <$> traverse f a
plate _ xs = pure xs
{-# INLINE plate #-}