{-# 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
data Parser p a = Parser
{ parser_path :: p
, parser_default :: Maybe a
, parser_prism :: Preview a
}
required :: p -> Preview a -> Parser p a
required path = Parser path Nothing
optional :: p -> a -> Preview a -> Parser p a
optional path = Parser path . Just
data ParseGIssue
= ParseGIssue (Int, Maybe Value, TypeRep)
| ParseGWrongNumberOfValues
deriving (Eq, Show)
jSOP
:: (All Typeable xs, IsProductType a xs)
=> (path -> [Text])
-> NP (Parser path) xs
-> Value
-> 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
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
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