diff --git a/ghci.sh b/ghci.sh index 76b9b6e9b..77391583f 100755 --- a/ghci.sh +++ b/ghci.sh @@ -16,4 +16,4 @@ if [[ -d .stack-work-ghci ]]; then trap move-back EXIT fi -stack ghci --flag uniworx:dev --flag uniworx:library-only ${@} +stack ghci --flag uniworx:dev --flag uniworx:library-only ${@:-uniworx:lib} diff --git a/package.yaml b/package.yaml index 4e09e10e4..0aa2b1269 100644 --- a/package.yaml +++ b/package.yaml @@ -160,6 +160,7 @@ default-extensions: - BinaryLiterals - PolyKinds - PackageImports + - TypeApplications ghc-options: - -Wall @@ -221,7 +222,12 @@ tests: - QuickCheck - yesod-test - conduit-extra + - quickcheck-classes - quickcheck-instances + - generic-arbitrary + - http-types + ghc-options: + - -fno-warn-orphans hlint: main: Hlint.hs other-modules: [] diff --git a/src/Mail.hs b/src/Mail.hs index 1d83e7d1c..e05f8fa1c 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -97,6 +97,8 @@ import Data.Universe.Instances.Reverse () import Data.Universe.Instances.Reverse.JSON () import Data.Universe.Instances.Reverse.Hashable () +import GHC.Exts (IsList) + makeLenses_ ''Mail makeLenses_ ''Part @@ -122,7 +124,7 @@ instance Monoid (MailSmtpData) where newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] } deriving (Eq, Ord, Show, Read, Generic, Typeable) - deriving newtype (FromJSON, ToJSON) + deriving newtype (FromJSON, ToJSON, IsList) instance Default MailLanguages where def = MailLanguages [] @@ -158,7 +160,7 @@ instance MonadHandler m => MonadMail (MailT m) where data VerpMode = VerpNone | Verp { verpSeparator, verpAtReplacement :: Char } - deriving (Eq, Show, Read) + deriving (Eq, Show, Read, Generic) deriveJSON defaultOptions { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel diff --git a/src/Model/Types.hs b/src/Model/Types.hs index da8a1e2b8..bb0fdebd8 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -94,10 +94,11 @@ instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where toPathMultiPiece = toPathMultiPiece . CI.foldedCase instance ToHttpApiData (CI Text) where - toUrlPiece = CI.original + toUrlPiece = toUrlPiece . CI.original + toEncodedUrlPiece = toEncodedUrlPiece . CI.original instance FromHttpApiData (CI Text) where - parseUrlPiece = return . CI.mk + parseUrlPiece = fmap CI.mk . parseUrlPiece @@ -138,7 +139,7 @@ data SheetGradeSummary = SheetGradeSummary , numGradePasses :: Sum Int , sumGradePoints :: Sum Points , achievedPasses :: Maybe (Sum Int) - , achievedPoints :: Maybe (Sum Points) + } deriving (Generic, Read, Show, Eq) } deriving (Generic, Show) -- TODO: Show added for Debugging only instance Monoid SheetGradeSummary where @@ -185,7 +186,7 @@ data SheetTypeSummary = SheetTypeSummary , bonusSummary , informationalSummary :: SheetGradeSummary , numNotGraded :: Sum Int - } deriving (Generic, Show) -- TODO: Show added for Debugging only + } deriving (Generic, Read, Show, Eq) instance Monoid SheetTypeSummary where mempty = memptydefault @@ -206,14 +207,14 @@ data SheetGroup = Arbitrary { maxParticipants :: Natural } | RegisteredGroups | NoGroups - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Generic) deriveJSON defaultOptions ''SheetGroup derivePersistFieldJSON ''SheetGroup makeLenses_ ''SheetGroup data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking - deriving (Show, Read, Eq, Ord, Enum, Bounded) + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) derivePersistField "SheetFileType" instance Universe SheetFileType where universe = universeDef @@ -240,7 +241,7 @@ partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs data SubmissionFileType = SubmissionOriginal | SubmissionCorrected - deriving (Show, Read, Eq, Ord, Enum, Bounded) + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) instance Universe SubmissionFileType where universe = universeDef instance Finite SubmissionFileType @@ -271,7 +272,7 @@ instance DisplayAble DA where data UploadMode = NoUpload | Upload { unpackZips :: Bool } - deriving (Show, Read, Eq, Ord) + deriving (Show, Read, Eq, Ord, Generic) deriveJSON defaultOptions ''UploadMode derivePersistFieldJSON ''UploadMode @@ -290,7 +291,7 @@ instance PathPiece UploadMode where data SheetSubmissionMode = NoSubmissions | CorrectorSubmissions | UserSubmissions - deriving (Show, Read, Eq, Ord, Enum, Bounded) + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece @@ -303,7 +304,7 @@ instance Finite SheetSubmissionMode nullaryPathPiece ''SheetSubmissionMode camelToPathPiece data ExamStatus = Attended | NoShow | Voided - deriving (Show, Read, Eq, Ord, Enum, Bounded) + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) derivePersistField "ExamStatus" -- | Specify a corrector's workload @@ -311,7 +312,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati = Load { byTutorial :: Maybe Bool -- ^ Just all from Tutorial, True if counting towards overall workload , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders } - deriving (Show, Read, Eq, Ord) + deriving (Show, Read, Eq, Ord, Generic) deriveJSON defaultOptions ''Load derivePersistFieldJSON ''Load @@ -358,6 +359,11 @@ data TermIdentifier = TermIdentifier , season :: Season } deriving (Show, Read, Eq, Ord, Generic, Typeable) +instance Enum TermIdentifier where + -- ^ Do not use for conversion – Enumeration only + toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..} + fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season + -- Conversion TermId <-> TermIdentifier:: -- from_TermId_to_TermIdentifier = unTermKey -- from_TermIdentifier_to_TermId = TermKey @@ -451,7 +457,7 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 data StudyFieldType = FieldPrimary | FieldSecondary - deriving (Eq, Ord, Enum, Show, Read, Bounded) + deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) derivePersistField "StudyFieldType" instance PersistField UUID where @@ -473,7 +479,7 @@ data Theme | ThemeAberdeenReds | ThemeMossGreen | ThemeSkyLove - deriving (Eq, Ord, Bounded, Enum, Show, Read) + deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic) deriveJSON defaultOptions { constructorTagModifier = fromJust . stripPrefix "Theme" @@ -498,7 +504,7 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused - deriving (Eq, Ord, Read, Show, Enum, Bounded) + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriveJSON defaultOptions { constructorTagModifier = fromJust . stripPrefix "Corrector" @@ -514,7 +520,7 @@ derivePersistField "CorrectorState" data AuthenticationMode = AuthLDAP | AuthPWHash { authPWHash :: Text } - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Read, Show, Generic) deriveJSON defaultOptions { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel @@ -592,7 +598,7 @@ type PseudonymWord = CI Text newtype Pseudonym = Pseudonym Word24 deriving (Eq, Ord, Read, Show, Generic, Data) - deriving newtype (Bounded, Enum, Integral, Num, Real, Bits, FiniteBits, Ix) + deriving newtype (Bounded, Enum, Integral, Num, Real, Ix) instance PersistField Pseudonym where @@ -647,7 +653,7 @@ _PseudonymWords = prism' pToWords pFromWords | Just i1 <- elemIndex w1 pseudonymWordlist , Just i2 <- elemIndex w2 pseudonymWordlist , i1 <= maxWord, i2 <= maxWord - = Just $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 + = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 pFromWords _ = Nothing pToWords :: Pseudonym -> [PseudonymWord] diff --git a/stack.yaml b/stack.yaml index 083c073db..bd108cdef 100644 --- a/stack.yaml +++ b/stack.yaml @@ -42,4 +42,7 @@ extra-deps: - pkcs7-1.0.0.1 + - quickcheck-classes-0.4.14 + - semirings-0.2.1.1 + resolver: lts-10.5 diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs index 031a7d153..19e176840 100644 --- a/test/Handler/Utils/ZipSpec.hs +++ b/test/Handler/Utils/ZipSpec.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Handler.Utils.ZipSpec where import TestImport @@ -27,8 +23,9 @@ instance Arbitrary File where spec :: Spec spec = describe "Zip file handling" $ do - it "has compatible encoding/decoding to/from zip files" . property $ - \zipFiles -> do + it "has compatible encoding/decoding to/from zip files" . property $ do + zipFiles <- listOf $ scale (`div` 2) arbitrary + return . property $ do zipFiles' <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= void consumeZip =$= Conduit.consume forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do let acceptableFilenameChanges diff --git a/test/MailSpec.hs b/test/MailSpec.hs new file mode 100644 index 000000000..6743f99fa --- /dev/null +++ b/test/MailSpec.hs @@ -0,0 +1,33 @@ +module MailSpec where + +import TestImport +import Utils.DateTimeSpec () + +import Mail + +instance Arbitrary MailSmtpData where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary MailLanguages where + arbitrary = MailLanguages <$> arbitrary + shrink = genericShrink + +instance Arbitrary MailContext where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary VerpMode where + arbitrary = genericArbitrary + shrink = genericShrink + +spec :: Spec +spec = do + lawsCheckHspec (Proxy @MailSmtpData) + [ eqLaws, ordLaws, showReadLaws, monoidLaws ] + lawsCheckHspec (Proxy @MailLanguages) + [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ] + lawsCheckHspec (Proxy @MailContext) + [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ] + lawsCheckHspec (Proxy @VerpMode) + [ eqLaws, showReadLaws, jsonLaws ] diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 518bb7990..bd192c991 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -1,19 +1,16 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Model.TypesSpec where import TestImport import Control.Lens (review, preview) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson -import Data.Aeson (encode, decode) +import MailSpec () instance Arbitrary Season where - arbitrary = elements [minBound..maxBound] + arbitrary = genericArbitrary shrink = genericShrink instance Arbitrary TermIdentifier where @@ -38,17 +35,156 @@ instance Arbitrary SheetGrading where shrink = genericShrink instance Arbitrary SheetType where - arbitrary = oneof - [ return NotGraded - , Normal <$> arbitrary - , Bonus <$> arbitrary - , Informational <$> arbitrary - ] + 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 SheetSubmissionMode 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 AuthenticationMode 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 spec :: Spec spec = 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 @SheetSubmissionMode) + [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, 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 ] + describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ \term -> termFromText (termToText term) == Right term @@ -57,6 +193,8 @@ spec = do , (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)) @@ -64,9 +202,6 @@ spec = do \pseudonym -> preview _PseudonymText (review _PseudonymText pseudonym) == Just pseudonym it "encodes to Text injectively" . property $ \p1 p2 -> p1 /= p2 ==> ((/=) `on` review _PseudonymText) p1 p2 - describe "SheetType" $ do - it "has compatible encoding/decoding to/from JSON" . property $ - \sg -> decode (encode sg) == Just (sg :: SheetType) termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do diff --git a/test/Test/QuickCheck/Classes/Hashable.hs b/test/Test/QuickCheck/Classes/Hashable.hs new file mode 100644 index 000000000..849511bd0 --- /dev/null +++ b/test/Test/QuickCheck/Classes/Hashable.hs @@ -0,0 +1,13 @@ +module Test.QuickCheck.Classes.Hashable + ( hashableLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Classes +import Data.Proxy + +hashableLaws :: forall a. (Arbitrary a, Hashable a, Eq a, Show a) => Proxy a -> Laws +hashableLaws _ = Laws "Hashable" + [ ("Injectivity", property $ \(a :: a) (a' :: a) (s :: Int) -> hashWithSalt s a /= hashWithSalt s a' ==> a /= a') + ] diff --git a/test/Test/QuickCheck/Classes/HttpApiData.hs b/test/Test/QuickCheck/Classes/HttpApiData.hs new file mode 100644 index 000000000..75ab8fe6f --- /dev/null +++ b/test/Test/QuickCheck/Classes/HttpApiData.hs @@ -0,0 +1,25 @@ +module Test.QuickCheck.Classes.HttpApiData + ( httpApiDataLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Classes +import Web.HttpApiData +import Data.Proxy +import Network.HTTP.Types.URI (encodePathSegmentsRelative) + +import qualified Data.ByteString.Lazy.Char8 as LCBS +import qualified Data.ByteString.Builder as BS + +httpApiDataLaws :: forall a. (Arbitrary a, ToHttpApiData a, FromHttpApiData a, Eq a, Show a) => Proxy a -> Laws +httpApiDataLaws _ = Laws "ToHttpApiData/FromHttpApiData" + [ ("Partial Isomorphism (UrlPiece)", property $ \(a :: a) -> parseUrlPiece (toUrlPiece a) == Right a) + , ("Encoding Equals Value (UrlPiece)", property $ \(a :: a) -> BS.toLazyByteString (toEncodedUrlPiece a) == BS.toLazyByteString (encodePathSegmentsRelative . pure $ toUrlPiece a)) + , ("Produces only valid characters (UrlPiece)", property $ \(a :: a) -> LCBS.all validUrlChar (BS.toLazyByteString $ toEncodedUrlPiece a) ) + , ("Partial Isomorphism (Header)", property $ \(a :: a) -> parseHeader (toHeader a) == Right a) + , ("Partial Isomorphism (QueryParam)", property $ \(a :: a) -> parseQueryParam (toQueryParam a) == Right a) + ] + where + validUrlChar :: Char -> Bool + validUrlChar = flip elem $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_.~:@&=+$," ++ "%" diff --git a/test/Test/QuickCheck/Classes/JSON.hs b/test/Test/QuickCheck/Classes/JSON.hs new file mode 100644 index 000000000..78d586ec3 --- /dev/null +++ b/test/Test/QuickCheck/Classes/JSON.hs @@ -0,0 +1,38 @@ +module Test.QuickCheck.Classes.JSON + ( jsonKeyLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Property (failed) +import Test.QuickCheck.Classes +import Data.Aeson +import Data.Aeson.Encoding.Internal +import Data.Aeson.Types (parseMaybe) +import Data.Proxy +import Unsafe.Coerce -- DON'T PANIC, it's aeson's fault + +jsonKeyLaws :: forall a. (Arbitrary a, FromJSONKey a, ToJSONKey a, Eq a, Show a, FromJSON a, ToJSON a) => Proxy a -> Laws +jsonKeyLaws _ = Laws "ToJSONKey/FromJSONKey" + [ ("Partial Isomorphism", property $ \(a :: a) -> partialIsomorphism a) + , ("Partial Isomorphism (List)", property $ \(as :: [a]) -> partialIsomorphism as) + , ("Encoding Equals Value", property $ \(a :: a) + -> let (toVal, toEnc) = case toJSONKey of + ToJSONKeyText toVal' toEnc' -> (String . toVal', retagEncoding . toEnc') + ToJSONKeyValue toVal' toEnc' -> (toVal', toEnc') + in decode (encodingToLazyByteString $ toEnc a) == Just (toVal a) + ) + ] + where + partialIsomorphism :: forall a'. (Arbitrary a', FromJSONKey a', ToJSONKey a', Eq a', Show a') => a' -> Property + partialIsomorphism a = case (toJSONKey, fromJSONKey) of + (ToJSONKeyText toVal _, FromJSONKeyCoerce _) + -> property $ unsafeCoerce (toVal a) == a + (ToJSONKeyText toVal _, FromJSONKeyText fromVal) + -> property $ fromVal (toVal a) == a + (ToJSONKeyText toVal _, FromJSONKeyTextParser parser) + -> property $ parseMaybe parser (toVal a) == Just a + (ToJSONKeyValue toVal _, FromJSONKeyValue parser) + -> property $ parseMaybe parser (toVal a) == Just a + (_, _) + -> property failed diff --git a/test/Test/QuickCheck/Classes/PathPiece.hs b/test/Test/QuickCheck/Classes/PathPiece.hs new file mode 100644 index 000000000..d7c95cef7 --- /dev/null +++ b/test/Test/QuickCheck/Classes/PathPiece.hs @@ -0,0 +1,20 @@ +module Test.QuickCheck.Classes.PathPiece + ( pathPieceLaws + , pathMultiPieceLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Classes +import Web.PathPieces +import Data.Proxy + +pathPieceLaws :: forall a. (Arbitrary a, PathPiece a, Eq a, Show a) => Proxy a -> Laws +pathPieceLaws _ = Laws "PathPiece" + [ ("Partial Isomorphism", property $ \(a :: a) -> fromPathPiece (toPathPiece a) == Just a) + ] + +pathMultiPieceLaws :: forall a. (Arbitrary a, PathMultiPiece a, Eq a, Show a) => Proxy a -> Laws +pathMultiPieceLaws _ = Laws "PathMultiPiece" + [ ("Partial Isomorphism", property $ \(a :: a) -> fromPathMultiPiece (toPathMultiPiece a) == Just a) + ] diff --git a/test/Test/QuickCheck/Classes/PersistField.hs b/test/Test/QuickCheck/Classes/PersistField.hs new file mode 100644 index 000000000..53b6419d7 --- /dev/null +++ b/test/Test/QuickCheck/Classes/PersistField.hs @@ -0,0 +1,14 @@ +module Test.QuickCheck.Classes.PersistField + ( persistFieldLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Classes +import Database.Persist +import Data.Proxy + +persistFieldLaws :: forall a. (Arbitrary a, PersistField a, Eq a, Show a) => Proxy a -> Laws +persistFieldLaws _ = Laws "PersistField" + [ ("Partial Isomorphism", property $ \(a :: a) -> fromPersistValue (toPersistValue a) == Right a) + ] diff --git a/test/Test/QuickCheck/Classes/Universe.hs b/test/Test/QuickCheck/Classes/Universe.hs new file mode 100644 index 000000000..60343d662 --- /dev/null +++ b/test/Test/QuickCheck/Classes/Universe.hs @@ -0,0 +1,24 @@ +module Test.QuickCheck.Classes.Universe + ( universeLaws + , finiteLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Classes +import Data.Proxy +import Data.Universe +import Data.List (genericLength, elemIndices) + +universeLaws :: forall a. (Arbitrary a, Universe a, Eq a, Show a) => Proxy a -> Laws +universeLaws _ = Laws "Universe" + [ ("universe contains everything", property $ \(a :: a) -> a `elem` universe) + ] + +finiteLaws :: forall a. (Arbitrary a, Finite a, Eq a, Show a) => Proxy a -> Laws +finiteLaws _ = Laws "Finite" $ + [ ("universeF is small", property $ genericLength (universeF :: [a]) <= toInteger (maxBound :: Word32)) + , ("universeF contains everything once", property $ \(a :: a) -> length (elemIndices a universeF) == 1) + , ("universe is permutation of universeF", property $ all (\(a :: a) -> length (elemIndices a universeF) == 1) universeF) + ] + diff --git a/test/TestImport.hs b/test/TestImport.hs index 207a563fe..641893b40 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -18,6 +18,16 @@ import Test.QuickCheck as X import Test.QuickCheck.Gen as X import Data.Default as X import Test.QuickCheck.Instances as X () +import Test.QuickCheck.Arbitrary.Generic as X +import Test.QuickCheck.Classes as X +import Test.QuickCheck.Classes.PathPiece as X +import Test.QuickCheck.Classes.PersistField as X +import Test.QuickCheck.Classes.Hashable as X +import Test.QuickCheck.Classes.JSON as X +import Test.QuickCheck.Classes.HttpApiData as X +import Test.QuickCheck.Classes.Universe as X +import Data.Proxy as X +import Data.UUID as X (UUID) import System.IO as X (hPrint, hPutStrLn, stderr) import Jobs (handleJobs, stopJobCtl) @@ -29,9 +39,11 @@ import Data.Pool (destroyAllResources) import Settings -import Data.CaseInsensitive (CI) +import Data.CaseInsensitive as X (CI) import qualified Data.CaseInsensitive as CI +import Data.Typeable + runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do @@ -105,3 +117,9 @@ createUser userIdent = do userMailLanguages = def userNotificationSettings = def runDB $ insertEntity User{..} + +lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec +lawsCheckHspec p = describe (show $ typeRep p) . mapM_ (checkHspec . ($ p)) + where + checkHspec (Laws className properties) = describe className $ + forM_ properties $ \(name, prop) -> it name $ property prop diff --git a/test/Utils/DateTimeSpec.hs b/test/Utils/DateTimeSpec.hs new file mode 100644 index 000000000..e851c95e9 --- /dev/null +++ b/test/Utils/DateTimeSpec.hs @@ -0,0 +1,20 @@ +module Utils.DateTimeSpec where + +import TestImport + +instance Arbitrary DateTimeFormat where + arbitrary = DateTimeFormat <$> arbitrary + shrink = genericShrink + +instance Arbitrary SelDateTimeFormat where + arbitrary = genericArbitrary + shrink = genericShrink +instance CoArbitrary SelDateTimeFormat where + coarbitrary = genericCoarbitrary + +spec :: Spec +spec = do + lawsCheckHspec (Proxy @DateTimeFormat) + [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, hashableLaws ] + lawsCheckHspec (Proxy @SelDateTimeFormat) + [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ] diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs index dd50cf61e..4eb5d9e1f 100644 --- a/test/UtilsSpec.hs +++ b/test/UtilsSpec.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - module UtilsSpec where import TestImport