module Handler.Sheet.PersonalisedFiles.Meta
  ( formatPersonalisedSheetFilesMeta
  ) where

import Import

import Handler.Sheet.PersonalisedFiles.Types

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

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 Control.Monad.Trans.State.Lazy (evalState)

import qualified Database.Esqueleto.Legacy as E

import qualified Data.CaseInsensitive as CI

  
data PrettifyState
  = PrettifyInitial
  | PrettifyFlowSequence PrettifyState
  | PrettifyBlockSequence PrettifyState
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

  
formatPersonalisedSheetFilesMeta
  :: MonadIO m
  => PersonalisedSheetFilesDownloadAnonymous
  -> CourseParticipant
  -> CryptoFileNameUser
  -> SqlPersistT m Lazy.ByteString
formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
  User{..} <- getJust courseParticipantUser
  exams <- E.select . E.from $ \(exam `E.InnerJoin` examRegistration) -> E.distinctOnOrderBy [E.asc $ exam E.^. ExamName] $ do
    E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
    E.where_ $ exam E.^. ExamCourse E.==. E.val courseParticipantCourse
    E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val courseParticipantUser
    return $ exam E.^. ExamName
  
  let uglyYAML = YAML.Event.writeEvents YAML.UTF8 $ concat
        [ [ YAML.Event.StreamStart
          , YAML.Event.DocumentStart $ YAML.Event.DirEndMarkerVersion 2
          , YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block
          ]
        , mapEvents (str' "user") (str $ toPathPiece cID)
        , guardOnM (isn't _PersonalisedSheetFilesDownloadAnonymous anonMode) $ concat
          [ mapEvents (str' "display_name") (str userDisplayName)
          , mapEvents (str' "surname") (str userSurname)
          , mapEvents (str' "first_names") (str userFirstName)
          , case userMatrikelnummer of
              Just matr -> mapEvents (str' "matriculation") (str matr)
              Nothing -> mzero
          , mapEvents (str' "email") (str $ CI.original userEmail)
          ]
        , map flowStyle $ mapEvents (str' "languages") . YAML.Sequence () YAML.untagged $ maybe [] (views _Wrapped $ map str) userLanguages
        , mapEvents (str' "registered_exams") . YAML.Sequence () YAML.untagged $ map (str . CI.original . E.unValue) exams
        , [ YAML.Event.MappingEnd
          , YAML.Event.DocumentEnd False
          , YAML.Event.StreamEnd
          ]
        ]
        where
          str :: forall t. Textual t => t -> YAML.Node ()
          str = YAML.Scalar () . YAML.SStr . repack
          str' :: Text -> YAML.Node ()
          str' = str

          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

          flowStyle :: YAML.Event.Event -> YAML.Event.Event
          flowStyle = \case
            YAML.Event.SequenceStart a t _ -> YAML.Event.SequenceStart a t YAML.Event.Flow
            YAML.Event.MappingStart a t _ -> YAML.Event.MappingStart a t YAML.Event.Flow
            other -> other

      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, ann3, 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 $ ann3 event'') <> fromStrict (encodeUtf8 $ ann2 ws) <> after, pos1')

          transduce :: PrettifyState -> YAML.Event.Event -> ((Text, Text -> Text, Text -> Text), PrettifyState)
          transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Flow) = ((mempty, id, bool " " mempty . null), PrettifyFlowSequence cState)
          transduce (PrettifyFlowSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState)
          transduce cState@(PrettifyFlowSequence _) _ = ((mempty, f, bool " " mempty . null), cState)
            where f str | ']' `elem` str = filter (/= '\n') str
                        | otherwise = str
          -- transduce PrettifyInitial _ = ((mempty, id), PrettifyInitial)
          transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Block) = (("  ", id, id), PrettifyBlockSequence cState)
          transduce (PrettifyBlockSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState)
          transduce cState@(PrettifyBlockSequence _) _ = ((mempty, Text.replace "\n-" "\n  -", id), cState)
          transduce cState _ = ((mempty, id, id), cState)
          -- transduce cState _ = (("<", id, \ws -> "|" <> ws <> ">"), cState) -- TODO
  return prettyYAML