diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexey Raga (c) 2016, (c) Edward Kmett 2013-2014, (c) Paul Wilson 2012 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# hw-xml-lens + +[![0.0-branch](https://circleci.com/gh/haskell-works/hw-xml-lens/tree/0.0-branch.svg?style=svg)](https://circleci.com/gh/haskell-works/hw-xml-lens/tree/0.0-branch) + +`hw-xml-lens` provides traversals and prisms for the [HW-JSON](http://hackage.haskell.org/package/hw-json) library's JsonPartialValue type. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Criterion.Main + +benchJsonMQuery :: [Benchmark] +benchJsonMQuery = + [ + ] + +main :: IO () +main = defaultMain benchJsonMQuery diff --git a/hw-json-lens.cabal b/hw-json-lens.cabal new file mode 100644 --- /dev/null +++ b/hw-json-lens.cabal @@ -0,0 +1,103 @@ +name: hw-json-lens +version: 0.0.0.1 +synopsis: Lens for hw-json +description: Please see README.md +homepage: http://github.com/haskell-works/hw-json-lens#readme +license: MIT +license-file: LICENSE +author: Alexey Raga +maintainer: alexey.raga@gmail.com +copyright: 2016 Alexey Raga +category: Data +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.22 + +library + hs-source-dirs: src + exposed-modules: HaskellWorks.Data.Json.Lens, HaskellWorks.Data.ListMap + build-depends: base >= 4 && < 5 + , array + , ansi-wl-pprint + , attoparsec + , bytestring + , conduit + , containers + , dlist + , hw-balancedparens >= 0.1.0.0 + , hw-bits >= 0.4.0.0 + , hw-conduit >= 0.1.0.0 + , hw-diagnostics >= 0.0.0.5 + , hw-json >= 0.4.0.0 + , hw-parser + , hw-prim >= 0.4.0.0 + , hw-rankselect >= 0.8.0.0 + , lens >=3.8 + , mmap + , mono-traversable + , resourcet + , scientific + , text + , unordered-containers + , vector + , word8 + + default-language: Haskell2010 + ghc-options: -Wall -O2 -msse4.2 + +test-suite hw-json-lens-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: HaskellWorks.Data.Json.NthSpec + , HaskellWorks.Data.Json.LensSpec + build-depends: base >= 4 && < 5 + , attoparsec + , bytestring + , containers + , conduit + , hspec + , hw-balancedparens >= 0.1.0.0 + , hw-bits >= 0.4.0.0 + , hw-conduit >= 0.1.0.0 + , hw-json >= 0.4.0.0 + , hw-json-lens + , hw-prim >= 0.4.0.0 + , hw-rankselect >= 0.8.0.0 + , lens >=3.8 + , mmap + , parsec + , QuickCheck + , resourcet + , scientific + , transformers + , unordered-containers + , vector + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/haskell-works/hw-json-lens + +benchmark bench + Type: exitcode-stdio-1.0 + HS-Source-Dirs: bench + Main-Is: Main.hs + GHC-Options: -O2 -Wall -msse4.2 + Default-Language: Haskell2010 + Build-Depends: base >= 4 && < 5 + , bytestring + , conduit + , criterion + , hw-bits >= 0.4.0.0 + , hw-conduit >= 0.1.0.0 + , hw-json-lens + , hw-prim >= 0.4.0.0 + , hw-rankselect >= 0.8.0.0 + , lens >=3.8 + , mmap + , resourcet + , scientific + , unordered-containers + , vector diff --git a/src/HaskellWorks/Data/Json/Lens.hs b/src/HaskellWorks/Data/Json/Lens.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Lens.hs @@ -0,0 +1,438 @@ +{-# 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 #-} + +-------------------------------------------------------------------- +-- | +-- Copyright : (c) Alexey Raga 2016, (c) Edward Kmett 2013-2014, (c) Paul Wilson 2012 +-- License : BSD3 +-- Maintainer: Alexey Raga +-- Stability : experimental +-- Portability: non-portable +-------------------------------------------------------------------- + +module HaskellWorks.Data.Json.Lens where + +import Control.Applicative +import Control.Lens +import Data.Data +import Data.Scientific (Scientific) +import qualified Data.Scientific as Scientific +import GHC.Base +import HaskellWorks.Data.Json.PartialValue as J +import HaskellWorks.Data.ListMap (ListMap, fromList, toList) +import Prelude hiding (null) + +------------------------------------------------------------------------------ +-- Scientific prisms +------------------------------------------------------------------------------ + +class AsNumber t where + -- | + -- >>> "[1, \"x\"]" ^? nth 0 . _Number + -- Just 1.0 + -- + -- >>> "[1, \"x\"]" ^? nth 1 . _Number + -- Nothing + _Number :: Prism' t Scientific +#ifndef HLINT + default _Number :: AsPrimitive t => Prism' t Scientific + _Number = _Primitive._Number + {-# INLINE _Number #-} +#endif + + -- | + -- Prism into an 'Double' over a 'Value', 'Primitive' or 'Scientific' + -- + -- >>> "[10.2]" ^? nth 0 . _Double + -- Just 10.2 + _Double :: Prism' t Double + _Double = _Number.iso Scientific.toRealFloat realToFrac + {-# INLINE _Double #-} + + -- | + -- Prism into an 'Integer' over a 'Value', 'Primitive' or 'Scientific' + -- + -- >>> "[10]" ^? nth 0 . _Integer + -- Just 10 + -- + -- >>> "[10.5]" ^? nth 0 . _Integer + -- Just 10 + -- + -- >>> "42" ^? _Integer + -- Just 42 + _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 #-} + +-- We can implement these once jw-json declared FromJSON/ToJSON classes + +-- instance AsNumber Strict.ByteString +-- instance AsNumber Lazy.ByteString +-- instance AsNumber Text +-- instance AsNumber LazyText.Text +-- instance AsNumber String + +------------------------------------------------------------------------------ +-- Conversion Prisms +------------------------------------------------------------------------------ + +-- | Access Integer 'Value's as Integrals. +-- +-- >>> "[10]" ^? nth 0 . _Integral +-- Just 10 +-- +-- >>> "[10.5]" ^? nth 0 . _Integral +-- Just 10 +_Integral :: (AsNumber t, Integral a) => Prism' t a +_Integral = _Number . iso floor fromIntegral +{-# INLINE _Integral #-} + +------------------------------------------------------------------------------ +-- Null values and primitives +------------------------------------------------------------------------------ + +-- | Primitives of 'Value' +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 + -- | + -- >>> "[1, \"x\", null, true, false]" ^? nth 0 . _Primitive + -- Just (NumberPrim 1.0) + -- + -- >>> "[1, \"x\", null, true, false]" ^? nth 1 . _Primitive + -- Just (StringPrim "x") + -- + -- >>> "[1, \"x\", null, true, false]" ^? nth 2 . _Primitive + -- Just NullPrim + -- + -- >>> "[1, \"x\", null, true, false]" ^? nth 3 . _Primitive + -- Just (BoolPrim True) + -- + -- >>> "[1, \"x\", null, true, false]" ^? nth 4 . _Primitive + -- Just (BoolPrim False) + _Primitive :: Prism' t Primitive +#ifndef HLINT + default _Primitive :: AsValue t => Prism' t Primitive + _Primitive = _Value._Primitive + {-# INLINE _Primitive #-} +#endif + + -- | + -- >>> "{\"a\": \"xyz\", \"b\": true}" ^? key "a" . _String + -- Just "xyz" + -- + -- >>> "{\"a\": \"xyz\", \"b\": true}" ^? key "b" . _String + -- Nothing + -- + -- >>> _Object._Wrapped # [("key" :: Text, _String # "value")] :: String + -- "{\"key\":\"value\"}" + _String :: Prism' t String + _String = _Primitive.prism StringPrim (\v -> case v of StringPrim s -> Right s; _ -> Left v) + {-# INLINE _String #-} + + -- | + -- >>> "{\"a\": \"xyz\", \"b\": true}" ^? key "b" . _Bool + -- Just True + -- + -- >>> "{\"a\": \"xyz\", \"b\": true}" ^? key "a" . _Bool + -- Nothing + -- + -- >>> _Bool # True :: String + -- "true" + -- + -- >>> _Bool # False :: String + -- "false" + _Bool :: Prism' t Bool + _Bool = _Primitive.prism BoolPrim (\v -> case v of BoolPrim b -> Right b; _ -> Left v) + {-# INLINE _Bool #-} + + -- | + -- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "b" . _Null + -- Just () + -- + -- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "a" . _Null + -- Nothing + -- + -- >>> _Null # () :: String + -- "null" + _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 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 s + fromPrim (NumberPrim n) = JsonPartialNumber (realToFrac n) + fromPrim (BoolPrim b) = JsonPartialBool b + fromPrim NullPrim = JsonPartialNull + {-# INLINE fromPrim #-} + {-# INLINE _Primitive #-} + _String = prism JsonPartialString $ \v -> case v of JsonPartialString s -> Right 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 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 #-} + +-- | Prism into non-'Null' values +-- +-- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "a" . nonNull +-- Just (String "xyz") +-- +-- >>> "{\"a\": {}, \"b\": null}" ^? key "a" . nonNull +-- Just (Object (fromList [])) +-- +-- >>> "{\"a\": \"xyz\", \"b\": null}" ^? key "b" . nonNull +-- Nothing +nonNull :: Prism' JsonPartialValue JsonPartialValue +nonNull = prism id (\v -> if isn't _Null v then Right v else Left v) +{-# INLINE nonNull #-} + +------------------------------------------------------------------------------ +-- Non-primitive traversals +------------------------------------------------------------------------------ + +class AsPrimitive t => AsValue t where + -- | + -- >>> preview _Value "[1,2,3]" == Just (Array (Vector.fromList [Number 1.0,Number 2.0,Number 3.0])) + -- True + _Value :: Prism' t JsonPartialValue + + -- | + -- >>> "{\"a\": {}, \"b\": null}" ^? key "a" . _Object + -- Just (fromList []) + -- + -- >>> "{\"a\": {}, \"b\": null}" ^? key "b" . _Object + -- Nothing + -- + -- >>> _Object._Wrapped # [("key" :: String, _String # "value")] :: String + -- "{\"key\":\"value\"}" + _Object :: Prism' t (ListMap JsonPartialValue) + _Object = _Value.prism (JsonPartialObject . toList) (\v -> case v of + JsonPartialObject o -> Right (fromList o) + _ -> Left v) + {-# INLINE _Object #-} + + -- | + -- >>> preview _Array "[1,2,3]" == Just (Vector.fromList [Number 1.0,Number 2.0,Number 3.0]) + -- True + _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 #-} + +-- 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 #-} + +-- | +-- Like 'ix', but for 'Object' with Text indices. This often has better +-- inference than 'ix' when used with OverloadedStrings. +-- +-- >>> "{\"a\": 100, \"b\": 200}" ^? key "a" +-- Just (Number 100.0) +-- +-- >>> "[1,2,3]" ^? key "a" +-- Nothing +key :: AsValue t => String -> Traversal' t JsonPartialValue +key i = _Object . ix i +{-# INLINE key #-} + +-- | An indexed Traversal into Object properties +-- +-- >>> "{\"a\": 4, \"b\": 7}" ^@.. members +-- [("a",Number 4.0),("b",Number 7.0)] +-- +-- >>> "{\"a\": 4, \"b\": 7}" & members . _Number *~ 10 +-- "{\"a\":40,\"b\":70}" +members :: AsValue t => IndexedTraversal' String t JsonPartialValue +members = _Object . itraversed +{-# INLINE members #-} + +-- | Like 'ix', but for Arrays with Int indexes +-- +-- >>> "[1,2,3]" ^? nth 1 +-- Just (Number 2.0) +-- +-- >>> "\"a\": 100, \"b\": 200}" ^? nth 1 +-- Nothing +-- +-- >>> "[1,2,3]" & nth 1 .~ Number 20 +-- "[1,20,3]" +nth :: AsValue t => Int -> Traversal' t JsonPartialValue +nth i = _Array . ix i +{-# INLINE nth #-} + +-- | An indexed Traversal into Array elements +-- +-- >>> "[1,2,3]" ^.. values +-- [Number 1.0,Number 2.0,Number 3.0] +-- +-- >>> "[1,2,3]" & values . _Number *~ 10 +-- "[10,20,30]" +values :: AsValue t => IndexedTraversal' Int t JsonPartialValue +values = _Array . traversed +{-# INLINE values #-} + +-- strictUtf8 :: Iso' String Strict.ByteString +-- strictUtf8 = packed . strictTextUtf8 +-- +-- strictTextUtf8 :: Iso' Text.Text Strict.ByteString +-- strictTextUtf8 = iso StrictText.encodeUtf8 StrictText.decodeUtf8 +-- +-- lazyTextUtf8 :: Iso' LazyText.Text Lazy.ByteString +-- lazyTextUtf8 = iso LazyText.encodeUtf8 LazyText.decodeUtf8 + +-- class AsJSON t where +-- -- | '_JSON' is a 'Prism' from something containing JSON to something encoded in that structure +-- _JSON :: (FromJSON a, ToJSON a) => Prism' t a +-- +-- instance AsJSON Strict.ByteString where +-- _JSON = lazy._JSON +-- {-# INLINE _JSON #-} +-- +-- instance AsJSON Lazy.ByteString where +-- _JSON = prism' encode decodeValue +-- where +-- decodeValue :: (FromJSON a) => Lazy.ByteString -> Maybe a +-- decodeValue s = maybeResult (parse value s) >>= \x -> case fromJSON x of +-- Success v -> Just v +-- _ -> 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 = prism toJSON $ \x -> case fromJSON x of +-- Success y -> Right y; +-- _ -> Left x +-- {-# INLINE _JSON #-} + +------------------------------------------------------------------------------ +-- Some additional tests for prismhood; see https://github.com/ekmett/lens/issues/439. +------------------------------------------------------------------------------ + +-- $LazyByteStringTests +-- >>> "42" ^? (_JSON :: Prism' Lazy.ByteString Value) +-- Just (Number 42.0) +-- +-- >>> preview (_Integer :: Prism' Lazy.ByteString Integer) "42" +-- Just 42 +-- +-- >>> Lazy.unpack (review (_Integer :: Prism' Lazy.ByteString Integer) 42) +-- "42" + +-- $StrictByteStringTests +-- >>> "42" ^? (_JSON :: Prism' Strict.ByteString Value) +-- Just (Number 42.0) +-- +-- >>> preview (_Integer :: Prism' Strict.ByteString Integer) "42" +-- Just 42 +-- +-- >>> Strict.Char8.unpack (review (_Integer :: Prism' Strict.ByteString Integer) 42) +-- "42" + +-- $StringTests +-- >>> "42" ^? (_JSON :: Prism' String Value) +-- Just (Number 42.0) +-- +-- >>> preview (_Integer :: Prism' String Integer) "42" +-- Just 42 +-- +-- >>> review (_Integer :: Prism' String Integer) 42 +-- "42" + +------------------------------------------------------------------------------ +-- Orphan instances for lens library interop +------------------------------------------------------------------------------ + +type instance Index JsonPartialValue = String + +type instance IxValue JsonPartialValue = JsonPartialValue +instance Ixed JsonPartialValue where + ix i f (JsonPartialObject o) = (JsonPartialObject . toList) <$> ix i f (fromList o) + ix _ _ v = pure v + {-# INLINE ix #-} + +instance Plated JsonPartialValue where + plate f (JsonPartialObject o) = (JsonPartialObject . toList) <$> traverse f (fromList o) + plate f (JsonPartialArray a) = JsonPartialArray <$> traverse f a + plate _ xs = pure xs + {-# INLINE plate #-} diff --git a/src/HaskellWorks/Data/ListMap.hs b/src/HaskellWorks/Data/ListMap.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/ListMap.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HaskellWorks.Data.ListMap where + +import Control.Lens +import Data.Monoid +import Prelude hiding (lookup, null) +import qualified Prelude as P + +newtype ListMap a = ListMap [(String, a)] deriving (Eq, Show) + +instance Functor ListMap where + fmap f = mapWithKey (\_ v -> f v) + {-# INLINE fmap #-} + +instance Foldable ListMap where + foldMap f (ListMap as) = foldMap f (snd <$> as) + {-# INLINE foldMap #-} + foldr f z (ListMap as) = foldr f z (snd <$> as) + {-# INLINE foldr #-} + + +instance Traversable ListMap where + traverse f = traverseWithKey (\_ v -> f v) + {-# INLINE traverse #-} + + +type instance Index (ListMap a) = String +type instance IxValue (ListMap a) = a + +instance Ixed (ListMap a) where + ix k f m = case lookup k m of + Just v -> f v <&> \v' -> insert k v' m + Nothing -> pure m + {-# INLINE ix #-} + +instance At (ListMap a) where + at k f m = f mv <&> \r -> case r of + Nothing -> maybe m (const (delete k m)) mv + Just v' -> insert k v' m + where mv = lookup k m + {-# INLINE at #-} + +-- | @'each' :: 'Traversal' ('Map' c a) ('Map' c b) a b@ +instance Each (ListMap a) (ListMap b) a b where + each = traversed + {-# INLINE each #-} + +instance AsEmpty (ListMap a) where + _Empty = nearly empty null + {-# INLINE _Empty #-} + +instance FunctorWithIndex String ListMap +instance FoldableWithIndex String ListMap +instance TraversableWithIndex String ListMap where +#if MIN_VERSION_containers(0,5,0) + itraverse = traverseWithKey +#else + itraverse f = sequenceA . IntMap.mapWithKey f +#endif + {-# INLINE [0] itraverse #-} + +mapWithKey :: (String -> a -> b) -> ListMap a -> ListMap b +mapWithKey f (ListMap as) = ListMap $ (\(k, v) -> (k, f k v)) <$> as +{-# INLINE mapWithKey #-} + +traverseWithKey :: Applicative t => (String -> a -> t b) -> ListMap a -> t (ListMap b) +traverseWithKey f (ListMap as) = ListMap <$> traverse (\(k, v) -> (k,) <$> f k v) as +{-# INLINE traverseWithKey #-} + +empty :: ListMap a +empty = ListMap [] +{-# INLINE empty #-} + +null :: ListMap a -> Bool +null (ListMap xs) = P.null xs +{-# INLINE null #-} + +fromList :: [(String, a)] -> ListMap a +fromList = ListMap +{-# INLINE fromList #-} + +toList :: ListMap a -> [(String, a)] +toList (ListMap m) = m +{-# INLINE toList #-} + +insert :: String -> a -> ListMap a -> ListMap a +insert k v (ListMap m) = ListMap $ case break (\(k', _) -> k' == k) m of + (ps, _:xs) -> ps <> ((k, v):xs) + _ -> (k, v) : m +{-# INLINE insert #-} + +delete :: String -> ListMap a -> ListMap a +delete k (ListMap m) = ListMap $ case break (\(k', _) -> k' == k) m of + (ps, _:xs) -> ps <> xs + _ -> m +{-# INLINE delete #-} + +lookup :: String -> ListMap a -> Maybe a +lookup k (ListMap m) = P.lookup k m +{-# INLINE lookup #-} diff --git a/test/HaskellWorks/Data/Json/LensSpec.hs b/test/HaskellWorks/Data/Json/LensSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/LensSpec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +module HaskellWorks.Data.Json.LensSpec (spec) where + +import GHC.Base +import Control.Lens +import qualified Data.ByteString as Strict +import HaskellWorks.Data.ListMap (fromList) +import qualified Data.Vector.Storable as DVS +import Data.Word +import Prelude hiding (null) +import HaskellWorks.Data.BalancedParens.Simple +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Json.Succinct.Cursor +import HaskellWorks.Data.Json.Succinct.PartialIndex +import HaskellWorks.Data.Json.PartialValue +import HaskellWorks.Data.Json.Lens +import HaskellWorks.Data.FromByteString +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +loadJson :: Strict.ByteString -> JsonCursor Strict.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) +loadJson = fromByteString + +j :: Strict.ByteString -> JsonPartialValue +j = jsonPartialJsonValueAt . jsonPartialIndexAt . loadJson + +spec :: Spec +spec = describe "Nth Spec" $ do + let json = j "{\"d\": 1.5, \"s\": \"xyz\", \"b\": true, \"n\": null, \"o\": {}}" + + it "key" $ do + json ^? key "d" `shouldBe` Just (JsonPartialNumber 1.5) + j "[1,2,3]" ^? key "s" `shouldBe` Nothing + + it "key composed" $ do + json ^? key "d" . _Number `shouldBe` Just 1.5 + json ^? key "s" . _String `shouldBe` Just "xyz" + json ^? key "b" . _Bool `shouldBe` Just True + json ^? key "n" . _Null `shouldBe` Just () + json ^? key "b" . _Null `shouldBe` Nothing + + it "nonNull" $ do + json ^? key "s" . nonNull `shouldBe` Just (JsonPartialString "xyz") + json ^? key "o" . nonNull `shouldBe` Just (JsonPartialObject []) + json ^? key "n" . nonNull `shouldBe` Nothing + + it "preview" $ do + preview _Value (j "[1,2,3]") `shouldBe` Just (JsonPartialArray [JsonPartialNumber 1.0,JsonPartialNumber 2.0,JsonPartialNumber 3.0]) + + it "object" $ do + json ^? key "o" . _Object `shouldBe` Just (fromList []) + json ^? key "n" . _Object `shouldBe` Nothing + + it "members" $ do + fromList (json ^@.. members) `shouldBe` fromList [("d", JsonPartialNumber 1.5), ("s", JsonPartialString "xyz"), ("b", JsonPartialBool True), ("n", JsonPartialNull), ("o", JsonPartialObject [])] + (json & members . _Number *~10) ^? key "d" `shouldBe` Just (JsonPartialNumber 15) + + it "values" $ do + j "[1,2,3]" ^.. values `shouldBe` [JsonPartialNumber 1, JsonPartialNumber 2, JsonPartialNumber 3] + (j "[1,2,3]" & values . _Number *~ 10) `shouldBe` JsonPartialArray [JsonPartialNumber 10, JsonPartialNumber 20, JsonPartialNumber 30] diff --git a/test/HaskellWorks/Data/Json/NthSpec.hs b/test/HaskellWorks/Data/Json/NthSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/NthSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +module HaskellWorks.Data.Json.NthSpec (spec) where + +import GHC.Base +import Control.Lens +import qualified Data.ByteString as Strict +import qualified Data.Vector.Storable as DVS +import Data.Word +import Prelude hiding (null) +import HaskellWorks.Data.BalancedParens.Simple +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Json.Succinct.Cursor +import HaskellWorks.Data.Json.Succinct.PartialIndex +import HaskellWorks.Data.Json.PartialValue +import HaskellWorks.Data.Json.Lens +import HaskellWorks.Data.FromByteString +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +loadJson :: Strict.ByteString -> JsonCursor Strict.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) +loadJson = fromByteString + +j :: Strict.ByteString -> JsonPartialValue +j = jsonPartialJsonValueAt . jsonPartialIndexAt . loadJson + +spec :: Spec +spec = describe "Nth Spec" $ do + let json = j "[1.5, \"x\", null, true, false]" + it "nth" $ do + json ^? nth 0 . _Number `shouldBe` Just 1.5 + json ^? nth 0 . _Double `shouldBe` Just 1.5 + json ^? nth 0 . _Integer `shouldBe` Just 1 + json ^? nth 0 . _String `shouldBe` Nothing + + it "nth with string" $ do + json ^? nth 1 . _String `shouldBe` Just "x" + json ^? nth 1 . _Double `shouldBe` Nothing + + it "nth out of bound" $ do + json ^? nth 8 . _Double `shouldBe` Nothing + json ^? nth 22 . _String `shouldBe` Nothing + + it "nth with null" $ do + json ^? nth 2 . _Null `shouldBe` Just () + json ^? nth 3 . _Null `shouldBe` Nothing + + it "nth with bool" $ do + json ^? nth 3 . _Bool `shouldBe` Just True + json ^? nth 4 . _Bool `shouldBe` Just False + json ^? nth 2 . _Bool `shouldBe` Nothing + + it "nth with primitive" $ do + json ^? nth 0 . _Primitive `shouldBe` Just (NumberPrim 1.5) + json ^? nth 1 . _Primitive `shouldBe` Just (StringPrim "x") + json ^? nth 2 . _Primitive `shouldBe` Just NullPrim + json ^? nth 3 . _Primitive `shouldBe` Just (BoolPrim True) + json ^? nth 4 . _Primitive `shouldBe` Just (BoolPrim False) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}