From 1877fb81b4ddf932330bafdb3591b4418e13ef04 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 4 Oct 2017 16:20:29 +0200 Subject: [PATCH] Structured TermIdentifier & tests for it --- models | 7 ++- package.yaml | 3 ++ src/Model.hs | 3 -- src/Model/Types.hs | 95 ++++++++++++++++++++++++++++++++++------- test/Model/TypesSpec.hs | 34 +++++++++++++++ test/TestImport.hs | 2 + 6 files changed, 121 insertions(+), 23 deletions(-) create mode 100644 test/Model/TypesSpec.hs diff --git a/models b/models index a90cbeab5..e115ddd5e 100644 --- a/models +++ b/models @@ -3,14 +3,13 @@ User ident Text UniqueAuthentication plugin ident Term json - name Text - shorthand Text + name TermIdentifier start Day end Day holidays [Day] -- UniqueTerm shorthand - Primary shorthand - deriving Eq + Primary name + deriving Show School json name Text shorthand Text diff --git a/package.yaml b/package.yaml index 13da5a6b4..e2b9b88f3 100644 --- a/package.yaml +++ b/package.yaml @@ -49,6 +49,7 @@ dependencies: - cryptonite-conduit - base64-bytestring - memory +- http-api-data # The library contains all of our application code. The executable # defined below is just a thin wrapper. @@ -61,6 +62,7 @@ library: - -Wall - -fwarn-tabs - -O0 + - -ddump-splices cpp-options: -DDEVELOPMENT else: ghc-options: @@ -92,6 +94,7 @@ tests: dependencies: - uniworx - hspec >=2.0.0 + - QuickCheck - yesod-test # Define flags used by "yesod devel" to make compilation faster diff --git a/src/Model.hs b/src/Model.hs index dedba802f..62909c626 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -25,8 +25,5 @@ import Model.Types share [mkPersist sqlSettings, mkMigrate "migrateAll"] $(persistFileWith lowerCaseSettings "models") -instance Show Term where - show = ClassyPrelude.Yesod.unpack . termName - diff --git a/src/Model/Types.hs b/src/Model/Types.hs index be40723b9..5d7f3c3d7 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -1,31 +1,94 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} module Model.Types where +import ClassyPrelude + import Database.Persist.TH +import Database.Persist.Class +import Database.Persist.Sql + +import Web.HttpApiData + +import Data.Text (Text) +import qualified Data.Text as Text + +import Text.Read (readMaybe) + +-- import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import Yesod.Core.Dispatch (PathPiece(..)) +import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..)) + +import GHC.Generics (Generic) +import Data.Typeable (Typeable) data SheetType = Regular | Bonus | Extra deriving (Show, Read, Eq, Ord, Enum, Bounded) -derivePersistField "SheetType" +derivePersistField "SheetType" data ExamStatus = Attended | NoShow | Voided deriving (Show, Read, Eq, Ord, Enum, Bounded) -derivePersistField "ExamStatus" +derivePersistField "ExamStatus" -{- Modelled in DB -data Season = WS | SO - deriving (Show, Read, Eq, Enum) -derivePersistField "Season" -data Term = Term { season:: Season, year :: Int } +data Season = Summer | Winter + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) -instance Show Term where - show (Term {season, year}) = take 1 (show season) ++ (show year) +seasonToChar :: Season -> Char +seasonToChar Summer = 'S' +seasonToChar Winter = 'W' -instance PersistField Term where - toPersistValue (Term {season, year}) = undefined - fromPersistValue (Term {season, year}) = undefined - sqlType _ = SqlInteger - isNullable _ = False --} +seasonFromChar :: Char -> Either Text Season +seasonFromChar c + | c ~= 'S' = Right Summer + | c ~= 'W' = Right Winter + | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’" + where + (~=) = (==) `on` CI.mk + +data TermIdentifier = TermIdentifier + { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' + , season :: Season + } deriving (Show, Read, Eq, Ord, Generic, Typeable) + +termToText :: TermIdentifier -> Text +termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show year + +termFromText :: Text -> Either Text TermIdentifier +termFromText t + | (s:ys) <- Text.unpack t + , Just year <- readMaybe ys + , Right season <- seasonFromChar s + = Right TermIdentifier{..} + | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" + +instance PersistField TermIdentifier where + toPersistValue = PersistText . termToText + fromPersistValue (PersistText t) = termFromText t + fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x + +instance PersistFieldSql TermIdentifier where + sqlType _ = SqlString + +instance ToHttpApiData TermIdentifier where + toUrlPiece = termToText + +instance FromHttpApiData TermIdentifier where + parseUrlPiece = termFromText + +instance PathPiece TermIdentifier where + fromPathPiece = either (const Nothing) Just . termFromText + toPathPiece = termToText + +instance ToJSON TermIdentifier where + toJSON = String . termToText + +instance FromJSON TermIdentifier where + parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs new file mode 100644 index 000000000..87302d3c7 --- /dev/null +++ b/test/Model/TypesSpec.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.TypesSpec where + +import TestImport + +instance Arbitrary Season where + arbitrary = elements [minBound..maxBound] + shrink = genericShrink + +instance Arbitrary TermIdentifier where + arbitrary = do + season <- arbitrary + year <- arbitrary + return $ TermIdentifier{..} + shrink = genericShrink + +spec :: Spec +spec = do + 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, "S2017") + , (TermIdentifier 1995 Winter, "W1995") + ] + +termExample :: (TermIdentifier, Text) -> Expectation +termExample (term, encoded) = example $ do + termFromText encoded `shouldBe` Right term + encoded `shouldBe` termToText term diff --git a/test/TestImport.hs b/test/TestImport.hs index 909ba72d4..eba79ed72 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -20,6 +20,8 @@ import Yesod.Default.Config2 (useEnv, loadYamlSettings) import Yesod.Auth as X import Yesod.Test as X import Yesod.Core.Unsafe (fakeHandlerGetLogger) +import Test.QuickCheck as X +import Test.QuickCheck.Gen as X runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do