content: {-# LANGUAGE BinaryLiterals #-}
  {-# LANGUAGE BlockArguments #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedRecordDot #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  
  -- | RON-Text parsing
  module RON.Text.Parse (
      parseAtom,
      parseObject,
      parseOp,
      parseOpenFrame,
      parseOpenOp,
      parsePayload,
      parseStateChunk,
      parseStateFrame,
      parseString,
      parseUuid,
      parseUuidKey,
      parseUuidAtom,
      parseWireFrame,
      parseWireFrames,
      uuidFromString,
      uuidFromText,
  ) where
  
  import RON.Prelude hiding (takeWhile)
  
  import Attoparsec.Extra (
      Parser,
      char,
      definiteDouble,
      endOfInputEx,
      isSuccessful,
      label,
      manyTill,
      parseOnly,
      satisfy,
      (<+>),
      (??),
   )
  import Data.Aeson qualified as Json
  import Data.Attoparsec.ByteString (takeWhile1)
  import Data.Attoparsec.ByteString.Char8 (
      anyChar,
      decimal,
      double,
      signed,
      skipSpace,
      takeWhile,
   )
  import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.))
  import Data.ByteString qualified as BS
  import Data.ByteString.Char8 qualified as BSC
  import Data.ByteString.Lazy qualified as BSL
  import Data.Map.Strict qualified as Map
  import Data.Maybe (isJust, isNothing)
  import Data.Text qualified as Text
  import Data.Text.Encoding qualified as Text
  
  import RON.Base64 qualified as Base64
  import RON.Types (
      Atom (AFloat, AInteger, AString, AUuid),
      ClosedOp (..),
      ObjectFrame (ObjectFrame),
      Op (..),
      OpTerm (TClosed, THeader, TQuery, TReduced),
      Packer (PackChain, PackFixed, PackIncrement),
      Payload,
      StateFrame,
      UUID (UUID),
      WireChunk (Closed, Query, Value),
      WireFrame,
      WireReducedChunk (..),
      WireStateChunk (..),
   )
  import RON.UUID (UuidFields (..), addValue, succValue)
  import RON.UUID qualified as UUID
  import RON.Util.Word (
      Word2,
      Word4,
      Word60,
      b00,
      b0000,
      b01,
      b10,
      b11,
      ls60,
      safeCast,
   )
  
  -- | Parse a common frame
  parseWireFrame :: ByteStringL -> Either String WireFrame
  parseWireFrame = parseOnly frame
  
  chunksTill :: Parser () -> Parser [WireChunk]
  chunksTill end = label "[WireChunk]" $ go closedOpZero
    where
      go prev = do
          skipSpace
          atEnd <- isSuccessful end
          if atEnd then
              pure []
          else do
              (ch, lastOp) <- pChunk prev
              (ch :) <$> go lastOp
  
  -- | Returns a chunk and the last op in it
  pChunk :: ClosedOp -> Parser (WireChunk, ClosedOp)
  pChunk prev = label "WireChunk" $ wireReducedChunk prev <+> chunkClosed prev
  
  chunkClosed :: ClosedOp -> Parser (WireChunk, ClosedOp)
  chunkClosed prev =
      label "WireChunk-closed" do
          skipSpace
          (_, x) <- closedOp prev
          skipSpace
          void $ char ';'
          pure (Closed x, x)
  
  -- | Returns a chunk and the last op (converted to closed) in it
  wireReducedChunk :: ClosedOp -> Parser (WireChunk, ClosedOp)
  wireReducedChunk prev =
      label "WireChunk-reduced" do
          (wrcHeader, isQuery) <- header prev
          wrcBody <- reducedOps wrcHeader.objectId wrcHeader.op <|> stop
          let lastOp = lastDef wrcHeader.op wrcBody
              lastClosedOp = wrcHeader{op = lastOp}
          pure
              ( (if isQuery then Query else Value) WireReducedChunk{..}
              , lastClosedOp
              )
    where
      stop = pure []
  
  parseStateChunk :: ByteStringL -> Either String WireStateChunk
  parseStateChunk =
      parseOnly do
          (Value value, _) <- wireReducedChunk closedOpZero
          let WireReducedChunk{wrcHeader, wrcBody} = value
              ClosedOp{reducerId} = wrcHeader
          pure WireStateChunk{stateType = reducerId, stateBody = wrcBody}
  
  frame :: Parser WireFrame
  frame = label "WireFrame" $ chunksTill (endOfFrame <|> endOfInputEx)
  
  -- | Parse a sequence of common frames
  parseWireFrames :: ByteStringL -> Either String [WireFrame]
  parseWireFrames = parseOnly $ manyTill frameInStream endOfInputEx
  
  frameInStream :: Parser WireFrame
  frameInStream = label "WireFrame-stream" $ chunksTill endOfFrame
  
  -- | Parse a single context-free op
  parseOp :: ByteStringL -> Either String ClosedOp
  parseOp =
      parseOnly do
          (_, x) <- closedOp closedOpZero <* skipSpace <* endOfInputEx
          pure x
  
  -- | Parse a single context-free UUID
  parseUuid :: ByteStringL -> Either String UUID
  parseUuid =
      parseOnly $
          uuid UUID.zero UUID.zero PrevOpSameKey <* skipSpace <* endOfInputEx
  
  uuidFromText :: Text -> Either String UUID
  uuidFromText = parseUuid . BSL.fromStrict . Text.encodeUtf8
  
  uuidFromString :: String -> Either String UUID
  uuidFromString = uuidFromText . Text.pack
  
  -- | Parse a UUID in key position
  parseUuidKey ::
      -- | same key in the previous op (default is 'UUID.zero')
      UUID ->
      -- | previous key of the same op (default is 'UUID.zero')
      UUID ->
      ByteStringL ->
      Either String UUID
  parseUuidKey prevKey prev =
      parseOnly $ uuid prevKey prev PrevOpSameKey <* skipSpace <* endOfInputEx
  
  -- | Parse a UUID in value (atom) position
  parseUuidAtom ::
      -- | previous
      UUID ->
      ByteStringL ->
      Either String UUID
  parseUuidAtom prev = parseOnly $ uuidAtom prev <* skipSpace <* endOfInputEx
  
  endOfFrame :: Parser ()
  endOfFrame = label "end of frame" $ void $ skipSpace *> char '.'
  
  closedOp :: ClosedOp -> Parser (Bool, ClosedOp)
  closedOp prev =
      label "ClosedOp-cont" do
          (hasTyp, reducerId) <- key "reducer" '*' prev.reducerId UUID.zero
          (hasObj, objectId) <- key "object" '#' prev.objectId reducerId
          (hasEvt, opId) <- key "opId" '@' prev.op.opId objectId
          (hasRef, refId) <- key "ref" ':' prev.op.refId opId
          payload <- pPayload objectId
          let op = Op{..}
          pure
              ( hasTyp || hasObj || hasEvt || hasRef || not (null payload)
              , ClosedOp{..}
              )
  
  reducedOps :: UUID -> Op -> Parser [Op]
  reducedOps objectId y = do
      skipSpace
      (isNotEmpty, packerM, x) <- reducedOpOrPack objectId y
      t <- optional term
      unless (t == Just TReduced || isNothing t) $
          fail "reduced op may end with `,` only"
      unless (isNotEmpty || t == Just TReduced) $ fail "Empty reduced op"
      let (ops, lastOp) = maybe ([x], x) (unpackOps x) packerM
      cont <- reducedOps objectId lastOp <|> pure []
      pure $ ops ++ cont
  
  unpackOps :: Op -> Packer -> ([Op], Op)
  unpackOps first packer =
      case first.payload of
          [AString s] ->
              ( unpackLetters first.opId first.refId $ Text.unpack s
              , lastOp $ fromIntegral $ Text.length s
              )
          [AInteger i] ->
              (unpackEmpties first.opId first.refId i, lastOp $ fromIntegral i)
          _ -> undefined
    where
      nextRef opId refId =
          case packer of
              PackChain -> opId
              PackFixed -> refId
              PackIncrement -> succValue refId
  
      lastRef size =
          case packer of
              PackChain -> first.opId `addValue` (size - 2)
              PackFixed -> first.refId
              PackIncrement -> first.refId `addValue` (size - 1)
  
      lastOp size =
          Op
              { opId = first.opId `addValue` (size - 1)
              , refId = lastRef size
              , payload = ["CANNOT HAPPEN! TODO OpHead"]
              }
  
      unpackLetters opId refId = \case
          [] -> []
          c : cs ->
              Op{opId, refId, payload = [AString $ Text.singleton c]}
                  : unpackLetters (succValue opId) (nextRef opId refId) cs
  
      unpackEmpties opId refId size
          | size > 0 =
              Op{opId, refId, payload = []}
                  : unpackEmpties (succValue opId) (nextRef opId refId) (size - 1)
          | otherwise = []
  
  reducedOpOrPack :: UUID -> Op -> Parser (Bool, Maybe Packer, Op)
  reducedOpOrPack opObject prev =
      label "Op-reduced-cont" do
          (hasEvt, opId) <- key "event" '@' prev.opId opObject
          (hasRef, refId) <- key "ref" ':' prev.refId opId
          packerM <- optional pPacker
          payload <- pPayload opObject
          let op = Op{opId, refId, payload}
          pure (hasEvt || hasRef || not (null payload), packerM, op)
  
  openOp :: UUID -> Parser Op
  openOp prev =
      label "Op-open-cont" do
          opId <- openKey "event" '@' <|> pure (UUID.succValue prev)
          refId <- openKey "ref" ':' <|> pure prev
          payload <- pPayload opId
          t <- term
          guard $ t == TReduced || t == TClosed
          pure Op{opId, refId, payload}
  
  key :: String -> Char -> UUID -> UUID -> Parser (Bool, UUID)
  key name keyChar prevOpSameKey sameOpPrevUuid =
      label name do
          skipSpace
          isKeyPresent <- isSuccessful $ char keyChar
          if isKeyPresent then do
              u <- uuid prevOpSameKey sameOpPrevUuid PrevOpSameKey
              pure (True, u)
          else
              -- no key => use previous key
              pure (False, prevOpSameKey)
  
  openKey :: String -> Char -> Parser UUID
  openKey name keyChar =
      label name do
          skipSpace
          _ <- char keyChar
          uuid UUID.zero UUID.zero PrevOpSameKey
  
  uuid :: UUID -> UUID -> UuidZipBase -> Parser UUID
  uuid prevOpSameKey sameOpPrevUuid defaultZipBase =
      label "UUID" $
          uuid22
              <+> uuid11
              <+> uuidZip prevOpSameKey sameOpPrevUuid defaultZipBase
  
  uuid11 :: Parser UUID
  uuid11 =
      label "UUID-RON-11-letter-value" do
          rawX <- base64word 11
          guard $ BS.length rawX == 11
          x <- Base64.decode64 rawX ?? fail "Base64.decode64"
          rawUuidVersionM <- optional pUuidVersion
          y <-
              case rawUuidVersionM of
                  Nothing -> pure 0
                  Just rawUuidVersion -> do
                      rawOrigin <- optional $ base64word 10
                      origin <- case rawOrigin of
                          Nothing -> pure $ ls60 0
                          Just origin ->
                              Base64.decode60 origin ?? fail "Base64.decode60"
                      pure $ UUID.buildY b00 rawUuidVersion origin
          pure $ UUID x y
  
  data UuidZipBase = PrevOpSameKey | SameOpPrevUuid
  
  uuidZip' :: Parser UUID
  uuidZip' =
      label "UUID-zip'" do
          rawVariety <- optional pVariety
          rawValue <- base64word60 10
          rawUuidVersion <- optional pUuidVersion
          rawOrigin <- case rawUuidVersion of
              Just _ -> optional $ base64word60 10
              Nothing -> pure Nothing
  
          pure $
              UUID.build
                  UuidFields
                      { uuidVariety = fromMaybe b0000 rawVariety
                      , uuidValue = rawValue
                      , uuidVariant = b00
                      , uuidVersion = fromMaybe b00 rawUuidVersion
                      , uuidOrigin = fromMaybe (ls60 0) rawOrigin
                      }
  
  {-# DEPRECATED uuidZip "Deprecated since RON 2.1 ." #-}
  uuidZip :: UUID -> UUID -> UuidZipBase -> Parser UUID
  uuidZip prevOpSameKey sameOpPrevUuid defaultZipBase =
      label "UUID-zip" do
          changeZipBase <- isSuccessful $ char '`'
          rawVariety <- optional pVariety
          rawReuseValue <- optional pReuse
          rawValue <- optional $ base64word60 $ 10 - (rawReuseValue ?: 0)
          rawUuidVersion <- optional pUuidVersion
          rawReuseOrigin <- optional pReuse
          rawOrigin <- optional $ base64word60 $ 10 - (rawReuseOrigin ?: 0)
  
          let prev = UUID.split $ whichPrev changeZipBase
          let isSimple =
                  prev.uuidVariant /= b00
                      || ( not changeZipBase
                              && isNothing rawReuseValue
                              && isJust rawValue
                              && isNothing rawReuseOrigin
                              && (isNothing rawUuidVersion || isJust rawOrigin)
                         )
  
          let fields
                  | isSimple =
                      UuidFields
                          { uuidVariety = rawVariety ?: b0000
                          , uuidValue = rawValue ?: 0
                          , uuidVariant = b00
                          , uuidVersion = rawUuidVersion ?: b00
                          , uuidOrigin = rawOrigin ?: 0
                          }
                  | otherwise =
                      UuidFields
                          { uuidVariety = rawVariety ?: prev.uuidVariety
                          , uuidValue =
                              reuse rawReuseValue rawValue prev.uuidValue
                          , uuidVariant = b00
                          , uuidVersion = rawUuidVersion ?: prev.uuidVersion
                          , uuidOrigin =
                              reuse rawReuseOrigin rawOrigin prev.uuidOrigin
                          }
          pure $ UUID.build fields
    where
      whichPrev changeZipBase
          | changeZipBase = sameOpPrevUuid
          | otherwise = case defaultZipBase of
              PrevOpSameKey -> prevOpSameKey
              SameOpPrevUuid -> sameOpPrevUuid
  
  reuse :: Maybe Int -> Maybe Word60 -> Word60 -> Word60
  reuse Nothing Nothing prev = prev
  reuse Nothing (Just new) _ = new
  reuse (Just prefixLen) Nothing prev =
      ls60 $ safeCast prev .&. complement 0 `shiftL` (60 - 6 * prefixLen)
  reuse (Just prefixLen) (Just new) prev = ls60 $ prefix .|. postfix
    where
      prefix = safeCast prev .&. complement 0 `shiftL` (60 - 6 * prefixLen)
      postfix = safeCast new `shiftR` (6 * prefixLen)
  
  pReuse :: Parser Int
  pReuse =
      anyChar >>= \case
          '(' -> pure 4
          '[' -> pure 5
          '{' -> pure 6
          '}' -> pure 7
          ']' -> pure 8
          ')' -> pure 9
          _ -> fail "not a reuse symbol"
  
  uuid22 :: Parser UUID
  uuid22 =
      label "UUID-Base64-double-word" do
          xy <- base64word 22
          guard $ BS.length xy == 22
          maybe (fail "Base64 decoding error") pure $
              UUID
                  <$> Base64.decode64 (BS.take 11 xy)
                  <*> Base64.decode64 (BS.drop 11 xy)
  
  base64word :: Int -> Parser ByteString
  base64word maxSize =
      label "Base64 word" do
          word <- takeWhile1 Base64.isLetter
          guard $ BS.length word <= maxSize
          pure word
  
  base64word60 :: Int -> Parser Word60
  base64word60 maxSize =
      label "Base64 word60" do
          word <- base64word maxSize
          Base64.decode60 word ?? fail "decode60"
  
  isUpperHexDigit :: Word8 -> Bool
  isUpperHexDigit c =
      (fromIntegral (c - fromIntegral (ord '0')) :: Word) <= 9
          || (fromIntegral (c - fromIntegral (ord 'A')) :: Word) <= 5
  
  pVariety :: Parser Word4
  pVariety =
      label "variety" do
          letter <- satisfy isUpperHexDigit <* "/"
          Base64.decodeLetter4 letter ?? fail "Base64.decodeLetter4"
  
  pUuidVersion :: Parser Word2
  pUuidVersion =
      label "UUID-version" $
          anyChar >>= \case
              '$' -> pure b00
              '%' -> pure b01
              '+' -> pure b10
              '-' -> pure b11
              _ -> fail "not a UUID-version"
  
  pPacker :: Parser Packer
  pPacker = do
      skipSpace
      _ <- char '%'
      anyChar >>= \case
          'c' -> pure PackChain
          'f' -> pure PackFixed
          'i' -> pure PackIncrement
          _ -> fail "bad packer"
  
  pPayload :: UUID -> Parser Payload
  pPayload = label "payload" . go
    where
      go prevUuid = do
          ma <- optional $ atom prevUuid
          case ma of
              Nothing -> pure []
              Just a -> (a :) <$> go newUuid
                where
                  newUuid = case a of
                      AUuid u -> u
                      _ -> prevUuid
  
  parsePayload :: ByteStringL -> Either String Payload
  parsePayload = parseOnly $ pPayload UUID.zero <* endOfInputEx
  
  atom :: UUID -> Parser Atom
  atom prevUuid = skipSpace *> atom'
    where
      atom' =
          (char '^' *> skipSpace *> (AFloat <$> double))
              <+> (char '=' *> skipSpace *> (AInteger <$> integer))
              <+> (char '>' *> skipSpace *> (AUuid <$> uuid'))
              <+> (AString <$> string)
              <+> atomUnprefixed
      integer = signed decimal
      uuid' = uuidAtom prevUuid
  
  atomUnprefixed :: Parser Atom
  atomUnprefixed =
      (AFloat <$> definiteDouble)
          <+> (AInteger <$> integer)
          <+> (AUuid <$> uuidUnzipped)
    where
      integer = signed decimal
      uuidUnzipped = uuid22 <+> uuid11 <+> uuidZip'
  
  uuidAtom :: UUID -> Parser UUID
  uuidAtom prev = uuid UUID.zero prev SameOpPrevUuid
  
  -- | Parse an atom
  parseAtom :: ByteStringL -> Either String Atom
  parseAtom = parseOnly $ atom UUID.zero <* endOfInputEx
  
  string :: Parser Text
  string = do
      bs <- char '\'' *> content
      case Json.decodeStrict $ '"' `BSC.cons` (bs `BSC.snoc` '"') of
          Just s -> pure s
          Nothing -> fail "bad string"
    where
      content = do
          chunk <- takeWhile \c -> c /= '\'' && c /= '\\'
          anyChar >>= \case
              '\'' -> pure chunk
              '\\' ->
                  anyChar >>= \case
                      '\'' -> (chunk <>) . BSC.cons '\'' <$> content
                      c -> (chunk <>) . BSC.cons '\\' . BSC.cons c <$> content
              _ -> fail "cannot happen"
  
  -- | Parse a string atom
  parseString :: ByteStringL -> Either String Text
  parseString = parseOnly $ string <* endOfInputEx
  
  -- | Return 'ClosedOp' and 'chunkIsQuery'
  header :: ClosedOp -> Parser (ClosedOp, Bool)
  header prev = do
      (_, x) <- closedOp prev
      t <- term
      case t of
          THeader -> pure (x, False)
          TQuery -> pure (x, True)
          _ -> fail "not a header"
  
  term :: Parser OpTerm
  term = do
      skipSpace
      anyChar >>= \case
          '!' -> pure THeader
          '?' -> pure TQuery
          ',' -> pure TReduced
          ';' -> pure TClosed
          _ -> fail "not a term"
  
  {- | Parse a state frame
  TODO deprecate multi-object states
  -}
  parseStateFrame :: ByteStringL -> Either String StateFrame
  parseStateFrame = parseWireFrame >=> findObjects
  
  -- | Parse a state frame as an object
  parseObject :: UUID -> ByteStringL -> Either String (ObjectFrame a)
  parseObject oid bytes = ObjectFrame oid <$> parseStateFrame bytes
  
  {- | Extract object states from a common frame
  TODO deprecate multi-object states
  -}
  findObjects :: WireFrame -> Either String StateFrame
  findObjects = fmap Map.fromList . traverse loadBody
    where
      loadBody = \case
          Value WireReducedChunk{wrcHeader, wrcBody} -> do
              let ClosedOp{reducerId, objectId} = wrcHeader
              pure
                  ( objectId
                  , WireStateChunk{stateType = reducerId, stateBody = wrcBody}
                  )
          _ -> Left "expected reduced chunk"
  
  closedOpZero :: ClosedOp
  closedOpZero =
      ClosedOp{reducerId = UUID.zero, objectId = UUID.zero, op = opZero}
  
  opZero :: Op
  opZero = Op{opId = UUID.zero, refId = UUID.zero, payload = []}
  
  parseOpenFrame :: ByteStringL -> Either String [Op]
  parseOpenFrame =
      parseOnly $ go UUID.zero <* skipSpace <* endOfInputEx
    where
      go :: UUID -> Parser [Op]
      go prev =
          ( do
              op@Op{opId} <- openOp prev
              (op :) <$> go opId
          )
              <|> pure []
  
  parseOpenOp :: ByteStringL -> Either String Op
  parseOpenOp = parseOnly $ openOp UUID.zero <* skipSpace <* endOfInputEx
  