module Model.TypesSpec where

import TestImport
import Settings

import Control.Lens (review, preview)
import Data.Aeson (Value)
import qualified Data.Aeson as Aeson

import MailSpec ()

import System.IO.Unsafe
import Yesod.Auth.Util.PasswordStore


instance Arbitrary Season where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary TermIdentifier where
  arbitrary = do
    season <- arbitrary
    year <- arbitrary `suchThat` (\y -> abs y >= 100)
    return $ TermIdentifier{..}
  shrink = genericShrink

instance Arbitrary Pseudonym where
  arbitrary = Pseudonym <$> arbitraryBoundedIntegral

instance Arbitrary SheetGrading where
  arbitrary = oneof
    [ Points <$> arbitrary
    , do
        maxPoints <- getNonNegative <$> arbitrary
        passingPoints <- (getNonNegative <$> arbitrary) `suchThat` (<= maxPoints)
        return PassPoints{..}
    , return PassBinary
    ]
  shrink = genericShrink

instance Arbitrary SheetType where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary SheetGradeSummary where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary SheetGroup where
  arbitrary = genericArbitrary
  shrink = genericShrink
  
instance Arbitrary SheetTypeSummary where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary SheetFileType where
  arbitrary = genericArbitrary
  shrink = genericShrink
  
instance Arbitrary SubmissionFileType where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary UploadMode where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary SubmissionMode where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary SubmissionModeDescr where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary ExamStatus where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary Load where
  arbitrary = do
    byTutorial <- arbitrary
    byProportion <- getNonNegative <$> arbitrary
    return Load{..}
  shrink = genericShrink

instance Arbitrary StudyFieldType where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary Theme where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary CorrectorState where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary NotificationTrigger where
  arbitrary = genericArbitrary
  shrink = genericShrink
instance CoArbitrary NotificationTrigger where
  coarbitrary = genericCoarbitrary

instance Arbitrary NotificationSettings where
  arbitrary = NotificationSettings <$> arbitrary
  shrink = genericShrink

instance Arbitrary AuthTag where
  arbitrary = genericArbitrary
  shrink = genericShrink
instance CoArbitrary AuthTag where
  coarbitrary = genericCoarbitrary
  
instance Arbitrary AuthTagActive where
  arbitrary = AuthTagActive <$> arbitrary
  shrink = genericShrink

instance Arbitrary Value where
  arbitrary = sized $ \n -> if
    | n <= 0 -> oneof [ Aeson.Number <$> arbitrary, Aeson.Bool <$> arbitrary, pure Aeson.Null ]
    | otherwise -> oneof
      [ Aeson.Object <$> arbitrary'
      , Aeson.Array <$> arbitrary'
      , Aeson.String <$> arbitrary'
      , resize 0 arbitrary
      ]
    where
      arbitrary' :: forall a. Arbitrary a => Gen a
      arbitrary' = scale (`div` 2) arbitrary
  shrink = genericShrink

instance Arbitrary AuthenticationMode where
  arbitrary = oneof
    [ pure AuthLDAP
    , do
        pw <- encodeUtf8 . pack . getPrintableString <$> arbitrary
        let
          PWHashConf{..} = appAuthPWHash compileTimeAppSettings
          authPWHash = unsafePerformIO . fmap decodeUtf8 $ makePasswordWith pwHashAlgorithm pw (pwHashStrength `div` 2)
        return $ AuthPWHash{..}
    ]
  
  shrink AuthLDAP = []
  shrink (AuthPWHash _) = [AuthLDAP]

instance Arbitrary LecturerType where
  arbitrary = genericArbitrary
  shrink = genericShrink
  

spec :: Spec
spec = do
  parallel $ do
    lawsCheckHspec (Proxy @UUID)
      [ persistFieldLaws, pathPieceLaws, eqLaws, ordLaws, showReadLaws, hashableLaws, jsonLaws, storableLaws, jsonKeyLaws, httpApiDataLaws ]
    lawsCheckHspec (Proxy @FilePath)
      [ pathMultiPieceLaws ]
    lawsCheckHspec (Proxy @(CI Text))
      [ httpApiDataLaws ]
    lawsCheckHspec (Proxy @SheetGrading)
      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @SheetGradeSummary)
      [ eqLaws, showReadLaws, commutativeMonoidLaws, commutativeSemigroupLaws ]
    lawsCheckHspec (Proxy @SheetType)
      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @SheetTypeSummary)
      [ eqLaws, showReadLaws, commutativeMonoidLaws ]
    lawsCheckHspec (Proxy @SheetGroup)
      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @SheetFileType)
      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
    lawsCheckHspec (Proxy @SubmissionFileType)
      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
    lawsCheckHspec (Proxy @UploadMode)
      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
    lawsCheckHspec (Proxy @SubmissionMode)
      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, finiteLaws ]
    lawsCheckHspec (Proxy @SubmissionModeDescr)
      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
    lawsCheckHspec (Proxy @ExamStatus)
      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @Load)
      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
    lawsCheckHspec (Proxy @Season)
      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
    lawsCheckHspec (Proxy @TermIdentifier)
      [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
    lawsCheckHspec (Proxy @StudyFieldType)
      [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @Theme)
      [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @CorrectorState)
      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @AuthenticationMode)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @Value)
      [ persistFieldLaws ]
    lawsCheckHspec (Proxy @NotificationTrigger)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
    lawsCheckHspec (Proxy @NotificationSettings)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @MailLanguages)
      [ persistFieldLaws ]
    lawsCheckHspec (Proxy @Pseudonym)
      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @AuthTag)
      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, pathPieceLaws, jsonKeyLaws ]
    lawsCheckHspec (Proxy @AuthTagActive)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @LecturerType)
      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]

  describe "TermIdentifier" $ do
    it "has compatible encoding/decoding to/from Text" . property $
      \term -> termFromText (termToText term) == Right term
    it "works for some examples" . mapM_ termExample $
      [ (TermIdentifier 2017 Summer, "S17")
      , (TermIdentifier 1995 Winter, "W95")
      , (TermIdentifier 3068 Winter, "W3068")
      ]
    it "has compatbile encoding/decoding to/from Rational" . property $
      \term -> termFromRational (termToRational term) == term
  describe "Pseudonym" $ do
    it "has sufficient vocabulary" $
      (length pseudonymWordlist ^ 2) `shouldBe` (succ $ fromIntegral (maxBound - minBound :: Pseudonym))
    it "has compatible encoding/decoding to/from Text" . property $
      \pseudonym -> preview _PseudonymText (review _PseudonymText pseudonym) == Just pseudonym
    it "encodes to Text injectively" . property $
      \p1 p2 -> p1 /= p2 ==> ((/=) `on` review _PseudonymText) p1 p2

termExample :: (TermIdentifier, Text) -> Expectation
termExample (term, encoded) = example $ do
  termFromText encoded `shouldBe` Right term
  encoded `shouldBe` termToText term
