fuzzy-dates (empty) → 0.1.0.0
raw patch · 9 files changed
+811/−0 lines, 9 filesdep +basedep +fuzzy-datesdep +hourglasssetup-changed
Dependencies added: base, fuzzy-dates, hourglass, hspec, lens, parsec
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +18/−0
- Setup.hs +2/−0
- app/Main.hs +5/−0
- fuzzy-dates.cabal +75/−0
- src/Data/Dates/Parsing.hs +397/−0
- src/Data/Dates/Parsing/Internal.hs +152/−0
- test/Spec.hs +129/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for fuzzy-dates++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Reed Oei (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Reed Oei nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,18 @@+# fuzzy-dates++[](https://travis-ci.org/ReedOei/fuzzy-dates)++`fuzzy-dates` is a Haskell library for parsing dates when you don't know/care to specify the format of the dates beforehand.++It is heavily based off of <https://gitlab.com/doshitan/hourglass-fuzzy-parsing>, which had not been updated for over 2 years at the time of writing, so I created this library, and added numerous new date formats to it.++# Quickstart++Import the main module, then call one of the extract dates functions, like so:++```+>>> import Data.Dates.Parsing+>>> extractDatesY 2018 "The party will be on 6/9"+[Date 2018 June 9]+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,5 @@+module Main where++main :: IO ()+main = pure ()+
+ fuzzy-dates.cabal view
@@ -0,0 +1,75 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: a9ebf0d34504c67f2b28393aa560365b2e0f7c4bcdfc12512e614700f1c14e36++name: fuzzy-dates+version: 0.1.0.0+description: Please see the README on GitHub at <https://github.com/ReedOei/fuzzy-dates#readme>+homepage: https://github.com/ReedOei/fuzzy-dates#readme+bug-reports: https://github.com/ReedOei/fuzzy-dates/issues+author: Reed Oei+maintainer: oei.reed@gmail.com+copyright: 2018 Reed Oei+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/ReedOei/fuzzy-dates++library+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , hourglass+ , hspec+ , lens+ , parsec+ exposed-modules:+ Data.Dates.Parsing+ Data.Dates.Parsing.Internal+ other-modules:+ Paths_fuzzy_dates+ default-language: Haskell2010++executable fuzzy-dates-exe+ main-is: Main.hs+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , fuzzy-dates+ , hourglass+ , hspec+ , lens+ , parsec+ other-modules:+ Paths_fuzzy_dates+ default-language: Haskell2010++test-suite fuzzy-dates-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , fuzzy-dates+ , hourglass+ , hspec+ , lens+ , parsec+ other-modules:+ Paths_fuzzy_dates+ default-language: Haskell2010
+ src/Data/Dates/Parsing.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Parse strings that aren't so precise+module Data.Dates.Parsing+ (+ Config (..)+ , DateTime (..)+ , DateInterval (..)+ , Time (..)+ , defaultConfig+ , defaultConfigIO+ , parseDate+ , parseDateTime+ , pAbsDateTime+ , pAbsDate+ , pDate+ , pDateTime+ , pTime+ , pDateInterval+ , weekdayToInterval+ , dateWeekDay+ , getStartOfThisWeek+ , getStartOfNextWeek+ , lastDate+ , nextDate+ , addInterval+ , negateInterval+ , minusInterval+ , dateInFormat+ , extractDates, extractDatesY, extract+ ) where++import Control.Lens+import Control.Monad++import Data.Char (toLower)+import Data.Data (Data, Typeable)+import Data.Hourglass+import Data.List (intercalate, find)+import Text.Parsec+import Text.Read (readMaybe)++import Time.System (dateCurrent)++import Data.Dates.Parsing.Internal++data DateInterval = Days Int+ | Weeks Int+ | Months Int+ | Years Int+ deriving (Eq,Show,Data,Typeable)++data Config = Config+ { _now :: DateTime -- ^ "Current" date/time, to use as base for relative dates+ , _startOfWeekDay :: WeekDay} -- ^ Which day of the week to consider the start day++makeLenses ''Config++defaultConfig :: DateTime -> Config+defaultConfig now' = Config+ {+ _now = now'+ , _startOfWeekDay = Monday+ }++defaultConfigIO :: IO Config+defaultConfigIO = defaultConfig <$> dateCurrent++-- | Weekday as interval from the configure start of the week+weekdayToInterval :: Config -> WeekDay -> DateInterval+weekdayToInterval c wd =+ Days (fromIntegral $ fromEnum wd - fromEnum (c^.startOfWeekDay))++getStartOfThisWeek :: Config -> DateTime+getStartOfThisWeek c = (c^.now) `minusInterval` weekdayToInterval c (dateWeekDay (c^.now))++getStartOfNextWeek :: Config -> DateTime+getStartOfNextWeek c = getStartOfThisWeek c `addInterval` Weeks 1++-- | Get weekday of given date.+dateWeekDay :: DateTime -> WeekDay+dateWeekDay = getWeekDay . timeGetDate++lookupMonth :: String -> Either [Month] Month+lookupMonth = uniqFuzzyMatch++time :: Stream s m Char => Hours -> ParsecT s st m TimeOfDay+time hMax = do+ h <- number 2 hMax+ char ':'+ m <- number 2 59+ x <- optionMaybe $ char ':'+ case x of+ Nothing -> return $ TimeOfDay h m 0 0+ Just _ -> do+ s <- number 2 59+ notFollowedBy letter+ return $ TimeOfDay h m s 0++time24 :: Stream s m Char => ParsecT s st m TimeOfDay+time24 = time 23+time12 :: Stream s m Char => ParsecT s st m TimeOfDay+time12 = time 12++ampm :: Stream s m Char => ParsecT s st m Int+ampm = do+ s <- many1 letter+ case uppercase s of+ "AM" -> return 0+ "PM" -> return 12+ _ -> fail "AM/PM expected"+++pTime :: Stream s m Char => ParsecT s st m TimeOfDay+pTime = choice $ map try [time12, time24]++newtype DateFormat = DateFormat [(DatePart, String)]+data DatePart = D | M | Y+data DatePartVal = DV Int | MV Month | YV Int++datePart :: Stream s m Char => DatePart -> ParsecT s st m DatePartVal+datePart M = MV <$> pMonth+datePart D = DV <$> pDay+datePart Y = YV <$> pYear++isYV (YV _) = True+isYV _ = False++isMV (MV _) = True+isMV _ = False++isDV (DV _) = True+isDV _ = False++monthPart :: [DatePartVal] -> Month+monthPart = maybe January (\(MV m) -> m) . find isMV++dayPart :: [DatePartVal] -> Int+dayPart = maybe 1 (\(DV d) -> d) . find isDV++yearPart :: Int -> [DatePartVal] -> Int+yearPart year = maybe year (\(YV y) -> y) . find isYV++makeFormat :: String -> [DatePart] -> DateFormat+makeFormat sep parts = DateFormat $ zip parts $ repeat sep++dateInFormat year (DateFormat parts) = do+ partVals <- zipWithM go [1..] parts++ pure $ Date (yearPart year partVals) (monthPart partVals) (dayPart partVals)+ where+ go i (p, sep)+ -- The last one doesn't need to have a separator.+ | i == length parts = datePart p+ | otherwise = do+ v <- datePart p+ string sep+ pure v++euroNumDate = makeFormat "." [D, M, Y]+writtenDate = DateFormat [(M, " "), (D, ","), (Y, "")]+americanDate = makeFormat "/" [M, D, Y]+dashDate = makeFormat "-" [Y, M, D]+strDate = makeFormat " " [D, M, Y]+spaceDate = makeFormat " " [D, M]+spaceDateMD = makeFormat " " [M, D]++dotDateMonth = makeFormat "." [D, M]+dashDateMonth = makeFormat "-" [M, D]+slashDateMonth = makeFormat "/" [M, D]++pAbsDateTime :: Stream s m Char => Int -> ParsecT s st m DateTime+pAbsDateTime year = do+ date <- pAbsDate year+ optional $ char ','+ s <- optionMaybe space+ case s of+ Nothing -> return $ DateTime date (TimeOfDay 0 0 0 0)+ Just _ -> do+ t <- pTime+ return $ DateTime date t++pAbsDate :: Stream s m Char => Int -> ParsecT s st m Date+pAbsDate year = choice $ map (try . dateInFormat year)+ [euroNumDate, americanDate, strDate, writtenDate, dashDate,+ dotDateMonth, dashDateMonth, slashDateMonth, spaceDate, spaceDateMD]++intervalToPeriod :: DateInterval -> Period+intervalToPeriod (Days ds) = mempty { periodDays = ds}+intervalToPeriod (Weeks ws) = mempty { periodDays = ws*7 }+intervalToPeriod (Months ms) = mempty { periodMonths = ms }+intervalToPeriod (Years ys) = mempty { periodYears = ys }++-- | Add date interval to DateTime+addInterval :: DateTime -> DateInterval -> DateTime+addInterval dt@DateTime {dtDate = date} interval =+ dt { dtDate = date `dateAddPeriod` intervalToPeriod interval }++-- | Negate DateInterval value: Days 3 -> Days (-3).+negateInterval :: DateInterval -> DateInterval+negateInterval (Days n) = Days (negate n)+negateInterval (Weeks n) = Weeks (negate n)+negateInterval (Months n) = Months (negate n)+negateInterval (Years n) = Years (negate n)++-- | Subtract DateInterval from DateTime.+minusInterval :: DateTime -> DateInterval -> DateTime+minusInterval date int = date `addInterval` negateInterval int++maybePlural :: Stream s m Char => String -> ParsecT s st m String+maybePlural str = do+ r <- string str+ optional $ char 's'+ return r++pDateIntervalType :: Stream s m Char => ParsecT s st m (Int -> DateInterval)+pDateIntervalType = do+ s <- choice $ map maybePlural ["day", "week", "month", "year"]+ case toLower (head s) of+ 'd' -> return Days+ 'w' -> return Weeks+ 'm' -> return Months+ 'y' -> return Years+ _ -> fail $ "Unknown date interval type: " ++ s++pDateInterval :: Stream s m Char => ParsecT s st m DateInterval+pDateInterval = do+ maybeN <- readMaybe <$> many1 digit++ case maybeN of+ Nothing -> fail "Noperino."+ Just n -> do+ spaces+ tp <- pDateIntervalType+ pure $ tp n++pRelDate :: Stream s m Char => Config -> ParsecT s st m DateTime+pRelDate c = do+ offs <- try futureDate+ <|> try passDate+ <|> try today+ <|> try tomorrow+ <|> yesterday+ return $ (c^.now) `addInterval` offs++lastDate :: Stream s m Char => Config -> ParsecT s st m DateTime+lastDate c = do+ string "last"+ spaces+ try byweek <|> try bymonth <|> byyear+ where+ startOfWeekDay' = c^.startOfWeekDay+ now' = c^.now+ byweek = do+ wd <- try (string "week" >> return startOfWeekDay') <|> pWeekDay+ let lastWeekStart = getStartOfThisWeek c `minusInterval` Weeks 1+ return $ lastWeekStart `addInterval` weekdayToInterval c wd++ bymonth = do+ string "month"+ let lastMonth = now' `minusInterval` Months 1+ return $ lastMonth { dtDate = (dtDate lastMonth) { dateDay = 1 } }++ byyear = do+ string "year"+ let lastYear = now' `minusInterval` Years 1+ return $ lastYear { dtDate = (dtDate lastYear) { dateMonth = January, dateDay = 1 } }++nextDate :: Stream s m Char => Config -> ParsecT s st m DateTime+nextDate c = do+ string "next"+ spaces+ try byweek <|> try bymonth <|> byyear+ where+ startOfWeekDay' = c^.startOfWeekDay+ now' = c^.now+ byweek = do+ wd <- try (string "week" >> return startOfWeekDay') <|> pWeekDay+ let nextWeekStart = getStartOfNextWeek c+ return $ nextWeekStart `addInterval` weekdayToInterval c wd++ bymonth = do+ string "month"+ let nextMonth = now' `addInterval` Months 1+ return nextMonth { dtDate = (dtDate nextMonth) { dateDay = 1 } }++ byyear = do+ string "year"+ let nextYear = now' `addInterval` Years 1+ return nextYear { dtDate = (dtDate nextYear) { dateMonth = January, dateDay = 1 } }++pWeekDay :: Stream s m Char => ParsecT s st m WeekDay+pWeekDay = do+ w <- many1 (oneOf "mondaytueswnhrfi")+ case uniqFuzzyMatch w :: Either [WeekDay] WeekDay of+ Left ds -> fail $ if null ds+ then "unknown weekday: " ++ w+ else "ambiguous weekday '" ++ w ++ "' could mean: " ++ intercalate " or " (map show ds)+ Right d -> return d++futureDate :: Stream s m Char => ParsecT s st m DateInterval+futureDate = do+ string "in "+ maybeN <- readMaybe <$> many1 digit++ case maybeN of+ Nothing -> fail "Noperino."+ Just n -> do+ char ' '+ tp <- pDateIntervalType+ pure $ tp n++passDate :: Stream s m Char => ParsecT s st m DateInterval+passDate = do+ maybeN <- readMaybe <$> many1 digit++ case maybeN of+ Nothing -> fail "Noperino."+ Just n -> do+ char ' '+ tp <- pDateIntervalType+ string " ago"+ pure $ tp $ negate n++today :: Stream s m Char => ParsecT s st m DateInterval+today = do+ string "today" <|> string "now"+ return $ Days 0++tomorrow :: Stream s m Char => ParsecT s st m DateInterval+tomorrow = do+ string "tomorrow"+ return $ Days 1++yesterday :: Stream s m Char => ParsecT s st m DateInterval+yesterday = do+ string "yesterday"+ return $ Days (-1)++pByWeek :: Stream s m Char => Config -> ParsecT s st m DateTime+pByWeek c =+ try (lastDate c) <|> nextDate c++-- | Parsec parser for DateTime.+pDateTime :: Stream s m Char+ => Config+ -> ParsecT s st m DateTime+pDateTime c =+ try (pRelDate c)+ <|> try (pByWeek c)+ <|> try (pAbsDateTime (dateYear (timeGetDate (c^.now))))++-- | Parsec parser for Date only.+pDate :: Stream s m Char+ => Config+ -> ParsecT s st m Date+pDate c =+ try (timeGetDate <$> pRelDate c)+ <|> try (timeGetDate <$> pByWeek c)+ <|> try (pAbsDate $ dateYear (timeGetDate (c^.now)))++-- | Parse date/time+parseDate :: Config+ -> String -- ^ String to parse+ -> Either ParseError Date+parseDate c = runParser (pDate c) () ""++-- | Parse date/time+parseDateTime :: Config+ -> String -- ^ String to parse+ -> Either ParseError DateTime+parseDateTime c = runParser (pDateTime c) () ""++-- | Same as extractDatesY, but will get the current year from the system, so you don't have to provide it.+extractDates :: String -> IO [Date]+extractDates str = do+ c <- defaultConfigIO++ pure $ extractDatesY (dateYear (timeGetDate (c ^. now))) str++-- | Extract dates from a string, with the first argument being the current year (used for things like "Jan 18").+--+-- >>> extractDatesY 2018 "The party will be on 6/9"+-- [Date 2018 June 9]+extractDatesY :: Int -> String -> [Date]+extractDatesY y str =+ case parse (extract (pAbsDate y)) "" str of+ Left err -> error $ show err+ Right dates -> dates++extract :: Stream s m Char => ParsecT s st m a -> ParsecT s st m [a]+extract parser = Text.Parsec.many loop+ where+ loop = try parser <|> (anyChar >> loop)+
+ src/Data/Dates/Parsing/Internal.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE FlexibleContexts #-}++module Data.Dates.Parsing.Internal where++import Data.Char (digitToInt, isDigit, toUpper, toLower, toUpper)+import Data.Hourglass+import Data.List (isPrefixOf, lookup)+import Data.Maybe (fromJust, catMaybes)+import Text.Parsec+import Text.Read (readMaybe)++-- | Parsers the parser at least once, but no more than n times.+takeN1 :: Stream s m Char => Int -> ParsecT s st m a -> ParsecT s st m [a]+takeN1 0 _ = error "n must not be 0!"+takeN1 1 parser = (:[]) <$> parser+takeN1 n parser = do+ v <- parser+ rest <- takeN1 (n - 1) parser <|> pure []+ pure $ v : rest++-- | Parse natural number of N digits which is not greater than M+number :: (Stream s m Char, Read a, Num a, Ord a)+ => Int -- ^ Number of digits+ -> a -- ^ Maximum value+ -> ParsecT s st m a+number n m = do+ maybeT <- readMaybe <$> takeN1 n digit+ case maybeT of+ Just t | t <= m -> pure t+ _ -> parserZero++pYear :: Stream s m Char => ParsecT s st m Int+pYear = do+ n <- try pYearNormal <|> pYearAny+ -- Assume two digit years are after 2000.+ -- TODO: Update in 82 years (2018-05-03).+ pure $ if n < 2000 && n < 100 && n >= 10 then n + 2000 else n++pYearNormal :: Stream s m Char => ParsecT s st m Int+pYearNormal = do+ n <- read <$> many1 digit++ notFollowedBy (try (spaces >> yearAbbreviations) <|> (digit >> pure ""))++ pure n++readNum :: (Num a, Stream s m Char) => ParsecT s st m a+readNum = do+ isNegative <- optionMaybe $ char '-'+ digits <- many1 digit++ let sign = maybe 1 (const (-1)) isNegative++ pure $ sign * fromInteger (read digits)++yearAbbreviations :: Stream s m Char => ParsecT s st m String+yearAbbreviations = choice $ map (try . abbParser) ["BCE", "AD", "CE", "BC"]+ where+ abbParser :: Stream s m Char => String -> ParsecT s st m String+ abbParser abbr = parseAs (concatMap casings $ makeAbbr abbr) abbr++makeAbbr :: String -> [String]+makeAbbr abb = [abb, foldl (\cur n -> cur ++ [n] ++ ".") "" abb]++pYearAny :: Stream s m Char => ParsecT s st m Int+pYearAny = do+ spaces+ -- Allow abbreviations before or after.+ prefix <- optionMaybe yearAbbreviations++ spaces+ n <- readNum+ spaces++ suffix <- optionMaybe yearAbbreviations++ let isBC = case catMaybes [prefix, suffix] of+ (abb:_) -> abb == "BC" || abb == "BCE"+ [] -> False++ pure $ if isBC then -n else n++monthAssoc :: [(String, Month)]+monthAssoc = [("january", January), ("jan", January), ("february", February), ("feb", February),+ ("march", March), ("mar", March), ("april", April), ("apr", April),+ ("may", May), ("june", June), ("jun", June), ("july", July), ("july", July),+ ("august", August), ("aug", August), ("september", September), ("sept", September),+ ("october", October), ("oct", October), ("november", November), ("nov", November),+ ("december", December), ("dec", December)]++casings :: String -> [String]+casings [] = []+casings str@(f:rest) = [str, map toLower str, map toUpper str, toUpper f : rest]++-- | Parse various capitalizations of the given string, but always return the same string on success.+parseAs :: Stream s m Char => [String] -> String -> ParsecT s st m String+parseAs options str = do+ _ <- choice $ map (try . string) options++ optional $ char '.'++ pure str++pMonthName :: Stream s m Char => ParsecT s st m Month+pMonthName = do+ monthName <- choice $ map (\(name,_) -> try $ parseAs (casings name) name) monthAssoc++ -- Safe because month names come from monthAssoc+ return $ fromJust $ lookup monthName monthAssoc++pMonth :: Stream s m Char => ParsecT s st m Month+pMonth = try (toEnum . pred <$> number 2 12) <|>+ pMonthName++pDay :: Stream s m Char => ParsecT s st m Int+pDay = number 2 31++uppercase :: String -> String+uppercase = map toUpper++-- | Case-insensitive version of 'isPrefixOf'+isPrefixOfI :: String -> String -> Bool+p `isPrefixOfI` s = uppercase p `isPrefixOf` uppercase s++-- | Use a data type's Bounded, Enum and Show instances to determine if the+-- given string uniquely matches a constructor. The comparison is+-- case-insensitive and starts from the beginning of the strings (so a partial+-- constructor name can still match if there are enough characters for a+-- unique match)+--+-- For example:+--+-- @+-- data Things = Foo | Bar | Baz deriving (Bounded, Enum, Show)+--+-- -- Right Foo+-- uniqFuzzyMatch "f" :: Either [Things] Things+--+-- -- Left [Bar, Baz]+-- uniqFuzzyMatch "ba" :: Either [Things] Things+-- @+uniqFuzzyMatch :: (Bounded a, Enum a, Show a)+ => String+ -> Either [a] a -- ^ Either collection of matches or the unique match+uniqFuzzyMatch n =+ case matches of+ [match] -> Right match+ _ -> Left matches+ where+ possibilities = [minBound..maxBound]+ matches = filter (isPrefixOfI n . show) possibilities+
+ test/Spec.hs view
@@ -0,0 +1,129 @@+module Main where++import Data.Hourglass+import Data.Dates.Parsing+import Test.Hspec+import Text.Parsec (parse)++testConfig :: Config+testConfig = defaultConfig testDateTime++testDate :: Date+testDate = Date 2015 March 14++testTimeOfDay :: TimeOfDay+testTimeOfDay = TimeOfDay 3 1 4 0++testDateTime :: DateTime+testDateTime = DateTime testDate testTimeOfDay++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "weekdayToInterval" $+ it "should consider the configured day as the start of the week" $ do+ weekdayToInterval testConfig { _startOfWeekDay = Monday } Monday `shouldBe` Days 0+ weekdayToInterval testConfig { _startOfWeekDay = Sunday } Monday `shouldBe` Days 1++ describe "getStartOfThisWeek" $ do+ it "gives the preceding Monday when Monday is the week start" $+ getStartOfThisWeek testConfig+ `shouldBe` testDateTime { dtDate = Date 2015 March 9 }++ it "gives the preceding Sunday when Sunday is the week start" $+ getStartOfThisWeek testConfig { _startOfWeekDay = Sunday }+ `shouldBe` testDateTime { dtDate = Date 2015 March 8 }++ describe "getStartOfNextWeek" $ do+ it "gives the next Monday when Monday is the week start" $+ getStartOfNextWeek testConfig+ `shouldBe` testDateTime { dtDate = Date 2015 March 16 }++ it "gives the next Sunday when Sunday is the week start" $+ getStartOfNextWeek testConfig { _startOfWeekDay = Sunday }+ `shouldBe` testDateTime { dtDate = Date 2015 March 15 }++ describe "lastDate" $ do+ mapM_+ (\(str, ans) ->+ it ("understands '" ++ str ++ "'") (parse (lastDate testConfig) "" str `shouldBe` Right ans)+ )+ [+ ("last week", testDateTime { dtDate = (dtDate testDateTime) { dateDay = 2 } })+ , ("last month", testDateTime { dtDate = (dtDate testDateTime) { dateMonth = February, dateDay = 1 } })+ , ("last year", testDateTime { dtDate = (dtDate testDateTime) { dateYear = 2014, dateMonth = January, dateDay = 1 } })+ ]++ it "understands 'last week' using configured week start" $+ parse+ (lastDate testConfig { _startOfWeekDay = Sunday })+ ""+ "last week"+ `shouldBe` Right testDateTime { dtDate = (dtDate testDateTime) { dateDay = 1 } }++ it "understands 'last thursday' as last week's Thursday when 'now' is Friday" $+ parse+ (lastDate testConfig { _now = testDateTime { dtDate = (dtDate testDateTime) { dateDay = 13 } } })+ ""+ "last thursday"+ `shouldBe` Right testDateTime { dtDate = (dtDate testDateTime) { dateDay = 5 } }++ describe "nextDate" $ do+ mapM_+ (\(str, ans) ->+ it ("understands '" ++ str ++ "'") (parse (nextDate testConfig) "" str `shouldBe` Right ans)+ )+ [+ ("next week", testDateTime { dtDate = (dtDate testDateTime) { dateDay = 16 } })+ , ("next month", testDateTime { dtDate = (dtDate testDateTime) { dateMonth = April, dateDay = 1 } })+ , ("next year", testDateTime { dtDate = (dtDate testDateTime) { dateYear = 2016, dateMonth = January, dateDay = 1 } })+ ]++ it "understands 'next week' using configured week start" $+ parse+ (nextDate testConfig { _startOfWeekDay = Sunday })+ ""+ "next week"+ `shouldBe` Right testDateTime { dtDate = (dtDate testDateTime) { dateDay = 15 } }++ it "understands 'next thursday' as next week's Thursday when 'now' is Monday" $+ parse+ (nextDate testConfig { _now = testDateTime { dtDate = (dtDate testDateTime) { dateDay = 9 } } })+ ""+ "next thursday"+ `shouldBe` Right testDateTime { dtDate = (dtDate testDateTime) { dateDay = 19 } }++ describe "parseDate" $+ mapM_+ (\(str, ans) ->+ it ("understands '" ++ str ++ "'") (parseDate testConfig str `shouldBe` Right ans)+ )+ [+ ("today", testDate)+ , ("tomorrow", testDate { dateDay = 15 })+ , ("yesterday", testDate { dateDay = 13 })+ , ("in 2 days", testDate { dateDay = 16 })+ , ("in 3 weeks", Date 2015 April 4)+ , ("1 week ago", testDate { dateDay = 7 })+ , ("next friday", testDate { dateDay = 20 })+ , ("next year", Date 2016 January 1)+ , ("12 September 2012", Date 2012 September 12)+ , ("12 September 12", Date 2012 September 12)+ , ("12.09.2012", Date 2012 September 12)+ , ("January 1, 2017", Date 2017 January 1)+ , ("apr. 8, 15", Date 2015 April 8)+ , ("july 30, BC 82", Date (-82) July 30)+ , ("aug 15, 7 AD", Date 7 August 15)+ , ("2017-08-09", Date 2017 August 9)+ , ("DECEMBER 8, -9", Date (-9) December 8)+ ]++ describe "extractDatesY" $+ mapM_ (\(str, ans) -> it ("understands '" ++ str ++ "'") (extractDatesY 2018 str `shouldBe` ans))+ [ ("2017-08-9", [Date 2017 August 9])+ , ("Jan 19", [Date 2018 January 19])+ , ("The party will be on 6/9", [Date 2018 June 9])+ , ("Start: November 27, 1993\nEnd: December 5, 1993", [Date 1993 November 27, Date 1993 December 5])]+