fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(dayterms): change termidentifiers to single days complete

Browse Source
This commit is contained in:
Steffen Jost 2021-10-27 20:03:02 +02:00
parent 0c0cb06cdc
commit f807b42089
3 changed files with 184 additions and 809 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/Model/Types/DateTime.hs
View File

@ -108,7 +108,7 @@ instance PersistField TermIdentifier where
fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
instance PersistFieldSql TermIdentifier where instance PersistFieldSql TermIdentifier where
sqlType _ = SqlNumeric 5 1 sqlType _ = SqlNumeric 9 5 -- total significant digits; significant digits after decimal point
instance ToHttpApiData TermIdentifier where instance ToHttpApiData TermIdentifier where
toUrlPiece = termToText toUrlPiece = termToText
@ -145,10 +145,10 @@ guessDay :: TermIdentifier
-> Day -> Day
guessDay TermIdentifier{..} TermDayLectureStart = getTermDay guessDay TermIdentifier{..} TermDayLectureStart = getTermDay
guessDay TermIdentifier{..} TermDayLectureEnd = addDays 8 getTermDay -- courses last only a week guessDay TermIdentifier{..} TermDayLectureEnd = addDays 8 getTermDay -- courses last only a week
guessDay tid TermDayStart = fromWeekDate year weekStart 1 -- Monday before lecture time guessDay tid TermDayStart = fromWeekDate year week 1 -- Monday before lecture time
where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureStart where ( year, week, _) = toWeekDate $ addDays (-7*4*3) $ guessDay tid TermDayLectureStart
guessDay tid TermDayEnd = fromWeekDate year weekStart 7 -- Sunday after lecture time guessDay tid TermDayEnd = fromWeekDate year week 7 -- Sunday after lecture time
where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureEnd where ( year, week, _) = toWeekDate $ addDays (7*3) $ guessDay tid TermDayLectureEnd
withinTerm :: Day -> TermIdentifier -> Bool withinTerm :: Day -> TermIdentifier -> Bool
withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd

964
test/Database/Fill.hs
View File

File diff suppressed because it is too large Load Diff

11
test/Model/TypesSpec.hs
View File

@ -46,6 +46,8 @@ import qualified Data.Text.Lazy as LT
import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Blaze.Html.Renderer.Text (renderHtml)
import Handler.Utils.DateTime (getYear)
{- {-
instance Arbitrary Day where instance Arbitrary Day where
arbitrary = ModifiedJulianDay <$> choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31 arbitrary = ModifiedJulianDay <$> choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31
@ -63,7 +65,7 @@ instance CoArbitrary Day where
instance Arbitrary TermIdentifier where instance Arbitrary TermIdentifier where
arbitrary = TermIdentifier <$> arbitrary arbitrary = TermIdentifier <$> arbitrary
shrink = fmap TermIdentifier . shrink . tday shrink = fmap TermIdentifier . shrink . getTermDay
instance CoArbitrary TermIdentifier instance CoArbitrary TermIdentifier
instance Function TermIdentifier instance Function TermIdentifier
@ -387,8 +389,6 @@ spec = do
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ] [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @Load) lawsCheckHspec (Proxy @Load)
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ] [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
lawsCheckHspec (Proxy @Season)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
lawsCheckHspec (Proxy @TermIdentifier) lawsCheckHspec (Proxy @TermIdentifier)
[ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ] [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @StudyFieldType) lawsCheckHspec (Proxy @StudyFieldType)
@ -467,8 +467,11 @@ spec = do
\term -> termFromText (termToText term) == Right term \term -> termFromText (termToText term) == Right term
it "has compatible encoding/decoding to/from Rational" . property $ it "has compatible encoding/decoding to/from Rational" . property $
\term -> termFromRational (termToRational term) == term \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 $ it "has human readable year encoding to Rational" . property $
\term -> truncate (termToRational term) == fst3 $ toGregorian $ tday term \term -> truncate (termToRational term) == getYear (getTermDay term)
describe "Pseudonym" $ do describe "Pseudonym" $ do
it "has sufficient vocabulary" $ it "has sufficient vocabulary" $
(length pseudonymWordlist ^ 2) `shouldSatisfy` (> (fromIntegral (maxBound :: Pseudonym) - fromIntegral (minBound :: Pseudonym))) (length pseudonymWordlist ^ 2) `shouldSatisfy` (> (fromIntegral (maxBound :: Pseudonym) - fromIntegral (minBound :: Pseudonym)))