json_lens_stuff.hs

import Data.Text
import Data.Aeson
import Data.Aeson.Lens (_Value,_String)
import Data.Foldable (toList)
import Data.Traversable (traverse)

import qualified Data.HashMap.Strict as HM
import qualified Data.Vector as V

import Control.Applicative
import Control.Lens (Fold,Traversal',folding,universeOf,toListOf,paraOf,preview)

-- to use with transformOf
vplate :: Traversal' Value Value
vplate f v = case v of
    Object o -> fmap Object (traverse f o)
    Array a -> fmap Array (traverse f a)
    _ -> pure v

vchildren :: Fold Value Value
vchildren = folding $ \v -> case v of
    Object o -> toList o
    Array a -> toList a
    _ -> []

allValues :: Value -> [Value]
allValues = universeOf vchildren

allTexts :: Value -> [Text]
allTexts = toListOf (folding allValues . _String)

vpara :: (Value -> [r] -> r) -> Value -> r
vpara = paraOf vchildren

type Path = [Value]

pathsThatEndInText :: (Text -> Bool) -> Value -> [Path]
pathsThatEndInText pred = vpara func
  where
    func :: Value -> [[Path]] -> [Path]
    func v@(String txt) _ | pred txt = [[v]]
    func v l@(_:_) = Prelude.map (v:) (Prelude.concat l)
    func _ _ = []

describePath :: Path -> [String]
describePath (v:vs) = Prelude.zipWith step (v:vs) vs
  where
    step (Object o) next = (unpack . Prelude.head . HM.keys . HM.filter (==next)) o
    step (Array a) next = (show . maybe (error "not found") id) (V.elemIndex next a)
    step _ _ = error "should not happen"

exampleJSON :: Value
exampleJSON = maybe Null id (preview _Value str)
  where
    str = "[{ \"k1\" : \"aaa\" },{ \"k2\" : \"ccc\" }, { \"k3\" : \"ddd\" }]"