timeparsers (empty) → 0.3
raw patch · 11 files changed
+823/−0 lines, 11 filesdep +attoparsecdep +basedep +bytestringsetup-changed
Dependencies added: attoparsec, base, bytestring, containers, convertible, mtl, time
Files
- Data/Time/Parsers.hs +27/−0
- Data/Time/Parsers/Date.hs +227/−0
- Data/Time/Parsers/Tables.hs +74/−0
- Data/Time/Parsers/Time.hs +71/−0
- Data/Time/Parsers/Timestamp.hs +144/−0
- Data/Time/Parsers/Types.hs +96/−0
- Data/Time/Parsers/Util.hs +112/−0
- LICENSE +30/−0
- README +2/−0
- Setup.hs +2/−0
- timeparsers.cabal +38/−0
+ Data/Time/Parsers.hs view
@@ -0,0 +1,27 @@+module Data.Time.Parsers ( -- * Utility functions+ fromExtendedTimestamp+ , fromExtendedTimestampIO+ , withOptions+ , withDefaultOptions+ , parseWithOptions+ , parseWithDefaultOptions+ , defaultOptions+ -- * Date Parsers+ , module Data.Time.Parsers.Date+ -- * Time Parsers+ , module Data.Time.Parsers.Time+ -- * Timestamp Parsers+ , module Data.Time.Parsers.Timestamp+ -- * Data Types+ , module Data.Time.Parsers.Types+ ) where++import Data.Time.Parsers.Date++import Data.Time.Parsers.Time++import Data.Time.Parsers.Timestamp++import Data.Time.Parsers.Types++import Data.Time.Parsers.Util
+ Data/Time/Parsers/Date.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}++module Data.Time.Parsers.Date ( yyyymmdd+ , yymmdd+ , tokenizedDate+ , fullDate+ , yearDayOfYear+ , julianDay+ , defaultDay+ , defaultDayCE+ ) where++import Data.Time.Parsers.Util+import Data.Time.Parsers.Tables (weekdays, months)++import Control.Applicative ((<$>),(<*>),(<|>))+import Control.Monad.Reader+import Data.Attoparsec.Char8+import qualified Data.ByteString.Char8 as B+import Data.Char (toLower)+import Data.Map as M hiding (map)+import Data.Time+import Prelude hiding (takeWhile)+++lookupMonth :: B.ByteString -> Maybe Integer+lookupMonth = flip M.lookup months . B.map toLower++makeDate :: forall (m :: * -> *). Monad m =>+ DateToken -> DateToken -> DateToken -> DateFormat -> m Day+makeDate a b c f = case (a, b, c) of+ (Year y, m, Any d) -> ymd y m d f+ (Month m, Any d, y) -> mdy m d y f+ (Any d, Month m, Year y) -> if (f==DMY)+ then (makeDate' y m d)+ else fail'+ (Any p, Month m, Any q) -> case f of+ YMD -> makeDate' p m q+ MDY -> fail'+ DMY -> makeDate' q m p+ (Any p, Any q, Year y) -> case f of+ YMD -> fail'+ MDY -> makeDate' y p q+ DMY -> makeDate' y q p+ (Any p, Any q, Any r) -> case f of+ YMD -> makeDate' p q r+ MDY -> makeDate' r p q+ DMY -> makeDate' r q p+ _ -> fail'+ where+ ymd y (Month m) d YMD = makeDate' y m d+ ymd y (Any m) d YMD = makeDate' y m d+ ymd _ _ _ _ = fail'+ mdy m d (Year y) MDY = makeDate' y m d+ mdy m d (Any y) MDY = makeDate' y m d+ mdy _ _ _ _ = fail'+ fail' = fail "Unsupported Date Format"+ makeDate' y m d = if validDate y m d+ then return $ fromGregorian' y m d+ else fail "Invalid date range"+ validDate y m' d' = let m = fromIntegral m'+ d = fromIntegral d'+ in and [ m > 0+ , d > 0+ , m <= 12+ , d <= (gregorianMonthLength y m)+ ]+ fromGregorian' y m d = fromGregorian y (fromIntegral m) (fromIntegral d)++forceRecent :: Day -> Day+forceRecent day | y < 100 && y < 70 = addGregorianYearsClip 2000 day+ | y < 100 = addGregorianYearsClip 1900 day+ | otherwise = day+ where+ (y,_,_) = toGregorian day++tryFormats :: forall (m :: * -> *). MonadPlus m =>+ [DateFormat] -> (DateFormat -> m Day) -> m Day+tryFormats fs d = (msum $ Prelude.map d fs)++yearDayToDate :: forall (m:: * -> *). Monad m =>+ Integer -> Integer -> m Day+yearDayToDate year day = if (day <= lastDay && day > 0)+ then return . addDays (day - 1) $+ fromGregorian year 0 0+ else fail "Invalid Day of Year"+ where+ lastDay = if isLeapYear year then 366 else 365++--Date Parsers++skipWeekday :: Parser ()+skipWeekday = option () $+ ( choice $ map stringCI weekdays ) >>+ (option undefined $ char ',') >>+ skipSpace++-- | parse a date with no separators of the format yyyymmdd.+-- Will treat a preceding weekday as noise.+yyyymmdd :: OptionedParser Day+yyyymmdd = lift yyyymmdd'++yyyymmdd' :: Parser Day+yyyymmdd' = skipWeekday >>+ (fromGregorianValid <$> nDigit 4 <*> nDigit 2 <*> nDigit 2) >>=+ maybe (fail "Invalid Date Range") return++-- | parse a date with no separators of the format yymmdd.+-- Will treat a preceding weekday as noise+yymmdd :: OptionedParser Day+yymmdd = isFlagSet MakeRecent >>= lift . yymmdd'++yymmdd' :: Bool -> Parser Day+yymmdd' mr =+ skipWeekday >>+ (fromGregorianValid <$> nDigit 2 <*> nDigit 2 <*> nDigit 2) >>=+ maybe (fail "Invalid Date Range") return'+ where+ return' = if mr then return . forceRecent else return++-- | parse a date formatted as three values separated by some separator+-- values can be month names, abbreviations, or numeric values. Numeric values+-- with more than two digits are assumed to represent years.++numericDateToken :: Parser DateToken+numericDateToken = tokenize <$> takeWhile1 isDigit+ where+ tokenize bs = if B.length bs > 2+ then Year . read $ B.unpack bs+ else Any . read $ B.unpack bs++namedMonthToken :: Parser DateToken+namedMonthToken = (lookupMonth <$> takeWhile isAlpha_ascii) >>=+ maybe (fail "Invalid Month") (return . Month)++dateToken :: Parser DateToken+dateToken = numericDateToken <|> namedMonthToken++tokenizedDate :: OptionedParser Day+tokenizedDate = do+ s <- asks seps+ f <- asks formats+ m <- isFlagSet MakeRecent+ lift $ tokenizedDate' s f m++tokenizedDate' :: String -> [DateFormat] -> Bool -> Parser Day+tokenizedDate' seps' formats' makeRecent' = do+ a <- dateToken+ sep <- satisfy $ inClass seps'+ b <- dateToken+ _ <- satisfy (==sep)+ c <- numericDateToken+ let noYear (Year _) = False+ noYear _ = True+ noExplicitYear = and . map noYear $ [a,b,c]+ date <- tryFormats formats' =<< (return $ makeDate a b c)+ if (makeRecent' && noExplicitYear)+ then return $ forceRecent date+ else return date+++-- | parse a date such as "January 1, 2011".+-- Will treat a preceding weekday as noise+fullDate :: OptionedParser Day+fullDate = isFlagSet MakeRecent >>= lift . fullDate'++fullDate' :: Bool -> Parser Day+fullDate' makeRecent' = do+ skipWeekday+ month <- maybe mzero (return . Month) <$>+ lookupMonth =<< (takeWhile isAlpha_ascii)+ _ <- space+ day <- numericDateToken+ _ <- string ", "+ year <- numericDateToken+ let forceRecent' = if (noYear year && makeRecent')+ then forceRecent+ else id+ forceRecent' <$> makeDate month day year MDY+ where+ noYear (Year _) = False+ noYear _ = True+-- | parse a date in year, day of year format+-- i.e yyyy/ddd or yyyydd+yearDayOfYear :: OptionedParser Day+yearDayOfYear = do+ s <- asks seps+ lift $ yearDayOfYear' s++yearDayOfYear' :: String -> Parser Day+yearDayOfYear' seps' = do+ year <- nDigit 4+ day <- maybeSep >> nDigit 3+ yearDayToDate year day+ where+ maybeSep = option () $ satisfy (inClass seps') >> return ()++-- | parse a julian day (days since 4713/1/1 BCE)+-- Must prepend with "J", "JD", or "Julian"+julianDay :: OptionedParser Day+julianDay = lift julianDay'++julianDay' :: Parser Day+julianDay' = skipWeekday >>+ (string "Julian" <|> string "JD" <|> string "J") >>+ julianDay'' <$> signed decimal+ where+ julianDay'' n = ModifiedJulianDay $ n - 2399963++-- | parse a date using tokenizedDate, yyyymmdd, yymmdd, yearDayOfYear, fullDate+-- or julianDay, converting to BCE if necessary+defaultDay :: OptionedParser Day+defaultDay = do date <- defaultDayCE+ bce <- isBCE+ if bce then makeBCE date else return date++-- | Parse a date as in defaultDay, but don't check for BCE+defaultDayCE :: OptionedParser Day+defaultDayCE = tokenizedDate <|>+ yyyymmdd <|>+ yearDayOfYear <|>+ yymmdd <|>+ fullDate <|>+ julianDay
+ Data/Time/Parsers/Tables.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections#-}++module Data.Time.Parsers.Tables ( weekdays+ , months+ , timeZones+ , ausTimeZones+ ) where++import Data.ByteString.Char8 (ByteString, unpack)+import Data.Map hiding (map)+import Data.Time (TimeZone(..))++weekdays :: [ByteString]+weekdays = [ "Monday", "Mon"+ , "Tuesday", "Tue", "Tues"+ , "Wednesday", "Wed", "Weds"+ , "Thursday", "Thu", "Thur", "Thurs"+ , "Friday", "Fri"+ , "Saturday", "Sat"+ , "Sunday", "Sun"+ ]++months :: Map ByteString Integer+months = fromList [ ("january", 1), ("jan", 1)+ , ("february", 2), ("feb", 2)+ , ("march", 3), ("mar", 3)+ , ("april", 4), ("apr", 4)+ , ("may", 5)+ , ("june", 6), ("jun", 6)+ , ("july", 7), ("jul", 7)+ , ("august", 8), ("aug", 8)+ , ("september", 9), ("sep", 9), ("sept", 9)+ , ("october", 10), ("oct", 10)+ , ("november", 11), ("nov", 11)+ , ("december", 12), ("dec", 12)+ ]++mkTimeZone :: (ByteString, Int) -> (ByteString, TimeZone)+mkTimeZone (name, minutes) = (name,) . TimeZone minutes False $ unpack name++timeZones :: Map ByteString TimeZone+timeZones = fromList . map mkTimeZone $+ [ ("NZDT",780), ("IDLE",720), ("NZST",720), ("NZT",720)+ , ("AESST",660), ("ACSST",630), ("CADT",630), ("SADT",630)+ , ("AEST",600), ("EAST",600), ("GST",600), ("LIGT",600)+ , ("SAST",570), ("CAST",570), ("AWSST",540), ("JST",540)+ , ("KST",540), ("MHT",540), ("WDT",540), ("MT",510)+ , ("AWST",480), ("CCT",480), ("WADT",480), ("WST",480)+ , ("JT",450), ("ALMST",420), ("WAST",420), ("CXT",420)+ , ("MMT",390), ("ALMT",360), ("MAWT",360), ("IOT",300)+ , ("MVT",300), ("TFT",300), ("AFT",270), ("EAST",240)+ , ("MUT",240), ("RET",240), ("SCT",240), ("IRT",180)+ , ("IT",210), ("EAT",180), ("BT",180), ("EETDST",180)+ , ("HMT",180), ("BDST",120), ("CEST",120), ("CETDST",120)+ , ("EET",120), ("FWT",120), ("IST",120), ("MEST",120)+ , ("METDST",120), ("SST",120), ("BST",60), ("CET",60)+ , ("DNT",60), ("FST",60), ("MET",60), ("MEWT",60)+ , ("MEZ",60), ("NOR",60), ("SET",60), ("SWT",60)+ , ("WETDST",60), ("GMT",0), ("UT",0), ("UTC",0)+ , ("Z",0), ("ZULU",0), ("WET",0), ("WAT",-60)+ , ("FNST",-60), ("FNT",-120), ("BRST",-120), ("NDT",-150)+ , ("ADT",-180), ("AWT",-180), ("BRT",-180), ("NFT",-210)+ , ("NST",-210), ("AST",-240), ("ACST",-240), ("EDT",-240)+ , ("ACT",-300), ("CDT",-300), ("EST",-300), ("CST",-360)+ , ("MDT",-360), ("MST",-420), ("PDT",-420), ("AKDT",-480)+ , ("PST",-480), ("YDT",-480), ("AKST",-540), ("HDT",-540)+ , ("YST",-540), ("MART",-570), ("AHST",-600), ("HST",-600)+ , ("CAT",-600), ("NT",-660), ("IDLW",-720)+ ]++ausTimeZones :: Map ByteString TimeZone+ausTimeZones = fromList . map mkTimeZone $+ [("ACST",570), ("CST", 630), ("EST",600), ("SAT",570)]
+ Data/Time/Parsers/Time.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Time.Parsers.Time ( twelveHour+ , twentyFourHour+ , defaultTimeOfDay+ ) where++import Data.Time.Parsers.Util++import Control.Applicative ((<$>),(<*>),(<|>))+import Control.Monad.Reader+import qualified Data.ByteString.Char8 as B+import Data.Attoparsec.Char8+import Data.Char (toUpper)+import Data.Fixed (Pico)+import Data.Time+import Prelude hiding (takeWhile)++--Time Parsers++parsePico :: Parser Pico+parsePico = (+) <$> (fromInteger <$> decimal) <*> (option 0 postradix)+ where+ postradix = do+ _ <- char '.'+ bs <- takeWhile isDigit+ let i = fromInteger . read . B.unpack $ bs+ l = B.length bs+ return (i/10^l)++-- | Parse a TimeOfDay in twelve hour format+twelveHour :: OptionedParser TimeOfDay+twelveHour = lift twelveHour'++twelveHour' :: Parser TimeOfDay+twelveHour' = do+ h' <- (nDigit 2 <|> nDigit 1)+ m <- option 0 $ char ':' >> nDigit 2+ s <- option 0 $ char ':' >> parsePico+ ampm <- B.map toUpper <$> (skipSpace >> (stringCI "AM" <|> stringCI "PM"))+ h <- case ampm of+ "AM" -> make24 False h'+ "PM" -> make24 True h'+ _ -> fail "Should be impossible."+ maybe (fail "Invalid Time Range") return $+ makeTimeOfDayValid h m s+ where+ make24 pm h = case compare h 12 of+ LT -> return $ if pm then (h+12) else h+ EQ -> return $ if pm then 12 else 0+ GT -> mzero++-- | Parse a TimeOfDay in twenty four hour format+twentyFourHour :: OptionedParser TimeOfDay+twentyFourHour = lift twentyFourHour'++twentyFourHour' :: Parser TimeOfDay+twentyFourHour' = maybe (fail "Invalid Time Range") return =<<+ (colon <|> nocolon)+ where+ colon = makeTimeOfDayValid <$>+ (nDigit 2 <|> nDigit 1) <*>+ (char ':' >> nDigit 2) <*>+ (option 0 $ char ':' >> parsePico)+ nocolon = makeTimeOfDayValid <$>+ nDigit 2 <*>+ option 0 (nDigit 2) <*>+ option 0 parsePico++-- | Parse a time of day intwelve hour or twenty four hour format+defaultTimeOfDay :: OptionedParser TimeOfDay+defaultTimeOfDay = twelveHour <|> twentyFourHour
+ Data/Time/Parsers/Timestamp.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Time.Parsers.Timestamp ( -- * TimeZone Parsers+ offsetTimeZone+ , namedTimeZone+ , defaultTimeZone+ -- * Timestamp Parsers+ , posixTime+ , zonedTime+ , localTime+ , defaultZonedTime+ , defaultLocalTime+ , defaultTimestamp+ -- * Extended Timestamps+ , extendTimestamp+ ) where++import Data.Time.Parsers.Util+import Data.Time.Parsers.Date+import Data.Time.Parsers.Tables (timeZones, ausTimeZones)+import Data.Time.Parsers.Time++import Control.Applicative ((<$>),(<*>),(<|>))+import Control.Monad.Reader+import Data.Attoparsec.Char8+import qualified Data.ByteString.Char8 as B+import Data.Char (toUpper)+import Data.Map as M+import Data.Time+import Data.Time.Clock.POSIX+import Prelude hiding (takeWhile)+++lookupTimeZone :: B.ByteString -> Maybe TimeZone+lookupTimeZone = flip M.lookup timeZones . B.map toUpper++lookupAusTimeZone :: B.ByteString -> Maybe TimeZone+lookupAusTimeZone bs = M.lookup (B.map toUpper bs) ausTimeZones <|>+ lookupTimeZone bs++-- | Parse a timezone in offset format+offsetTimeZone :: OptionedParser TimeZone+offsetTimeZone = lift offsetTimeZone'++offsetTimeZone' :: Parser TimeZone+offsetTimeZone' = (char 'Z' >> return utc) <|>+ ((plus <|> minus) <*> timeZone'')+ where+ plus = char '+' >> return minutesToTimeZone+ minus = char '-' >> return (minutesToTimeZone . negate)+ hour p = p >>= (\n -> if (n < 24) then (return $ 60*n) else mzero)+ minute p = option () (char ':' >> return ()) >> p >>=+ (\n -> if (n < 60) then return n else mzero)+ timeZone'' = choice [ (+) <$> (hour $ nDigit 2) <*> (minute $ nDigit 2)+ , (+) <$> (hour $ nDigit 1) <*> (minute $ nDigit 2)+ , hour $ nDigit 2+ , hour $ nDigit 1+ ]++-- | Parse an lookup a named timezone+namedTimeZone :: OptionedParser TimeZone+namedTimeZone = isFlagSet AustralianTimeZones >>= lift . namedTimeZone'++namedTimeZone' :: Bool -> Parser TimeZone+namedTimeZone' aussie = (lookup' <$> takeWhile isAlpha_ascii) >>=+ maybe (fail "Invalid TimeZone") return+ where+ lookup' = if aussie then lookupAusTimeZone else lookupTimeZone++-- | Parse a rational number and interpret as seconds since the Epoch+posixTime :: OptionedParser POSIXTime+posixTime = isFlagSet RequirePosixUnit >>= lift . posixTime'++posixTime' :: Bool -> Parser POSIXTime+posixTime' requireS = do+ r <- rational+ when requireS $ char 's' >> return ()+ return r++-- | Given a LocalTime parser and a TimeZone Parser, parse a ZonedTime+zonedTime :: OptionedParser LocalTime ->+ OptionedParser TimeZone ->+ OptionedParser ZonedTime+zonedTime localT timeZone = do+ defaultToUTC <- isFlagSet DefaultToUTC+ let timeZone' = (option undefined $ lift skipSpace) >> timeZone+ mtimeZone = if defaultToUTC+ then (option utc timeZone')+ else timeZone'+ zonedT <- ZonedTime <$> localT <*> mtimeZone+ bce <- isBCE+ if bce then makeBCE' zonedT else return zonedT+ where+ makeBCE' (ZonedTime (LocalTime d t) tz) =+ makeBCE d >>= \d' -> return $ ZonedTime (LocalTime d' t) tz++-- | Given a Date parser and a TimeOfDay parser, parse a LocalTime+localTime :: OptionedParser Day ->+ OptionedParser TimeOfDay ->+ OptionedParser LocalTime+localTime date time = do+ defaultToMidnight <- isFlagSet DefaultToMidnight+ let time' = (lift $ (const () <$> char 'T') <|> skipSpace) >> time+ mtime = if defaultToMidnight+ then (option midnight time')+ else time'+ localT <- LocalTime <$> date <*> mtime+ bce <- isBCE+ if bce then makeBCE' localT else return localT+ where+ makeBCE' (LocalTime d t) = makeBCE d >>= \d' -> return $ LocalTime d' t++-- | Parse an explicit timestamp, or a relative time+-- (now, today, yesterday, tomorrow)+extendTimestamp :: FromZonedTime a =>+ OptionedParser a ->+ OptionedParser ( ExtendedTimestamp a )+extendTimestamp p = either Timestamp id <$> eitherP p extendedTimestamp'+ where+ extendedTimestamp' =+ lift $ choice [ stringCI "now" >> return Now+ , stringCI "yesterday" >> return Yesterday+ , stringCI "today" >> return Today+ , stringCI "tomorrow" >> return Tomorrow+ ]++-- | Parse an offset TimeZone or named TimeZone+defaultTimeZone :: OptionedParser TimeZone+defaultTimeZone = namedTimeZone <|> offsetTimeZone++-- | Parse a LocalTime using defaultDay and defaultTime+defaultLocalTime :: OptionedParser LocalTime+defaultLocalTime = localTime defaultDayCE defaultTimeOfDay++-- | Parse a zonedTime using defaultLocalTime and defaultTimeZone+defaultZonedTime :: OptionedParser ZonedTime+defaultZonedTime = zonedTime defaultLocalTime defaultTimeZone++-- | Parse a Timestamp using posixTime or defaultZonedTime+defaultTimestamp :: FromZonedTime a => OptionedParser a+defaultTimestamp = fromZonedTime <$> defaultTimestamp'+ where+ defaultTimestamp' = onlyParse defaultZonedTime <|>+ (toZonedTime <$> posixTime)
+ Data/Time/Parsers/Types.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Data.Time.Parsers.Types where++import Control.Monad.Reader (ReaderT)+import Data.Attoparsec.Char8 (Parser)+import Data.Convertible+import Data.Convertible.Instances()+import qualified Data.Set as Set+import Data.Time+import Data.Time.Clock.POSIX++-- | A type that can be converted from ZonedTime+class FromZonedTime a where+ fromZonedTime :: ZonedTime -> a++instance FromZonedTime ZonedTime where+ fromZonedTime = id++instance FromZonedTime LocalTime where+ fromZonedTime = zonedTimeToLocalTime++instance FromZonedTime Day where+ fromZonedTime = localDay . fromZonedTime++instance FromZonedTime UTCTime where+ fromZonedTime = zonedTimeToUTC++instance FromZonedTime POSIXTime where+ fromZonedTime = convert++-- | A type that can be converted to ZonedTime+-- For LocalTime, it is assumed the TimeZone is UTC+-- For Day, it is assumed that the TimeOfDay is midnight and the TimeZone is UTC+class ToZonedTime a where+ toZonedTime :: a -> ZonedTime++instance ToZonedTime ZonedTime where+ toZonedTime = id++instance ToZonedTime LocalTime where+ toZonedTime = flip ZonedTime utc++instance ToZonedTime Day where+ toZonedTime = toZonedTime . flip LocalTime midnight++instance ToZonedTime UTCTime where+ toZonedTime = utcToZonedTime utc++instance ToZonedTime POSIXTime where+ toZonedTime = convert++-- | Formats for purely numeric dates, e.g. 99-2-27+data DateFormat+ = YMD -- ^ year-month-day+ | MDY -- ^ month-year-day+ | DMY -- ^ day-month-year+ deriving (Eq, Show)++-- | Flags to tune the behavior of a parser+data Flag+ = MakeRecent -- ^ Interpret years 0-99 as 1970-2069+ | DefaultToMidnight -- ^ If no TimeOfDay is supplied for a type where it+ -- is required, use midnight+ | DefaultToUTC -- ^ If no timezone is supplied for a type where it+ -- is required, use UTC+ | RequirePosixUnit -- ^ Require an 's' at the end of a POSIX timestamp.+ -- Can be used to distinguish between POSIXTime and+ -- iso8601 with no separators.+ | AustralianTimeZones -- ^ Use Australian Timezones+ deriving (Eq,Ord,Show)++data Options =+ Options { formats :: [DateFormat] -- ^ List of what DateFormats to try.+ , seps :: String -- ^ Set of accepted separators+ , flags :: Set.Set Flag -- ^ Set of Flags+ }++-- | A Parser with Options+type OptionedParser a = ReaderT Options Parser a++data DateToken+ = Year Integer -- ^ An Integer that is known to represent a year+ | Month Integer -- ^ An Integer that is known to represent a month+ | Any Integer -- ^ An Integer that could represent a day, month, or year+ deriving (Eq, Show)++data ExtendedTimestamp a+ = Timestamp a -- ^ An explicit Timestamp+ | Now -- ^ The current time+ | Yesterday -- ^ Midnight yesterday+ | Today -- ^ Midnight today+ | Tomorrow -- ^ Midight tomorrow+ deriving (Eq, Show)
+ Data/Time/Parsers/Util.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse #-}++module Data.Time.Parsers.Util ( nDigit+ , isBCE+ , onlyParse+ , defaultOptions+ , withOptions+ , withDefaultOptions+ , parseWithOptions+ , parseWithDefaultOptions+ , isFlagSet+ , makeBCE+ , fromExtendedTimestamp+ , fromExtendedTimestampIO+ , module Data.Time.Parsers.Types+ ) where++import Data.Time.Parsers.Types++import Control.Applicative ((<|>),(<$>),(<*),(*>))+import Control.Monad.Reader+import Data.Attoparsec.Char8+import qualified Data.ByteString.Char8 as B+import Data.Set as Set (member, fromList)+import Data.Time++-- | Parse a given number of digits+nDigit :: (Read a, Num a) => Int -> Parser a+nDigit n = read <$> count n digit++-- | Return true if the strings "BC" or "BCE" are consumed, false otherwise+isBCE :: OptionedParser Bool+isBCE = lift . option False $ const True <$> isBCE'+ where+ isBCE' = skipSpace *> (string "BCE" <|> string "BC")++-- | Fail if the given parser fails to consume all of the input+onlyParse :: OptionedParser a -> OptionedParser a+onlyParse p = p <* lift endOfInput++-- | Default Options to use:+-- Try YMD, then MDY, then DMY+-- Accept '.', ' ', '/', '-' as separators.+-- Use flags MakeRecent, DefaultToUTC, DefaultToMidnight+defaultOptions :: Options+defaultOptions = Options { formats = [YMD,MDY,DMY]+ , seps = ". /-"+ , flags = Set.fromList [ MakeRecent+ , DefaultToUTC+ , DefaultToMidnight+ ]+ }++withOptions :: OptionedParser a -> Options -> Parser a+withOptions = runReaderT++withDefaultOptions :: OptionedParser a -> Parser a+withDefaultOptions = flip runReaderT defaultOptions++-- | Use given options and parser to parse a single Timestamp.+-- always feeds empty, so a Partial result is never returned.+-- Ignores preceding and trailing whitespace.+parseWithOptions :: Options -> OptionedParser a ->+ B.ByteString -> Result a+parseWithOptions opt p = flip feed B.empty . (parse $ runReaderT p' opt)+ where+ p' = onlyParse (lift skipSpace *> p <* lift skipSpace)++-- | Use default options to parse single Timestamp with a given parser,+-- ignoring preceding and trailing whitespace+parseWithDefaultOptions :: OptionedParser a -> B.ByteString -> Result a+parseWithDefaultOptions = parseWithOptions defaultOptions++-- | Return whether a given flag is set.+isFlagSet :: Flag -> OptionedParser Bool+isFlagSet f = asks $ Set.member f . flags++-- | Converts a CE date into a BCE date. Fails if the date is already BCE+-- Warning: If you anticipate BCE dates, it is advisable to not use the+-- MakeRecent flag. It will cause ByteStrings such as "79 BC" to be parsed as+-- "1979 BCE"+makeBCE :: Monad m => Day -> m Day+makeBCE day = let (y,d,m) = toGregorian day+ in if (y < 0)+ then fail "Already BCE"+ else return $ fromGregorian (negate y + 1) d m++-- | Given a timestamp to use as the current time, purely convert an+-- ExtendedTimestamp to a timestamp+fromExtendedTimestamp :: (FromZonedTime a, ToZonedTime a) =>+ a -> ExtendedTimestamp a -> a+fromExtendedTimestamp now ts = case ts of+ Timestamp a -> a+ Now -> now+ Yesterday -> fromZonedTime . addDays' (-1) . atMidnight $ toZonedTime now+ Today -> fromZonedTime . atMidnight $ toZonedTime now+ Tomorrow -> fromZonedTime . addDays' 1 . atMidnight $ toZonedTime now+ where+ atMidnight (ZonedTime (LocalTime d _) tz) =+ ZonedTime (LocalTime d midnight) tz+ addDays' n (ZonedTime (LocalTime d tod) tz) =+ ZonedTime (LocalTime (addDays n d) tod) tz++-- | Use getZonedTime to get the current time, and use it to convert an+-- ExtendedTimestamp to a timestamp+fromExtendedTimestampIO :: (FromZonedTime a, ToZonedTime a) =>+ ExtendedTimestamp a -> IO a+fromExtendedTimestampIO ts = (fromZonedTime <$> getZonedTime) >>=+ return . flip fromExtendedTimestamp ts
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Nathan Ferris Hunter++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 Nathan Ferris Hunter 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 view
@@ -0,0 +1,2 @@+This package contains parsers for various date and time formats, implemented in+Attoparsec.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ timeparsers.cabal view
@@ -0,0 +1,38 @@+Name: timeparsers+Version: 0.3+Synopsis: Attoparsec parsers for various Date/Time formats.+License: BSD3+License-file: LICENSE+Author: Nathan Ferris Hunter+Maintainer: Nathan Ferris Hunter <nathan.f.hunter@gmail.com>+Copyright: Nathan Ferris Hunter, 2011+Stability: Experimental+Category: Data+Build-type: Simple+Description:+ Parsers for various Date/Time formats, implemented in AttoParsec.++Extra-source-files:+ LICENSE+ README+ Setup.hs++Cabal-version: >=1.2++Library+ Exposed-modules:+ Data.Time.Parsers,+ Data.Time.Parsers.Date,+ Data.Time.Parsers.Tables,+ Data.Time.Parsers.Time,+ Data.Time.Parsers.Timestamp,+ Data.Time.Parsers.Types,+ Data.Time.Parsers.Util+ Build-depends:+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.10,+ attoparsec >= 0.10.1 && < 0.11,+ time >= 1.0 && < 1.3,+ mtl >= 2.0.1 && <= 2.1,+ convertible >= 1.0 && < 1.1,+ containers >= 0.3 && < 0.5