{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Data.Aeson.Pointer
(
JsonPointer
, mkJsonPointer
, pointerSegments
, jsonPtr
, parsePointer
, parseURIFragment
, renderPointer
, valueAt
, overValueAt
, pointerTraversal
, segmentTraversal
, PointerSegment
, unsafeTextSegment
, unsafeTextOrNumberSegment
, segmentText
, segmentNumber
, pointerParser
, pointerSegmentParser
) where
import Control.Applicative
import Lens.Micro (Traversal', (&), (^?), (%~), _Just, to)
import Data.Aeson
import Data.Attoparsec.Text
import Data.Char (ord)
import qualified Data.HashMap.Strict as H
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V
import Instances.TH.Lift ()
import Text.Read (readMaybe)
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import URI.ByteString
newtype JsonPointer = JsonPointer { pointerSegments :: [PointerSegment] }
deriving (Show, Eq, Lift, Monoid, Semigroup)
instance ToJSON JsonPointer where
toJSON = String . renderPointer
instance FromJSON JsonPointer where
parseJSON (String str) = case parsePointer str of
Left err -> fail err
Right x -> return x
parseJSON _ = fail "JSON pointer must be a string"
data PointerSegment = TextSegment T.Text
| TextOrNumberSegment T.Text Int
deriving (Show, Eq, Lift)
mkJsonPointer :: [PointerSegment] -> JsonPointer
mkJsonPointer = JsonPointer
unsafeTextSegment :: T.Text -> PointerSegment
unsafeTextSegment = TextSegment
unsafeTextOrNumberSegment :: Int -> PointerSegment
unsafeTextOrNumberSegment n = TextOrNumberSegment (T.pack $ show n) n
segmentText :: PointerSegment -> T.Text
segmentText (TextSegment t) = t
segmentText (TextOrNumberSegment t _) = t
segmentNumber :: PointerSegment -> Maybe Int
segmentNumber (TextSegment _) = Nothing
segmentNumber (TextOrNumberSegment _ n) = Just n
renderPointer :: JsonPointer -> T.Text
renderPointer (JsonPointer ss) = T.concat $ map renderSegment ss
renderSegment :: PointerSegment -> T.Text
renderSegment p = T.cons '/' $ T.replace "/" "~1" $ T.replace "~" "~0" t
where
t = case p of
TextOrNumberSegment s _ -> s
TextSegment s -> s
pointerParser :: Parser JsonPointer
pointerParser = JsonPointer <$> (many (char '/' *> pointerSegmentParser) <* endOfInput)
escapedCharParser :: Parser Char
escapedCharParser = (char '~' *> ((char '0' *> pure '~') <|> (char '1' *> pure '/'))) <|> charRanges
where
charRanges = satisfy (matchesCharRange . ord)
matchesCharRange x = (x >= 0x00 && x <= 0x2E) ||
(x >= 0x30 && x <= 0x7D) ||
(x >= 0x7F && x <= 0x10FFFF)
pointerSegmentParser :: Parser PointerSegment
pointerSegmentParser = mkSegment <$> many escapedCharParser
where
mkSegment :: String -> PointerSegment
mkSegment "0" = TextOrNumberSegment "0" 0
mkSegment s@(c:_) = let
packed = T.pack s
cNum = ord c in if cNum >= 0x31 && cNum <= 0x39
then case readMaybe s of
Nothing -> TextSegment packed
Just x -> TextOrNumberSegment packed x
else TextSegment packed
mkSegment s = TextSegment $ T.pack s
parsePointer :: T.Text -> Either String JsonPointer
parsePointer = parseOnly pointerParser
{-# INLINE parsePointer #-}
parseURIFragment :: URIRef a -> Either String JsonPointer
parseURIFragment u = parseOnly pointerParser p
where
p =
fromMaybe ""
(u ^? fragmentL . _Just . to (T.decodeUtf8 . urlDecode True))
{-# INLINE parseURIFragment #-}
pointerTraversal :: JsonPointer -> Traversal' Value Value
pointerTraversal (JsonPointer ps) = foldl' (\f s -> f . segmentTraversal s) id ps
{-# INLINE pointerTraversal #-}
segmentTraversal :: PointerSegment -> Traversal' Value Value
segmentTraversal (TextSegment t) f miss@(Object o) = case H.lookup t o of
Nothing -> pure miss
Just cv -> f cv
segmentTraversal (TextOrNumberSegment t _) f miss@(Object o) = case H.lookup t o of
Nothing -> pure miss
Just cv -> f cv
segmentTraversal (TextOrNumberSegment _ i) f miss@(Array a) = case a V.!? i of
Nothing -> pure miss
Just cv -> f cv
segmentTraversal _ _ miss = pure miss
{-# INLINE segmentTraversal #-}
valueAt :: JsonPointer -> Value -> Maybe Value
valueAt p v = v ^? pointerTraversal p
{-# INLINE valueAt #-}
overValueAt :: JsonPointer -> Value -> (Value -> Value) -> Value
overValueAt p v f = v & pointerTraversal p %~ f
{-# INLINE overValueAt #-}
jsonPtr :: QuasiQuoter
jsonPtr = QuasiQuoter
{ quoteExp = \str -> case parsePointer $ T.pack str of
Left err -> fail err
Right ok -> lift ok
, quotePat = error "Patterns not supported by jsonPtr quasiquoter"
, quoteType = error "Types not supported by jsonPtr quasiquoter"
, quoteDec = error "Declarations not supported by jsonPtr quasiquoter"
}