{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-|
Module     : Data.Aeson.Pointer
Description: RFC 6901 pointers parsing and traversing
Copyright  : (c) 2019 Ian Duncan
License    : BSD3

Parsing, rendering, and traversing of <https://tools.ietf.org/html/rfc6901 RFC 6901 JSON pointers>
-}
{-# LANGUAGE DeriveLift        #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Data.Aeson.Pointer
  ( -- $setup
    -- $usage
    JsonPointer
  , mkJsonPointer
  , pointerSegments
  , jsonPtr
  , parsePointer
  , parseURIFragment
  , renderPointer
    -- ** Simple pointer access
  , valueAt
  , overValueAt
    -- ** Traversing JSON Documents
  , pointerTraversal
  , segmentTraversal
    -- ** Segments
  , PointerSegment
  , unsafeTextSegment
  , unsafeTextOrNumberSegment
  , segmentText
  , segmentNumber
    -- ** Parsers
  , 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

-- $setup
-- >>> import URI.ByteString.QQ
-- >>> :set -XOverloadedStrings
-- >>> :set -XQuasiQuotes
-- >>> :{
-- let sampleDoc = object
--       [ "foo" .= ["bar" :: T.Text, "baz"]
--       , "" .= (0 :: Int)
--       , "a/b" .= (1 :: Int)
--       , "c%d" .= (2 :: Int)
--       , "e^f" .= (3 :: Int)
--       , "g|h" .= (4 :: Int)
--       , "i\\j" .= (5 :: Int)
--       , "k\"l" .= (6 :: Int)
--       , " " .= (7 :: Int)
--       , "m~n" .= (8 :: Int)
--       ]
-- :}

-- $usage
--
-- >>> let samplePointerText = "/data/foo" :: T.Text
-- >>> :{
-- let extractPointerValue = case parsePointer samplePointerText of
--       Left err -> Nothing
--       Right ptr ->
--         (object ["data" .= object ["foo" .= 5.2]]) ^? pointerTraversal ptr
-- in extractPointerValue
-- :}
-- Just (Number 5.2)
--
--
-- >>> sampleDoc ^? pointerTraversal [jsonPtr||]
-- Just (Object (fromList [("c%d",Number 2.0),("m~n",Number 8.0),("e^f",Number 3.0),("",Number 0.0),(" ",Number 7.0),("foo",Array [String "bar",String "baz"]),("a/b",Number 1.0),("i\\j",Number 5.0),("k\"l",Number 6.0),("g|h",Number 4.0)]))
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/foo|]
-- Just (Array [String "bar",String "baz"])
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/foo/0|]
-- Just (String "bar")
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/foo/4|]
-- Nothing
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/|]
-- Just (Number 0.0)
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/a~1b|]
-- Just (Number 1.0)
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/c%d|]
-- Just (Number 2.0)
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/e^f|]
-- Just (Number 3.0)
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/g|h|]
-- Just (Number 4.0)
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/i\j|]
-- Just (Number 5.0)
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/k"l|]
-- Just (Number 6.0)
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/ |]
-- Just (Number 7.0)
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/m~0n|]
-- Just (Number 8.0)
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/woo|]
-- Nothing
-- >>> sampleDoc ^? pointerTraversal [jsonPtr|/m~0n/woo|]
-- Nothing
-- >>> parseURIFragment [relativeRef|#/c%25d|]
-- Right (JsonPointer {pointerSegments = [TextSegment "c%d"]})



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

-- | Construct a 'PointerSegment' from a 'T.Text' value. The value __must__ not be an Integer.
unsafeTextSegment :: T.Text -> PointerSegment
unsafeTextSegment = TextSegment

-- | Construct a 'PointerSegment' from an 'Int' value. The value __must__ be greater than or equal to zero.
unsafeTextOrNumberSegment :: Int -> PointerSegment
unsafeTextOrNumberSegment n = TextOrNumberSegment (T.pack $ show n) n

-- | Retrieve the text value of a pointer segment.
segmentText :: PointerSegment -> T.Text
segmentText (TextSegment t) = t
segmentText (TextOrNumberSegment t _) = t

-- | Retrieve the numeric value of a pointer segment, if the segment can be interpreted as a number.
segmentNumber :: PointerSegment -> Maybe Int
segmentNumber (TextSegment _) = Nothing
segmentNumber (TextOrNumberSegment _ n) = Just n

-- | Render a 'JsonPointer' back into its RFC 6901 machine-readable format:
--
-- >>> renderPointer [jsonPtr|/~1/~0/woo|]
-- "/~1/~0/woo"
renderPointer :: JsonPointer -> T.Text
renderPointer (JsonPointer ss) = T.concat $ map renderSegment ss

-- | Render an individual 'PointerSegment'. Not generally useful, but may be
-- helpful for pretty-printing or other more niche situations.
--
-- >>> renderSegment $ unsafeTextOrNumberSegment 0
-- "/0"
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

-- | Parse a pointer from 'T.Text' into a 'JsonPointer'
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 #-}

-- | Parse a JSON Pointer at compile time and embed as an expression.
--
-- >>> [jsonPtr|/foo/0|]
-- JsonPointer {pointerSegments = [TextSegment "foo",TextOrNumberSegment "0" 0]}
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"
  }