diff --git a/Data/Time/Parsers.hs b/Data/Time/Parsers.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Parsers.hs @@ -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 diff --git a/Data/Time/Parsers/Date.hs b/Data/Time/Parsers/Date.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Parsers/Date.hs @@ -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 diff --git a/Data/Time/Parsers/Tables.hs b/Data/Time/Parsers/Tables.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Parsers/Tables.hs @@ -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)] diff --git a/Data/Time/Parsers/Time.hs b/Data/Time/Parsers/Time.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Parsers/Time.hs @@ -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 diff --git a/Data/Time/Parsers/Timestamp.hs b/Data/Time/Parsers/Timestamp.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Parsers/Timestamp.hs @@ -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) diff --git a/Data/Time/Parsers/Types.hs b/Data/Time/Parsers/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Parsers/Types.hs @@ -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) diff --git a/Data/Time/Parsers/Util.hs b/Data/Time/Parsers/Util.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Parsers/Util.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,2 @@ +This package contains parsers for various date and time formats, implemented in +Attoparsec. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/timeparsers.cabal b/timeparsers.cabal new file mode 100644 --- /dev/null +++ b/timeparsers.cabal @@ -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 +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