-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-|
Module: Model.Types.Submission
Description: Types to support sheet submissions
-}

module Model.Types.Submission
  ( module Model.Types.Submission
  ) where

import Import.NoModel

import qualified Data.Aeson.Types as Aeson

import Database.Persist.Sql

import qualified Data.CaseInsensitive as CI

import qualified Data.Text as Text
import qualified Data.Set as Set


import Data.List (genericIndex)
import Data.Bits
import Data.Text.Metrics (damerauLevenshtein)

-------------------------
-- Submission Download --
-------------------------

data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
  deriving anyclass (Universe, Finite, Hashable)

nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1

submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
submissionFileTypeIsUpdate SubmissionOriginal  = False
submissionFileTypeIsUpdate SubmissionCorrected = True

isUpdateSubmissionFileType :: Bool -> SubmissionFileType
isUpdateSubmissionFileType False = SubmissionOriginal
isUpdateSubmissionFileType True  = SubmissionCorrected

---------------------------
-- Submission Pseudonyms --
---------------------------

type PseudonymWord = CI Text

newtype Pseudonym = Pseudonym Word24
  deriving (Eq, Ord, Read, Show, Generic, Data)
  deriving newtype ( Bounded, Enum, Integral, Num, Real, Ix
                   , PersistField, Random
                   )
  deriving anyclass (NFData)

instance PersistFieldSql Pseudonym where
  sqlType _ = sqlType $ Proxy @Word24

instance FromJSON Pseudonym where
  parseJSON v@(Aeson.Number _) = do
    w <- parseJSON v :: Aeson.Parser Word32
    if
      | 0 <= w
      , w <= fromIntegral (maxBound :: Pseudonym)
        -> return $ fromIntegral w
      | otherwise
        -> fail "Pseudonym out auf range"
  parseJSON (Aeson.String t)
    = case t ^? _PseudonymText of
        Just p -> return p
        Nothing -> fail "Could not parse pseudonym"
  parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
    ws' <- toList . map CI.mk <$> mapM parseJSON ws
    case ws' ^? _PseudonymWords of
      Just p -> return p
      Nothing -> fail "Could not parse pseudonym words"

instance ToJSON Pseudonym where
  toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord])

pseudonymWordlist :: [PseudonymWord]
pseudonymCharacters :: Set (CI Char)
(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt")

_PseudonymWords :: Prism' [PseudonymWord] Pseudonym
_PseudonymWords = prism' pToWords pFromWords
  where
    pFromWords :: [PseudonymWord] -> Maybe Pseudonym
    pFromWords [w1, w2]
      | Just i1 <- elemIndex w1 pseudonymWordlist
      , Just i2 <- elemIndex w2 pseudonymWordlist
      , i1 <= maxWord, i2 <= maxWord
      = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2
    pFromWords _ = Nothing

    pToWords :: Pseudonym -> [PseudonymWord]
    pToWords (Pseudonym p)
      = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord
        , genericIndex pseudonymWordlist $ p .&. maxWord
        ]

    maxWord :: Num a => a
    maxWord = 0b111111111111

_PseudonymText :: Prism' Text Pseudonym
_PseudonymText = prism' tToWords tFromWords . _PseudonymWords
  where
    tFromWords :: Text -> Maybe [PseudonymWord]
    tFromWords input
      | [result] <- input ^.. pseudonymFragments
      = Just result
      | otherwise
      = Nothing

    tToWords :: [PseudonymWord] -> Text
    tToWords = Text.unwords . map CI.original

pseudonymWords :: Fold Text PseudonymWord
pseudonymWords = folding
  $ \(CI.mk -> input) -> maybe [] (map (view _2)) . listToMaybe . groupBy ((==) `on` view _1) . sortOn (view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
  where
    distance = damerauLevenshtein `on` CI.foldedCase
    -- | Arbitrary cutoff point, for reference: ispell cuts off at 1
    distanceCutoff :: Int
    distanceCutoff = 2

pseudonymFragments :: Fold Text [PseudonymWord]
pseudonymFragments = folding
  $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)


instance PathPiece Pseudonym where
  toPathPiece = review _PseudonymText
  fromPathPiece t
    | Just p <- t ^? _PseudonymText = Just p
    | Just n <- fromPathPiece t = Just $ Pseudonym n
    | otherwise = Nothing

pathPieceCsv ''Pseudonym

  
data AuthorshipStatementSubmissionState
  = ASMissing
  | ASOldStatement
  | ASExists
  deriving (Eq, Read, Show, Enum, Bounded, Generic)
  deriving anyclass (Universe, Finite)

deriving stock instance Ord AuthorshipStatementSubmissionState -- Larger roughly encodes better; summaries are taken with max

nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1
pathPieceCsv ''AuthorshipStatementSubmissionState
pathPieceJSON ''AuthorshipStatementSubmissionState
