hourglass-fuzzy-parsing (empty) → 0.1.0.0
raw patch · 7 files changed
+568/−0 lines, 7 filesdep +basedep +hourglassdep +parsecsetup-changed
Dependencies added: base, hourglass, parsec
Files
- CHANGELOG.markdown +3/−0
- Data/Hourglass/FuzzyParsing.hs +379/−0
- Data/Hourglass/FuzzyParsing/Internal.hs +93/−0
- LICENSE +30/−0
- README.markdown +30/−0
- Setup.hs +2/−0
- hourglass-fuzzy-parsing.cabal +31/−0
+ CHANGELOG.markdown view
@@ -0,0 +1,3 @@+## 0.1.0.0 (2015-07-23)++Initial fork from the [dates package](https://hackage.haskell.org/package/dates).
+ Data/Hourglass/FuzzyParsing.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | Parse strings that aren't so precise+module Data.Hourglass.FuzzyParsing+ (+ DateTime (..)+ , Time (..)+ , parseDate+ , parseDateTime+ , pDate+ , pDateTime+ , pTime+ , pDateInterval+ , tryRead+ , tryReadInt+ , DateIntervalType (..)+ , DateInterval (..)+ , weekdayToInterval+ , dateWeekDay+ , lastMonday+ , nextMonday+ , addInterval+ , negateInterval+ , minusInterval+ ) where++import Data.Char (toLower)+import Data.Data (Data, Typeable)+import Data.Hourglass+import Data.List (intercalate)+import Text.Parsec++import Data.Hourglass.FuzzyParsing.Internal++data DateIntervalType = Day | Week | Month | Year+ deriving (Eq,Show,Read,Data,Typeable)++data DateInterval = Days Int+ | Weeks Int+ | Months Int+ | Years Int+ deriving (Eq,Show,Data,Typeable)++deriving instance Bounded Month+deriving instance Bounded WeekDay++-- TODO: Hourglass weekday starts on Sunday+-- | Weekday as interval from Monday, so that+-- weekdayToInterval Monday == 0 and+-- weekdayToInterval Sunday == 6.+weekdayToInterval :: WeekDay -> DateInterval+weekdayToInterval wd = Days (fromIntegral $ fromEnum wd)++lastMonday :: DateTime -> DateTime+lastMonday dt = dt `minusInterval` weekdayToInterval (dateWeekDay dt)++nextMonday :: DateTime -> DateTime+nextMonday dt = lastMonday dt `addInterval` Weeks 1++-- | Get weekday of given date.+dateWeekDay :: DateTime -> WeekDay+dateWeekDay = getWeekDay . timeGetDate++lookupMonth :: String -> Either [Month] Month+lookupMonth = uniqFuzzyMatch++euroNumDate :: Stream s m Char => ParsecT s st m Date+euroNumDate = do+ d <- pDay+ char '.'+ m <- pMonth+ char '.'+ y <- pYear+ return $ Date y m d++americanDate :: Stream s m Char => ParsecT s st m Date+americanDate = do+ y <- pYear+ char '/'+ m <- pMonth+ char '/'+ d <- pDay+ return $ Date y m d++euroNumDate' :: Stream s m Char => Int -> ParsecT s st m Date+euroNumDate' year = do+ d <- pDay+ char '.'+ m <- pMonth+ return $ Date year m d++americanDate' :: Stream s m Char => Int -> ParsecT s st m Date+americanDate' year = do+ m <- pMonth+ char '/'+ d <- pDay+ return $ Date year m d++strDate :: Stream s m Char => ParsecT s st m Date+strDate = do+ d <- pDay+ space+ ms <- many1 letter+ case lookupMonth ms of+ Left ms' -> fail $ if null ms'+ then "unknown month: " ++ ms+ else "ambiguous month '" ++ ms ++ "' could be: " ++ intercalate " or " (map show ms')+ Right m -> do+ space+ y <- pYear+ notFollowedBy $ char ':'+ return $ Date y m d++strDate' :: Stream s m Char => Int -> ParsecT s st m Date+strDate' year = do+ d <- pDay+ space+ ms <- many1 letter+ case lookupMonth ms of+ Left ms' -> fail $ if null ms'+ then "unknown month: " ++ ms+ else "ambiguous month '" ++ ms ++ "' could be: " ++ intercalate " or " (map show ms')+ Right m -> return $ Date year m d++time24 :: Stream s m Char => ParsecT s st m TimeOfDay+time24 = do+ h <- number 2 23+ 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++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"++time12 :: Stream s m Char => ParsecT s st m TimeOfDay+time12 = do+ h <- number 2 12+ char ':'+ m <- number 2 59+ x <- optionMaybe $ char ':'+ s <- case x of+ Nothing -> return 0+ Just _ -> number 2 59+ optional space+ hd <- ampm+ return $ TimeOfDay (h + fromIntegral hd) m s 0++pTime :: Stream s m Char => ParsecT s st m TimeOfDay+pTime = choice $ map try [time12, time24]++pAbsDateTime :: Stream s m Char => Int -> ParsecT s st m DateTime+pAbsDateTime year = do+ date <- choice $ map try $ map ($ year) $+ [+ const euroNumDate+ , const americanDate+ , const strDate+ , strDate'+ , euroNumDate'+ , americanDate'+ ]+ 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 $ map ($ year) $+ [+ const euroNumDate+ , const americanDate+ , const strDate+ , strDate'+ , euroNumDate'+ , americanDate'+ ]++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 DateIntervalType+pDateIntervalType = do+ s <- choice $ map maybePlural ["day", "week", "month", "year"]+ case toLower (head s) of+ 'd' -> return Day+ 'w' -> return Week+ 'm' -> return Month+ 'y' -> return Year+ _ -> fail $ "Unknown date interval type: " ++ s++pDateInterval :: Stream s m Char => ParsecT s st m DateInterval+pDateInterval = do+ n <- many1 digit+ spaces+ tp <- pDateIntervalType+ case tp of+ Day -> Days `fmap` tryReadInt n+ Week -> Weeks `fmap` tryReadInt n+ Month -> Months `fmap` tryReadInt n+ Year -> Years `fmap` tryReadInt n++pRelDate :: Stream s m Char => DateTime -> ParsecT s st m DateTime+pRelDate date = do+ offs <- try futureDate+ <|> try passDate+ <|> try today+ <|> try tomorrow+ <|> yesterday+ return $ date `addInterval` offs++lastDate :: Stream s m Char => DateTime -> ParsecT s st m DateTime+lastDate now = do+ string "last"+ spaces+ try byweek <|> try bymonth <|> byyear+ where+ byweek = do+ wd <- try (string "week" >> return Monday) <|> pWeekDay+ let monday = lastMonday now+ monday' = if wd > dateWeekDay now+ then monday `minusInterval` Weeks 1+ else monday+ return $ monday' `addInterval` weekdayToInterval wd++ bymonth = do+ string "month"+ return $ now { dtDate = (dtDate now) { dateDay = 1 } }++ byyear = do+ string "year"+ return $ now { dtDate = (dtDate now) { dateMonth = January, dateDay = 1 } }++nextDate :: Stream s m Char => DateTime -> ParsecT s st m DateTime+nextDate now = do+ string "next"+ spaces+ try byweek <|> try bymonth <|> byyear+ where+ byweek = do+ wd <- try (string "week" >> return Monday) <|> pWeekDay+ let monday = nextMonday now+ monday' = if wd > dateWeekDay now+ then monday `minusInterval` Weeks 1+ else monday+ return $ monday' `addInterval` weekdayToInterval 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 "+ n <- many1 digit+ char ' '+ tp <- pDateIntervalType+ case tp of+ Day -> Days `fmap` tryReadInt n+ Week -> Weeks `fmap` tryReadInt n+ Month -> Months `fmap` tryReadInt n+ Year -> Years `fmap` tryReadInt n++passDate :: Stream s m Char => ParsecT s st m DateInterval+passDate = do+ n <- many1 digit+ char ' '+ tp <- pDateIntervalType+ string " ago"+ case tp of+ Day -> (Days . negate) `fmap` tryReadInt n+ Week -> (Weeks . negate) `fmap` tryReadInt n+ Month -> (Months . negate) `fmap` tryReadInt n+ Year -> (Years . negate) `fmap` tryReadInt 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 => DateTime -> ParsecT s st m DateTime+pByWeek date =+ try (lastDate date) <|> nextDate date++-- | Parsec parser for DateTime.+pDateTime :: Stream s m Char+ => DateTime -- ^ Current date / time, to use as base for relative dates+ -> ParsecT s st m DateTime+pDateTime date =+ (try $ pRelDate date)+ <|> (try $ pByWeek date)+ <|> (try $ pAbsDateTime $ dateYear (timeGetDate date))++-- | Parsec parser for Date only.+pDate :: Stream s m Char+ => DateTime -- ^ Current date / time, to use as base for relative dates+ -> ParsecT s st m Date+pDate date =+ (try $ timeGetDate <$> pRelDate date)+ <|> (try $ timeGetDate <$> pByWeek date)+ <|> (try $ pAbsDate $ dateYear (timeGetDate date))++-- | Parse date/time+parseDate :: DateTime -- ^ Current date / time, to use as base for relative dates+ -> String -- ^ String to parse+ -> Either ParseError Date+parseDate date s = runParser (pDate date) () "" s++-- | Parse date/time+parseDateTime :: DateTime -- ^ Current date / time, to use as base for relative dates+ -> String -- ^ String to parse+ -> Either ParseError DateTime+parseDateTime date s = runParser (pDateTime date) () "" s
+ Data/Hourglass/FuzzyParsing/Internal.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE FlexibleContexts #-}++module Data.Hourglass.FuzzyParsing.Internal where++import Data.Char (digitToInt, isDigit, toUpper)+import Data.Hourglass (Month)+import Data.List (isPrefixOf)++import Text.Parsec++-- | Parser version of Prelude.read+tryRead :: (Read a, Stream s m Char) => String -> ParsecT s st m a+tryRead str =+ case reads str of+ [(res, "")] -> return res+ _ -> fail $ "Cannot read: " ++ str++tryReadInt :: (Stream s m Char, Num a) => String -> ParsecT s st m a+tryReadInt str =+ if all isDigit str+ then return $ fromIntegral $ foldl (\a b -> 10*a+b) 0 $ map digitToInt str+ else fail $ "Cannot read: " ++ str++-- | Apply parser N times+times :: (Stream s m Char)+ => Int+ -> ParsecT s st m t+ -> ParsecT s st m [t]+times 0 _ = return []+times n p = do+ ts <- times (n - 1) p+ t <- optionMaybe p+ case t of+ Just t' -> return (ts ++ [t'])+ Nothing -> return ts++-- | Parse natural number of N digits which is not greater than M+number :: (Stream s m Char, Num a, Ord a)+ => Int -- ^ Number of digits+ -> a -- ^ Maximum value+ -> ParsecT s st m a+number n m = do+ t <- tryReadInt =<< (n `times` digit)+ if t > m+ then fail "number too large"+ else return t++pYear :: Stream s m Char => ParsecT s st m Int+pYear = do+ y <- number 4 10000+ if y < 2000+ then return (y + 2000)+ else return y++pMonth :: Stream s m Char => ParsecT s st m Month+pMonth = toEnum . pred <$> number 2 12++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 = if length matches == 1+ then Right (head matches)+ else Left matches+ where+ possibilities = [minBound..maxBound]+ matches = filter (isPrefixOfI n . show) possibilities
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, IlyaPortnov++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 IlyaPortnov 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.markdown view
@@ -0,0 +1,30 @@+# Hourglass Fuzzy Parsing++A small package for parsing more human friendly date/time formats into+[hourglass types](https://hackage.haskell.org/package/hourglass). Relative+things like:++* "today", "tomorrow", "yesterday"+* "in 2 days", "3 weeks ago"+* "last monday", "next friday"+* "last month" (1st of this month), "next year" (1st of January of next year)++And absolute things like:++* DD.MM.YYYY+* YYYY/MM/DD+* "12 September 2012 23:12"++4-digits years may be abbreviated (such as 12 for 2012). Both 12-hour and+24-hour time formats are supported, though only for absolute things currently.+Relative times only support offsets of days, weeks, months or years currently.+Only English words and sentence structure are supported.++Originally based on the [dates package](https://hackage.haskell.org/package/dates).+++## TODOs++* Support `<date> at <time>`, e.g., `yesterday at 5 pm`+* Support seconds, minutes, and hours for relative times, e.g., "10 minutes ago"+* Write some tests and benchmarks
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hourglass-fuzzy-parsing.cabal view
@@ -0,0 +1,31 @@+name: hourglass-fuzzy-parsing+version: 0.1.0.0+synopsis: A small library for parsing more human friendly date/time formats.+description: This package parses many different date/time formats.+ Both absolute and relative dates are supported. See the+ README for more.+homepage: https://gitlab.com/doshitan/hourglass-fuzzy-parsing+license: BSD3+license-file: LICENSE+author: IlyaPortnov, Tanner Doshier <doshitan@gmail.com>+maintainer: Tanner Doshier <doshitan@gmail.com>+category: Time, Parsing+build-type: Simple+cabal-version: >=1.8++extra-source-files: README.markdown+ , CHANGELOG.markdown++library+ exposed-modules: Data.Hourglass.FuzzyParsing+ , Data.Hourglass.FuzzyParsing.Internal++ build-depends: base >= 4 && < 5+ , hourglass+ , parsec >= 3.1++ GHC-Options: -Wall -fno-warn-unused-do-bind++source-repository head+ type: git+ location: git://gitlab.com/doshitan/hourglass-fuzzy-parsing.git