fuzzy-time 0.1.0.0 → 0.2.0.0
raw patch · 8 files changed
+178/−204 lines, 8 filesdep ~timesetup-changed
Dependency ranges changed: time
Files
- CHANGELOG.md +7/−0
- LICENSE +1/−1
- Setup.hs +0/−3
- fuzzy-time.cabal +7/−5
- src/Data/FuzzyTime.hs +5/−4
- src/Data/FuzzyTime/Parser.hs +73/−88
- src/Data/FuzzyTime/Resolve.hs +31/−29
- src/Data/FuzzyTime/Types.hs +54/−74
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Changelog++## [0.2.0.0] - 2021-11-21++### Changed++- Got rid of CPP: Now requires `time >=1.9`
LICENSE view
@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2017-2020 Tom Sydney Kerckhove+Copyright (c) 2017-2021 Tom Sydney Kerckhove Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
− Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain
fuzzy-time.cabal view
@@ -1,22 +1,24 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: 4979abc627af2c6063f556a9b81bcde01dac4d1131f6201b91cc0d4c3556f29e+-- hash: 6469e029979ef60ea4025a3c77b68c315934bc45e576beb1ba77b9e1d70f06ee name: fuzzy-time-version: 0.1.0.0+version: 0.2.0.0 description: Fuzzy time types, parsing and resolution category: Time homepage: https://github.com/NorfairKing/fuzzy-time author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu-copyright: Copyright: (c) 2017-2020 Tom Sydney Kerckhove+copyright: Copyright: (c) 2017-2021 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple+extra-source-files:+ CHANGELOG.md library exposed-modules:@@ -35,7 +37,7 @@ , deepseq , megaparsec , text- , time+ , time >=1.9 , validity , validity-time default-language: Haskell2010
src/Data/FuzzyTime.hs view
@@ -1,8 +1,9 @@ module Data.FuzzyTime- ( module Data.FuzzyTime.Types- , module Data.FuzzyTime.Parser- , module Data.FuzzyTime.Resolve- ) where+ ( module Data.FuzzyTime.Types,+ module Data.FuzzyTime.Parser,+ module Data.FuzzyTime.Resolve,+ )+where import Data.FuzzyTime.Parser import Data.FuzzyTime.Resolve
src/Data/FuzzyTime/Parser.hs view
@@ -1,24 +1,28 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} module Data.FuzzyTime.Parser- ( fuzzyZonedTimeP- , fuzzyLocalTimeP- , fuzzyTimeOfDayP- , atHourP- , atMinuteP- , atExactP- , hourSegmentP- , minuteSegmentP- , twoDigitsSegmentP- , fuzzyDayP- , fuzzyDayOfTheWeekP- , Parser- ) where+ ( fuzzyZonedTimeP,+ fuzzyLocalTimeP,+ fuzzyTimeOfDayP,+ atHourP,+ atMinuteP,+ atExactP,+ hourSegmentP,+ minuteSegmentP,+ twoDigitsSegmentP,+ fuzzyDayP,+ fuzzyDayOfTheWeekP,+ Parser,+ )+where +import Control.Monad+import Data.Char as Char import Data.Fixed+import Data.FuzzyTime.Types import Data.List import Data.Maybe import Data.Text (Text)@@ -26,54 +30,48 @@ import Data.Tree import Data.Validity import Data.Void--import Control.Monad- import Text.Megaparsec import Text.Megaparsec.Char as Char import Text.Megaparsec.Char.Lexer as Lexer -import Data.FuzzyTime.Types- type Parser = Parsec Void Text fuzzyZonedTimeP :: Parser FuzzyZonedTime fuzzyZonedTimeP = pure ZonedNow fuzzyLocalTimeP :: Parser FuzzyLocalTime-fuzzyLocalTimeP =- label "FuzzyLocalTime" $- FuzzyLocalTime <$> parseSome fuzzyDayP fuzzyTimeOfDayP+fuzzyLocalTimeP = label "FuzzyLocalTime" $ FuzzyLocalTime <$> parseSome fuzzyDayP fuzzyTimeOfDayP -- | Note: Not composable parseSome :: Parser a -> Parser b -> Parser (Some a b) parseSome pa pb = label "Some" $- choice''- [ do a <- pa- space1- b <- pb- pure $ Both a b- , One <$> pa- , Other <$> pb- ]+ choice''+ [ do+ a <- pa+ space1+ b <- pb+ pure $ Both a b,+ One <$> pa,+ Other <$> pb+ ] fuzzyTimeOfDayP :: Parser FuzzyTimeOfDay fuzzyTimeOfDayP = label "FuzzyTimeOfDay" $- choice'- [ recTreeParser- [ ("midnight", Midnight)- , ("midday", Noon)- , ("noon", Noon)- , ("morning", Morning)- , ("evening", Evening)- ]- , atExactP- , atMinuteP- , atHourP- , diffP- ]+ choice'+ [ recTreeParser+ [ ("midnight", Midnight),+ ("midday", Noon),+ ("noon", Noon),+ ("morning", Morning),+ ("evening", Evening)+ ],+ atExactP,+ atMinuteP,+ atHourP,+ diffP+ ] atHourP :: Parser FuzzyTimeOfDay atHourP =@@ -85,7 +83,6 @@ atMinuteP = label "AtMinute" $ do h <- hourSegmentP- void $ optional $ char ':' m <- minuteSegmentP pure $ AtMinute h m @@ -93,7 +90,6 @@ atExactP = label "AtExact" $ do h <- hourSegmentP- void $ optional $ char ':' m <- minuteSegmentP void $ char ':' s <- readSimplePico@@ -129,6 +125,7 @@ label "hour segment" $ do h <- twoDigitsSegmentP guard $ h >= 0 && h < 24+ void $ optional $ char ':' pure h minuteSegmentP :: Parser Int@@ -169,36 +166,29 @@ fuzzyDayP :: Parser FuzzyDay fuzzyDayP = label "FuzzyDay" $- choice'- [ recTreeParser- [ ("yesterday", Yesterday)- , ("now", Now)- , ("today", Today)- , ("tomorrow", Tomorrow)- ]- , fmap- ExactDay- (some (digitChar <|> char '-') >>=- parseTimeM True defaultTimeLocale "%Y-%m-%d")- , dayInMonthP- , dayOfTheMonthP- , NextDayOfTheWeek <$> fuzzyDayOfTheWeekP- , diffDayP- ]+ choice'+ [ recTreeParser+ [("yesterday", Yesterday), ("now", Now), ("today", Today), ("tomorrow", Tomorrow)],+ fmap ExactDay (some (digitChar <|> char '-') >>= parseTimeM True defaultTimeLocale "%Y-%m-%d"),+ dayInMonthP,+ dayOfTheMonthP,+ NextDayOfTheWeek <$> fuzzyDayOfTheWeekP,+ diffDayP+ ] dayOfTheMonthP :: Parser FuzzyDay dayOfTheMonthP = do- v <- OnlyDay <$> Lexer.lexeme (pure ()) Lexer.decimal+ v <- OnlyDay <$> twoDigitsSegmentP guard $ isValid v pure v dayInMonthP :: Parser FuzzyDay dayInMonthP = do- m <- Lexer.lexeme (pure ()) Lexer.decimal+ m <- twoDigitsSegmentP guard (m >= 1) guard (m <= 12) void $ string "-"- d <- Lexer.lexeme (pure ()) Lexer.decimal+ d <- twoDigitsSegmentP let v = DayInMonth m d guard $ isValid v pure v@@ -230,13 +220,13 @@ fuzzyDayOfTheWeekP :: Parser DayOfWeek fuzzyDayOfTheWeekP = recTreeParser- [ ("monday", Monday)- , ("tuesday", Tuesday)- , ("wednesday", Wednesday)- , ("thursday", Thursday)- , ("friday", Friday)- , ("saturday", Saturday)- , ("sunday", Sunday)+ [ ("monday", Monday),+ ("tuesday", Tuesday),+ ("wednesday", Wednesday),+ ("thursday", Thursday),+ ("friday", Friday),+ ("saturday", Saturday),+ ("sunday", Sunday) ] recTreeParser :: [(String, a)] -> Parser a@@ -245,24 +235,22 @@ s <- some letterChar case lookupInParseForest s pf of Nothing ->- fail $- "Could not parse any of these recursively unambiguously: " ++- show (map fst tups)+ fail $ "Could not parse any of these recursively unambiguously: " ++ show (map fst tups) Just f -> pure f -lookupInParseForest :: Eq c => [c] -> Forest (c, Maybe a) -> Maybe a+lookupInParseForest :: [Char] -> Forest (Char, Maybe a) -> Maybe a lookupInParseForest = gof where- gof :: Eq c => [c] -> Forest (c, Maybe a) -> Maybe a+ gof :: [Char] -> Forest (Char, Maybe a) -> Maybe a gof cs = msum . map (got cs)- got :: Eq c => [c] -> Tree (c, Maybe a) -> Maybe a+ got :: [Char] -> Tree (Char, Maybe a) -> Maybe a got [] _ = Nothing- got (c:cs) Node {..} =+ got (c : cs) Node {..} = let (tc, tma) = rootLabel- in if tc == c+ in if Char.toLower tc == Char.toLower c then case cs of- [] -> tma- _ -> gof cs subForest+ [] -> tma+ _ -> gof cs subForest else Nothing makeParseForest :: Eq c => [([c], a)] -> Forest (c, Maybe a)@@ -270,11 +258,11 @@ where insertf :: Eq c => Forest (c, Maybe a) -> ([c], a) -> Forest (c, Maybe a) insertf for ([], _) = for- insertf for (c:cs, a) =+ insertf for (c : cs, a) = case find ((== c) . fst . rootLabel) for of Nothing -> let got [] = Nothing- got (c_:cs_) = Just $ Node (c_, Just a) $ maybeToList $ got cs_+ got (c_ : cs_) = Just $ Node (c_, Just a) $ maybeToList $ got cs_ in case got (c : cs) of Nothing -> for -- Should not happen, but is fine Just t -> t : for@@ -282,10 +270,7 @@ flip map for $ \t -> let (tc, _) = rootLabel t in if tc == c- then n- { rootLabel = (tc, Nothing)- , subForest = insertf (subForest n) (cs, a)- }+ then n {rootLabel = (tc, Nothing), subForest = insertf (subForest n) (cs, a)} else t signed' :: Num a => Parser a -> Parser a@@ -296,7 +281,7 @@ choice' :: [Parser a] -> Parser a choice' [] = empty choice' [x] = x-choice' (a:as) = try a <|> choice' as+choice' (a : as) = try a <|> choice' as choice'' :: [Parser a] -> Parser a choice'' = choice' . map (<* eof)
src/Data/FuzzyTime/Resolve.hs view
@@ -1,24 +1,24 @@ module Data.FuzzyTime.Resolve- ( resolveZonedTime- , resolveLocalTime- , resolveLocalTimeOne- , resolveLocalTimeOther- , resolveLocalTimeBoth- , morning- , evening- , resolveTimeOfDay- , resolveTimeOfDayWithDiff- , normaliseTimeOfDay- , resolveDay- ) where+ ( resolveZonedTime,+ resolveLocalTime,+ resolveLocalTimeOne,+ resolveLocalTimeOther,+ resolveLocalTimeBoth,+ morning,+ evening,+ resolveTimeOfDay,+ resolveTimeOfDayWithDiff,+ normaliseTimeOfDay,+ resolveDay,+ )+where import Data.Fixed+import Data.FuzzyTime.Types import Data.Maybe import Data.Time import Data.Time.Calendar.WeekDate -import Data.FuzzyTime.Types- resolveZonedTime :: ZonedTime -> FuzzyZonedTime -> ZonedTime resolveZonedTime zt ZonedNow = zt @@ -62,9 +62,9 @@ AtHour h_ -> next $ TimeOfDay h_ 0 0 AtMinute h_ m_ -> next $ TimeOfDay h_ m_ 0 AtExact tod_ -> next tod_- HoursDiff hd -> normaliseTimeOfDay $ TimeOfDay (h + fromIntegral hd) m s- MinutesDiff md -> normaliseTimeOfDay $ TimeOfDay h (m + fromIntegral md) s- SecondsDiff sd -> normaliseTimeOfDay $ TimeOfDay h m (s + sd)+ HoursDiff hd -> normaliseTimeOfDay (h + fromIntegral hd) m s+ MinutesDiff md -> normaliseTimeOfDay h (m + fromIntegral md) s+ SecondsDiff sd -> normaliseTimeOfDay h m (s + sd) where next tod_ = (skipIf (>= tod_), tod_) skipIf p =@@ -72,10 +72,10 @@ then 1 else 0 -normaliseTimeOfDay :: TimeOfDay -> (Integer, TimeOfDay)-normaliseTimeOfDay (TimeOfDay h m s) =+normaliseTimeOfDay :: Int -> Int -> Pico -> (Integer, TimeOfDay)+normaliseTimeOfDay h m s = let s' = s `mod'` 60- totalM = m + (round $ s - s') `div` 60+ totalM = m + round (s - s') `div` 60 m' = totalM `mod` 60 totalH = h + (totalM - m') `div` 60 h' = totalH `mod` 24@@ -110,12 +110,13 @@ go y [] = let y' = y + 1 in go y' (daysInMonth y')- go y ((month, mds):rest) =+ go y ((month, mds) : rest) = if mds >= di- then let d' = fromGregorian y (monthNum month) di- in if d' >= d- then d'- else go y rest+ then+ let d' = fromGregorian y (monthNum month) di+ in if d' >= d+ then d'+ else go y rest else go y rest in go y_ (drop (m_ - 1) $ daysInMonth y_) @@ -125,10 +126,11 @@ go y = let mds = fromJust $ lookup (numMonth mi) (daysInMonth y) in if mds >= di- then let d' = fromGregorian y mi di- in if d' >= d- then d'- else go (y + 1)+ then+ let d' = fromGregorian y mi di+ in if d' >= d+ then d'+ else go (y + 1) else go (y + 1) in go y_
src/Data/FuzzyTime/Types.hs view
@@ -1,26 +1,23 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}-#if MIN_VERSION_time(1,9,0) {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-#endif+ module Data.FuzzyTime.Types- ( module Data.FuzzyTime.Types- , DayOfWeek(..)- ) where+ ( module Data.FuzzyTime.Types,+ DayOfWeek (..),+ )+where +import Control.DeepSeq import Data.Fixed import Data.Int+import Data.Time import Data.Validity import Data.Validity.Time () import GHC.Generics (Generic) -import Control.DeepSeq--import Data.Time--data FuzzyZonedTime =- ZonedNow+data FuzzyZonedTime+ = ZonedNow deriving (Show, Eq, Generic) instance Validity FuzzyZonedTime@@ -36,10 +33,9 @@ instance NFData AmbiguousLocalTime -newtype FuzzyLocalTime =- FuzzyLocalTime- { unFuzzyLocalTime :: Some FuzzyDay FuzzyTimeOfDay- }+newtype FuzzyLocalTime = FuzzyLocalTime+ { unFuzzyLocalTime :: Some FuzzyDay FuzzyTimeOfDay+ } deriving (Show, Eq, Generic) instance Validity FuzzyLocalTime@@ -73,19 +69,19 @@ instance Validity FuzzyTimeOfDay where validate ftod = mconcat- [ genericValidate ftod- , case ftod of+ [ genericValidate ftod,+ case ftod of AtHour h -> mconcat- [ declare "The hour is positive" $ h >= 0- , declare "The hours are fewer than 24" $ h < 24+ [ declare "The hour is positive" $ h >= 0,+ declare "The hours are fewer than 24" $ h < 24 ] AtMinute h m -> mconcat- [ declare "The hour is positive" $ h >= 0- , declare "The hours are fewer than 24" $ h < 24- , declare "The minute is positive" $ m >= 0- , declare "The minutes are fewer than 60" $ m < 60+ [ declare "The hour is positive" $ h >= 0,+ declare "The hours are fewer than 24" $ h < 24,+ declare "The minute is positive" $ m >= 0,+ declare "The minutes are fewer than 60" $ m < 60 ] HoursDiff hs -> mconcat@@ -93,12 +89,12 @@ MinutesDiff ms -> mconcat [ declare "The minutes difference is no less than 1440m" $- abs ms < 24 * 60+ abs ms < 24 * 60 ] SecondsDiff ms -> mconcat [ declare "The seconds difference is no less than 86400s" $- abs ms < 24 * 60 * 60+ abs ms < 24 * 60 * 60 ] _ -> valid ]@@ -122,56 +118,39 @@ instance Validity FuzzyDay where validate fd = mconcat- [ genericValidate fd- , case fd of+ [ genericValidate fd,+ case fd of OnlyDay di -> decorate "OnlyDay" $- mconcat- [ declare "The day is strictly positive" $ di >= 1- , declare "The day is less than or equal to 31" $ di <= 31- ]+ mconcat+ [ declare "The day is strictly positive" $ di >= 1,+ declare "The day is less than or equal to 31" $ di <= 31+ ] DayInMonth mi di -> decorate "DayInMonth" $- mconcat- [ declare "The day is strictly positive" $ di >= 1- , declare "The day is less than or equal to 31" $ di <= 31- , declare "The month is strictly positive" $ mi >= 1- , declare "The month is less than or equal to 12" $ mi <= 12- , declare "The number of days makes sense for the month" $- maybe False (>= di) $ lookup (numMonth mi) (daysInMonth 2004)- ]+ mconcat+ [ declare "The day is strictly positive" $ di >= 1,+ declare "The day is less than or equal to 31" $ di <= 31,+ declare "The month is strictly positive" $ mi >= 1,+ declare "The month is less than or equal to 12" $ mi <= 12,+ declare "The number of days makes sense for the month" $+ maybe False (>= di) $ lookup (numMonth mi) (daysInMonth 2004)+ ] _ -> valid ] instance NFData FuzzyDay-#if !MIN_VERSION_time(1,9,0)-data DayOfWeek- = Monday- | Tuesday- | Wednesday- | Thursday- | Friday- | Saturday- | Sunday- deriving (Show, Eq, Generic, Enum, Bounded)-#else+ deriving instance Generic DayOfWeek-#endif-instance NFData DayOfWeek -instance Validity DayOfWeek+instance NFData DayOfWeek dayOfTheWeekNum :: DayOfWeek -> Int-numDayOfTheWeek :: Int -> DayOfWeek-#if MIN_VERSION_time(1,9,0) dayOfTheWeekNum = fromEnum +numDayOfTheWeek :: Int -> DayOfWeek numDayOfTheWeek = toEnum-#else-dayOfTheWeekNum = (+ 1) . fromEnum -numDayOfTheWeek = toEnum . (\x -> x - 1)-#endif data Month = January | February@@ -193,21 +172,22 @@ daysInMonth :: Integer -> [(Month, Int)] daysInMonth y =- [ (January, 31)- , ( February- , if isLeapYear y+ [ (January, 31),+ ( February,+ if isLeapYear y then 29- else 28)- , (March, 31)- , (April, 30)- , (May, 31)- , (June, 30)- , (July, 31)- , (August, 31)- , (September, 30)- , (October, 31)- , (November, 30)- , (December, 31)+ else 28+ ),+ (March, 31),+ (April, 30),+ (May, 31),+ (June, 30),+ (July, 31),+ (August, 31),+ (September, 30),+ (October, 31),+ (November, 30),+ (December, 31) ] monthNum :: Month -> Int