Query.hs

{-# OPTIONS_GHC -Wno-unused-do-bind #-}
module Data.Aeson.JSONPath.Parser.Query where

import qualified Data.Text                      as T
import qualified Text.ParserCombinators.Parsec  as P

import Data.Functor                  (($>))
import Data.Maybe                    (isNothing)
import Text.ParserCombinators.Parsec ((<|>),(<?>))

import Data.Aeson.JSONPath.Parser.Filter (pFilter)
import Data.Aeson.JSONPath.Parser.Name
import Data.Aeson.JSONPath.Parser.Number
import Data.Aeson.JSONPath.Parser.Common
import Data.Aeson.JSONPath.Types

import Prelude

-- | Query parser
pQuery :: P.Parser Query
pQuery = pRootQuery <* P.eof

pRootQuery :: P.Parser Query
pRootQuery = do
  P.char '$'
  segs <- P.many $ P.try pSpacedOutSegments
  (return $ Query { queryType = Root, querySegments = segs }) <?> "root query ($)"
    where
      pQ = P.try pRootQuery <|> P.try pCurrentQuery
      pSpacedOutSegments = pSpaces *> pQuerySegment pQ

pCurrentQuery :: P.Parser Query
pCurrentQuery = do
  P.char '@'
  segs <- P.many $ P.try pSpacedOutSegments
  (return $ Query { queryType = Current, querySegments = segs }) <?> "current query (@)"
    where
      pQ = P.try pRootQuery <|> P.try pCurrentQuery
      pSpacedOutSegments = pSpaces *> pQuerySegment pQ


pQuerySegment :: P.Parser a -> P.Parser (QuerySegment a)
pQuerySegment pQ = do
  dotdot <- P.optionMaybe (P.try $ P.string "..")
  seg <- pSegment pQ $ isNothing dotdot
  let segType = if isNothing dotdot then Child else Descendant
  (return $ QuerySegment { segmentType = segType, segment = seg }) <?> "query segment"


pSegment :: P.Parser a -> Bool -> P.Parser (Segment a)
pSegment pQ isChild
        = P.try (pBracketed pQ)
       <|> P.try (pDotted isChild)
       <|> P.try (pWildcardSeg isChild)

pBracketed :: P.Parser a -> P.Parser (Segment a)
pBracketed pQ = do
  P.char '['
  pSpaces
  sel <- pSelector pQ
  optionalSels <- P.many $ pCommaSepSelectors pQ
  pSpaces
  P.char ']'
  return (Bracketed (sel:optionalSels)) <?> "bracketed segment"
    where
      pCommaSepSelectors :: P.Parser a -> P.Parser (Selector a)
      pCommaSepSelectors p = P.try $ pSpaces *> P.char ',' *> pSpaces *> pSelector p


pDotted :: Bool -> P.Parser (Segment a)
pDotted isChild = do
  (if isChild then P.string "." else P.string "")
  P.lookAhead (P.letter <|> P.oneOf "_" <|> pUnicodeChar)
  key <- T.pack <$> P.many1 (P.alphaNum <|> P.oneOf "_" <|> pUnicodeChar)
  return (Dotted key) <?> "dotted segment"


pWildcardSeg :: Bool -> P.Parser (Segment a)
pWildcardSeg isChild = (if isChild then P.string "." else P.string "") *> P.char '*' $> WildcardSegment <?> "wildcard segment"
  
pSelector :: P.Parser a -> P.Parser (Selector a)
pSelector pQ = P.try pName
                   <|> P.try pSlice 
                   <|> P.try pIndex
                   <|> P.try pWildcardSel
                   <|> P.try (pFilter pQ)

pName :: P.Parser (Selector a)
pName = Name . T.pack <$> (P.try pSingleQuotted <|> P.try pDoubleQuotted) <?> "name selector"

pIndex :: P.Parser (Selector a)
pIndex = Index <$> pSignedInt <?> "index selector"

pSlice :: P.Parser (Selector a)
pSlice = do
  start <- P.optionMaybe (pSignedInt <* pSpaces)
  P.char ':'
  pSpaces
  end <- P.optionMaybe (pSignedInt <* pSpaces)
  step <- P.optionMaybe (P.char ':' *> P.optionMaybe (pSpaces *> pSignedInt))
  let step' = case step of {Just (Just n) -> n; _ -> 1}
  return (ArraySlice (start, end, step')) <?> "array selector"


pWildcardSel :: P.Parser (Selector a)
pWildcardSel = P.char '*' $> WildcardSelector <?> "wildcard selector"