{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Waargonaut.Decode
(
CursorHistory
, SuccinctCursor
, DecodeResult (..)
, Decoder (..)
, JCurs (..)
, ParseFn
, Err (..)
, JsonType (..)
, runDecode
, runDecodeResult
, runPureDecode
, simpleDecode
, overrideParser
, generaliseDecoder
, DI.ppCursorHistory
, parseWith
, withCursor
, mkCursor
, cursorRankL
, manyMoves
, down
, up
, DI.try
, moveRightN
, moveRight1
, moveLeftN
, moveLeft1
, moveToKey
, moveToRankN
, jsonAtCursor
, fromKey
, atKey
, focus
, fromKeyOptional
, atKeyOptional
, withType
, jsonTypeAt
, leftwardCons
, rightwardSnoc
, foldCursor
, rank
, prismD
, prismDOrFail
, json
, int
, scientific
, integral
, string
, strictByteString
, lazyByteString
, unboundedChar
, boundedChar
, text
, bool
, null
, nonemptyAt
, nonempty
, listAt
, list
, objectAsKeyValuesAt
, objectAsKeyValues
, withDefault
, maybeOrNull
, either
, oneOf
) where
import GHC.Word (Word64)
import Control.Lens (Cons, Lens', Prism',
Snoc, cons, lens,
matching, modifying,
over, preview, snoc,
traverseOf, view,
( # ), (.~), (^.),
_Left, _Wrapped)
import Control.Monad.Error.Lens (throwing)
import Prelude (Bool, Bounded, Char,
Eq, Int, Integral,
Show, String,
fromIntegral, show,
(-), (==))
import Control.Applicative (Applicative (..))
import Control.Category ((.))
import Control.Monad (Monad (..), (=<<),
(>=>))
import Control.Monad.Morph (embed, generalize)
import Control.Monad.Except (catchError, lift,
liftEither)
import Control.Monad.Reader (ReaderT (..), ask,
local, runReaderT)
import Control.Monad.State (MonadState)
import Control.Error.Util (note)
import Control.Monad.Error.Hoist ((<!?>), (<?>))
import Data.Bool (Bool (..))
import Data.Either (Either (..))
import qualified Data.Either as Either (either)
import Data.Foldable (Foldable, foldl,
foldr)
import Data.Function (const, flip, ($),
(&))
import Data.Functor (fmap, (<$), (<$>))
import Data.Functor.Alt ((<!>))
import Data.Functor.Identity (Identity,
runIdentity)
import Data.Monoid (mempty)
import Data.Scientific (Scientific)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Maybe (Maybe (..),
fromMaybe, maybe)
import Natural (Natural, replicate,
successor', zero')
import Data.Text (Text)
import qualified Data.Text as Text
import Text.Parser.Char (CharParsing)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import HaskellWorks.Data.Positioning (Count)
import qualified HaskellWorks.Data.Positioning as Pos
import qualified HaskellWorks.Data.BalancedParens.FindOpen as BP
import HaskellWorks.Data.Bits ((.?.))
import HaskellWorks.Data.FromByteString (fromByteString)
import HaskellWorks.Data.TreeCursor (TreeCursor (..))
import HaskellWorks.Data.Json.Cursor (JsonCursor (..))
import qualified HaskellWorks.Data.Json.Cursor as JC
import Waargonaut.Decode.Error (AsDecodeError (..),
DecodeError (..),
Err (..))
import Waargonaut.Decode.ZipperMove (ZipperMove (..))
import Waargonaut.Types
import qualified Waargonaut.Decode.Internal as DI
import Waargonaut.Decode.Types (CursorHistory,
DecodeResult (..),
Decoder (..),
JCurs (..),
JsonType (..),
ParseFn,
SuccinctCursor,
jsonTypeAt)
withCursor
:: (JCurs -> DecodeResult f a)
-> Decoder f a
withCursor g = Decoder $ \p ->
DI.runDecoder' $ DI.withCursor' (flip runReaderT p . unDecodeResult . g)
mkCursor :: ByteString -> JCurs
mkCursor = JCurs . fromByteString
cursorRankL :: Lens' (JsonCursor s i p) Count
cursorRankL = lens JC.cursorRank (\c r -> c { cursorRank = r })
manyMoves :: Monad m => Natural -> (b -> m b) -> b -> m b
manyMoves i g = foldl (>=>) pure (replicate i g)
generaliseDecoder :: Monad f => Decoder Identity a -> Decoder f a
generaliseDecoder dr = Decoder (\p -> embed generalize . runDecoder dr p)
{-# INLINE generaliseDecoder #-}
moveCursBasic
:: Monad f
=> (SuccinctCursor -> Maybe SuccinctCursor)
-> ZipperMove
-> JCurs
-> DecodeResult f JCurs
moveCursBasic f m c =
traverseOf _Wrapped f c <?> FailedToMove m >>= recordRank m
down
:: Monad f
=> JCurs
-> DecodeResult f JCurs
down =
moveCursBasic firstChild D
up
:: Monad f
=> JCurs
-> DecodeResult f JCurs
up =
moveCursBasic parent U
moveToRankN
:: Monad f
=> Word64
-> JCurs
-> DecodeResult f JCurs
moveToRankN newRank c =
if JC.balancedParens (c ^. _Wrapped) .?. Pos.lastPositionOf newRank
then pure $ c & _Wrapped . cursorRankL .~ newRank
else throwing _InputOutOfBounds newRank
moveRightN
:: Monad f
=> Natural
-> JCurs
-> DecodeResult f JCurs
moveRightN i =
moveCursBasic (manyMoves i nextSibling) (R i)
moveRight1
:: Monad f
=> JCurs
-> DecodeResult f JCurs
moveRight1 =
moveRightN (successor' zero')
moveLeft1
:: Monad f
=> JCurs
-> DecodeResult f JCurs
moveLeft1 jc =
let
c = jc ^. _Wrapped
rnk = c ^. cursorRankL
setRank r = jc & _Wrapped . cursorRankL .~ r
prev = rnk - 1
in
setRank <$> BP.findOpen (JC.balancedParens c) prev <?> InputOutOfBounds prev
moveLeftN
:: Monad f
=> Natural
-> JCurs
-> DecodeResult f JCurs
moveLeftN i =
manyMoves i moveLeft1
jsonAtCursor
:: Monad f
=> (ByteString -> Either DecodeError a)
-> JCurs
-> DecodeResult f a
jsonAtCursor p jc = do
let
c = jc ^. _Wrapped
rnk = c ^. cursorRankL
leading = fromIntegral $ Pos.toCount (JC.jsonCursorPos c)
cursorTxt = BS8.drop leading (JC.cursorText c)
if JC.balancedParens c .?. Pos.lastPositionOf rnk
then liftEither (p cursorTxt)
else throwing _InputOutOfBounds rnk
recordRank
:: MonadState CursorHistory f
=> ZipperMove
-> JCurs
-> f JCurs
recordRank mv c =
c <$ modifying _Wrapped (`snoc` (mv, c ^. _Wrapped . cursorRankL))
focus
:: Monad f
=> Decoder f a
-> JCurs
-> DecodeResult f a
focus decoder curs = DecodeResult $ do
p <- ask
lift $ runDecoder decoder p curs
moveToKey
:: Monad f
=> Text
-> JCurs
-> DecodeResult f JCurs
moveToKey k c = do
k' <- DI.try (focus text c) <!?> (_KeyDecodeFailed # ())
if k' == k
then recordRank (DAt k) c >> moveRight1 c
else ( DI.try (moveRightN (successor' (successor' zero')) c) <!?> (_KeyNotFound # k) ) >>= moveToKey k
fromKey
:: ( Monad f
)
=> Text
-> Decoder f b
-> JCurs
-> DecodeResult f b
fromKey k d =
moveToKey k >=> focus d
atKey
:: Monad f
=> Text
-> Decoder f a
-> Decoder f a
atKey k d =
withCursor (down >=> fromKey k d)
fromKeyOptional
:: Monad f
=> Text
-> Decoder f b
-> JCurs
-> DecodeResult f (Maybe b)
fromKeyOptional k d c =
focus' =<< catchError (pure <$> moveToKey k c) (\de -> case de of
KeyNotFound _ -> pure Nothing
_ -> throwing _DecodeError de)
where
focus' = maybe (pure Nothing) (fmap Just . focus d)
atKeyOptional
:: Monad f
=> Text
-> Decoder f b
-> Decoder f (Maybe b)
atKeyOptional k d = withCursor (down >=> fromKeyOptional k d)
atCursor
:: Monad f
=> Text
-> (Json -> Maybe c)
-> Decoder f c
atCursor m c = withCursor $ \curs -> do
p <- ask
jsonAtCursor p curs >>=
liftEither . note (ConversionFailure m) . c
withType
:: Monad f
=> JsonType
-> (JCurs -> DecodeResult f a)
-> JCurs
-> DecodeResult f a
withType t d c =
if maybe False (== t) $ jsonTypeAt (unJCurs c) then d c
else throwing _TypeMismatch t
foldCursor
:: Monad f
=> (b -> a -> b)
-> (JCurs -> DecodeResult f JCurs)
-> b
-> Decoder f a
-> JCurs
-> DecodeResult f b
foldCursor nom f s elemD curs = DecodeResult . ReaderT $ \p ->
DI.foldCursor' s nom
(flip runReaderT p . unDecodeResult . f)
(DI.Decoder' $ runDecoder elemD p)
curs
oneOf
:: ( Foldable g
, Monad f
, Eq a
)
=> Decoder f a
-> Text
-> g (a, b)
-> Decoder f b
oneOf d l =
foldr (\i x -> g i <!> x) err
where
g (a,b) = d >>= \t -> if t == a then pure b else err
err = throwing _ConversionFailure l
leftwardCons
:: ( Monad f
, Cons s s a a
)
=> s
-> Decoder f a
-> JCurs
-> DecodeResult f s
leftwardCons =
foldCursor (flip cons) moveLeft1
rightwardSnoc
:: ( Monad f
, Snoc s s a a
)
=> s
-> Decoder f a
-> JCurs
-> DecodeResult f s
rightwardSnoc =
foldCursor snoc moveRight1
runDecode
:: Monad f
=> Decoder f a
-> ParseFn
-> JCurs
-> f (Either (DecodeError, CursorHistory) a)
runDecode dr p =
DI.runDecoderResultT . runDecoder dr p
runDecodeResult
:: Monad f
=> ParseFn
-> DecodeResult f a
-> f (Either (DecodeError, CursorHistory) a)
runDecodeResult p =
DI.runDecoderResultT
. flip runReaderT p
. unDecodeResult
simpleDecode
:: Decoder Identity a
-> ParseFn
-> ByteString
-> Either (DecodeError, CursorHistory) a
simpleDecode d parseFn =
runPureDecode d parseFn
. mkCursor
parseWith
:: ( CharParsing f
, Show e
)
=> (f a -> i -> Either e a)
-> f a
-> i
-> Either DecodeError a
parseWith f p =
over _Left (ParseFailed . Text.pack . show) . f p
runPureDecode
:: Decoder Identity a
-> ParseFn
-> JCurs
-> Either (DecodeError, CursorHistory) a
runPureDecode dr p =
runIdentity . runDecode dr p
overrideParser
:: Monad f
=> ParseFn
-> DecodeResult f a
-> DecodeResult f a
overrideParser parseOverride =
local (const parseOverride)
integral :: (Monad f, Integral n, Bounded n) => Decoder f n
integral = atCursor "integral" DI.integral'
rank :: Monad f => Decoder f Count
rank = withCursor (pure . view cursorRankL . unJCurs)
prismD
:: Monad f
=> Prism' a b
-> Decoder f a
-> Decoder f (Maybe b)
prismD p =
fmap (preview p)
prismDOrFail
:: Monad f
=> DecodeError
-> Prism' a b
-> Decoder f a
-> Decoder f b
prismDOrFail e = prismDOrFail' (const e)
prismDOrFail'
:: Monad f
=> (a -> DecodeError)
-> Prism' a b
-> Decoder f a
-> Decoder f b
prismDOrFail' e p d = withCursor $
focus d >=> Either.either (throwing _DecodeError . e) pure . matching p
int :: Monad f => Decoder f Int
int = integral
scientific :: Monad f => Decoder f Scientific
scientific = atCursor "scientific" DI.scientific'
string :: Monad f => Decoder f String
string = atCursor "string" DI.string'
strictByteString :: Monad f => Decoder f ByteString
strictByteString = atCursor "strict bytestring" DI.strictByteString'
lazyByteString :: Monad f => Decoder f BL.ByteString
lazyByteString = atCursor "lazy bytestring" DI.lazyByteString'
unboundedChar :: Monad f => Decoder f Char
unboundedChar = atCursor "unbounded char" DI.unboundedChar'
boundedChar :: Monad f => Decoder f Char
boundedChar = atCursor "bounded char" DI.boundedChar'
json :: Monad f => Decoder f Json
json = atCursor "json" pure
text :: Monad f => Decoder f Text
text = atCursor "text" DI.text'
null :: Monad f => Decoder f ()
null = atCursor "null" DI.null'
bool :: Monad f => Decoder f Bool
bool = atCursor "bool" DI.bool'
nonemptyAt
:: Monad f
=> Decoder f a
-> JCurs
-> DecodeResult f (NonEmpty a)
nonemptyAt elemD = withType JsonTypeArray $ down >=> \curs -> do
h <- focus elemD curs
DI.try (moveRight1 curs) >>= maybe
(pure $ h :| [])
(fmap (h :|) . rightwardSnoc [] elemD)
nonempty :: Monad f => Decoder f a -> Decoder f (NonEmpty a)
nonempty d = withCursor (nonemptyAt d)
listAt
:: Monad f
=> Decoder f a
-> JCurs
-> DecodeResult f [a]
listAt elemD = withType JsonTypeArray $ \c ->
DI.try (down c) >>= maybe (pure mempty) (rightwardSnoc mempty elemD)
list :: Monad f => Decoder f a -> Decoder f [a]
list d = withCursor (listAt d)
objectAsKeyValuesAt
:: Monad f
=> Decoder f k
-> Decoder f v
-> JCurs
-> DecodeResult f [(k,v)]
objectAsKeyValuesAt keyD valueD = withType JsonTypeObject $ \curs ->
DI.try (down curs) >>= maybe
(pure mempty)
(foldCursor snoc (moveRight1 >=> moveRight1) mempty (withCursor $ \c -> do
k <- focus keyD c
v <- moveRight1 c >>= focus valueD
pure (k,v)
))
objectAsKeyValues :: Monad f => Decoder f k -> Decoder f v -> Decoder f [(k,v)]
objectAsKeyValues k v = withCursor (objectAsKeyValuesAt k v)
withDefault
:: Monad f
=> a
-> Decoder f (Maybe a)
-> Decoder f a
withDefault def hasD =
fromMaybe def <$> hasD
maybeOrNull
:: Monad f
=> Decoder f a
-> Decoder f (Maybe a)
maybeOrNull a =
(Just <$> a) <!> (Nothing <$ null)
either
:: Monad f
=> Decoder f a
-> Decoder f b
-> Decoder f (Either a b)
either leftD rightD =
(Right <$> rightD) <!> (Left <$> leftD)