-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS -fno-warn-orphans #-}

module Handler.Utils.Rating.Format
  ( parseRating, formatRating
  ) where

import Import

import Handler.Utils.DateTime ()

import qualified Data.Map.Strict as Map

import qualified Data.Char as Char

import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy.Text
import qualified Data.Text.Lazy.Encoding as Lazy.Text

import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy as Lazy.ByteString

import qualified Data.CaseInsensitive as CI

import qualified Handler.Utils.Rating.Format.Legacy as Legacy

import qualified Data.YAML as YAML
import qualified Data.YAML.Event as YAML (untagged)
import qualified Data.YAML.Event as YAML.Event
import qualified Data.YAML.Token as YAML (Encoding(..))
import Data.YAML.Aeson () -- ToYAML Value

import Control.Monad.Trans.State.Lazy (evalState)

import qualified System.FilePath.Cryptographic as Explicit

import Control.Exception (ErrorCall(..))

import qualified Data.Conduit.Combinators as C


data PrettifyState
  = PrettifyInitial
  | PrettifyMetadata Natural
  | PrettifySubmissionId
  | PrettifyRatingPoints
  | PrettifyRatingPassed
  | PrettifyRating
  | PrettifyRatingDone
  | PrettifyComment
  deriving (Eq, Ord, Read, Show, Generic)


formatRating :: MsgRendererS UniWorX -> DateTimeFormatter -> CryptoFileNameSubmission -> Rating -> Lazy.ByteString
formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = Rating'{..}, .. } = mconcat
  [ prettyYAML
  , maybe Lazy.ByteString.empty (Lazy.Text.encodeUtf8 . Lazy.Text.fromStrict . ensureNewline) ratingComment
  ]
  where
    ensureNewline t = Text.strip t <> "\n"

    uglyYAML = YAML.Event.writeEvents YAML.UTF8 $ concat
      [ [ YAML.Event.StreamStart
        , YAML.Event.DocumentStart $ YAML.Event.DirEndMarkerVersion 2
        ]
      , concat
        [ pure $ YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block
        , mapEvents (str' "term") (msg $ ShortTermIdentifier ratingCourseTerm)
        , mapEvents (str' "school") (str $ CI.original ratingCourseSchool)
        , mapEvents (str' "course") (str $ CI.original ratingCourseName)
        , nodeEvents (str' "sheet")
        , case YAML.toYAML $ toJSON ratingSheetType of
            YAML.Mapping _ _ typeMap
              -> let typeMap' = flip sortOn (Map.toList typeMap) $ \case
                       (YAML.Scalar _ (YAML.SStr k), _) -> NTop $ k `elemIndex` ["type", "grading"]
                       _other -> NTop Nothing
                  in concat
                       [ pure $ YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block
                       , mapEvents (str' "name") (str $ CI.original ratingSheetName)
                       , concat [ mapEvents k v | (k, v) <- typeMap' ]
                       , pure YAML.Event.MappingEnd
                       ]
            _other -> nodeEvents . str $ CI.original ratingSheetName
        , mapEvents (str' "rated_by") (maybe (YAML.Scalar () YAML.SNull) str ratingCorrectorName)
        , mapEvents (str' "rated_at") (maybe (YAML.Scalar () YAML.SNull) (str . format SelFormatDateTime) ratingTime)
        , mapEvents (str' "submission") (str $ toPathPiece cID)

        , case ratingSheetType ^? _grading of
            Nothing -> mempty
            Just mode -> if
              | is _PassAlways mode
                -> mempty
              | has (_passingBound . _Left) mode
                -> mapEvents (str' "passed") (YAML.Scalar () . maybe YAML.SNull YAML.SBool $ gradingPassed mode =<< ratingPoints)
              | Just ratingPoints' <- ratingPoints ^? _Just . _Integer
                -> mapEvents (str' "points") (YAML.Scalar () $ YAML.SInt ratingPoints')
              | otherwise
                -> mapEvents (str' "points") (YAML.Scalar () $ maybe YAML.SNull (YAML.SFloat . realToFrac) ratingPoints)
        , mapEvents (str' "rating_done") (YAML.Scalar () $ YAML.SBool ratingDone)
        , pure YAML.Event.MappingEnd
        ]
      , [ YAML.Event.DocumentEnd True
        , YAML.Event.StreamEnd
        ]
      ]
      where str :: forall t. Textual t => t -> YAML.Node ()
            str = YAML.Scalar () . YAML.SStr . repack
            str' :: Text -> YAML.Node ()
            str' = str
            msg :: forall msg. RenderMessage UniWorX msg => msg -> YAML.Node ()
            msg = str . mr

            mapEvents :: YAML.Node () -> YAML.Node () -> [YAML.Event.Event]
            mapEvents k v = filterEvs . nodeEvents . YAML.Mapping () YAML.untagged $ singletonMap k v
              where filterEvs ((YAML.Event.MappingStart{} : inner) :> YAML.Event.MappingEnd) = inner
                    filterEvs _other = error "Could not strip Mapping"

            nodeEvents :: YAML.Node () -> [YAML.Event.Event]
            nodeEvents = filterEvs . mapMaybe (fmap YAML.Event.eEvent . preview _Right) . YAML.Event.parseEvents . YAML.encodeNode . pure . YAML.Doc
              where filterEvs = filter $ \case
                      YAML.Event.StreamStart -> False
                      YAML.Event.StreamEnd -> False
                      YAML.Event.DocumentStart _ -> False
                      YAML.Event.DocumentEnd _ -> False
                      _other -> True

    prettyYAML = annotate . (evalState ?? PrettifyInitial) . transduce' $ YAML.Event.parseEvents uglyYAML
      where
        transduce' (Left _ : _) = error "Parse error on uglyYAML"
        transduce' (Right YAML.Event.EvPos{ eEvent, ePos = pos1 } : es@(Right YAML.Event.EvPos{ ePos = pos2 }: _))
          = (:) <$> ((YAML.Event.posByteOffset pos1, YAML.Event.posByteOffset pos2, ) <$> state (`transduce` eEvent)) <*> transduce' es
        transduce' (Right YAML.Event.EvPos{..} : es)
          = (:) <$> ((YAML.Event.posByteOffset ePos, fromIntegral $ Lazy.ByteString.length uglyYAML, ) <$> state (`transduce` eEvent)) <*> transduce' es
        transduce' [] = return []

        annotate = fst . foldl' annotate' (uglyYAML, Lazy.ByteString.length uglyYAML) . reverse
          where annotate' (dat, mLength) (fromIntegral -> pos1, fromIntegral -> pos2, (fromStrict . encodeUtf8 -> ann1, ann2))
                  = let (before', after) = Lazy.ByteString.splitAt pos2' dat
                        (before, event) = Lazy.ByteString.splitAt pos1' before'
                        event' = decodeUtf8 $ toStrict event
                        ws = Text.takeWhileEnd Char.isSpace event'
                        event'' = Text.dropWhileEnd Char.isSpace event'
                        pos1' = min pos1 mLength
                        pos2' = min pos2 mLength
                     in (before <> ann1 <> fromStrict (encodeUtf8 event'') <> fromStrict (encodeUtf8 $ ann2 ws) <> after, pos1')

        transduce :: PrettifyState -> YAML.Event.Event -> ((Text, Text -> Text), PrettifyState)
        transduce PrettifyInitial YAML.Event.MappingStart{} = (("# " <> mr MsgRatingYAMLMetaComment <> "\n", id), PrettifyMetadata 0)
        transduce PrettifyInitial _ = ((mempty, id), PrettifyInitial)
        transduce (PrettifyMetadata 0) (YAML.Event.Scalar _ _ _ k)
          | k == "submission" = (("\n# " <> mr MsgRatingYAMLSubmissionIdComment <> "\n", id), PrettifySubmissionId)
        transduce (PrettifyMetadata n) YAML.Event.MappingStart{} = ((mempty, id), PrettifyMetadata $ succ n)
        transduce (PrettifyMetadata 0) _ = ((mempty, id), PrettifyMetadata 0)
        transduce (PrettifyMetadata n) YAML.Event.MappingEnd = ((mempty, id), PrettifyMetadata $ pred n)
        transduce cState@(PrettifyMetadata _) _ = ((mempty, id), cState)
        transduce PrettifySubmissionId (YAML.Event.Scalar _ _ _ k)
          | k == "points" = ((startRatingComment, id), PrettifyRatingPoints)
          | k == "passed" = ((startRatingComment, id), PrettifyRatingPassed)
          | k == "rating_done" = ((startRatingComment, id), PrettifyRatingDone)
          where startRatingComment = "\n# " <> mr MsgRatingYAMLRatingComment <> "\n"
        transduce PrettifySubmissionId _ = ((mempty, id), PrettifySubmissionId)
        transduce PrettifyRatingPoints _ = ((mempty, beforeBreak $ " # " <> mr MsgRatingYAMLChangePointsComment), PrettifyRating)
        transduce PrettifyRatingPassed _ = ((mempty, beforeBreak $ " # " <> mr MsgRatingYAMLChangePassedComment), PrettifyRating)
        transduce PrettifyRatingDone _ = ((mempty, beforeBreak $ " # " <> mr MsgRatingYAMLChangeDoneComment), PrettifyRating)
        transduce PrettifyRating (YAML.Event.Scalar _ _ _ k)
          | k == "points" = ((mempty, id), PrettifyRatingPoints)
          | k == "passed" = ((mempty, id), PrettifyRatingPassed)
          | k == "rating_done" = ((mempty, id), PrettifyRatingDone)
        transduce PrettifyRating YAML.Event.MappingEnd = (("\n", (<> ("# " <> mr MsgRatingYAMLChangeCommentComment <> "\n"))), PrettifyComment)
        transduce PrettifyRating _ = ((mempty, id), PrettifyRating)
        transduce PrettifyComment _ = ((mempty, id), PrettifyComment)
        -- transduce cState _ = (("<", \ws -> "|" <> ws <> ">"), cState) -- TODO

        beforeBreak :: Text -> Text -> Text
        beforeBreak ins ws = before <> ins <> break' <> after
          where (before', after) = Text.breakOnEnd "\n" ws
                before = Text.dropWhileEnd (== '\n') before'
                break' = Text.takeWhileEnd (== '\n') before'

instance ns ~ CryptoIDNamespace (CI FilePath) SubmissionId => YAML.FromYAML (Maybe UTCTime -> Maybe Text -> (Rating', Maybe (Explicit.CryptoFileName ns))) where
  parseYAML = YAML.withMap "Rating'" $ \m -> do
    ratingDone <- m YAML..:? "rating_done" YAML..!= False
    ratingPoints' <- asum
      [ fmap (fromIntegral :: Integer -> Points) <$> m YAML..:? "points"
      , fmap (realToFixed :: Double -> Points) <$> m YAML..:? "points"
      ]
    ratingPassed  <- fmap (bool 0 1) <$> m YAML..:? "passed"
    let ratingPoints = ratingPoints' <|> ratingPassed
        cIDNode = listToMaybe . Map.elems $ Map.filterWithKey isCIDNode m
          where isCIDNode (YAML.Scalar _ (YAML.SStr k)) _ = k == "submission"
                isCIDNode _ _ = False
    cID <- for cIDNode $ \cIDNode' ->
      YAML.withStr "CryptoFileNameSubmission" (maybe (YAML.failAtNode cIDNode' "Could not parse CryptoFileNameSubmission") return . fromPathPiece) cIDNode'
    ratingComment' <- fmap (assertM' (not . Text.null) . Text.strip) <$> m YAML..:? "comment"
    return $ \ratingTime ratingComment''
      -> ( Rating'{ ratingComment = fromMaybe ratingComment'' ratingComment', .. }
         , cID
         )


parseRating :: MonadCatch m => File m -> m (Rating', Maybe CryptoFileNameSubmission)
parseRating f@File{ fileContent = Just input', .. } = handle onFailure . handle (throwM . RatingParseException) . handleIf isYAMLUnicodeError (\(ErrorCall msg) -> throwM $ RatingYAMLNotUnicode msg) $ do
  input <- runConduit $ input' .| C.sinkLazy
  let evStream = YAML.Event.parseEvents input
      delimitDocument = do
        ev <- maybe (throwM RatingYAMLStreamTerminatedUnexpectedly) return =<< await
        case ev of
          Right YAML.Event.EvPos{ eEvent = YAML.Event.DocumentEnd _, ePos = YAML.Event.Pos{..}}
            | posByteOffset >= 0 -> return $ fromIntegral posByteOffset
            | otherwise -> throwM RatingYAMLDocumentEndIllDefined
          Left (pos, errStr) -> throwM . RatingYAMLExceptionBeforeComment $ YAML.prettyPosWithSource pos input errStr
          Right _ -> delimitDocument
  documentEnd <- runConduit $ yieldMany evStream .| delimitDocument
  ratingComment <- fmap join . for (Lazy.ByteString.stripPrefix "..." $ Lazy.ByteString.drop documentEnd input) $ \cbs ->
    case Lazy.Text.decodeUtf8' cbs of
      Left err -> throwM $ RatingYAMLCommentNotUnicode err
      Right ct -> return . assertM' (not . Text.null) . Text.strip $ toStrict ct
  let yamlInput = Lazy.ByteString.take documentEnd input
  res <- case YAML.decode1 yamlInput of
    Left (pos, errStr) -> throwM . RatingYAMLException $ YAML.prettyPosWithSource pos yamlInput errStr
    Right cb -> return $ cb (Just fileModified) ratingComment
  return $!! res
  where
    onFailure (e :: RatingException)
      = ((, Nothing) <$> Legacy.parseRating f) `catch` \case
          RatingParseLegacyException _ -> throwM e
          other -> throwM other
    isYAMLUnicodeError (ErrorCall msg) = "UTF" `isPrefixOf` msg
parseRating _ = throwM RatingFileIsDirectory
