{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Aeson.Match.QQ.Internal.Parse
  ( parse
  ) where

import           Control.Applicative ((<|>), optional)
import qualified Data.Aeson.Parser as Aeson
import qualified Data.Attoparsec.ByteString as Atto
import qualified Data.ByteString as ByteString
-- cannot use .Text here due to .Aeson parsers being tied to .ByteString
import           Data.Bool (bool)
import           Data.ByteString (ByteString)
import qualified Data.CaseInsensitive as CI
import qualified Data.Char as Char
import           Data.Foldable (asum)
import qualified Data.HashMap.Strict as HashMap
import           Data.Maybe (isJust)
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Vector as Vector
import           Data.Word (Word8)
import           Language.Haskell.Meta.Parse (parseExp)
import           Language.Haskell.TH (Exp(..))
import           Prelude hiding (any, null)

import           Aeson.Match.QQ.Internal.Value (Value(..), Box(..), TypeSig(..), Type(..), Nullable(..))


parse :: ByteString -> Either String (Value Exp)
parse :: ByteString -> Either [Char] (Value Exp)
parse =
  forall a. Parser a -> ByteString -> Either [Char] a
Atto.parseOnly Parser (Value Exp)
value

value :: Atto.Parser (Value Exp)
value :: Parser (Value Exp)
value = do
  Parser ()
spaces
  Word8
b <- Parser Word8
Atto.peekWord8'
  case Word8
b of
    Word8
AnyP ->
      Parser (Value Exp)
any
    Word8
NP ->
      Parser (Value Exp)
null
    Word8
FP ->
      Parser (Value Exp)
false
    Word8
TP ->
      Parser (Value Exp)
true
    Word8
DoubleQuoteP ->
      Parser (Value Exp)
string
    Word8
OpenSquareBracketP ->
      Parser (Value Exp)
array
    Word8
OpenParenP ->
      Parser (Value Exp)
arrayUO forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Value Exp)
stringCI
    Word8
OpenCurlyBracketP ->
      Parser (Value Exp)
object
    Word8
HashP ->
      Parser (Value Exp)
haskellExp
    Word8
_ | Word8 -> Bool
startOfNumber Word8
b ->
        Parser (Value Exp)
number
      | Bool
otherwise ->
        forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"a value cannot start with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word8
b)
 where
  startOfNumber :: Word8 -> Bool
startOfNumber Word8
b =
    Word8
b forall a. Ord a => a -> a -> Bool
>= Word8
ZeroP Bool -> Bool -> Bool
&& Word8
b forall a. Ord a => a -> a -> Bool
<= Word8
NineP Bool -> Bool -> Bool
|| Word8
b forall a. Eq a => a -> a -> Bool
== Word8
MinusP

any :: Atto.Parser (Value Exp)
any :: Parser (Value Exp)
any = do
  Word8
_ <- Word8 -> Parser Word8
Atto.word8 Word8
AnyP
  Maybe Text
name <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just Parser Text
key forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  Parser ()
spaces
  Maybe TypeSig
expectedType <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser TypeSig
typeSig
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall ext. Maybe TypeSig -> Maybe Text -> Value ext
Any Maybe TypeSig
expectedType Maybe Text
name)

null :: Atto.Parser (Value Exp)
null :: Parser (Value Exp)
null =
  forall ext. Value ext
Null forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString
Atto.string ByteString
"null"

false :: Atto.Parser (Value Exp)
false :: Parser (Value Exp)
false =
  forall ext. Bool -> Value ext
Bool Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString
Atto.string ByteString
"false"

true :: Atto.Parser (Value Exp)
true :: Parser (Value Exp)
true =
  forall ext. Bool -> Value ext
Bool Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString
Atto.string ByteString
"true"

number :: Atto.Parser (Value Exp)
number :: Parser (Value Exp)
number =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ext. Scientific -> Value ext
Number Parser Scientific
Aeson.scientific

string :: Atto.Parser (Value Exp)
string :: Parser (Value Exp)
string =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ext. Text -> Value ext
String Parser Text
Aeson.jstring

stringCI :: Atto.Parser (Value Exp)
stringCI :: Parser (Value Exp)
stringCI = do
  ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
"(ci)"
  Parser ()
spaces
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall ext. CI Text -> Value ext
StringCI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. FoldCase s => s -> CI s
CI.mk) Parser Text
Aeson.jstring

array :: Atto.Parser (Value Exp)
array :: Parser (Value Exp)
array = do
  Word8
_ <- Word8 -> Parser Word8
Atto.word8 Word8
OpenSquareBracketP
  Parser ()
spaces
  Word8
b <- Parser Word8
Atto.peekWord8'
  case Word8
b of
    Word8
CloseSquareBracketP -> do
      Word8
_ <- Word8 -> Parser Word8
Atto.word8 Word8
CloseSquareBracketP
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall ext. Array ext -> Value ext
Array Box {knownValues :: Vector (Value Exp)
knownValues = forall a. Vector a
Vector.empty, extendable :: Bool
extendable = Bool
False})
    Word8
_ -> do
      [Value Exp] -> Int -> Parser (Value Exp)
loop [] Int
0
 where
  loop :: [Value Exp] -> Int -> Parser (Value Exp)
loop [Value Exp]
values !Int
n = do
    Value Exp
val <- Parser (Value Exp)
value
    Parser ()
spaces
    Word8
b <- (Word8 -> Bool) -> Parser Word8
Atto.satisfy (\Word8
w -> Word8
w forall a. Eq a => a -> a -> Bool
== Word8
CommaP Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
CloseSquareBracketP) forall i a. Parser i a -> [Char] -> Parser i a
Atto.<?> [Char]
"',' or ']'"
    case Word8
b of
      Word8
CommaP -> do
        Parser ()
spaces
        Word8
b' <- Parser Word8
Atto.peekWord8'
        case Word8
b' of
          Word8
DotP -> do
            Parser ()
rest
            Parser ()
spaces
            Word8
_ <- Word8 -> Parser Word8
Atto.word8 Word8
CloseSquareBracketP
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ext. Array ext -> Value ext
Array Box
              { knownValues :: Vector (Value Exp)
knownValues = forall a. Int -> [a] -> Vector a
Vector.fromListN (Int
n forall a. Num a => a -> a -> a
+ Int
1) (forall a. [a] -> [a]
reverse (Value Exp
val forall a. a -> [a] -> [a]
: [Value Exp]
values))
              , extendable :: Bool
extendable = Bool
True
              }
          Word8
_ ->
            [Value Exp] -> Int -> Parser (Value Exp)
loop (Value Exp
val forall a. a -> [a] -> [a]
: [Value Exp]
values) (Int
n forall a. Num a => a -> a -> a
+ Int
1)
      Word8
CloseSquareBracketP ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ext. Array ext -> Value ext
Array Box
          { knownValues :: Vector (Value Exp)
knownValues = forall a. Int -> [a] -> Vector a
Vector.fromListN (Int
n forall a. Num a => a -> a -> a
+ Int
1) (forall a. [a] -> [a]
reverse (Value Exp
val forall a. a -> [a] -> [a]
: [Value Exp]
values))
          , extendable :: Bool
extendable = Bool
False
          }
      Word8
_ ->
        forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"

arrayUO :: Atto.Parser (Value Exp)
arrayUO :: Parser (Value Exp)
arrayUO = do
  ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
"(unordered)"
  Parser ()
spaces
  Array Array Exp
box <- Parser (Value Exp)
array
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall ext. Array ext -> Value ext
ArrayUO Array Exp
box)

object :: Atto.Parser (Value Exp)
object :: Parser (Value Exp)
object = do
  Word8
_ <- Word8 -> Parser Word8
Atto.word8 Word8
OpenCurlyBracketP
  Parser ()
spaces
  Word8
b <- Parser Word8
Atto.peekWord8'
  case Word8
b of
    Word8
CloseCurlyBracketP -> do
      Word8
_ <- Word8 -> Parser Word8
Atto.word8 Word8
CloseCurlyBracketP
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall ext. Object ext -> Value ext
Object Box {knownValues :: HashMap Text (Value Exp)
knownValues = forall k v. HashMap k v
HashMap.empty, extendable :: Bool
extendable = Bool
False})
    Word8
_ ->
      [(Text, Value Exp)] -> Parser (Value Exp)
loop []
 where
  loop :: [(Text, Value Exp)] -> Parser (Value Exp)
loop [(Text, Value Exp)]
values = do
    Text
k <- Parser Text
key
    Parser ()
spaces
    Word8
_ <- Word8 -> Parser Word8
Atto.word8 Word8
ColonP
    Parser ()
spaces
    Value Exp
val <- Parser (Value Exp)
value
    Parser ()
spaces
    Word8
b <- (Word8 -> Bool) -> Parser Word8
Atto.satisfy (\Word8
b -> Word8
b forall a. Eq a => a -> a -> Bool
== Word8
CommaP Bool -> Bool -> Bool
|| Word8
b forall a. Eq a => a -> a -> Bool
== Word8
CloseCurlyBracketP) forall i a. Parser i a -> [Char] -> Parser i a
Atto.<?> [Char]
"',' or '}'"
    case Word8
b of
      Word8
CommaP -> do
        Parser ()
spaces
        Word8
b' <- Parser Word8
Atto.peekWord8'
        case Word8
b' of
          Word8
DotP -> do
            Parser ()
rest
            Parser ()
spaces
            Word8
_ <- Word8 -> Parser Word8
Atto.word8 Word8
CloseCurlyBracketP
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ext. Object ext -> Value ext
Object Box
              { knownValues :: HashMap Text (Value Exp)
knownValues = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ((Text
k, Value Exp
val) forall a. a -> [a] -> [a]
: [(Text, Value Exp)]
values)
              , extendable :: Bool
extendable = Bool
True
              }
          Word8
_ ->
            [(Text, Value Exp)] -> Parser (Value Exp)
loop ((Text
k, Value Exp
val) forall a. a -> [a] -> [a]
: [(Text, Value Exp)]
values)
      Word8
CloseCurlyBracketP ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ext. Object ext -> Value ext
Object Box
          { knownValues :: HashMap Text (Value Exp)
knownValues = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ((Text
k, Value Exp
val) forall a. a -> [a] -> [a]
: [(Text, Value Exp)]
values)
          , extendable :: Bool
extendable = Bool
False
          }
      Word8
_ ->
        forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"

key :: Atto.Parser Text
key :: Parser Text
key =
  Parser Text
Aeson.jstring forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
Text.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
ByteString.pack) (forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 ((Word8 -> Bool) -> Parser Word8
Atto.satisfy (\Word8
c -> Int -> Char
Char.chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Char]
"\\ \":;><${}[]," :: String))))

rest :: Atto.Parser ()
rest :: Parser ()
rest =
  () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString
Atto.string ByteString
"..."

haskellExp :: Atto.Parser (Value Exp)
haskellExp :: Parser (Value Exp)
haskellExp =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ext. ext -> Value ext
Ext (ByteString -> Parser ByteString
Atto.string ByteString
"#{" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Exp
go)
 where
  go :: Parser ByteString Exp
go = do
    ByteString
str <- (Word8 -> Bool) -> Parser ByteString
Atto.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Word8
CloseCurlyBracketP) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Word8 -> Parser Word8
Atto.word8 Word8
CloseCurlyBracketP
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] Exp
parseExp (Text -> [Char]
Text.unpack (ByteString -> Text
Text.decodeUtf8 ByteString
str)))

typeSig :: Atto.Parser TypeSig
typeSig :: Parser TypeSig
typeSig = do
  Word8
_ <- Word8 -> Parser Word8
Atto.word8 Word8
ColonP
  Parser ()
spaces
  forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ ByteString -> Type -> Parser TypeSig
p ByteString
"bool" Type
BoolT
    , ByteString -> Type -> Parser TypeSig
p ByteString
"number" Type
NumberT
    , ByteString -> Type -> Parser TypeSig
p ByteString
"string" Type
StringT
    , ByteString -> Type -> Parser TypeSig
p ByteString
"ci-string" Type
StringCIT
    , ByteString -> Type -> Parser TypeSig
p ByteString
"array" Type
ArrayT
    , ByteString -> Type -> Parser TypeSig
p ByteString
"unordered-array" Type
ArrayUOT
    , ByteString -> Type -> Parser TypeSig
p ByteString
"object" Type
ObjectT
    ]
 where
  p :: ByteString -> Type -> Parser TypeSig
p ByteString
name Type
typeName = do
    ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
name
    Maybe Word8
q <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Word8 -> Parser Word8
Atto.word8 Word8
QuestionMarkP)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Nullable -> TypeSig
TypeSig Type
typeName (forall a. a -> a -> Bool -> a
bool Nullable
NonNullable Nullable
Nullable (forall a. Maybe a -> Bool
isJust Maybe Word8
q)))

-- This function has been stolen from aeson.
-- ref: https://hackage.haskell.org/package/aeson-1.4.6.0/docs/src/Data.Aeson.Parser.Internal.html#skipSpace
spaces :: Atto.Parser ()
spaces :: Parser ()
spaces =
  (Word8 -> Bool) -> Parser ()
Atto.skipWhile (\Word8
b -> Word8
b forall a. Eq a => a -> a -> Bool
== Word8
SpaceP Bool -> Bool -> Bool
|| Word8
b forall a. Eq a => a -> a -> Bool
== Word8
NewLineP Bool -> Bool -> Bool
|| Word8
b forall a. Eq a => a -> a -> Bool
== Word8
CRP Bool -> Bool -> Bool
|| Word8
b forall a. Eq a => a -> a -> Bool
== Word8
TabP)
{-# INLINE spaces #-}

pattern AnyP, NP, FP, TP, DoubleQuoteP, DotP, CommaP, HashP :: Word8
pattern $bAnyP :: Word8
$mAnyP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
AnyP = 95 -- '_'
pattern $bNP :: Word8
$mNP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
NP = 110 -- 'n'
pattern $bFP :: Word8
$mFP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
FP = 102 -- 'f'
pattern $bTP :: Word8
$mTP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
TP = 116 -- 't'
pattern $bDoubleQuoteP :: Word8
$mDoubleQuoteP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
DoubleQuoteP = 34 -- '"'
pattern $bCommaP :: Word8
$mCommaP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
CommaP = 44 -- ','
pattern $bDotP :: Word8
$mDotP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
DotP = 46 -- '.'
pattern $bHashP :: Word8
$mHashP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
HashP = 35 -- '#'

pattern OpenSquareBracketP, CloseSquareBracketP :: Word8
pattern $bOpenSquareBracketP :: Word8
$mOpenSquareBracketP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
OpenSquareBracketP = 91 -- '['
pattern $bCloseSquareBracketP :: Word8
$mCloseSquareBracketP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
CloseSquareBracketP = 93 -- ']'

pattern OpenParenP :: Word8
pattern $bOpenParenP :: Word8
$mOpenParenP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
OpenParenP = 40 -- '('
-- pattern CloseParenP :: Word8
-- pattern CloseParenP = 41 -- ')'

pattern OpenCurlyBracketP, CloseCurlyBracketP, ColonP :: Word8
pattern $bOpenCurlyBracketP :: Word8
$mOpenCurlyBracketP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
OpenCurlyBracketP = 123 -- '{'
pattern $bCloseCurlyBracketP :: Word8
$mCloseCurlyBracketP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
CloseCurlyBracketP = 125 -- '}'

pattern $bColonP :: Word8
$mColonP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
ColonP = 58 -- ':'

pattern ZeroP, NineP, MinusP :: Word8
pattern $bZeroP :: Word8
$mZeroP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
ZeroP = 48 -- '0'
pattern $bNineP :: Word8
$mNineP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
NineP = 57 -- '9'
pattern $bMinusP :: Word8
$mMinusP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
MinusP = 45 -- '-'

pattern SpaceP, NewLineP, CRP, TabP :: Word8
pattern $bSpaceP :: Word8
$mSpaceP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
SpaceP = 0x20
pattern $bNewLineP :: Word8
$mNewLineP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
NewLineP = 0x0a
pattern $bCRP :: Word8
$mCRP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
CRP = 0x0d
pattern $bTabP :: Word8
$mTabP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
TabP = 0x09

pattern QuestionMarkP :: Word8
pattern $bQuestionMarkP :: Word8
$mQuestionMarkP :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
QuestionMarkP = 63 -- '?'