merge master

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}

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: []

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

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]

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

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

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 ]

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

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')
+  ]

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'] ++ "-_.~:@&=+$," ++ "%"

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

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)
+  ]

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)
+  ]

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)
+  ]
+  

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

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 ]

test/UtilsSpec.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 module UtilsSpec where
 
 import TestImport