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

{-# LANGUAGE UndecidableInstances #-}

module Model.TypesSpec
  ( module Model.TypesSpec
  ) where

import TestImport
import TestInstances ()
import Settings

import Utils (guardOn)

import Data.Aeson (Value)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson

import Model.Types.LanguagesSpec ()

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

import Database.Persist.Sql (SqlBackend, fromSqlKey, toSqlKey)

import qualified Data.Set as Set

import Network.IP.Addr

import Web.PathPieces

import qualified Data.Csv as Csv
import Data.Scientific

import Utils.Lens hiding (elements)

import qualified Data.Char as Char
import Data.Word.Word24

import qualified Data.Binary as Binary
import qualified Data.ByteString.Lazy as LBS

import qualified Data.CaseInsensitive as CI

import Model.Types.FileSpec ()

import Text.Blaze.TestInstances ()

import qualified Data.Text.Lazy as LT

import Text.Blaze.Html.Renderer.Text (renderHtml)

import qualified Data.SemVer as SemVer
import qualified Data.SemVer.Constraint as SemVer (Constraint)
import qualified Data.SemVer.Constraint as SemVer.Constraint

import qualified Data.HashSet as HashSet


{-
instance Arbitrary Day where
    arbitrary = ModifiedJulianDay <$> choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31
    -- arbitrary = ModifiedJulianDay <$> choose (15020, 2973483) -- 1900-01-1 to 9999-12-31
    shrink day = let
        (y, m, d) = toGregorian day
        dayShrink   = [fromGregorian y m (d - 1) | d > 1]
        monthShrink = [fromGregorian y (m - 1) d | m > 1]            
        yearShrink  = [fromGregorian (y - 1) m d | y > 2000] 
        in dayShrink ++ monthShrink ++ yearShrink

instance CoArbitrary Day where
    coarbitrary (ModifiedJulianDay d) = coarbitrary d
-}

instance Arbitrary TermIdentifier where
  arbitrary = TermIdentifier <$> arbitrary    
  shrink = fmap TermIdentifier . shrink . year
instance CoArbitrary TermIdentifier
instance Function TermIdentifier

deriving instance Generic TermId
instance Arbitrary TermId where
  arbitrary = genericArbitrary
  shrink = genericShrink
instance CoArbitrary TermId
instance Function TermId

deriving instance Generic SchoolId
instance Arbitrary SchoolId where
  arbitrary = genericArbitrary
  shrink = genericShrink
instance CoArbitrary SchoolId
instance Function SchoolId

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 epId => Arbitrary (SheetType epId) where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary SheetGradeSummary where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary SheetGroup where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance (Arbitrary epId, Ord epId) => Arbitrary (SheetTypeSummary epId) where
  arbitrary = foldMap (uncurry sheetTypeSum) <$> listOf arbitrary

instance Arbitrary SheetFileType where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary SubmissionFileType where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary UploadSpecificFile where
  arbitrary = UploadSpecificFile
    <$> (pack . getPrintableString <$> arbitrary)
    <*> (pack . getPrintableString <$> arbitrary)
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
  shrink = genericShrink

instance Arbitrary UploadMode where
  arbitrary = oneof
    [ pure NoUpload
    , UploadAny
      <$> arbitrary
      <*> (fromNullable . Set.fromList . map (pack . getPrintableString) <$> arbitrary)
      <*> arbitrary
    , UploadSpecific <$> arbitrary
    ]
  shrink = genericShrink

instance Arbitrary UploadModeDescr where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary SubmissionMode where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary SubmissionModeDescr where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary Load where
  arbitrary = do
    byTutorial <- arbitrary
    byProportion <- getNonNegative <$> arbitrary
    byDeficit <- oneof [ pure 0, pure 1, 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 AuthNoLogin = []
  shrink (AuthPWHash _) = [AuthLDAP]

instance Arbitrary LecturerType where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary IP where
  arbitrary = oneof
    [ fmap IPv4 $ ip4FromOctets <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
    , fmap IPv6 $ ip6FromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
    ]

instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key record) where
  arbitrary = toSqlKey <$> arbitrary
  shrink = map toSqlKey . shrink . fromSqlKey

instance Arbitrary StoredMarkup where
  arbitrary = (`suchThat` (not . null . LT.strip . renderHtml . markupOutput)) $ oneof
    [ htmlToStoredMarkup <$> arbitrary
    , plaintextToStoredMarkup . getPrintableString <$> arbitrary
    ]

instance Arbitrary OccurrenceSchedule where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary OccurrenceException where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary Occurrences where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary res => Arbitrary (ExamResult' res) where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary ExamBonusRule where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary ExamOccurrenceRule where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary ExamGrade where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary ExamGradingRule where
  arbitrary = oneof
    [ ExamGradingKey . reverse . fromOffsets . map getNonNegative <$> replicateM 10 arbitrary
    ]
    where
      fromOffsets [] = []
      fromOffsets (x:xs) = x + sum xs : fromOffsets xs

instance Arbitrary ExamPassed where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary Quoting where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary CsvFormatOptions where
  arbitrary = oneof
    [ CsvFormatOptions
        <$> suchThat arbitrary validDelimiter
        <*> arbitrary
        <*> arbitrary
        <*> elements ["UTF8", "CP1252"]
        <*> pure True
    , pure CsvXlsxFormatOptions
    ]
    where
      validDelimiter c = and
        [ Char.isLatin1 c
        , c /= '"'
        , c /= '\r'
        , c /= '\n'
        ]

instance Arbitrary CsvOptions where
  arbitrary = CsvOptions
    <$> arbitrary
    <*> arbitrary
    <*> suchThat arbitrary (maybe True $ not . elem (Char.chr 0))
  shrink = genericShrink

instance Arbitrary CsvPreset where
  arbitrary = genericArbitrary
  shrink = genericShrink
instance CoArbitrary CsvPreset
instance Function CsvPreset

instance Arbitrary CsvFormat where
  arbitrary = genericArbitrary
instance CoArbitrary CsvFormat
instance Function CsvFormat

instance Arbitrary Sex where
  arbitrary = genericArbitrary

instance Arbitrary Word24 where
  arbitrary = arbitraryBoundedRandom

instance Arbitrary ExamPartNumber where
  arbitrary = review _ExamPartNumber . CI.mk . pack . getPrintableString <$> arbitrary
  shrink = map (review _ExamPartNumber) . shrink . view _ExamPartNumber

instance Arbitrary ExamCloseMode where
  arbitrary = genericArbitrary
  shrink = genericShrink

instance Arbitrary RoomReference where
  arbitrary = oneof
    [ RoomReferenceSimple . pack <$> suchThat (getPrintableString <$> arbitrary) (not . null)
    , RoomReferenceLink
      <$> arbitrary
      <*> arbitrary
    ]

instance Arbitrary RoomReference' where
  arbitrary = genericArbitrary

instance Arbitrary ExternalApiConfig where
  arbitrary = oneof
    [ EApiGradelistFormat <$> ((fmap HashSet.fromList . scale (`div` 10) $ listOf1 (resize 3 arbitrary)) `suchThatMap` fromNullable)
    ]
  shrink = genericShrink

instance Arbitrary SemVer.Version where
  arbitrary = SemVer.version
    <$> fmap getNonNegative arbitrary
    <*> fmap getNonNegative arbitrary
    <*> fmap getNonNegative arbitrary
    <*> arbitrary
    <*> pure mempty      -- Ord SemVer.Version ignores Metadata, so the Ord properties don't hold

instance Arbitrary SemVer.Identifier where
  arbitrary = -- oneof
    -- [ SemVer.numeric . getNonNegative <$> arbitrary -- Numeric does not roundtrip
    {- , -} fmap (\s -> fromMaybe (error $ "Generated invalid SemVer.Identifier: " <> s) . SemVer.textual $ pack s) . listOf1 . elements $ ['A'..'Z'] <> ['a'..'z'] {- <> ['0'..'9'] -} <> ['-']
    -- ]

deriving instance Generic SemVer.Constraint

instance Arbitrary SemVer.Constraint where
  -- Syntax has no brackets; so be very careful about nesting
  arbitrary = sized $ \n -> oneof $ catMaybes
    [ pure unitary
    , guardOn (n > 1) conj
    , guardOn (n > 1) disj
    ]
    where unitary = oneof
            [ pure SemVer.Constraint.CAny
            , elements [SemVer.Constraint.CLt, SemVer.Constraint.CLtEq, SemVer.Constraint.CGt, SemVer.Constraint.CGtEq, SemVer.Constraint.CEq] <*> arbitrary
            ]
          conj = SemVer.Constraint.CAnd <$> unitary <*> sized (\n -> oneof $ catMaybes [pure unitary, guardOn (n > 1) $ scale (`div` 2) conj])
          disj = SemVer.Constraint.COr <$> unitary <*> scale (`div` 2) arbitrary

instance Arbitrary UploadNonce where
  arbitrary = pure $ unsafePerformIO newUploadNonce


instance Arbitrary SchoolAuthorshipStatementMode where
  arbitrary = genericArbitrary
  
instance Arbitrary SheetAuthorshipStatementMode where
  arbitrary = genericArbitrary

instance Arbitrary LmsBool where
  arbitrary = LmsBool <$> arbitrary

instance Arbitrary LmsStatus where
  arbitrary = genericArbitrary

instance Arbitrary LmsState where
  arbitrary = genericArbitrary

instance Arbitrary LmsDay where
  arbitrary = LmsDay <$> arbitrary

deriving newtype instance Arbitrary LmsIdent

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 SqlBackendKey))
      [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @(SheetTypeSummary SqlBackendKey))
      [ eqLaws, showLaws, 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 @UploadSpecificFile)
      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @UploadMode)
      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @UploadModeDescr)
      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
    lawsCheckHspec (Proxy @SubmissionMode)
      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @SubmissionModeDescr)
      [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
    lawsCheckHspec (Proxy @Load)
      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
    lawsCheckHspec (Proxy @TermIdentifier)
      [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
    lawsCheckHspec (Proxy @Occurrences)
      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws  ]
    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 @Scientific)
      [ pathPieceLaws ]
    lawsCheckHspec (Proxy @Points)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
    lawsCheckHspec (Proxy @NotificationTrigger)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
    lawsCheckHspec (Proxy @NotificationSettings)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, 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 ]
    lawsCheckHspec (Proxy @IP)
      [ eqLaws, ordLaws, showReadLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @ExamResultPoints)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, csvFieldLaws ]
    lawsCheckHspec (Proxy @ExamResultGrade)
      [ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
    lawsCheckHspec (Proxy @ExamResultPassed)
      [ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
    lawsCheckHspec (Proxy @ExamBonusRule)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @ExamOccurrenceRule)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @ExamGrade)
      [ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
    lawsCheckHspec (Proxy @ExamGradingRule)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @ExamPassed)
      [ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
    lawsCheckHspec (Proxy @Quoting)
      [ eqLaws, ordLaws, jsonLaws, showReadLaws, finiteLaws, pathPieceLaws ]
    lawsCheckHspec (Proxy @CsvOptions)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @CsvFormatOptions)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws ]
    lawsCheckHspec (Proxy @CsvPreset)
      [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
    lawsCheckHspec (Proxy @Word24)
      [ persistFieldLaws, jsonLaws, binaryLaws ]
    lawsCheckHspec (Proxy @ExamPartNumber)
      [ persistFieldLaws, jsonLaws, pathPieceLaws, csvFieldLaws, eqLaws, ordLaws ]
    lawsCheckHspec (Proxy @StoredMarkup)
      [ persistFieldLaws, jsonLaws, eqLaws, ordLaws, showReadLaws, monoidLaws, semigroupLaws, semigroupMonoidLaws, csvFieldLaws ]
    lawsCheckHspec (Proxy @ExamCloseMode)
      [ persistFieldLaws, jsonLaws, eqLaws, ordLaws, showReadLaws, pathPieceLaws, jsonKeyLaws, finiteLaws, httpApiDataLaws, binaryLaws ]
    lawsCheckHspec (Proxy @RoomReference)
      [ persistFieldLaws, jsonLaws, eqLaws, ordLaws ]
    lawsCheckHspec (Proxy @RoomReference')
      [ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ]
    lawsCheckHspec (Proxy @SemVer.Version)
      [ eqLaws, ordLaws, showLaws, hashableLaws, httpApiDataLaws ]
    lawsCheckHspec (Proxy @SemVer.Constraint)
      [ eqLaws, showLaws, httpApiDataLaws ]
    lawsCheckHspec (Proxy @UploadNonce)
      [ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws ]
    lawsCheckHspec (Proxy @SchoolAuthorshipStatementMode)
      [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ]
    lawsCheckHspec (Proxy @SheetAuthorshipStatementMode)
      [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ]
    lawsCheckHspec (Proxy @LmsBool)
      [ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ]
    lawsCheckHspec (Proxy @LmsStatus)
      [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
    lawsCheckHspec (Proxy @LmsState)
      [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, csvFieldLaws ]
    lawsCheckHspec (Proxy @LmsDay)
      [ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ]

  describe "TermIdentifier" $ do
    it "has compatible encoding/decoding to/from Text" . property $
      \term -> termFromText (termToText term) == Right term      
    it "has compatible encoding/decoding to/from Rational" . property $
      \term -> termFromRational (termToRational term) == term
    -- This is not sufficient
    --it "has compatible encoding/decoding to/from PersistValue" . property $ 
    --  \term -> fromPersistValue (toPersistValue term) == term
    it "has human readable year encoding to Rational" . property $
      \term -> truncate (termToRational term) == year term
  describe "Pseudonym" $ do
    it "has sufficient vocabulary" $
      (length pseudonymWordlist ^ 2) `shouldSatisfy` (> (fromIntegral (maxBound :: Pseudonym) - fromIntegral (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
  describe "ExamPassed" $
    it "encodes to PathPiece as expected" . example $ do
      toPathPiece (ExamPassed False) `shouldBe` pack "failed"
      toPathPiece (ExamPassed True) `shouldBe` pack "passed"
  describe "ExamGrade" $
    it "decodes some examples from CSV" . example $ do
      let parse = Csv.runParser . Csv.parseField
      parse "5" `shouldBe` Right (ExamAttended Grade50)
      parse "1,7" `shouldBe` Right (ExamAttended Grade17)
      parse "1.7" `shouldBe` Right (ExamAttended Grade17)
      parse "1.8" `shouldSatisfy` is _Left
      parse "voided" `shouldBe` Right ExamVoided
      parse "no-show" `shouldBe` Right ExamNoShow
  describe "CsvOptions" $
    it "json-decodes from empty object" . example $
      Aeson.parseMaybe Aeson.parseJSON (Aeson.object []) `shouldBe` Just (def :: CsvOptions)
  describe "csvPreset" $
    it "is a prism" . property $ isPrism csvPreset
  describe "_CsvFormatPreset" $
    it "is a prism" . property $ isPrism _CsvFormatPreset
  describe "Word24" $ do
    it "encodes to the expected length" . property $
      \w -> olength (Binary.encode (w :: Word24)) == 3
    it "encodes some examples correctly" $ do
      let decode' inp = case Binary.decodeOrFail inp of
            Right (unc, _, res)
              | null unc -> Just res
            _other
              -> Nothing
          encEx w str = example $ do
            Binary.encode (w :: Word24) `shouldBe` LBS.pack str
            decode' (LBS.pack str) `shouldBe` Just w
      encEx 1      [0, 0, 1]
      encEx 256    [0, 1, 0]
      encEx 65536  [1, 0, 0]
      encEx 65537  [1, 0, 1]
      encEx 197121 [3, 2, 1]
  describe "SubmissionMode" $ do
    it "decodes some examples" . example $ do
      let t str = Aeson.eitherDecode str `shouldSatisfy` (is _Right :: Either _ SubmissionMode -> Bool)
      t "{\"user\": {\"mode\": \"upload\", \"unpack-zips\": true, \"extension-restriction\": [\"R\", \"pdf\", \"txt\"]}, \"corrector\": false}"
      t "{\"user\": {\"mode\": \"upload\", \"unpack-zips\": false}, \"corrector\": false}"
      t "{\"user\": {\"mode\": \"upload-specific\", \"specific-files\": [{\"name\": \"abgabe6.pdf\", \"label\": \"Abgabe 6\", \"required\": true}]}, \"corrector\": false}"
      t "{\"user\": {\"mode\": \"upload-specific\", \"specific-files\": [{\"name\": \"abgabe10.pdf\", \"label\": \"Abgabe 10\", \"required\": true}, {\"name\": \"deckblatt10.pdf\", \"label\": \"Deckblatt 10\", \"required\": true}]}, \"corrector\": false}"
      t "{\"user\": {\"mode\": \"no-upload\"}, \"corrector\": false}"
  describe "StoredMarkup" $ do
    it "decodes from Html via json" . property $
      \html -> case Aeson.eitherDecode (Aeson.encode html) of
        Left _ -> False
        Right StoredMarkup{..} -> ((==) `on` renderHtml) markupOutput html
                               && markupInputFormat == MarkupHtml
                               && renderHtml html == markupInput
    it "decodes from Html via persistent" . property $
      \html -> case fromPersistValue (toPersistValue html) of
        Left _ -> False
        Right StoredMarkup{..} -> ((==) `on` renderHtml) markupOutput html
                               && markupInputFormat == MarkupHtml
                               && renderHtml html == markupInput
  describe "ExamCloseMode" $ do
    it "PathPiece instance matches expectations" . example $ do
      toPathPiece ExamCloseSeparate `shouldBe` "separate"
      toPathPiece (ExamCloseOnFinished False) `shouldBe` "on-finished"
      toPathPiece (ExamCloseOnFinished True) `shouldBe` "on-finished-hidden"
  describe "Load" $
    it "decodes some examples from json" . example $ do
      let t str expect = Aeson.eitherDecode str `shouldBe` Right expect
      t "{}" $ Load Nothing 0 1
      t "{\"byTutorial\": true, \"byProportion\": {\"numerator\": 0, \"denominator\": 1}}" $ Load (Just True) 0 1
  describe "CompactCorrectorLoad" $ do
    it "matches expectations" . example $ do
      showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 0, byDeficit = 1 } CorrectorNormal  `shouldBe` "T"
      showCompactCorrectorLoad Load{ byTutorial = Just True,  byProportion = 0, byDeficit = 1 } CorrectorNormal  `shouldBe` "(T)"
      showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 1 } CorrectorNormal  `shouldBe` "1.0"
      showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 1, byDeficit = 1 } CorrectorNormal  `shouldBe` "1.0 + T"
      showCompactCorrectorLoad Load{ byTutorial = Just True,  byProportion = 1, byDeficit = 1 } CorrectorNormal  `shouldBe` "1.0 + (T)"
      showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 0, byDeficit = 1 } CorrectorNormal  `shouldBe` ""
      showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 1 } CorrectorMissing `shouldBe` "[1.0]"
      showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 1 } CorrectorExcused `shouldBe` "{1.0}"
      showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 0, byDeficit = 0 } CorrectorNormal  `shouldBe` "T - D"
      showCompactCorrectorLoad Load{ byTutorial = Just True,  byProportion = 0, byDeficit = 0 } CorrectorNormal  `shouldBe` "(T) - D"
      showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorNormal  `shouldBe` "1.0 - D"
      showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 1, byDeficit = 0 } CorrectorNormal  `shouldBe` "1.0 + T - D"
      showCompactCorrectorLoad Load{ byTutorial = Just True,  byProportion = 1, byDeficit = 0 } CorrectorNormal  `shouldBe` "1.0 + (T) - D"
      showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 0, byDeficit = 0 } CorrectorNormal  `shouldBe` "-D"
      showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]"
      showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}"

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