Structured TermIdentifier & tests for it

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

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

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
-
 
 

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

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

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