{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Data.JSOP where
import Control.Lens (APrism', clonePrism, re, (%~), (.~), (^.), (^?), _1)
import Data.Aeson (Value (..), object)
import Data.Aeson.Lens
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as M
import qualified Data.Map.Monoidal.Strict as Mm
import Generics.SOP
import Protolude hiding (All)
import Trie
type ValuePrism a = APrism' Value a
data JSOP p a = JSOP
{
jsop_path :: p
,
jsop_default :: Maybe a
,
jsop_prism :: ValuePrism a
}
required
:: p
-> ValuePrism a
-> JSOP p a
required path = JSOP path Nothing
optional
:: p
-> a
-> ValuePrism a
-> JSOP p a
optional path = JSOP path . Just
data JSOPIssue
=
JSOPIssue (Int, Maybe Value, TypeRep)
|
JSOPWrongNumberOfPaths
deriving (Eq, Show)
jread
:: (All Typeable xs, IsProductType a xs)
=> (path -> [Text])
-> NP (JSOP path) xs
-> Value
-> Either JSOPIssue a
jread splitter ps value = maybe
do Left JSOPWrongNumberOfPaths
do
fmap productTypeTo
. hsequence
. hcliftA2 (Proxy :: Proxy Typeable) parseSField ps
do fromList $ zip [0 ..] $ getValues splitter (paths ps) value
paths :: All Top xs => NP (JSOP p) xs -> [p]
paths = hcollapse . hmap (K . jsop_path)
parseSField :: forall a p. Typeable a => JSOP p a -> K (Int, Maybe Value) a -> Either JSOPIssue a
parseSField (JSOP _ md parser) (K (n, v)) = case v of
Nothing -> case md of
Just x -> Right x
Nothing -> Left $ JSOPIssue (n, v, typeOf @a $ panic "no value")
Just w -> case w ^? clonePrism parser of
Nothing -> Left $ JSOPIssue (n, v, typeOf @a $ panic "cannot parse")
Just r -> Right r
type QPaths = Trie Text (First Int, [Int])
mkPath :: Int -> [Text] -> QPaths
mkPath n =
foldr
(fmap (Trie (First Nothing, [n])) . Mm.singleton)
(Trie (First (Just n), [n]) mempty)
mkPaths :: [[Text]] -> QPaths
mkPaths = foldMap (uncurry mkPath) . zip [0 ..]
treequery :: QPaths -> 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
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
type TPaths = Trie Text (First Int, Any)
mkTPath :: Int -> (Bool, [Text]) -> TPaths
mkTPath n (b, xs) =
foldr
(fmap (Trie mempty) . Mm.singleton)
(Trie (First $ Just n, Any b) mempty)
xs
mkTPaths :: [(Bool, [Text])] -> TPaths
mkTPaths = foldMap (uncurry mkTPath) . zip [0 ..]
treechange :: Bool -> TPaths -> Value -> Map Int Value -> Value
treechange c (Trie (m, Any b) qs) v cs = case m of
First Nothing -> foldl' (changenode c) v $ Mm.assocs qs
First (Just n) ->
if c
then if b then cs M.! n else Null
else cs M.! n
where
changenode :: Bool -> Value -> (Text, TPaths) -> Value
changenode c' w (k, rest) = case w ^? key k of
Nothing -> _Object %~ HM.insert k (treechange True rest (object []) cs) $ w
Just w' -> key k .~ treechange c' rest w' cs $ w
setValues
:: (p -> (Bool, [Text]))
-> [(p, Value)]
-> Value
-> Value
setValues splitter ts v =
treechange False (mkTPaths $ splitter . fst <$> ts) v $
M.fromList $ zip [0 ..] $ snd <$> ts
jwrite
:: (All Typeable xs, IsProductType a xs, All Top xs, Show path, Ord path)
=> (path -> [Text])
-> NP (JSOP path) xs
-> Value
-> a
-> Value
jwrite splitter ps value x = setValues splitter' setters value
where
splitter' k = (optionals M.! k, splitter k)
optionals = M.fromList $ (\(p, b, _) -> (p, b)) <$> ops
ops = f ps x
setters = (\(p, _, v) -> (p, v)) <$> ops
f :: IsProductType a xs => NP (JSOP path) xs -> a -> [(path, Bool, Value)]
f ps' x' = hcollapse $ hzipWith g ps' $ productTypeFrom x'
g :: JSOP path a1 -> I a1 -> K (path, Bool, Value) a1
g (JSOP p md parser) (I x') = K (p, isJust md, x' ^. re (clonePrism parser))