From 3f0550418d7223c50ede1b74b7165057d2b4f8a2 Mon Sep 17 00:00:00 2001 From: Tommy Bidne Date: Mon, 20 Jan 2025 10:02:27 +1300 Subject: [PATCH] Add chart-request date filtering --- examples/chart-requests.toml | 2 +- pacer.cabal | 7 + src/Pacer/Class/Parser.hs | 64 +++- src/Pacer/Command/Chart/Data/ChartData.hs | 18 +- src/Pacer/Command/Chart/Data/ChartRequest.hs | 19 +- src/Pacer/Command/Chart/Data/Run.hs | 94 +----- src/Pacer/Command/Chart/Data/Time.hs | 318 ++++++++++++++++++ src/Pacer/Prelude.hs | 1 + src/Pacer/Utils.hs | 32 ++ test/unit/Main.hs | 2 + .../Pacer/Command/Chart/Data/ChartRequest.hs | 2 +- .../Unit/Pacer/Command/Chart/Data/Time.hs | 103 ++++++ .../testParseExampleChartRequestsToml.golden | 11 + .../goldens/testParseExampleRunsToml.golden | 10 +- 14 files changed, 578 insertions(+), 105 deletions(-) create mode 100644 src/Pacer/Command/Chart/Data/Time.hs create mode 100644 test/unit/Unit/Pacer/Command/Chart/Data/Time.hs diff --git a/examples/chart-requests.toml b/examples/chart-requests.toml index f46b571..532a4e4 100644 --- a/examples/chart-requests.toml +++ b/examples/chart-requests.toml @@ -13,7 +13,7 @@ unit = "mi" # Only takes runs with label 'marathon' [[charts]] title = 'Marathons' -filters = ['label marathon'] +filters = ['label marathon', 'date >= 2024'] y-axis = 'duration' y1-axis = 'pace' diff --git a/pacer.cabal b/pacer.cabal index fe1996a..7a19ab5 100644 --- a/pacer.cabal +++ b/pacer.cabal @@ -32,9 +32,11 @@ source-repository head common common-lang default-extensions: ApplicativeDo + DeriveAnyClass DerivingVia DuplicateRecordFields LexicalNegation + MultiWayIf NoImplicitPrelude OverloadedRecordDot OverloadedStrings @@ -71,6 +73,7 @@ library Pacer.Command.Chart.Data.ChartOptions Pacer.Command.Chart.Data.ChartRequest Pacer.Command.Chart.Data.Run + Pacer.Command.Chart.Data.Time Pacer.Command.Chart.Params Pacer.Command.Convert Pacer.Command.Convert.Args @@ -108,6 +111,7 @@ library , base >=4.20.0.0 && <4.22 , bytestring >=0.10.12 && <0.13 , containers >=0.6.3.1 && <0.8 + , deepseq >=1.4.6.0 && <1.6 , effectful ^>=2.5.0.0 , exception-utils ^>=0.1 , exceptions ^>=0.10.4 @@ -156,6 +160,7 @@ test-suite unit Unit.Pacer.Command.Chart Unit.Pacer.Command.Chart.Data.ChartRequest Unit.Pacer.Command.Chart.Data.Run + Unit.Pacer.Command.Chart.Data.Time Unit.Pacer.Command.Chart.Params Unit.Pacer.Command.Derive Unit.Pacer.Data.Distance @@ -181,8 +186,10 @@ test-suite unit , tasty-hunit >=0.9 && <0.11 , terminal-effectful , text + , time , toml-reader , typed-process-dynamic-effectful + , tz ^>=0.1.3.3 hs-source-dirs: test/unit ghc-options: -threaded -with-rtsopts=-N diff --git a/src/Pacer/Class/Parser.hs b/src/Pacer/Class/Parser.hs index 775e3c6..6a5955b 100644 --- a/src/Pacer/Class/Parser.hs +++ b/src/Pacer/Class/Parser.hs @@ -24,9 +24,12 @@ where import Data.Char qualified as Ch import Data.Text qualified as T +import Data.Time.Format qualified as Format import Data.Time.Relative qualified as Rel +import Data.Word (Word16) import Numeric.Data.Fraction.Algebra (mkFraction) import Pacer.Prelude +import Pacer.Utils (EitherString (EitherLeft, EitherRight)) import Text.Megaparsec (Parsec, ()) import Text.Megaparsec qualified as MP import Text.Read qualified as TR @@ -39,6 +42,9 @@ class Parser a where -- | Megaparsec parser for the given type. parser :: MParser a +instance Parser Word16 where + parser = parseIntegral + instance Parser Double where parser = parseDigits @@ -69,14 +75,70 @@ instance (AMonoid a, Ord a, Parser a, Show a) => Parser (Positive a) where Nothing -> fail $ "Parsed non-positive: " ++ show d Just x -> pure x +instance Parser LocalTime where + parser = do + str <- unpackText <$> MP.takeWhile1P Nothing (\c -> Ch.isDigit c || c == '-') + case Format.parseTimeM False Format.defaultTimeLocale fmt str of + EitherRight d -> pure d + EitherLeft err -> + fail + $ mconcat + [ "Failed parsing localtime from string '", + str, + "': ", + err + ] + where + fmt = "%Y-%m-%dT%H:%M:%S" + +instance Parser ZonedTime where + parser = do + str <- unpackText <$> MP.takeWhile1P Nothing (\c -> Ch.isDigit c || c == '-') + case Format.parseTimeM False Format.defaultTimeLocale fmt str of + EitherRight d -> pure d + EitherLeft err -> + fail + $ mconcat + [ "Failed parsing zoned time from string '", + str, + "': ", + err + ] + where + fmt = "%Y-%m-%dT%H:%M:%S%z" + +instance Parser Day where + parser = do + str <- unpackText <$> MP.takeWhile1P Nothing (\c -> Ch.isDigit c || c == '-') + case Format.parseTimeM False Format.defaultTimeLocale fmt str of + EitherRight d -> pure d + EitherLeft err -> + fail + $ mconcat + [ "Failed parsing day from string '", + str, + "': ", + err + ] + where + fmt = "%Y-%m-%d" + -- | Parser combinator for digits with a 'Read' instance. parseDigits :: (Read n) => Parsec Void Text n parseDigits = parseDigitText >>= readDigits +-- | Parser combinator for digits with a 'Read' instance. +parseIntegral :: (Read n) => Parsec Void Text n +parseIntegral = parseIntegralText >>= readDigits + -- | Parser combinator for digits. parseDigitText :: Parsec Void Text Text parseDigitText = - MP.takeWhile1P Nothing (\c -> Ch.isDigit c || c == '.') + MP.takeWhile1P (Just "parseDigitText") (\c -> Ch.isDigit c || c == '.') + +-- | Parser combinator for digits. +parseIntegralText :: Parsec Void Text Text +parseIntegralText = MP.takeWhile1P (Just "parseIntegralText") Ch.isDigit -- | Read text like "1d2h3m4s", parse w/ relative time into Fractional -- seconds. diff --git a/src/Pacer/Command/Chart/Data/ChartData.hs b/src/Pacer/Command/Chart/Data/ChartData.hs index 8521575..39f2a12 100644 --- a/src/Pacer/Command/Chart/Data/ChartData.hs +++ b/src/Pacer/Command/Chart/Data/ChartData.hs @@ -18,7 +18,7 @@ import Pacer.Command.Chart.Data.ChartRequest ChartRequests (unChartRequests), FilterExpr, FilterOp (MkFilterOp), - FilterType (FilterDistance, FilterDuration, FilterLabel, FilterPace), + FilterType (FilterDate, FilterDistance, FilterDuration, FilterLabel, FilterPace), YAxisType ( YAxisDistance, YAxisDuration, @@ -28,12 +28,12 @@ import Pacer.Command.Chart.Data.ChartRequest ) import Pacer.Command.Chart.Data.Run ( Run (datetime, distance, duration), - RunTimestamp, SomeRun (MkSomeRun), SomeRuns (MkSomeRuns), SomeRunsKey (MkSomeRunsKey, unSomeRunsKey), ) import Pacer.Command.Chart.Data.Run qualified as Run +import Pacer.Command.Chart.Data.Time (Moment (MomentTimestamp), Timestamp) import Pacer.Data.Distance (Distance (unDistance), SomeDistance) import Pacer.Data.Distance.Units ( DistanceUnit (Kilometer, Meter, Mile), @@ -57,7 +57,7 @@ instance ToJSON ChartData where -- | Data for a chart with a single Y axis. data ChartY = MkChartY { -- | X and Y axis data. - values :: NESeq (Tuple2 RunTimestamp Double), + values :: NESeq (Tuple2 Timestamp Double), -- | Y axis type. This is used for the label on the line itself, __not__ -- the y-axis (that label is on ChartOptions). yType :: YAxisType @@ -78,7 +78,7 @@ instance ToJSON ChartY where -- | Data for a chart with two Y axes. data ChartY1 = MkChartY1 { -- | Data for a chart with two y Axes. - values :: NESeq (Tuple3 RunTimestamp Double Double), + values :: NESeq (Tuple3 Timestamp Double Double), -- | Type of first Y axis. yType :: YAxisType, -- | Type of second Y axis. @@ -109,10 +109,10 @@ mkYJson yVal yType yId = ] -- | Accumulator for chart with a single Y axis. -type AccY = NESeq (Tuple2 RunTimestamp Double) +type AccY = NESeq (Tuple2 Timestamp Double) -- | Accumulator for chart with two Y axes. -type AccY1 = NESeq (Tuple3 RunTimestamp Double Double) +type AccY1 = NESeq (Tuple3 Timestamp Double Double) -- | Turns a sequence of runs and chart requests into charts. mkChartDatas :: @@ -224,6 +224,7 @@ filterRuns rs filters = (.unSomeRunsKey) <$> NESeq.filter filterRun rs applyFilter :: SomeRunsKey a -> FilterType a -> Bool applyFilter srk (FilterLabel lbl) = applyLabel srk.unSomeRunsKey lbl + applyFilter srk (FilterDate op m) = applyDate srk.unSomeRunsKey op m applyFilter srk (FilterDistance op d) = applyDist srk.unSomeRunsKey op d applyFilter srk (FilterDuration op d) = applyDur srk.unSomeRunsKey op d applyFilter srk (FilterPace op p) = applyPace srk.unSomeRunsKey op p @@ -231,6 +232,11 @@ filterRuns rs filters = (.unSomeRunsKey) <$> NESeq.filter filterRun rs applyLabel :: SomeRun a -> Text -> Bool applyLabel (MkSomeRun _ r) lbl = lbl `elem` r.labels + applyDate :: SomeRun a -> FilterOp -> Moment -> Bool + applyDate (MkSomeRun _ r) op m = (opToFun op) runMoment m + where + runMoment = MomentTimestamp r.datetime + applyDist :: SomeRun a -> FilterOp -> SomeDistance (Positive a) -> Bool applyDist (MkSomeRun @runDist sr r) op fDist = withSingI sr $ (opToFun op) r.distance fDist' diff --git a/src/Pacer/Command/Chart/Data/ChartRequest.hs b/src/Pacer/Command/Chart/Data/ChartRequest.hs index a8c9989..2013dea 100644 --- a/src/Pacer/Command/Chart/Data/ChartRequest.hs +++ b/src/Pacer/Command/Chart/Data/ChartRequest.hs @@ -21,6 +21,7 @@ import Data.Aeson (ToJSON) import Data.Aeson.Types (ToJSON (toJSON)) import Pacer.Class.Parser (Parser (parser)) import Pacer.Class.Parser qualified as P +import Pacer.Command.Chart.Data.Time (Moment) import Pacer.Data.Distance (DistanceUnit, SomeDistance) import Pacer.Data.Duration (Seconds) import Pacer.Data.Pace (SomePace) @@ -82,10 +83,11 @@ instance Parser FilterOp where -- | Ways in which we can filter runs. data FilterType a - = -- | Filters by label equality. - FilterLabel Text - | FilterDistance FilterOp (SomeDistance (Positive a)) + = FilterDistance FilterOp (SomeDistance (Positive a)) | FilterDuration FilterOp (Seconds (Positive a)) + | -- | Filters by label equality. + FilterLabel Text + | FilterDate FilterOp Moment | FilterPace FilterOp (SomePace (Positive a)) deriving stock (Eq, Show) @@ -103,13 +105,22 @@ instance [ parseLabel, parseDist, parseDuration, - parsePace + parsePace, + parseDate ] where parseLabel = do void $ MPC.string "label " FilterLabel <$> MP.takeWhile1P Nothing (/= ')') + parseDate = do + MPC.string "date" + MPC.space1 + op <- parser + MPC.space1 + m <- parser + pure $ FilterDate op m + parseDist = parsePred "distance" FilterDistance parseDuration = parsePred "duration" FilterDuration parsePace = parsePred "pace" FilterPace diff --git a/src/Pacer/Command/Chart/Data/Run.hs b/src/Pacer/Command/Chart/Data/Run.hs index 68689e2..d0be234 100644 --- a/src/Pacer/Command/Chart/Data/Run.hs +++ b/src/Pacer/Command/Chart/Data/Run.hs @@ -3,7 +3,6 @@ module Pacer.Command.Chart.Data.Run ( -- * Run Run (..), - RunTimestamp (..), -- ** Functions derivePace, @@ -20,18 +19,13 @@ module Pacer.Command.Chart.Data.Run ) where -import Data.Aeson (ToJSON (toJSON)) import Data.Map.NonEmpty (NEMap) import Data.Map.NonEmpty qualified as NEMap import Data.Set.NonEmpty qualified as NESet -import Data.Time qualified as Time -import Data.Time.Format qualified as Format -import Data.Time.LocalTime - ( LocalTime (LocalTime), - ZonedTime (ZonedTime), - ) import Pacer.Class.Parser (Parser) import Pacer.Class.Parser qualified as P +import Pacer.Command.Chart.Data.Time (Timestamp) +import Pacer.Command.Chart.Data.Time qualified as Time import Pacer.Command.Derive qualified as Derive import Pacer.Data.Distance ( Distance, @@ -60,80 +54,6 @@ import TOML ) import TOML qualified -------------------------------------------------------------------------------- --- RunTimestamp -- -------------------------------------------------------------------------------- - --- | Timestamp for runs. -data RunTimestamp - = RunDay Day - | RunLocalTime LocalTime - | RunZonedTime ZonedTime - deriving stock (Show) - -------------------------------------------------------------------------------- --- Base Classes -- -------------------------------------------------------------------------------- - -instance Eq RunTimestamp where - RunDay d1 == t2 = d1 == toDay t2 - RunLocalTime (LocalTime d1 _) == RunDay d2 = d1 == d2 - RunLocalTime l1 == RunLocalTime l2 = l1 == l2 - RunLocalTime l1 == RunZonedTime (ZonedTime l2 _) = l1 == l2 - RunZonedTime (ZonedTime (LocalTime d1 _) _) == RunDay d2 = d1 == d2 - RunZonedTime (ZonedTime l1 _) == RunLocalTime l2 = l1 == l2 - RunZonedTime z1 == RunZonedTime z2 = - Time.zonedTimeToUTC z1 == Time.zonedTimeToUTC z2 - -instance Ord RunTimestamp where - RunDay d1 <= t2 = d1 <= toDay t2 - RunLocalTime (LocalTime d1 _) <= RunDay d2 = d1 <= d2 - RunLocalTime l1 <= RunLocalTime l2 = l1 <= l2 - RunLocalTime l1 <= RunZonedTime (ZonedTime l2 _) = l1 <= l2 - RunZonedTime (ZonedTime (LocalTime d1 _) _) <= RunDay d2 = d1 <= d2 - RunZonedTime (ZonedTime l1 _) <= RunLocalTime l2 = l1 <= l2 - RunZonedTime z1 <= RunZonedTime z2 = - Time.zonedTimeToUTC z1 <= Time.zonedTimeToUTC z2 - -------------------------------------------------------------------------------- --- Serialization -- -------------------------------------------------------------------------------- - -instance DecodeTOML RunTimestamp where - tomlDecoder = - RunDay - <$> tomlDecoder - <|> RunLocalTime - <$> tomlDecoder - <|> RunZonedTime - <$> tomlDecoder - -instance ToJSON RunTimestamp where - toJSON (RunDay d) = toJSON d - toJSON (RunLocalTime lt) = toJSON lt - toJSON (RunZonedTime zt) = toJSON zt - -------------------------------------------------------------------------------- --- Misc -- -------------------------------------------------------------------------------- - -toDay :: RunTimestamp -> Day -toDay (RunDay d) = d -toDay (RunLocalTime (LocalTime d _)) = d -toDay (RunZonedTime (ZonedTime (LocalTime d _) _)) = d - -fmtRunTimestamp :: RunTimestamp -> Text -fmtRunTimestamp = - packText <<< \case - RunDay d -> Format.formatTime l dfmt d - RunLocalTime lt -> Format.formatTime l (dfmt ++ tfmt) lt - RunZonedTime zt -> Format.formatTime l (dfmt ++ tfmt ++ zfmt) zt - where - dfmt = "%Y-%m-%d" - tfmt = "T%H:%M:%S" - zfmt = "%z" - l = Format.defaultTimeLocale - ------------------------------------------------------------------------------- -- Run -- ------------------------------------------------------------------------------- @@ -142,7 +62,7 @@ fmtRunTimestamp = type Run :: DistanceUnit -> Type -> Type data Run dist a = MkRun { -- | The start time of the run. - datetime :: RunTimestamp, + datetime :: Timestamp, -- | The run's total distance. distance :: Distance dist (Positive a), -- | The run's total duration. @@ -395,11 +315,11 @@ instance [ "Found overlapping timestamps\n - ", fmtTitle mTitle1, ": ", - fmtRunTimestamp ts1, + Time.fmtTimestamp ts1, "\n - ", fmtTitle mTitle2, ": ", - fmtRunTimestamp ts2 + Time.fmtTimestamp ts2 ] Right mp -> pure $ MkSomeRuns $ NESet.fromList (toNonEmpty mp) @@ -440,12 +360,12 @@ instance fmtTitle Nothing = "" fmtTitle (Just t) = t -type TitleAndTime = Tuple2 RunTimestamp (Maybe Text) +type TitleAndTime = Tuple2 Timestamp (Maybe Text) type SomeRunsAcc a = Either (Tuple2 TitleAndTime TitleAndTime) - (NEMap RunTimestamp (SomeRunsKey a)) + (NEMap Timestamp (SomeRunsKey a)) ------------------------------------------------------------------------------- -- Misc -- diff --git a/src/Pacer/Command/Chart/Data/Time.hs b/src/Pacer/Command/Chart/Data/Time.hs new file mode 100644 index 0000000..30fd473 --- /dev/null +++ b/src/Pacer/Command/Chart/Data/Time.hs @@ -0,0 +1,318 @@ +module Pacer.Command.Chart.Data.Time + ( -- * Timestamp + Timestamp (..), + fmtTimestamp, + + -- * Month + Month (..), + + -- * Year + Year (..), + + -- * Moment + Moment (..), + ) +where + +import Data.Aeson (ToJSON (toJSON)) +import Data.Char qualified as Ch +import Data.Enum (Enum (fromEnum, toEnum)) +import Data.Time (LocalTime (LocalTime), ZonedTime (ZonedTime)) +import Data.Time qualified as Time +import Data.Time.Calendar qualified as Cal +import Data.Time.Format qualified as Format +import Data.Word (Word16) +import Numeric.Data.Interval.Algebra + ( Interval, + IntervalBound (Closed), + ) +import Numeric.Data.Interval.Algebra qualified as Interval +import Pacer.Class.Parser (Parser (parser)) +import Pacer.Prelude +import TOML (DecodeTOML (tomlDecoder)) +import Text.Megaparsec qualified as MP +import Text.Megaparsec.Char qualified as MPC + +------------------------------------------------------------------------------- +-- Timestamp -- +------------------------------------------------------------------------------- + +-- | Timestamp for runs. +data Timestamp + = TimestampDay Day + | TimestampTime LocalTime + | TimestampZoned ZonedTime + deriving stock (Generic, Show) + deriving anyclass (NFData) + +------------------------------------------------------------------------------- +-- Base Classes -- +------------------------------------------------------------------------------- + +instance Eq Timestamp where + TimestampDay d1 == t2 = d1 == toDay t2 + TimestampTime (LocalTime d1 _) == TimestampDay d2 = d1 == d2 + TimestampTime l1 == TimestampTime l2 = l1 == l2 + TimestampTime l1 == TimestampZoned (ZonedTime l2 _) = l1 == l2 + TimestampZoned (ZonedTime (LocalTime d1 _) _) == TimestampDay d2 = d1 == d2 + TimestampZoned (ZonedTime l1 _) == TimestampTime l2 = l1 == l2 + TimestampZoned z1 == TimestampZoned z2 = + Time.zonedTimeToUTC z1 == Time.zonedTimeToUTC z2 + +instance Ord Timestamp where + TimestampDay d1 <= t2 = d1 <= toDay t2 + TimestampTime (LocalTime d1 _) <= TimestampDay d2 = d1 <= d2 + TimestampTime l1 <= TimestampTime l2 = l1 <= l2 + TimestampTime l1 <= TimestampZoned (ZonedTime l2 _) = l1 <= l2 + TimestampZoned (ZonedTime (LocalTime d1 _) _) <= TimestampDay d2 = d1 <= d2 + TimestampZoned (ZonedTime l1 _) <= TimestampTime l2 = l1 <= l2 + TimestampZoned z1 <= TimestampZoned z2 = + Time.zonedTimeToUTC z1 <= Time.zonedTimeToUTC z2 + +------------------------------------------------------------------------------- +-- Serialization -- +------------------------------------------------------------------------------- + +instance DecodeTOML Timestamp where + tomlDecoder = + TimestampDay + <$> tomlDecoder + <|> TimestampTime + <$> tomlDecoder + <|> TimestampZoned + <$> tomlDecoder + +-- TODO: Why does this fail??? +-- +-- TOML.decode @Timestamp "2024-10-20T14:30:00" + +instance Parser Timestamp where + -- reuse toml instance since it is already done for us upstream. + parser = do + MP.choice + [ TimestampZoned <$> MP.try parser, + TimestampTime <$> MP.try parser, + TimestampDay <$> parser + ] + +instance ToJSON Timestamp where + toJSON (TimestampDay d) = toJSON d + toJSON (TimestampTime lt) = toJSON lt + toJSON (TimestampZoned zt) = toJSON zt + +------------------------------------------------------------------------------- +-- Misc -- +------------------------------------------------------------------------------- + +toDay :: Timestamp -> Day +toDay (TimestampDay d) = d +toDay (TimestampTime (LocalTime d _)) = d +toDay (TimestampZoned (ZonedTime (LocalTime d _) _)) = d + +fmtTimestamp :: Timestamp -> Text +fmtTimestamp = + packText <<< \case + TimestampDay d -> Format.formatTime l dfmt d + TimestampTime lt -> Format.formatTime l (dfmt ++ tfmt) lt + TimestampZoned zt -> Format.formatTime l (dfmt ++ tfmt ++ zfmt) zt + where + dfmt = "%Y-%m-%d" + tfmt = "T%H:%M:%S" + zfmt = "%z" + l = Format.defaultTimeLocale + +------------------------------------------------------------------------------- +-- Month -- +------------------------------------------------------------------------------- + +data Month + = Jan + | Feb + | Mar + | Apr + | May + | Jun + | Jul + | Aug + | Sep + | Oct + | Nov + | Dec + deriving stock (Bounded, Enum, Eq, Generic, Ord, Show) + deriving anyclass (NFData) + +------------------------------------------------------------------------------- +-- Serialization -- +------------------------------------------------------------------------------- + +instance Parser Month where + parser = do + txt <- MP.takeWhile1P Nothing (\c -> Ch.isDigit c) + case txt of + "01" -> pure Jan + "02" -> pure Feb + "03" -> pure Mar + "04" -> pure Apr + "05" -> pure May + "06" -> pure Jun + "07" -> pure Jul + "08" -> pure Aug + "09" -> pure Sep + "10" -> pure Oct + "11" -> pure Nov + "12" -> pure Dec + other -> + fail $ "Expected a month in 01 - 12, received: " ++ unpackText other + +------------------------------------------------------------------------------- +-- Year -- +------------------------------------------------------------------------------- + +newtype Year = MkYear + { unYear :: Interval (Closed 1950) (Closed 2099) Word16 + } + deriving stock (Eq, Generic, Ord, Show) + deriving anyclass (NFData) + +instance Bounded Year where + minBound = MkYear $ Interval.unsafeInterval 1950 + maxBound = MkYear $ Interval.unsafeInterval 2099 + +instance Enum Year where + fromEnum = fromIntegral . (.unInterval) . (.unYear) + toEnum = MkYear . Interval.unsafeInterval . fromIntegral + +instance Parser Year where + parser = do + word <- parser + case Interval.mkInterval word of + Just y -> pure $ MkYear y + Nothing -> + fail $ "Expected a year in 1950 - 2099, received: " ++ show word + +------------------------------------------------------------------------------- +-- Timestamp -- +------------------------------------------------------------------------------- + +data Moment + = MomentYear Year + | MomentMonth Year Month + | -- NOTE: These timestamps should be in between 1950 and 2099. Should we + -- enforce this? E.g. with a smart constructor. + MomentTimestamp Timestamp + deriving stock (Generic, Show) + deriving anyclass (NFData) + +------------------------------------------------------------------------------- +-- Base Classes -- +------------------------------------------------------------------------------- + +instance Eq Moment where + MomentYear y1 == mt2 = y1 == momentToYear mt2 + MomentMonth y1 _ == MomentYear y2 = y1 == y2 + MomentMonth y1 m1 == MomentMonth y2 m2 = y1 == y2 && m1 == m2 + MomentMonth y1 m1 == MomentTimestamp t2 = + let (y2, m2) = timestampToYearMonth t2 + in y1 == y2 && m1 == m2 + MomentTimestamp t1 == MomentYear y2 = + let y1 = timestampToYear t1 + in y1 == y2 + MomentTimestamp t1 == MomentMonth y2 m2 = + let (y1, m1) = timestampToYearMonth t1 + in y1 == y2 && m1 == m2 + MomentTimestamp t1 == MomentTimestamp t2 = t1 == t2 + +instance Ord Moment where + MomentYear y1 <= mt2 = y1 <= momentToYear mt2 + MomentMonth y1 _ <= MomentYear y2 = y1 <= y2 + MomentMonth y1 m1 <= MomentMonth y2 m2 = yearMonthLte y1 m1 y2 m2 + MomentMonth y1 m1 <= MomentTimestamp t2 = + let (y2, m2) = timestampToYearMonth t2 + in yearMonthLte y1 m1 y2 m2 + MomentTimestamp t1 <= MomentYear y2 = + let y1 = timestampToYear t1 + in y1 == y2 + MomentTimestamp t1 <= MomentMonth y2 m2 = + let (y1, m1) = timestampToYearMonth t1 + in yearMonthLte y1 m1 y2 m2 + MomentTimestamp t1 <= MomentTimestamp t2 = t1 <= t2 + +instance Parser Moment where + parser = do + MP.choice + [ MomentTimestamp <$> MP.try parser, + MP.try parseYearMonth, + parseYear + ] + where + parseYearMonth = do + year <- parser + MPC.char '-' + month <- parser + pure $ MomentMonth year month + + parseYear = MomentYear <$> parser + +------------------------------------------------------------------------------- +-- Misc -- +------------------------------------------------------------------------------- + +yearMonthLte :: Year -> Month -> Year -> Month -> Bool +yearMonthLte y1 m1 y2 m2 + | y1 < y2 = True + | y1 == y2 = m1 <= m2 + | otherwise = False + +momentToYear :: Moment -> Year +momentToYear (MomentYear y) = y +momentToYear (MomentMonth y _) = y +momentToYear (MomentTimestamp ts) = timestampToYear ts + +timestampToYear :: Timestamp -> Year +timestampToYear = \case + (TimestampDay d) -> toYear d + (TimestampTime (LocalTime d _)) -> toYear d + (TimestampZoned (ZonedTime (LocalTime d _) _)) -> toYear d + where + toYear :: Day -> Year + toYear = + MkYear + . Interval.unsafeInterval + . fromIntegral @Integer @Word16 + . (\(y, _, _) -> y) + . Cal.toGregorian + +timestampToYearMonth :: Timestamp -> Tuple2 Year Month +timestampToYearMonth = \case + (TimestampDay d) -> toYearMonth d + (TimestampTime (LocalTime d _)) -> toYearMonth d + (TimestampZoned (ZonedTime (LocalTime d _) _)) -> toYearMonth d + where + toYearMonth :: Day -> Tuple2 Year Month + toYearMonth = + (\(y, m, _) -> (toYear y, toMonth m)) + . Cal.toGregorian + + toYear :: Integer -> Year + toYear = + MkYear + . Interval.unsafeInterval + . fromIntegral @Integer @Word16 + + toMonth :: Cal.MonthOfYear -> Month + toMonth 1 = Jan + toMonth 2 = Feb + toMonth 3 = Mar + toMonth 4 = Apr + toMonth 5 = May + toMonth 6 = Jun + toMonth 7 = Jul + toMonth 8 = Aug + toMonth 9 = Sep + toMonth 10 = Oct + toMonth 11 = Nov + toMonth 12 = Dec + toMonth other = + error + $ "Expected month in 1-12: " + ++ show other diff --git a/src/Pacer/Prelude.hs b/src/Pacer/Prelude.hs index dea87c5..b51ee4e 100644 --- a/src/Pacer/Prelude.hs +++ b/src/Pacer/Prelude.hs @@ -110,6 +110,7 @@ import Control.Applicative as X (<**>), ) import Control.Category as X (Category ((.)), (<<<), (>>>)) +import Control.DeepSeq as X (NFData) import Control.Exception as X ( Exception (displayException, fromException, toException), SomeException, diff --git a/src/Pacer/Utils.hs b/src/Pacer/Utils.hs index 92a8b18..9c986bb 100644 --- a/src/Pacer/Utils.hs +++ b/src/Pacer/Utils.hs @@ -13,6 +13,7 @@ module Pacer.Utils showListF, -- * Misc + EitherString (..), PaceMetersErrMsg, ) where @@ -54,3 +55,34 @@ showListF f xs@(_ : _) = "[" <> go xs go [] = "]" go [y] = f y <> "]" go (y : ys) = f y <> ", " <> go ys + +-- | Either, specializing Left to String, for the purposes of MonadFail. +data EitherString a + = EitherLeft String + | EitherRight a + deriving stock (Eq, Functor, Show) + +instance Applicative EitherString where + pure = EitherRight + + EitherRight f <*> EitherRight x = EitherRight (f x) + EitherLeft x <*> _ = EitherLeft x + _ <*> EitherLeft x = EitherLeft x + +instance Monad EitherString where + EitherRight x >>= f = f x + EitherLeft x >>= _ = EitherLeft x + +instance Foldable EitherString where + foldr _ e (EitherLeft _) = e + foldr f e (EitherRight x) = f x e + +instance Traversable EitherString where + sequenceA (EitherLeft x) = pure (EitherLeft x) + sequenceA (EitherRight x) = EitherRight <$> x + + traverse _ (EitherLeft x) = pure (EitherLeft x) + traverse f (EitherRight x) = EitherRight <$> f x + +instance MonadFail EitherString where + fail = EitherLeft diff --git a/test/unit/Main.hs b/test/unit/Main.hs index 3b8eec5..dd64547 100644 --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -5,6 +5,7 @@ import Test.Tasty.Golden (DeleteOutputFile (OnPass)) import Unit.Pacer.Command.Chart qualified import Unit.Pacer.Command.Chart.Data.ChartRequest qualified import Unit.Pacer.Command.Chart.Data.Run qualified +import Unit.Pacer.Command.Chart.Data.Time qualified import Unit.Pacer.Command.Chart.Params qualified import Unit.Pacer.Command.Derive qualified import Unit.Pacer.Data.Distance qualified @@ -22,6 +23,7 @@ main = [ Unit.Pacer.Command.Chart.tests, Unit.Pacer.Command.Chart.Data.ChartRequest.tests, Unit.Pacer.Command.Chart.Data.Run.tests, + Unit.Pacer.Command.Chart.Data.Time.tests, Unit.Pacer.Command.Chart.Params.tests, Unit.Pacer.Command.Derive.tests, Unit.Pacer.Data.Distance.tests, diff --git a/test/unit/Unit/Pacer/Command/Chart/Data/ChartRequest.hs b/test/unit/Unit/Pacer/Command/Chart/Data/ChartRequest.hs index 90b3bb3..2c12a0a 100644 --- a/test/unit/Unit/Pacer/Command/Chart/Data/ChartRequest.hs +++ b/test/unit/Unit/Pacer/Command/Chart/Data/ChartRequest.hs @@ -20,7 +20,7 @@ testParseExampleChartRequestsToml = testGoldenParams params where params = MkGoldenParams - { testDesc = "Parses example runs.toml", + { testDesc = "Parses example chart-requsts.toml", testName = [osp|testParseExampleChartRequestsToml|], runner = do contents <- decodeUtf8ThrowM =<< readBinaryFileIO path diff --git a/test/unit/Unit/Pacer/Command/Chart/Data/Time.hs b/test/unit/Unit/Pacer/Command/Chart/Data/Time.hs new file mode 100644 index 0000000..91348e6 --- /dev/null +++ b/test/unit/Unit/Pacer/Command/Chart/Data/Time.hs @@ -0,0 +1,103 @@ +module Unit.Pacer.Command.Chart.Data.Time (tests) where + +import Data.Enum (Enum (toEnum)) +import Data.Time (Day (ModifiedJulianDay), LocalTime (LocalTime), TimeOfDay (TimeOfDay), TimeZone, ZonedTime (ZonedTime)) +import Data.Time.Zones qualified as TZ +import Data.Time.Zones.All (TZLabel) +import Data.Time.Zones.All qualified as TZ.All +import Hedgehog qualified as H +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Pacer.Command.Chart.Data.Time + ( Moment (MomentMonth, MomentTimestamp, MomentYear), + Month, + Timestamp (TimestampDay, TimestampTime, TimestampZoned), + Year, + ) +import Unit.Prelude + +tests :: TestTree +tests = + testGroup + "Pacer.Command.Chart.Data.Time" + [ testMomentEqTotal, + testMomentOrdTotal + ] + +testMomentEqTotal :: TestTree +testMomentEqTotal = testPropertyNamed name desc $ property $ do + m1 <- forAll genMoment + m2 <- forAll genMoment + evalF (==) m1 m2 + where + name = "testMomentEqTotal" + desc = "Moment Eq is total" + +testMomentOrdTotal :: TestTree +testMomentOrdTotal = testPropertyNamed name desc $ property $ do + m1 <- forAll genMoment + m2 <- forAll genMoment + evalF (<=) m1 m2 + where + name = "testMomentOrdTotal" + desc = "Moment Ord is total" + +evalF :: (NFData c) => (a -> b -> c) -> a -> b -> PropertyT IO () +evalF f x y = void $ H.evalNF (x `f` y) + +genMoment :: Gen Moment +genMoment = + Gen.choice + [ MomentYear <$> genYear, + MomentMonth <$> genYear <*> genMonth, + MomentTimestamp <$> genTimestamp + ] + +genYear :: Gen Year +genYear = Gen.enumBounded + +genMonth :: Gen Month +genMonth = Gen.enumBounded + +genTimestamp :: Gen Timestamp +genTimestamp = + Gen.choice + [ TimestampDay <$> genDay, + TimestampTime <$> genLocalTime, + TimestampZoned <$> genZonedTime + ] + +genZonedTime :: Gen ZonedTime +genZonedTime = do + lt <- genLocalTime + tz <- genTimeZone + pure $ ZonedTime lt tz + +genTimeZone :: Gen TimeZone +genTimeZone = + (\l -> TZ.timeZoneForPOSIX (TZ.All.tzByLabel l) 0) + <$> tzLabels + where + tzLabels :: Gen TZLabel + tzLabels = Gen.enumBounded + +genLocalTime :: Gen LocalTime +genLocalTime = do + d <- genDay + tod <- genTimeOfDay + pure $ LocalTime d tod + +genDay :: Gen Day +genDay = + Gen.element + [ ModifiedJulianDay 33282, -- 1950-01-01 + ModifiedJulianDay 88068 -- 2099-12-31 + ] + +genTimeOfDay :: Gen TimeOfDay +genTimeOfDay = do + h <- Gen.integral (Range.linear 0 23) + m <- Gen.integral (Range.linear 0 59) + s <- Gen.integral (Range.linear 0 60) -- 60 == leap second + -- REVIEW: Is toEnum legit here? + pure $ TimeOfDay h m (toEnum s) diff --git a/test/unit/goldens/testParseExampleChartRequestsToml.golden b/test/unit/goldens/testParseExampleChartRequestsToml.golden index ebc3a7e..ca1801e 100644 --- a/test/unit/goldens/testParseExampleChartRequestsToml.golden +++ b/test/unit/goldens/testParseExampleChartRequestsToml.golden @@ -21,6 +21,17 @@ MkChartRequests , filters = [ Atom ( FilterLabel "marathon" ) + , Atom + ( FilterDate MkFilterOp >= _ + ( MomentYear + ( MkYear + { unYear = UnsafeInterval + ( Closed 1950 ) + ( Closed 2099 ) 2024 + } + ) + ) + ) ] , title = "Marathons" , unit = Nothing diff --git a/test/unit/goldens/testParseExampleRunsToml.golden b/test/unit/goldens/testParseExampleRunsToml.golden index 57c9bca..1e89e0c 100644 --- a/test/unit/goldens/testParseExampleRunsToml.golden +++ b/test/unit/goldens/testParseExampleRunsToml.golden @@ -3,7 +3,7 @@ MkSomeRuns ( MkSomeRunsKey { unSomeRunsKey = MkSomeRun SKilometer ( MkRun - { datetime = RunZonedTime 2024-10-10 12:00:00 -0800 + { datetime = TimestampZoned 2024-10-10 12:00:00 -0800 , distance = MkDistance ( UnsafePositive 21.0975 ) Kilometer , duration = MkDuration @@ -19,7 +19,7 @@ MkSomeRuns [ MkSomeRunsKey { unSomeRunsKey = MkSomeRun SKilometer ( MkRun - { datetime = RunDay 2024-10-15 + { datetime = TimestampDay 2024-10-15 , distance = MkDistance ( UnsafePositive 5.0 ) Kilometer , duration = MkDuration @@ -32,7 +32,7 @@ MkSomeRuns , MkSomeRunsKey { unSomeRunsKey = MkSomeRun SMile ( MkRun - { datetime = RunLocalTime 2024-10-20 14:30:00 + { datetime = TimestampTime 2024-10-20 14:30:00 , distance = MkDistance ( UnsafePositive 20.0 ) Mile , duration = MkDuration @@ -45,7 +45,7 @@ MkSomeRuns , MkSomeRunsKey { unSomeRunsKey = MkSomeRun SKilometer ( MkRun - { datetime = RunZonedTime 2024-10-25 12:00:00 -0800 + { datetime = TimestampZoned 2024-10-25 12:00:00 -0800 , distance = MkDistance ( UnsafePositive 42.195 ) Kilometer , duration = MkDuration @@ -61,7 +61,7 @@ MkSomeRuns , MkSomeRunsKey { unSomeRunsKey = MkSomeRun SKilometer ( MkRun - { datetime = RunZonedTime 2024-10-28 12:00:00 -0800 + { datetime = TimestampZoned 2024-10-28 12:00:00 -0800 , distance = MkDistance ( UnsafePositive 42.195 ) Kilometer , duration = MkDuration