packages feed

fuzzy-time (empty) → 0.0.0.0

raw patch · 7 files changed

+723/−0 lines, 7 filesdep +basedep +containersdep +deepseqsetup-changed

Dependencies added: base, containers, deepseq, megaparsec, text, time, validity, validity-time

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017-2020 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+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ fuzzy-time.cabal view
@@ -0,0 +1,41 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: dea630de13df312effc0438356b40d45d73d14b8b862e0dada4bcb0492bbcc79++name:           fuzzy-time+version:        0.0.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+license:        MIT+license-file:   LICENSE+build-type:     Simple++library+  exposed-modules:+      Data.FuzzyTime+      Data.FuzzyTime.Parser+      Data.FuzzyTime.Resolve+      Data.FuzzyTime.Types+  other-modules:+      Paths_fuzzy_time+  hs-source-dirs:+      src/+  ghc-options: -Wall+  build-depends:+      base >=4.9 && <=5+    , containers+    , deepseq+    , megaparsec+    , text+    , time+    , validity+    , validity-time+  default-language: Haskell2010
+ src/Data/FuzzyTime.hs view
@@ -0,0 +1,9 @@+module Data.FuzzyTime+    ( module Data.FuzzyTime.Types+    , module Data.FuzzyTime.Parser+    , module Data.FuzzyTime.Resolve+    ) where++import Data.FuzzyTime.Parser+import Data.FuzzyTime.Resolve+import Data.FuzzyTime.Types
+ src/Data/FuzzyTime/Parser.hs view
@@ -0,0 +1,302 @@+{-# 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++import Data.Fixed+import Data.List+import Data.Maybe+import Data.Text (Text)+import Data.Time+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++-- | 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+    ]++fuzzyTimeOfDayP :: Parser FuzzyTimeOfDay+fuzzyTimeOfDayP =+  label "FuzzyTimeOfDay" $+  choice'+    [ recTreeParser+        [ ("midnight", Midnight)+        , ("midday", Noon)+        , ("noon", Noon)+        , ("morning", Morning)+        , ("evening", Evening)+        ]+    , atExactP+    , atMinuteP+    , atHourP+    , diffP+    ]++atHourP :: Parser FuzzyTimeOfDay+atHourP =+  label "AtHour" $ do+    h <- hourSegmentP+    pure $ AtHour h++atMinuteP :: Parser FuzzyTimeOfDay+atMinuteP =+  label "AtMinute" $ do+    h <- hourSegmentP+    void $ optional $ char ':'+    m <- minuteSegmentP+    pure $ AtMinute h m++atExactP :: Parser FuzzyTimeOfDay+atExactP =+  label "AtExact" $ do+    h <- hourSegmentP+    void $ optional $ char ':'+    m <- minuteSegmentP+    void $ char ':'+    s <- readSimplePico+    pure $ AtExact $ TimeOfDay h m s++readSimplePico :: Parser Pico+readSimplePico = do+  let d = oneOf ['0' .. '9']+  beforeDot <- some d :: Parser String+  afterDot <-+    optional $ do+      dot <- char '.'+      r <- some d+      pure $ dot : r+  pure $ read $ beforeDot <> fromMaybe "" afterDot++diffP :: Parser FuzzyTimeOfDay+diffP =+  label "Diff" $ do+    n <- signed' decimal+    mc <- optional $ choice' [char 'h', char 'm', char 's']+    f <-+      case mc of+        Nothing -> pure HoursDiff+        Just 'h' -> pure HoursDiff+        Just 'm' -> pure MinutesDiff+        Just 's' -> pure (\i -> SecondsDiff $ fromIntegral i)+        _ -> fail "should not happen."+    pure $ f n++hourSegmentP :: Parser Int+hourSegmentP =+  label "hour segment" $ do+    h <- twoDigitsSegmentP+    guard $ h >= 0 && h < 24+    pure h++minuteSegmentP :: Parser Int+minuteSegmentP =+  label "minute segment" $ do+    m <- twoDigitsSegmentP+    guard $ m >= 0 && m < 60+    pure m++twoDigitsSegmentP :: Parser Int+twoDigitsSegmentP =+  label "two digit segment" $ do+    d1 <- digit+    md2 <- optional digit+    pure $+      case md2 of+        Nothing -> d1+        Just d2 -> 10 * d1 + d2++digit :: Parser Int+digit =+  label "digit" $ do+    let l = ['0' .. '9']+    c <- oneOf l+    case elemIndex c l of+      Nothing -> fail "Shouldn't happen."+      Just d -> pure d++-- | Can handle:+--+-- - yesterday+-- - now+-- - today+-- - tomorrow+-- - "%Y-%m-%d"+--+-- and all non-ambiguous prefixes+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+    ]++dayOfTheMonthP :: Parser FuzzyDay+dayOfTheMonthP = do+  v <- OnlyDay <$> Lexer.lexeme (pure ()) Lexer.decimal+  guard $ isValid v+  pure v++dayInMonthP :: Parser FuzzyDay+dayInMonthP = do+  m <- Lexer.lexeme (pure ()) Lexer.decimal+  guard (m >= 1)+  guard (m <= 12)+  void $ string "-"+  d <- Lexer.lexeme (pure ()) Lexer.decimal+  let v = DayInMonth m d+  guard $ isValid v+  pure v++diffDayP :: Parser FuzzyDay+diffDayP = do+  d <- signed' decimal+  mc <- optional $ oneOf ['d', 'w', 'm']+  let f =+        case mc of+          Nothing -> DiffDays+          Just 'd' -> DiffDays+          Just 'w' -> DiffWeeks+          Just 'm' -> DiffMonths+          _ -> DiffDays -- Should not happen.+  pure $ f d++-- | Can handle:+--+-- - monday+-- - tuesday+-- - wednesday+-- - thursday+-- - friday+-- - saturday+-- - sunday+--+-- and all non-ambiguous prefixes+fuzzyDayOfTheWeekP :: Parser DayOfTheWeek+fuzzyDayOfTheWeekP =+  recTreeParser+    [ ("monday", Monday)+    , ("tuesday", Tuesday)+    , ("wednesday", Wednesday)+    , ("thursday", Thursday)+    , ("friday", Friday)+    , ("saturday", Saturday)+    , ("sunday", Sunday)+    ]++recTreeParser :: [(String, a)] -> Parser a+recTreeParser tups = do+  let pf = makeParseForest tups+  s <- some letterChar+  case lookupInParseForest s pf of+    Nothing ->+      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 = gof+  where+    gof :: Eq c => [c] -> Forest (c, Maybe a) -> Maybe a+    gof cs = msum . map (got cs)+    got :: Eq c => [c] -> Tree (c, Maybe a) -> Maybe a+    got [] _ = Nothing+    got (c:cs) Node {..} =+      let (tc, tma) = rootLabel+       in if tc == c+            then case cs of+                   [] -> tma+                   _ -> gof cs subForest+            else Nothing++makeParseForest :: Eq c => [([c], a)] -> Forest (c, Maybe a)+makeParseForest = foldl insertf []+  where+    insertf :: Eq c => Forest (c, Maybe a) -> ([c], a) -> Forest (c, Maybe a)+    insertf for ([], _) = for+    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_+           in case got (c : cs) of+                Nothing -> for -- Should not happen, but is fine+                Just t -> t : for+        Just n ->+          flip map for $ \t ->+            let (tc, _) = rootLabel t+             in if tc == c+                  then n+                         { rootLabel = (tc, Nothing)+                         , subForest = insertf (subForest n) (cs, a)+                         }+                  else t++signed' :: Num a => Parser a -> Parser a+signed' p = sign <*> p+  where+    sign = (id <$ char '+') <|> (negate <$ char '-')++choice' :: [Parser a] -> Parser a+choice' [] = empty+choice' [x] = x+choice' (a:as) = try a <|> choice' as++choice'' :: [Parser a] -> Parser a+choice'' = choice' . map (<* eof)
+ src/Data/FuzzyTime/Resolve.hs view
@@ -0,0 +1,144 @@+module Data.FuzzyTime.Resolve+  ( resolveZonedTime+  , resolveLocalTime+  , resolveLocalTimeOne+  , resolveLocalTimeOther+  , resolveLocalTimeBoth+  , morning+  , evening+  , resolveTimeOfDay+  , resolveTimeOfDayWithDiff+  , normaliseTimeOfDay+  , resolveDay+  ) where++import Data.Fixed+import Data.Maybe+import Data.Time+import Data.Time.Calendar.WeekDate++import Data.FuzzyTime.Types++resolveZonedTime :: ZonedTime -> FuzzyZonedTime -> ZonedTime+resolveZonedTime zt ZonedNow = zt++resolveLocalTime :: LocalTime -> FuzzyLocalTime -> AmbiguousLocalTime+resolveLocalTime lt (FuzzyLocalTime sft) =+  case sft of+    One fd -> OnlyDaySpecified $ resolveLocalTimeOne lt fd+    Other ftod -> BothTimeAndDay $ resolveLocalTimeOther lt ftod+    Both fd ftod -> BothTimeAndDay $ resolveLocalTimeBoth lt fd ftod++resolveLocalTimeOne :: LocalTime -> FuzzyDay -> Day+resolveLocalTimeOne (LocalTime ld _) fd = resolveDay ld fd++resolveLocalTimeOther :: LocalTime -> FuzzyTimeOfDay -> LocalTime+resolveLocalTimeOther (LocalTime ld ltod) ftod =+  let (d, tod) = resolveTimeOfDayWithDiff ltod ftod+   in LocalTime (addDays d ld) tod++resolveLocalTimeBoth :: LocalTime -> FuzzyDay -> FuzzyTimeOfDay -> LocalTime+resolveLocalTimeBoth (LocalTime ld ltod) fd ftod =+  let withDiff = resolveTimeOfDayWithDiff ltod ftod+      withoutDiff = (0, resolveTimeOfDay ltod ftod)+      (d, tod) =+        case fd of+          Now -> withDiff+          Today -> withDiff+          _ -> withoutDiff+   in LocalTime (addDays d $ resolveDay ld fd) tod++resolveTimeOfDay :: TimeOfDay -> FuzzyTimeOfDay -> TimeOfDay+resolveTimeOfDay tod ftod = snd $ resolveTimeOfDayWithDiff tod ftod++resolveTimeOfDayWithDiff :: TimeOfDay -> FuzzyTimeOfDay -> (Integer, TimeOfDay)+resolveTimeOfDayWithDiff tod@(TimeOfDay h m s) ftod =+  case ftod of+    SameTime -> (0, tod)+    Noon -> next midday+    Midnight -> next midnight+    Morning -> next morning+    Evening -> next evening+    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)+  where+    next tod_ = (skipIf (>= tod_), tod_)+    skipIf p =+      if p tod+        then 1+        else 0++normaliseTimeOfDay :: TimeOfDay -> (Integer, TimeOfDay)+normaliseTimeOfDay (TimeOfDay h m s) =+  let s' = s `mod'` 60+      totalM = m + (round $ s - s') `div` 60+      m' = totalM `mod` 60+      totalH = h + (totalM - m') `div` 60+      h' = totalH `mod` 24+      totalD = (totalH - h') `div` 24+   in (fromIntegral totalD, TimeOfDay h' m' s')++morning :: TimeOfDay+morning = TimeOfDay 6 0 0++evening :: TimeOfDay+evening = TimeOfDay 18 0 0++resolveDay :: Day -> FuzzyDay -> Day+resolveDay d fd =+  case fd of+    Yesterday -> addDays (-1) d+    Now -> d+    Today -> d+    Tomorrow -> addDays 1 d+    OnlyDay di -> nextDayOnDay d di+    DayInMonth mi di -> nextDayOndayInMonth d mi di+    DiffDays ds -> addDays (fromIntegral ds) d+    DiffWeeks ws -> addDays (7 * fromIntegral ws) d+    DiffMonths ms -> addDays (30 * fromIntegral ms) d+    NextDayOfTheWeek dow -> nextDayOfTheWeek d dow+    ExactDay d_ -> d_++nextDayOnDay :: Day -> Int -> Day+nextDayOnDay d di =+  let (y_, m_, _) = toGregorian d+      go :: Integer -> [(Month, Int)] -> Day+      go y [] =+        let y' = y + 1+         in go y' (daysInMonth y')+      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+          else go y rest+   in go y_ (drop (m_ - 1) $ daysInMonth y_)++nextDayOndayInMonth :: Day -> Int -> Int -> Day+nextDayOndayInMonth d mi di =+  let (y_, _, _) = toGregorian d+      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)+              else go (y + 1)+   in go y_++nextDayOfTheWeek :: Day -> DayOfTheWeek -> Day+nextDayOfTheWeek d dow =+  let (_, _, i_) = toWeekDate d+      down = dayOfTheWeekNum dow+      diff = fromIntegral $ down - i_+      diff' =+        if diff <= 0+          then diff + 7+          else diff+   in addDays diff' d
+ src/Data/FuzzyTime/Types.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE DeriveGeneric #-}++module Data.FuzzyTime.Types where++import Data.Fixed+import Data.Int+import Data.Validity+import Data.Validity.Time ()+import GHC.Generics (Generic)++import Control.DeepSeq++import Data.Time++data FuzzyZonedTime =+  ZonedNow+  deriving (Show, Eq, Generic)++instance Validity FuzzyZonedTime++instance NFData FuzzyZonedTime++data AmbiguousLocalTime+  = OnlyDaySpecified Day+  | BothTimeAndDay LocalTime+  deriving (Show, Eq, Generic)++instance Validity AmbiguousLocalTime++instance NFData AmbiguousLocalTime++newtype FuzzyLocalTime =+  FuzzyLocalTime+    { unFuzzyLocalTime :: Some FuzzyDay FuzzyTimeOfDay+    }+  deriving (Show, Eq, Generic)++instance Validity FuzzyLocalTime++instance NFData FuzzyLocalTime++data Some a b+  = One a+  | Other b+  | Both a b+  deriving (Show, Eq, Generic)++instance (Validity a, Validity b) => Validity (Some a b)++instance (NFData a, NFData b) => NFData (Some a b)++data FuzzyTimeOfDay+  = SameTime+  | Noon+  | Midnight+  | Morning+  | Evening+  | AtHour Int+  | AtMinute Int Int+  | AtExact TimeOfDay+  | HoursDiff Int -- Max 24+  | MinutesDiff Int -- Max 24 * 60+  | SecondsDiff Pico -- Max 24 * 60 * 60+  deriving (Show, Eq, Generic)++instance Validity FuzzyTimeOfDay where+  validate ftod =+    mconcat+      [ genericValidate ftod+      , case ftod of+          AtHour h ->+            mconcat+              [ 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+              ]+          HoursDiff hs ->+            mconcat+              [declare "The hours difference is no less than 24h" $ abs hs < 24]+          MinutesDiff ms ->+            mconcat+              [ declare "The minutes difference is no less than 1440m" $+                abs ms < 24 * 60+              ]+          SecondsDiff ms ->+            mconcat+              [ declare "The seconds difference is no less than 86400s" $+                abs ms < 24 * 60 * 60+              ]+          _ -> valid+      ]++instance NFData FuzzyTimeOfDay++data FuzzyDay+  = Yesterday+  | Now+  | Today+  | Tomorrow+  | OnlyDay Int+  | DayInMonth Int Int+  | DiffDays Int16+  | DiffWeeks Int16+  | DiffMonths Int16+  | NextDayOfTheWeek DayOfTheWeek+  | ExactDay Day+  deriving (Show, Eq, Generic)++instance Validity FuzzyDay where+  validate fd =+    mconcat+      [ 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+              ]+          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)+              ]+          _ -> valid+      ]++instance NFData FuzzyDay++data DayOfTheWeek+  = Monday+  | Tuesday+  | Wednesday+  | Thursday+  | Friday+  | Saturday+  | Sunday+  deriving (Show, Eq, Generic, Enum, Bounded)++instance Validity DayOfTheWeek++instance NFData DayOfTheWeek++data Month+  = January+  | February+  | March+  | April+  | May+  | June+  | July+  | August+  | September+  | October+  | November+  | December+  deriving (Show, Eq, Generic, Enum, Bounded)++dayOfTheWeekNum :: DayOfTheWeek -> Int+dayOfTheWeekNum = (+ 1) . fromEnum++numDayOfTheWeek :: Int -> DayOfTheWeek+numDayOfTheWeek = toEnum . (\x -> x - 1)++instance Validity Month++instance NFData Month++daysInMonth :: Integer -> [(Month, Int)]+daysInMonth 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)+  ]++monthNum :: Month -> Int+monthNum = (+ 1) . fromEnum++numMonth :: Int -> Month+numMonth = toEnum . (\x -> x - 1)