diff --git a/attoparsec-time.cabal b/attoparsec-time.cabal --- a/attoparsec-time.cabal +++ b/attoparsec-time.cabal @@ -1,7 +1,7 @@ name: attoparsec-time version: - 0.1.4 + 1 synopsis: Attoparsec parsers of time description: @@ -25,7 +25,7 @@ build-type: Custom cabal-version: - >= 1.24 + >=1.10 source-repository head type: @@ -35,7 +35,7 @@ custom-setup setup-depends: - base, Cabal, cabal-doctest >= 1.0.2 && < 1.1 + base, Cabal, cabal-doctest >=1.0.2 && <1.1 library hs-source-dirs: @@ -45,21 +45,23 @@ default-language: Haskell2010 exposed-modules: - Attoparsec.Time + Attoparsec.Time.ByteString + Attoparsec.Time.Text other-modules: Attoparsec.Time.Prelude - Attoparsec.Time.Validators - Attoparsec.Time.Constructors + Attoparsec.Time.Validation + Attoparsec.Time.Pure build-depends: -- - attoparsec >= 0.13 && < 0.15, + attoparsec >=0.13 && <0.15, -- - time >= 1.4 && < 2, - scientific == 0.3.*, - text >= 1 && < 2, + time >=1.4 && <2, + scientific ==0.3.*, + text >=1 && <2, + bytestring ==0.10.*, -- - base-prelude < 2, - base >= 4.7 && < 5 + base-prelude <2, + base >=4.7 && <5 test-suite doctests type: @@ -75,8 +77,8 @@ default-language: Haskell2010 build-depends: - doctest == 0.13.*, - directory >= 1.2 && < 2, - filepath >= 1.4 && < 2, - base-prelude < 2, - base < 5 + doctest ==0.13.*, + directory >=1.2 && <2, + filepath >=1.4 && <2, + base-prelude <2, + base <5 diff --git a/library/Attoparsec/Time.hs b/library/Attoparsec/Time.hs deleted file mode 100644 --- a/library/Attoparsec/Time.hs +++ /dev/null @@ -1,332 +0,0 @@ -module Attoparsec.Time -( - timeOfDayInISO8601, - dayInISO8601, - timeZoneInISO8601, - utcTimeInISO8601, - diffTime, - nominalDiffTime, -) -where - -import Attoparsec.Time.Prelude hiding (take, takeWhile) -import Data.Attoparsec.Text -import qualified Attoparsec.Time.Constructors as A -import qualified Attoparsec.Time.Validators as B -import qualified Data.Text as C - - -validated :: Show a => B.Validator a -> Parser a -> Parser a -validated validator parser = - parser >>= \x -> B.run validator (pure x) fail x - -sign :: Parser Bool -sign = - anyChar >>= \case - '+' -> return True - '-' -> return False - _ -> empty - -decimalChar :: Parser Int -decimalChar = - satisfyWith ((subtract 48) . ord) ((&&) <$> (>= 0) <*> (<= 9)) - -decimalOfLength :: Num a => Int -> Parser a -decimalOfLength length = - foldl' (\a b -> a * 10 + b) 0 <$> - replicateM length (fmap fromIntegral decimalChar) <|> - fail "Invalid decimal length" - -shortMonth :: Parser Int -shortMonth = - liftM C.toLower (take 3) >>= \case - "jan" -> return 1 - "feb" -> return 2 - "mar" -> return 3 - "apr" -> return 4 - "may" -> return 5 - "jun" -> return 6 - "jul" -> return 7 - "aug" -> return 8 - "sep" -> return 9 - "oct" -> return 10 - "nov" -> return 11 - "dec" -> return 12 - _ -> empty - -picoWithBasisOfLength :: Int -> Parser Pico -picoWithBasisOfLength basisLength = - (\a b -> MkFixed (foldl' (\a b -> a * 10 + fromIntegral b) 0 (a ++ b))) <$> beforePoint <*> afterPoint - where - resolution = - 12 - beforePoint = - replicateM basisLength decimalChar - afterPoint = - padListFromRight 0 [] resolution <$> ((char '.' *> many decimalChar) <|> pure []) - where - padListFromRight padding accumulator length list = - case length of - 0 -> reverse accumulator - _ -> case list of - head : tail -> padListFromRight padding (head : accumulator) (pred length) tail - _ -> reverse accumulator ++ replicate length padding - -{-# INLINE hour #-} -hour :: Parser Int -hour = - validated B.hour (decimalOfLength 2) "hour" - -{-# INLINE minute #-} -minute :: Parser Int -minute = - validated B.minute (decimalOfLength 2) "minute" - -{-# INLINE second #-} -second :: Parser Pico -second = - validated B.second (picoWithBasisOfLength 2) "second" - -{-| ->>> parseOnly timeOfDayInISO8601 "05:03:58" -Right 05:03:58 - ->>> parseOnly timeOfDayInISO8601 "05:03:58.02" -Right 05:03:58.02 - ->>> parseOnly timeOfDayInISO8601 "05:03:58.020" -Right 05:03:58.02 - -Checks the elements to be within a proper range: - ->>> parseOnly timeOfDayInISO8601 "24:00:00" -Left "timeOfDayInISO8601 > hour: Failed reading: Validator \"hour\" failed on the following input: 24" - ->>> parseOnly timeOfDayInISO8601 "00:00:60" -Left "timeOfDayInISO8601 > second: Failed reading: Validator \"second\" failed on the following input: 60.000000000000" - -Checks the elements to be of proper length: - ->>> parseOnly timeOfDayInISO8601 "1:00:00" -Left "timeOfDayInISO8601 > hour: Failed reading: Invalid decimal length" - ->>> parseOnly timeOfDayInISO8601 "01:1:00" -Left "timeOfDayInISO8601 > minute: Failed reading: Invalid decimal length" --} -{-# INLINE timeOfDayInISO8601 #-} -timeOfDayInISO8601 :: Parser TimeOfDay -timeOfDayInISO8601 = - unnamedParser "timeOfDayInISO8601" - where - unnamedParser = - A.timeOfDay <$> - (hour <* char ':') <*> - (minute <* char ':') <*> - (second) - -{-| ->>> parseOnly dayInISO8601 "2017-02-01" -Right 2017-02-01 - -Checks the elements to be in proper range: - ->>> parseOnly dayInISO8601 "2017-13-01" -Left "dayInISO8601: Failed reading: Invalid combination of year month and day: (2017,13,1)" - -That is accounting for leap year: - ->>> parseOnly dayInISO8601 "2017-02-29" -Left "dayInISO8601: Failed reading: Invalid combination of year month and day: (2017,2,29)" - ->>> parseOnly dayInISO8601 "2016-02-29" -Right 2016-02-29 --} -{-# INLINE dayInISO8601 #-} -dayInISO8601 :: Parser Day -dayInISO8601 = - unnamedParser "dayInISO8601" - where - unnamedParser = - do - year <- decimalOfLength 4 - char '-' - month <- decimalOfLength 2 - char '-' - day <- decimalOfLength 2 - case fromGregorianValid year month day of - Just day -> return day - Nothing -> fail (error year month day) - where - error year month day = - showString "Invalid combination of year month and day: " $ - show (year, month, day) - -{-| ->>> parseOnly timeZoneInISO8601 "+01:00" -Right +0100 - ->>> parseOnly timeZoneInISO8601 "+0100" -Right +0100 - ->>> parseOnly timeZoneInISO8601 "-0100" -Right -0100 - ->>> parseOnly timeZoneInISO8601 "Z" -Right UTC --} -timeZoneInISO8601 :: Parser TimeZone -timeZoneInISO8601 = - unnamedParser "timeZoneInISO8601" - where - unnamedParser = - z <|> offset - where - z = - char 'Z' $> utc - offset = - A.timeZone <$> sign <*> decimalOfLength 2 <*> (char ':' *> decimalOfLength 2 <|> decimalOfLength 2 <|> pure 0) - -{-| ->>> parseOnly utcTimeInISO8601 "2017-02-01T05:03:58+01:00" -Right 2017-02-01 04:03:58 UTC --} -utcTimeInISO8601 :: Parser UTCTime -utcTimeInISO8601 = - unnamedParser "utcTimeInISO8601" - where - unnamedParser = - do - day <- dayInISO8601 - char 'T' - time <- timeOfDayInISO8601 - zone <- timeZoneInISO8601 - return (A.utcTimeFromDayAndTimeOfDay day time zone) - -{-| -No suffix implies the "seconds" unit: - ->>> parseOnly diffTime "10" -Right 10s - -Various units (seconds, minutes, hours, days): - ->>> parseOnly diffTime "10s" -Right 10s - ->>> parseOnly diffTime "10m" -Right 600s - ->>> parseOnly diffTime "10h" -Right 36000s - ->>> parseOnly diffTime "10d" -Right 864000s - -Metric prefixes to seconds (down to Pico): - ->>> parseOnly diffTime "10ms" -Right 0.01s - ->>> parseOnly diffTime "10μs" -Right 0.00001s - ->>> parseOnly diffTime "10us" -Right 0.00001s - ->>> parseOnly diffTime "10ns" -Right 0.00000001s - ->>> parseOnly diffTime "10ps" -Right 0.00000000001s - -Negative values: - ->>> parseOnly diffTime "-1s" -Right -1s - -Unsupported units: - ->>> parseOnly diffTime "1k" -Left "diffTime: Failed reading: Unsupported unit: \"k\"" --} -diffTime :: Parser DiffTime -diffTime = - unnamedParser "diffTime" - where - unnamedParser = - do - amount <- scientific - factor <- timeUnitFactor - return (factor (realToFrac amount)) - -{-| -No suffix implies the "seconds" unit: - ->>> parseOnly nominalDiffTime "10" -Right 10s - -Various units (seconds, minutes, hours, days): - ->>> parseOnly nominalDiffTime "10s" -Right 10s - ->>> parseOnly nominalDiffTime "10m" -Right 600s - ->>> parseOnly nominalDiffTime "10h" -Right 36000s - ->>> parseOnly nominalDiffTime "10d" -Right 864000s - -Metric prefixes to seconds (down to Pico): - ->>> parseOnly nominalDiffTime "10ms" -Right 0.01s - ->>> parseOnly nominalDiffTime "10μs" -Right 0.00001s - ->>> parseOnly nominalDiffTime "10us" -Right 0.00001s - ->>> parseOnly nominalDiffTime "10ns" -Right 0.00000001s - ->>> parseOnly nominalDiffTime "10ps" -Right 0.00000000001s - -Negative values: - ->>> parseOnly nominalDiffTime "-1s" -Right -1s - -Unsupported units: - ->>> parseOnly nominalDiffTime "1k" -Left "nominalDiffTime: Failed reading: Unsupported unit: \"k\"" --} -nominalDiffTime :: Parser NominalDiffTime -nominalDiffTime = - unnamedParser "nominalDiffTime" - where - unnamedParser = - do - amount <- scientific - factor <- timeUnitFactor - return (factor (realToFrac amount)) - -timeUnitFactor :: Fractional a => Parser (a -> a) -timeUnitFactor = - takeWhile isAlpha >>= \case - "" -> return id - "s" -> return id - "ms" -> return (/ 1000) - "μs" -> return (/ 1000000) - "us" -> return (/ 1000000) - "ns" -> return (/ 1000000000) - "ps" -> return (/ 1000000000000) - "m" -> return (* 60) - "h" -> return (* 3600) - "d" -> return (* 86400) - unit -> fail ("Unsupported unit: " <> show unit) diff --git a/library/Attoparsec/Time/ByteString.hs b/library/Attoparsec/Time/ByteString.hs new file mode 100644 --- /dev/null +++ b/library/Attoparsec/Time/ByteString.hs @@ -0,0 +1,318 @@ +{-| +ASCII ByteString Parsers. +-} +module Attoparsec.Time.ByteString +( + timeOfDayInISO8601, + dayInISO8601, + timeZoneInISO8601, + utcTimeInISO8601, + diffTime, + nominalDiffTime, +) +where + +import Attoparsec.Time.Prelude hiding (take, takeWhile) +import Data.Attoparsec.ByteString +import qualified Attoparsec.Time.Pure as A +import qualified Attoparsec.Time.Validation as B +import qualified Data.ByteString as C +import qualified Data.Attoparsec.ByteString.Char8 as D + + +validated :: Show a => B.Validator a -> Parser a -> Parser a +validated validator parser = + parser >>= \x -> B.run validator (pure x) fail x + +sign :: Parser Bool +sign = + anyWord8 >>= \case + 43 -> return True + 45 -> return False + _ -> empty + +decimalOfLength :: Integral a => Int -> Parser a +decimalOfLength length = + do + bytes <- take length + if C.all A.word8IsAsciiDigit bytes + then return (A.decimalFromBytes bytes) + else fail "Not all chars are valid decimals" + +picoWithBasisOfLength :: Int -> Parser Pico +picoWithBasisOfLength basisLength = + MkFixed <$> ((+) <$> beforePoint <*> ((word8 46 *> afterPoint) <|> pure 0)) + where + beforePoint = + (* (10 ^ 12)) <$> decimalOfLength basisLength + afterPoint = + fmap (updater . C.take 12) (takeWhile1 A.word8IsAsciiDigit) + where + updater bytes = + let + afterPoint = + A.decimalFromBytes bytes + afterPointLength = + C.length bytes + paddedAfterPoint = + if afterPointLength < 12 + then afterPoint * (10 ^ (12 - afterPointLength)) + else afterPoint + in paddedAfterPoint + +{-# INLINE hour #-} +hour :: Parser Int +hour = + validated B.hour (decimalOfLength 2) "hour" + +{-# INLINE minute #-} +minute :: Parser Int +minute = + validated B.minute (decimalOfLength 2) "minute" + +{-# INLINE second #-} +second :: Parser Pico +second = + validated B.second (picoWithBasisOfLength 2) "second" + +{-| +>>> parseOnly timeOfDayInISO8601 "05:03:58" +Right 05:03:58 + +>>> parseOnly timeOfDayInISO8601 "05:03:58.02" +Right 05:03:58.02 + +>>> parseOnly timeOfDayInISO8601 "05:03:58.020" +Right 05:03:58.02 + +Checks the elements to be within a proper range: + +>>> parseOnly timeOfDayInISO8601 "24:00:00" +Left "timeOfDayInISO8601 > hour: Failed reading: Validator \"hour\" failed on the following input: 24" + +>>> parseOnly timeOfDayInISO8601 "00:00:60" +Left "timeOfDayInISO8601 > second: Failed reading: Validator \"second\" failed on the following input: 60.000000000000" + +Checks the elements to be of proper length: + +>>> parseOnly timeOfDayInISO8601 "1:00:00" +Left "timeOfDayInISO8601 > hour: Failed reading: Not all chars are valid decimals" + +>>> parseOnly timeOfDayInISO8601 "01:1:00" +Left "timeOfDayInISO8601 > minute: Failed reading: Not all chars are valid decimals" +-} +{-# INLINE timeOfDayInISO8601 #-} +timeOfDayInISO8601 :: Parser TimeOfDay +timeOfDayInISO8601 = + unnamedParser "timeOfDayInISO8601" + where + unnamedParser = + A.timeOfDay <$> + (hour <* word8 58) <*> + (minute <* word8 58) <*> + (second) + +{-| +>>> parseOnly dayInISO8601 "2017-02-01" +Right 2017-02-01 + +Checks the elements to be in proper range: + +>>> parseOnly dayInISO8601 "2017-13-01" +Left "dayInISO8601: Failed reading: Invalid combination of year month and day: (2017,13,1)" + +That is accounting for leap year: + +>>> parseOnly dayInISO8601 "2017-02-29" +Left "dayInISO8601: Failed reading: Invalid combination of year month and day: (2017,2,29)" + +>>> parseOnly dayInISO8601 "2016-02-29" +Right 2016-02-29 +-} +{-# INLINE dayInISO8601 #-} +dayInISO8601 :: Parser Day +dayInISO8601 = + unnamedParser "dayInISO8601" + where + unnamedParser = + do + year <- decimalOfLength 4 + word8 45 + month <- decimalOfLength 2 + word8 45 + day <- decimalOfLength 2 + case fromGregorianValid year month day of + Just day -> return day + Nothing -> fail (error year month day) + where + error year month day = + showString "Invalid combination of year month and day: " $ + show (year, month, day) + +{-| +>>> parseOnly timeZoneInISO8601 "+01:00" +Right +0100 + +>>> parseOnly timeZoneInISO8601 "+0100" +Right +0100 + +>>> parseOnly timeZoneInISO8601 "-0100" +Right -0100 + +>>> parseOnly timeZoneInISO8601 "Z" +Right UTC +-} +timeZoneInISO8601 :: Parser TimeZone +timeZoneInISO8601 = + unnamedParser "timeZoneInISO8601" + where + unnamedParser = + z <|> offset + where + z = + word8 90 $> utc + offset = + A.timeZone <$> sign <*> decimalOfLength 2 <*> (word8 58 *> decimalOfLength 2 <|> decimalOfLength 2 <|> pure 0) + +{-| +>>> parseOnly utcTimeInISO8601 "2017-02-01T05:03:58+01:00" +Right 2017-02-01 04:03:58 UTC +-} +utcTimeInISO8601 :: Parser UTCTime +utcTimeInISO8601 = + unnamedParser "utcTimeInISO8601" + where + unnamedParser = + do + day <- dayInISO8601 + word8 84 + time <- timeOfDayInISO8601 + zone <- timeZoneInISO8601 + return (A.utcTimeFromDayAndTimeOfDay day time zone) + +{-| +No suffix implies the "seconds" unit: + +>>> parseOnly diffTime "10" +Right 10s + +Various units (seconds, minutes, hours, days): + +>>> parseOnly diffTime "10s" +Right 10s + +>>> parseOnly diffTime "10m" +Right 600s + +>>> parseOnly diffTime "10h" +Right 36000s + +>>> parseOnly diffTime "10d" +Right 864000s + +Metric prefixes to seconds (down to Pico): + +>>> parseOnly diffTime "10ms" +Right 0.01s + +Notice that \"μs\" is not supported, because it's not ASCII. + +>>> parseOnly diffTime "10us" +Right 0.00001s + +>>> parseOnly diffTime "10ns" +Right 0.00000001s + +>>> parseOnly diffTime "10ps" +Right 0.00000000001s + +Negative values: + +>>> parseOnly diffTime "-1s" +Right -1s + +Unsupported units: + +>>> parseOnly diffTime "1k" +Left "diffTime: Failed reading: Unsupported unit: \"k\"" +-} +diffTime :: Parser DiffTime +diffTime = + unnamedParser "diffTime" + where + unnamedParser = + do + amount <- D.scientific + factor <- timeUnitFactor + return (factor (realToFrac amount)) + +{-| +No suffix implies the "seconds" unit: + +>>> parseOnly nominalDiffTime "10" +Right 10s + +Various units (seconds, minutes, hours, days): + +>>> parseOnly nominalDiffTime "10s" +Right 10s + +>>> parseOnly nominalDiffTime "10m" +Right 600s + +>>> parseOnly nominalDiffTime "10h" +Right 36000s + +>>> parseOnly nominalDiffTime "10d" +Right 864000s + +Metric prefixes to seconds (down to Pico): + +>>> parseOnly nominalDiffTime "10ms" +Right 0.01s + +Notice that \"μs\" is not supported, because it's not ASCII. + +>>> parseOnly nominalDiffTime "10us" +Right 0.00001s + +>>> parseOnly nominalDiffTime "10ns" +Right 0.00000001s + +>>> parseOnly nominalDiffTime "10ps" +Right 0.00000000001s + +Negative values: + +>>> parseOnly nominalDiffTime "-1s" +Right -1s + +Unsupported units: + +>>> parseOnly nominalDiffTime "1k" +Left "nominalDiffTime: Failed reading: Unsupported unit: \"k\"" +-} +nominalDiffTime :: Parser NominalDiffTime +nominalDiffTime = + unnamedParser "nominalDiffTime" + where + unnamedParser = + do + amount <- D.scientific + factor <- timeUnitFactor + return (factor (realToFrac amount)) + +timeUnitFactor :: Fractional a => Parser (a -> a) +timeUnitFactor = + takeWhile A.word8IsAsciiAlpha >>= \case + "" -> return id + "s" -> return id + "ms" -> return (/ 1000) + "μs" -> return (/ 1000000) + "us" -> return (/ 1000000) + "ns" -> return (/ 1000000000) + "ps" -> return (/ 1000000000000) + "m" -> return (* 60) + "h" -> return (* 3600) + "d" -> return (* 86400) + unit -> fail ("Unsupported unit: " <> show unit) diff --git a/library/Attoparsec/Time/Constructors.hs b/library/Attoparsec/Time/Constructors.hs deleted file mode 100644 --- a/library/Attoparsec/Time/Constructors.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | --- Efficient construction functions for values of the \"time\" library. -module Attoparsec.Time.Constructors where - -import Attoparsec.Time.Prelude - - -{-# INLINE timeZone #-} -timeZone :: Bool -> Int -> Int -> TimeZone -timeZone positive hour minute = - minutesToTimeZone $ - bool negate id positive $ - hour * 60 + minute - -{-# INLINE day #-} -day :: Int -> Int -> Int -> Day -day y m d = - fromGregorian (fromIntegral y) m d - -{-# INLINE timeOfDay #-} -timeOfDay :: Int -> Int -> Pico -> TimeOfDay -timeOfDay = - TimeOfDay - -{-# INLINE zonedTime #-} -zonedTime :: Day -> TimeOfDay -> TimeZone -> ZonedTime -zonedTime day tod tz = - ZonedTime (LocalTime day tod) tz - -{-# INLINE utcTimeFromDayAndTimeOfDay #-} -utcTimeFromDayAndTimeOfDay :: Day -> TimeOfDay -> TimeZone -> UTCTime -utcTimeFromDayAndTimeOfDay day tod tz = - zonedTimeToUTC (zonedTime day tod tz) - -{-# INLINE utcTimeFromComponents #-} -utcTimeFromComponents :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> TimeZone -> UTCTime -utcTimeFromComponents year month day hour minute second millisecond timeZone = - undefined diff --git a/library/Attoparsec/Time/Pure.hs b/library/Attoparsec/Time/Pure.hs new file mode 100644 --- /dev/null +++ b/library/Attoparsec/Time/Pure.hs @@ -0,0 +1,55 @@ +module Attoparsec.Time.Pure where + +import Attoparsec.Time.Prelude +import qualified Data.ByteString as A + + +{-# INLINE timeZone #-} +timeZone :: Bool -> Int -> Int -> TimeZone +timeZone positive hour minute = + minutesToTimeZone $ + bool negate id positive $ + hour * 60 + minute + +{-# INLINE day #-} +day :: Int -> Int -> Int -> Day +day y m d = + fromGregorian (fromIntegral y) m d + +{-# INLINE timeOfDay #-} +timeOfDay :: Int -> Int -> Pico -> TimeOfDay +timeOfDay = + TimeOfDay + +{-# INLINE zonedTime #-} +zonedTime :: Day -> TimeOfDay -> TimeZone -> ZonedTime +zonedTime day tod tz = + ZonedTime (LocalTime day tod) tz + +{-# INLINE utcTimeFromDayAndTimeOfDay #-} +utcTimeFromDayAndTimeOfDay :: Day -> TimeOfDay -> TimeZone -> UTCTime +utcTimeFromDayAndTimeOfDay day tod tz = + zonedTimeToUTC (zonedTime day tod tz) + +{-# INLINE utcTimeFromComponents #-} +utcTimeFromComponents :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> TimeZone -> UTCTime +utcTimeFromComponents year month day hour minute second millisecond timeZone = + undefined + +{-# INLINE decimalFromBytes #-} +decimalFromBytes :: Integral decimal => A.ByteString -> decimal +decimalFromBytes = + A.foldl' step 0 + where + step a b = + a * 10 + fromIntegral b - 48 + +{-# INLINE word8IsAsciiDigit #-} +word8IsAsciiDigit :: Word8 -> Bool +word8IsAsciiDigit w = + w - 48 <= 9 + +{-# INLINE word8IsAsciiAlpha #-} +word8IsAsciiAlpha :: Word8 -> Bool +word8IsAsciiAlpha x = + (x - 97 <= 25) || (x - 65 <= 25) diff --git a/library/Attoparsec/Time/Text.hs b/library/Attoparsec/Time/Text.hs new file mode 100644 --- /dev/null +++ b/library/Attoparsec/Time/Text.hs @@ -0,0 +1,332 @@ +module Attoparsec.Time.Text +( + timeOfDayInISO8601, + dayInISO8601, + timeZoneInISO8601, + utcTimeInISO8601, + diffTime, + nominalDiffTime, +) +where + +import Attoparsec.Time.Prelude hiding (take, takeWhile) +import Data.Attoparsec.Text +import qualified Attoparsec.Time.Pure as A +import qualified Attoparsec.Time.Validation as B +import qualified Data.Text as C + + +validated :: Show a => B.Validator a -> Parser a -> Parser a +validated validator parser = + parser >>= \x -> B.run validator (pure x) fail x + +sign :: Parser Bool +sign = + anyChar >>= \case + '+' -> return True + '-' -> return False + _ -> empty + +decimalChar :: Parser Int +decimalChar = + satisfyWith ((subtract 48) . ord) ((&&) <$> (>= 0) <*> (<= 9)) + +decimalOfLength :: Num a => Int -> Parser a +decimalOfLength length = + foldl' (\a b -> a * 10 + b) 0 <$> + replicateM length (fmap fromIntegral decimalChar) <|> + fail "Invalid decimal length" + +shortMonth :: Parser Int +shortMonth = + liftM C.toLower (take 3) >>= \case + "jan" -> return 1 + "feb" -> return 2 + "mar" -> return 3 + "apr" -> return 4 + "may" -> return 5 + "jun" -> return 6 + "jul" -> return 7 + "aug" -> return 8 + "sep" -> return 9 + "oct" -> return 10 + "nov" -> return 11 + "dec" -> return 12 + _ -> empty + +picoWithBasisOfLength :: Int -> Parser Pico +picoWithBasisOfLength basisLength = + (\a b -> MkFixed (foldl' (\a b -> a * 10 + fromIntegral b) 0 (a ++ b))) <$> beforePoint <*> afterPoint + where + resolution = + 12 + beforePoint = + replicateM basisLength decimalChar + afterPoint = + padListFromRight 0 [] resolution <$> ((char '.' *> many decimalChar) <|> pure []) + where + padListFromRight padding accumulator length list = + case length of + 0 -> reverse accumulator + _ -> case list of + head : tail -> padListFromRight padding (head : accumulator) (pred length) tail + _ -> reverse accumulator ++ replicate length padding + +{-# INLINE hour #-} +hour :: Parser Int +hour = + validated B.hour (decimalOfLength 2) "hour" + +{-# INLINE minute #-} +minute :: Parser Int +minute = + validated B.minute (decimalOfLength 2) "minute" + +{-# INLINE second #-} +second :: Parser Pico +second = + validated B.second (picoWithBasisOfLength 2) "second" + +{-| +>>> parseOnly timeOfDayInISO8601 "05:03:58" +Right 05:03:58 + +>>> parseOnly timeOfDayInISO8601 "05:03:58.02" +Right 05:03:58.02 + +>>> parseOnly timeOfDayInISO8601 "05:03:58.020" +Right 05:03:58.02 + +Checks the elements to be within a proper range: + +>>> parseOnly timeOfDayInISO8601 "24:00:00" +Left "timeOfDayInISO8601 > hour: Failed reading: Validator \"hour\" failed on the following input: 24" + +>>> parseOnly timeOfDayInISO8601 "00:00:60" +Left "timeOfDayInISO8601 > second: Failed reading: Validator \"second\" failed on the following input: 60.000000000000" + +Checks the elements to be of proper length: + +>>> parseOnly timeOfDayInISO8601 "1:00:00" +Left "timeOfDayInISO8601 > hour: Failed reading: Invalid decimal length" + +>>> parseOnly timeOfDayInISO8601 "01:1:00" +Left "timeOfDayInISO8601 > minute: Failed reading: Invalid decimal length" +-} +{-# INLINE timeOfDayInISO8601 #-} +timeOfDayInISO8601 :: Parser TimeOfDay +timeOfDayInISO8601 = + unnamedParser "timeOfDayInISO8601" + where + unnamedParser = + A.timeOfDay <$> + (hour <* char ':') <*> + (minute <* char ':') <*> + (second) + +{-| +>>> parseOnly dayInISO8601 "2017-02-01" +Right 2017-02-01 + +Checks the elements to be in proper range: + +>>> parseOnly dayInISO8601 "2017-13-01" +Left "dayInISO8601: Failed reading: Invalid combination of year month and day: (2017,13,1)" + +That is accounting for leap year: + +>>> parseOnly dayInISO8601 "2017-02-29" +Left "dayInISO8601: Failed reading: Invalid combination of year month and day: (2017,2,29)" + +>>> parseOnly dayInISO8601 "2016-02-29" +Right 2016-02-29 +-} +{-# INLINE dayInISO8601 #-} +dayInISO8601 :: Parser Day +dayInISO8601 = + unnamedParser "dayInISO8601" + where + unnamedParser = + do + year <- decimalOfLength 4 + char '-' + month <- decimalOfLength 2 + char '-' + day <- decimalOfLength 2 + case fromGregorianValid year month day of + Just day -> return day + Nothing -> fail (error year month day) + where + error year month day = + showString "Invalid combination of year month and day: " $ + show (year, month, day) + +{-| +>>> parseOnly timeZoneInISO8601 "+01:00" +Right +0100 + +>>> parseOnly timeZoneInISO8601 "+0100" +Right +0100 + +>>> parseOnly timeZoneInISO8601 "-0100" +Right -0100 + +>>> parseOnly timeZoneInISO8601 "Z" +Right UTC +-} +timeZoneInISO8601 :: Parser TimeZone +timeZoneInISO8601 = + unnamedParser "timeZoneInISO8601" + where + unnamedParser = + z <|> offset + where + z = + char 'Z' $> utc + offset = + A.timeZone <$> sign <*> decimalOfLength 2 <*> (char ':' *> decimalOfLength 2 <|> decimalOfLength 2 <|> pure 0) + +{-| +>>> parseOnly utcTimeInISO8601 "2017-02-01T05:03:58+01:00" +Right 2017-02-01 04:03:58 UTC +-} +utcTimeInISO8601 :: Parser UTCTime +utcTimeInISO8601 = + unnamedParser "utcTimeInISO8601" + where + unnamedParser = + do + day <- dayInISO8601 + char 'T' + time <- timeOfDayInISO8601 + zone <- timeZoneInISO8601 + return (A.utcTimeFromDayAndTimeOfDay day time zone) + +{-| +No suffix implies the "seconds" unit: + +>>> parseOnly diffTime "10" +Right 10s + +Various units (seconds, minutes, hours, days): + +>>> parseOnly diffTime "10s" +Right 10s + +>>> parseOnly diffTime "10m" +Right 600s + +>>> parseOnly diffTime "10h" +Right 36000s + +>>> parseOnly diffTime "10d" +Right 864000s + +Metric prefixes to seconds (down to Pico): + +>>> parseOnly diffTime "10ms" +Right 0.01s + +>>> parseOnly diffTime "10μs" +Right 0.00001s + +>>> parseOnly diffTime "10us" +Right 0.00001s + +>>> parseOnly diffTime "10ns" +Right 0.00000001s + +>>> parseOnly diffTime "10ps" +Right 0.00000000001s + +Negative values: + +>>> parseOnly diffTime "-1s" +Right -1s + +Unsupported units: + +>>> parseOnly diffTime "1k" +Left "diffTime: Failed reading: Unsupported unit: \"k\"" +-} +diffTime :: Parser DiffTime +diffTime = + unnamedParser "diffTime" + where + unnamedParser = + do + amount <- scientific + factor <- timeUnitFactor + return (factor (realToFrac amount)) + +{-| +No suffix implies the "seconds" unit: + +>>> parseOnly nominalDiffTime "10" +Right 10s + +Various units (seconds, minutes, hours, days): + +>>> parseOnly nominalDiffTime "10s" +Right 10s + +>>> parseOnly nominalDiffTime "10m" +Right 600s + +>>> parseOnly nominalDiffTime "10h" +Right 36000s + +>>> parseOnly nominalDiffTime "10d" +Right 864000s + +Metric prefixes to seconds (down to Pico): + +>>> parseOnly nominalDiffTime "10ms" +Right 0.01s + +>>> parseOnly nominalDiffTime "10μs" +Right 0.00001s + +>>> parseOnly nominalDiffTime "10us" +Right 0.00001s + +>>> parseOnly nominalDiffTime "10ns" +Right 0.00000001s + +>>> parseOnly nominalDiffTime "10ps" +Right 0.00000000001s + +Negative values: + +>>> parseOnly nominalDiffTime "-1s" +Right -1s + +Unsupported units: + +>>> parseOnly nominalDiffTime "1k" +Left "nominalDiffTime: Failed reading: Unsupported unit: \"k\"" +-} +nominalDiffTime :: Parser NominalDiffTime +nominalDiffTime = + unnamedParser "nominalDiffTime" + where + unnamedParser = + do + amount <- scientific + factor <- timeUnitFactor + return (factor (realToFrac amount)) + +timeUnitFactor :: Fractional a => Parser (a -> a) +timeUnitFactor = + takeWhile isAlpha >>= \case + "" -> return id + "s" -> return id + "ms" -> return (/ 1000) + "μs" -> return (/ 1000000) + "us" -> return (/ 1000000) + "ns" -> return (/ 1000000000) + "ps" -> return (/ 1000000000000) + "m" -> return (* 60) + "h" -> return (* 3600) + "d" -> return (* 86400) + unit -> fail ("Unsupported unit: " <> show unit) diff --git a/library/Attoparsec/Time/Validation.hs b/library/Attoparsec/Time/Validation.hs new file mode 100644 --- /dev/null +++ b/library/Attoparsec/Time/Validation.hs @@ -0,0 +1,43 @@ +module Attoparsec.Time.Validation where + +import Attoparsec.Time.Prelude + + +data Validator a = + Validator String (a -> Bool) + +run :: Show a => Validator a -> b -> (String -> b) -> a -> b +run (Validator name predicate) onNoError onError input = + if predicate input + then + onNoError + else + onError $ + showString "Validator " $ + shows name $ + showString " failed on the following input: " $ + show input + +month :: (Num a, Ord a) => Validator a +month = + Validator "month" (liftA2 (&&) (>= 1) (<= 12)) + +monthDay :: (Num a, Ord a) => Validator a +monthDay = + Validator "monthDay" (liftA2 (&&) (>= 1) (<= 31)) + +weekDay :: (Num a, Ord a) => Validator a +weekDay = + Validator "weekDay" (liftA2 (&&) (>= 1) (<= 7)) + +hour :: (Num a, Ord a) => Validator a +hour = + Validator "hour" (liftA2 (&&) (>= 0) (< 24)) + +minute :: (Num a, Ord a) => Validator a +minute = + Validator "minute" (liftA2 (&&) (>= 0) (< 60)) + +second :: (Num a, Ord a) => Validator a +second = + Validator "second" (liftA2 (&&) (>= 0) (< 60)) diff --git a/library/Attoparsec/Time/Validators.hs b/library/Attoparsec/Time/Validators.hs deleted file mode 100644 --- a/library/Attoparsec/Time/Validators.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Attoparsec.Time.Validators where - -import Attoparsec.Time.Prelude - - -data Validator a = - Validator String (a -> Bool) - -run :: Show a => Validator a -> b -> (String -> b) -> a -> b -run (Validator name predicate) onNoError onError input = - if predicate input - then - onNoError - else - onError $ - showString "Validator " $ - shows name $ - showString " failed on the following input: " $ - show input - -month :: (Num a, Ord a) => Validator a -month = - Validator "month" (liftA2 (&&) (>= 1) (<= 12)) - -monthDay :: (Num a, Ord a) => Validator a -monthDay = - Validator "monthDay" (liftA2 (&&) (>= 1) (<= 31)) - -weekDay :: (Num a, Ord a) => Validator a -weekDay = - Validator "weekDay" (liftA2 (&&) (>= 1) (<= 7)) - -hour :: (Num a, Ord a) => Validator a -hour = - Validator "hour" (liftA2 (&&) (>= 0) (< 24)) - -minute :: (Num a, Ord a) => Validator a -minute = - Validator "minute" (liftA2 (&&) (>= 0) (< 60)) - -second :: (Num a, Ord a) => Validator a -second = - Validator "second" (liftA2 (&&) (>= 0) (< 60))