jsop (empty) → 0.1.0.0
raw patch · 10 files changed
+475/−0 lines, 10 filesdep +aesondep +basedep +containerssetup-changed
Dependencies added: aeson, base, containers, generics-sop, jsop, lens, lens-aeson, monoidal-containers, protolude, string-interpolate, tasty, tasty-discover, tasty-hspec, text
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +85/−0
- Setup.hs +2/−0
- jsop.cabal +74/−0
- src/JSOP/Example.hs +53/−0
- src/JSOP/Parse.hs +104/−0
- src/Trie.hs +15/−0
- test/Driver.hs +2/−0
- test/Parse.hs +107/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for jsop++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Paolo Veronelli, Global Access GmbH (c) 2020++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.
+ README.md view
@@ -0,0 +1,85 @@+# jsop, JSON record cherry picker ++JSOP is good for picking out a product type value from nested json objects ++## Example++Preamble++```haskell++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++import Data.Aeson+import Data.Aeson.Lens+import Data.String.Interpolate+import qualified Data.Text as T+import Generics.SOP+import Generics.SOP.TH+import JSOP.Parse+import Protolude hiding (All, optional, (:*:))+import Data.Maybe (fromJust)+```++Given we have a SOP encoding of the record (tuples are good). ++The `jSOP` memoize the keys path structure so `jSOP f g` should be curried to repeat on multiple values. The `Value` will be scanned only one time, despite the paths are always expressed from the root. Order is restored by a final lookup.++```haskell+data ABC = ABC Text Int Int deriving (Show, Eq)++deriveGeneric ''ABC++```++Then we need a product of pickers with the same shape as our product type.++In this case I choose to encode paths joining json keys with ` / `++```haskell+cherryPickABC :: NP (Parser Text) '[Text, Int, Int]+cherryPickABC =+ required "object 1 / a string" _String+ :* required "object 2 / a number" _Integral+ :* optional "object 4 / a number" 42 _Integral+ :* Nil+``` ++Given the next json structure++```haskell+jsonWithABC :: Value+jsonWithABC = fromJust . decode $ [i| + {+ "object 1": + { "a string": "ciao"+ , "ignore me" : 34+ }+ , "object 2": + { "a number": 2+ , "object 3": {}+ }+ , "object 4": {+ "a plumber" :43+ } + }+ |]+``` ++We can cherry pick the scattered `ABC` with++```haskell +abc :: ABC+Right abc = jSOP (T.splitOn " / ") cherryPickABC jsonWithAB+```++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ jsop.cabal view
@@ -0,0 +1,74 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 3f4c68738418c962984c03f7ae14cb7ab5164437477b357c723b2166f39e1402++name: jsop+version: 0.1.0.0+synopsis: Cherry picking in JSON objects+description: Simple single record picking out of nested JSON objects+category: Decoder+author: Paolo Veronelli+maintainer: paolo.veronelli@gmail.com+copyright: Global Access GmbH, Paolo Veronelli 2020+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++library+ exposed-modules:+ JSOP.Example+ JSOP.Parse+ Trie+ other-modules:+ Paths_jsop+ hs-source-dirs:+ src+ ghc-options: -O2 -Wall+ build-depends:+ aeson+ , base >=4.7 && <5+ , containers+ , generics-sop+ , lens+ , lens-aeson+ , monoidal-containers+ , protolude+ , string-interpolate+ , tasty+ , tasty-discover+ , tasty-hspec+ , text+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: Driver.hs+ other-modules:+ Parse+ Paths_jsop+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall+ build-depends:+ aeson+ , base >=4.7 && <5+ , containers+ , generics-sop+ , jsop+ , lens+ , lens-aeson+ , monoidal-containers+ , protolude+ , string-interpolate+ , tasty+ , tasty-discover+ , tasty-hspec+ , text+ default-language: Haskell2010
+ src/JSOP/Example.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module JSOP.Example where++import Data.Aeson+import Data.Aeson.Lens+import Data.String.Interpolate+import qualified Data.Text as T+import Generics.SOP+import Generics.SOP.TH+import JSOP.Parse+import Protolude hiding (All, optional, (:*:))+import Data.Maybe (fromJust)++data ABC = ABC Text Int Int deriving (Show, Eq)++deriveGeneric ''ABC++cherryPickABC :: NP (Parser Text) '[Text, Int, Int]+cherryPickABC =+ required "object 1 / a string" _String+ :* required "object 2 / a number" _Integral+ :* optional "object 4 / a number" 42 _Integral+ :* Nil++jsonWithABC :: Value+jsonWithABC = fromJust . decode $ [i| + {+ "object 1": + { "a string": "ciao"+ , "ignore me" : 34+ }+ , "object 2": + { "a number": 2+ , "object 3": {}+ }+ , "object 4": {+ "a plumber" :43+ } + }+ |]++abc :: ABC+Right abc = jSOP (T.splitOn " / ") cherryPickABC jsonWithABC
+ src/JSOP/Parse.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module JSOP.Parse where++import Control.Lens (Getting, (%~), (^?), _1)+import Data.Aeson (Value)+import Data.Aeson.Lens+import qualified Data.Map.Monoidal.Strict as Mm+import Generics.SOP+import Trie+import Protolude hiding (All)+import Data.Typeable (typeOf)+++type Preview a = Getting (First a) Value a++-- | A parser that can handle missing values+data Parser p a = Parser+ { parser_path :: p+ , parser_default :: Maybe a+ , parser_prism :: Preview a+ }++-- | shortcut for a parser that handle missing values+required :: p -> Preview a -> Parser p a+required path = Parser path Nothing++-- | shortcut for parsers that have a default if value is missing+optional :: p -> a -> Preview a -> Parser p a+optional path = Parser path . Just++-- | what wrong can happen+data ParseGIssue+ = ParseGIssue (Int, Maybe Value, TypeRep)+ | ParseGWrongNumberOfValues+ deriving (Eq, Show)++jSOP+ :: (All Typeable xs, IsProductType a xs)+ => (path -> [Text])+ -> NP (Parser path) xs -- ^ parsers for the indexed subvalues+ -> Value -- ^ json structure+ -> Either ParseGIssue a+jSOP splitter ps value = maybe+ do Left ParseGWrongNumberOfValues+ do+ fmap productTypeTo+ . hsequence+ . hcliftA2 (Proxy :: Proxy Typeable) parseSField ps+ do fromList $ zip [0 ..] $ getValues splitter paths value+ where+ paths = hcollapse $ hmap (K . parser_path) ps++parseSField :: forall a p. Typeable a => Parser p a -> K (Int, Maybe Value) a -> Either ParseGIssue a+parseSField (Parser _ md parser) (K (n, v)) = case v of+ Nothing -> case md of+ Just x -> Right x+ Nothing -> Left $ ParseGIssue (n, v, typeOf @a $ panic "no value")+ Just w -> case w ^? parser of+ Nothing -> Left $ ParseGIssue (n, v, typeOf @a $ panic "cannot parse")+ Just r -> Right r++--------------------------------------------------------------------------------------------+-- memoize a trie to resolve path queries+--------------------------------------------------------------------------------------------+type Paths = Trie Text (First Int, [Int])++mkPath :: Int -> [Text] -> Paths+mkPath n =+ foldr+ (fmap (Trie (First Nothing, [n])) . Mm.singleton)+ (Trie (First (Just n), [n]) mempty)++mkPaths :: [[Text]] -> Paths+mkPaths = foldMap (uncurry mkPath) . zip [0 ..]++treequery :: Paths -> Value -> ([(Int, Value)], [Int])+treequery (Trie (m, _ns) qs) v =+ appEndo (foldMap (\n -> Endo $ _1 %~ (:) (n, v)) m) $+ fold $ do+ (k, t) <- Mm.assocs qs+ pure $ case v ^? key k of+ Nothing -> ([], snd $ load t)+ Just w -> treequery t w++-- | close over paths argument to get an efficient Value -> [Maybe Value]+getValues :: (p -> [Text]) -> [p] -> Value -> [Maybe Value]+getValues splitter ts v =+ let (positive, negative) = treequery (mkPaths $ splitter <$> ts) v+ in fmap snd $+ sortOn fst $+ fmap (,Nothing) negative <> fmap (fmap Just) positive
+ src/Trie.hs view
@@ -0,0 +1,15 @@+module Trie where++import qualified Data.Map.Monoidal.Strict as Mm+data Trie k m = Trie+ { load :: m, + down :: Mm.MonoidalMap k (Trie k m)+ }+ deriving (Eq, Show)++instance (Ord k, Semigroup m) => Semigroup (Trie k m) where+ Trie fi t <> Trie fi' t' = Trie (fi <> fi') (t <> t')++instance (Ord k, Monoid m) => Monoid (Trie k m) where+ mempty = Trie mempty mempty+
+ test/Driver.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+
+ test/Parse.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications, QuasiQuotes #-}++module Parse where++import Data.Aeson+import Data.Aeson.Lens+import qualified Data.Text as T+import Generics.SOP+import JSOP.Parse+import Protolude hiding (All, optional, (:*:))+import Test.Tasty.Hspec (Spec, describe, it, shouldBe)+import Data.Maybe (fromJust)+import Data.String.Interpolate ++jSOP'+ :: (All Typeable xs, IsProductType a xs)+ => NP (Parser Text) xs+ -> Value+ -> Either ParseGIssue a+jSOP' = jSOP $ T.splitOn " / " ++decodeU :: Text -> Value +decodeU = fromJust . decode . toS++spec_generic :: Spec+spec_generic = do+ describe "generic parsers" do+ it "can parse an Int in an object" $ shouldBe+ do+ jSOP'+ do required "a number" _Integral :* Nil+ do object ["a number" .= Number 2]+ do Right (Identity (2 :: Int))+ it "can parse an Int in an nested object" $ shouldBe+ do+ jSOP'+ do required "object / a number" _Integral :* Nil+ do+ object+ [ "object" .= object ["a number" .= Number 2]+ ]+ do Right (Identity (2 :: Int))+ it "can parse String and Integer" $ shouldBe+ do+ jSOP'+ do+ required "a string" _String+ :* required "a number" _Integral+ :* Nil+ do+ object+ [ "a number" .= Number 2+ , "a string" .= ("ciao" :: Text)+ ]+ do Right ("ciao", 2 :: Int)+ it "can parse String and Int down different paths" $ shouldBe+ do+ jSOP + do T.splitOn " / " + do+ required "object 1 / a string" _String+ :* required "object 2 / a number" _Integral+ :* Nil+ do decodeU [i| + {+ "object 1": + { "a string": "ciao"+ , "ignore me" : 34+ }+ , "object 2": + { "a number": 2+ , "object 3": {}+ }+ }+ |]+ do Right ("ciao", 2 :: Int)+ it "can parse String and Int and Optional Int down different paths" $ shouldBe+ do+ jSOP + do T.splitOn " / " + do+ required "object 1 / a string" _String+ :* required "object 2 / a number" _Integral+ :* optional "object 4 / a number" 42 _Integral+ :* Nil+ do decodeU [i| + {+ "object 1": + { "a string": "ciao"+ , "ignore me" : 34+ }+ , "object 2": + { "a number": 2+ , "object 3": {}+ }+ , "object 4": {+ "a plumber" :43+ } + }+ |]+ do Right ("ciao", 2 :: Int, 42 :: Int )+