{-# 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 Data.Aeson.Types (ToJSON(..), FromJSON(..))
import qualified Data.Aeson.Types as Aeson

import Database.Persist.Sql

import Data.Word.Word24

import qualified Data.CaseInsensitive as CI

import Control.Lens

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


import Data.List (elemIndex, genericIndex)
import Data.Bits
import Data.Text.Metrics (damerauLevenshtein)
  
-------------------------
-- Submission Download --
-------------------------

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

instance Universe SubmissionFileType
instance Finite SubmissionFileType

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)


instance PersistField Pseudonym where
  toPersistValue p = toPersistValue (fromIntegral p :: Word32)
  fromPersistValue v = do
    w <- fromPersistValue v :: Either Text Word32
    if
      | 0 <= w
      , w <= fromIntegral (maxBound :: Pseudonym)
        -> return $ fromIntegral w
      | otherwise
        -> Left "Pseudonym out of range"

instance PersistFieldSql Pseudonym where
  sqlType _ = SqlInt32

instance Random Pseudonym where
  randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
  random = randomR (minBound, maxBound)

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) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ 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 = 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)
