X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=time-http.git;a=blobdiff_plain;f=Data%2FTime%2FHTTP%2FCommon.hs;h=bb4ac16527c0ac6768eb22c097fbd46a97f355a1;hp=f6b1afe64845649bad8dc36bdc2d0ac9c283c648;hb=512f9a871149c7dd20d0c1c86cb230fbb7dc43f6;hpb=c889f6f399e0e3c8bf6327323bbb838e06c9b7f9 diff --git a/Data/Time/HTTP/Common.hs b/Data/Time/HTTP/Common.hs index f6b1afe..bb4ac16 100644 --- a/Data/Time/HTTP/Common.hs +++ b/Data/Time/HTTP/Common.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} module Data.Time.HTTP.Common ( shortWeekDayName , shortWeekDayNameP @@ -24,16 +27,25 @@ module Data.Time.HTTP.Common , assertWeekDayIsGood , assertGregorianDateIsGood , assertTimeOfDayIsGood + + , optionMaybe ) where - +import Blaze.ByteString.Builder.ByteString as B +import Blaze.Text.Int as BT +import Control.Applicative import Control.Monad +import Data.Ascii (AsciiBuilder) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import Data.Monoid.Unicode import Data.Fixed import Data.Time import Data.Time.Calendar.WeekDate -import Text.Parsec +import Prelude.Unicode -shortWeekDayName :: Int -> String +shortWeekDayName ∷ Num n ⇒ n → String +{-# INLINEABLE shortWeekDayName #-} shortWeekDayName 1 = "Mon" shortWeekDayName 2 = "Tue" shortWeekDayName 3 = "Wed" @@ -41,24 +53,26 @@ shortWeekDayName 4 = "Thu" shortWeekDayName 5 = "Fri" shortWeekDayName 6 = "Sat" shortWeekDayName 7 = "Sun" -shortWeekDayName n = error ("shortWeekDayName: unknown day number: " ++ show n) +shortWeekDayName n = error ("shortWeekDayName: invalid week day: " ⧺ show n) -shortWeekDayNameP :: Stream s m Char => ParsecT s u m Int +shortWeekDayNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE shortWeekDayNameP #-} shortWeekDayNameP - = choice [ string "Mon" >> return 1 + = choice [ string "Mon" *> return 1 , char 'T' - >> choice [ string "ue" >> return 2 - , string "hu" >> return 4 + *> choice [ string "ue" *> return 2 + , string "hu" *> return 4 ] - , string "Wed" >> return 3 - , string "Fri" >> return 5 + , string "Wed" *> return 3 + , string "Fri" *> return 5 , char 'S' - >> choice [ string "at" >> return 6 - , string "un" >> return 7 + *> choice [ string "at" *> return 6 + , string "un" *> return 7 ] ] -longWeekDayName :: Int -> String +longWeekDayName ∷ Num n ⇒ n → String +{-# INLINEABLE longWeekDayName #-} longWeekDayName 1 = "Monday" longWeekDayName 2 = "Tuesday" longWeekDayName 3 = "Wednesday" @@ -66,23 +80,26 @@ longWeekDayName 4 = "Thursday" longWeekDayName 5 = "Friday" longWeekDayName 6 = "Saturday" longWeekDayName 7 = "Sunday" +longWeekDayName n = error ("longWeekDayName: invalid week day: " ⧺ show n) -longWeekDayNameP :: Stream s m Char => ParsecT s u m Int +longWeekDayNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE longWeekDayNameP #-} longWeekDayNameP - = choice [ string "Monday" >> return 1 + = choice [ string "Monday" *> return 1 , char 'T' - >> choice [ string "uesday" >> return 2 - , string "hursday" >> return 4 + *> choice [ string "uesday" *> return 2 + , string "hursday" *> return 4 ] - , string "Wednesday" >> return 3 - , string "Friday" >> return 5 + , string "Wednesday" *> return 3 + , string "Friday" *> return 5 , char 'S' - >> choice [ string "aturday" >> return 6 - , string "unday" >> return 7 + *> choice [ string "aturday" *> return 6 + , string "unday" *> return 7 ] ] -shortMonthName :: Int -> String +shortMonthName ∷ Num n ⇒ n → String +{-# INLINEABLE shortMonthName #-} shortMonthName 1 = "Jan" shortMonthName 2 = "Feb" shortMonthName 3 = "Mar" @@ -95,33 +112,35 @@ shortMonthName 9 = "Sep" shortMonthName 10 = "Oct" shortMonthName 11 = "Nov" shortMonthName 12 = "Dec" -shortMonthName n = error ("shortMonthName: unknown month number: " ++ show n) +shortMonthName n = error ("shortMonthName: invalid month: " ⧺ show n) -shortMonthNameP :: Stream s m Char => ParsecT s u m Int +shortMonthNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE shortMonthNameP #-} shortMonthNameP = choice [ char 'J' - >> choice [ string "an" >> return 1 + *> choice [ string "an" *> return 1 , char 'u' - >> choice [ char 'n' >> return 6 - , char 'l' >> return 7 + *> choice [ char 'n' *> return 6 + , char 'l' *> return 7 ] ] - , string "Feb" >> return 2 + , string "Feb" *> return 2 , string "Ma" - >> choice [ char 'r' >> return 3 - , char 'y' >> return 5 + *> choice [ char 'r' *> return 3 + , char 'y' *> return 5 ] , char 'A' - >> choice [ string "pr" >> return 4 - , string "ug" >> return 8 + *> choice [ string "pr" *> return 4 + , string "ug" *> return 8 ] - , string "Sep" >> return 9 - , string "Oct" >> return 10 - , string "Nov" >> return 11 - , string "Dec" >> return 12 + , string "Sep" *> return 9 + , string "Oct" *> return 10 + , string "Nov" *> return 11 + , string "Dec" *> return 12 ] -longMonthName :: Int -> String +longMonthName ∷ Num n ⇒ n → String +{-# INLINEABLE longMonthName #-} longMonthName 1 = "January" longMonthName 2 = "February" longMonthName 3 = "March" @@ -134,62 +153,70 @@ longMonthName 9 = "September" longMonthName 10 = "October" longMonthName 11 = "November" longMonthName 12 = "December" -longMonthName n = error ("longMonthName: unknown month number: " ++ show n) +longMonthName n = error ("longMonthName: invalid month: " ⧺ show n) -longMonthNameP :: Stream s m Char => ParsecT s u m Int +longMonthNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE longMonthNameP #-} longMonthNameP = choice [ char 'J' - >> choice [ string "anuary" >> return 1 + *> choice [ string "anuary" *> return 1 , char 'u' - >> choice [ string "ne" >> return 6 - , string "ly" >> return 7 + *> choice [ string "ne" *> return 6 + , string "ly" *> return 7 ] ] - , string "February" >> return 2 + , string "February" *> return 2 , string "Ma" - >> choice [ string "rch" >> return 3 - , char 'y' >> return 5 + *> choice [ string "rch" *> return 3 + , char 'y' *> return 5 ] , char 'A' - >> choice [ string "pril" >> return 4 - , string "ugust" >> return 8 + *> choice [ string "pril" *> return 4 + , string "ugust" *> return 8 ] - , string "September" >> return 9 - , string "October" >> return 10 - , string "November" >> return 11 - , string "December" >> return 12 + , string "September" *> return 9 + , string "October" *> return 10 + , string "November" *> return 11 + , string "December" *> return 12 ] -show4 :: Integral i => i -> String -show4 i - | i >= 0 && i < 10 = "000" ++ show i - | i >= 0 && i < 100 = "00" ++ show i - | i >= 0 && i < 1000 = "0" ++ show i - | i >= 0 && i < 10000 = show i - | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ++ show i) +show4 ∷ Integral i ⇒ i → AsciiBuilder +{-# INLINE show4 #-} +show4 = A.unsafeFromBuilder ∘ go + where + {-# INLINEABLE go #-} + go i | i ≥ 0 ∧ i < 10 = B.fromByteString "000" ⊕ BT.digit i + | i ≥ 0 ∧ i < 100 = B.fromByteString "00" ⊕ BT.integral i + | i ≥ 0 ∧ i < 1000 = B.fromByteString "0" ⊕ BT.integral i + | i ≥ 0 ∧ i < 10000 = BT.integral i + | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i) -show2 :: Integral i => i -> String -show2 i - | i >= 0 && i < 10 = "0" ++ show i - | i >= 0 && i < 100 = show i - | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ++ show i) +show2 ∷ Integral i ⇒ i → AsciiBuilder +{-# INLINE show2 #-} +show2 = A.unsafeFromBuilder ∘ go + where + go i | i ≥ 0 ∧ i < 10 = B.fromByteString "0" ⊕ BT.digit i + | i ≥ 0 ∧ i < 100 = BT.integral i + | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i) -read4 :: (Stream s m Char, Num n) => ParsecT s u m n -read4 = do n1 <- digit' - n2 <- digit' - n3 <- digit' - n4 <- digit' +read4 ∷ Num n ⇒ Parser n +{-# INLINEABLE read4 #-} +read4 = do n1 ← digit' + n2 ← digit' + n3 ← digit' + n4 ← digit' return (n1 * 1000 + n2 * 100 + n3 * 10 + n4) -read2 :: (Stream s m Char, Num n) => ParsecT s u m n -read2 = do n1 <- digit' - n2 <- digit' +read2 ∷ Num n ⇒ Parser n +{-# INLINEABLE read2 #-} +read2 = do n1 ← digit' + n2 ← digit' return (n1 * 10 + n2) -digit' :: (Stream s m Char, Num n) => ParsecT s u m n -digit' = liftM fromC digit +digit' ∷ Num n ⇒ Parser n +digit' = fromC <$> P.digit -fromC :: Num n => Char -> n +fromC ∷ Num n ⇒ Char → n fromC '0' = 0 fromC '1' = 1 fromC '2' = 2 @@ -202,75 +229,83 @@ fromC '8' = 8 fromC '9' = 9 fromC _ = undefined -show4digitsTZ :: TimeZone -> String +show4digitsTZ ∷ TimeZone → AsciiBuilder show4digitsTZ tz = case timeZoneMinutes tz of - offset | offset < 0 -> '-' : showTZ' (negate offset) - | otherwise -> '+' : showTZ' offset + offset | offset < 0 → A.toAsciiBuilder "-" ⊕ showTZ' (negate offset) + | otherwise → A.toAsciiBuilder "+" ⊕ showTZ' offset where showTZ' offset = let h = offset `div` 60 m = offset - h * 60 in - concat [show2 h, show2 m] + show2 h ⊕ show2 m -read4digitsTZ :: Stream s m Char => ParsecT s u m TimeZone +read4digitsTZ ∷ Parser TimeZone read4digitsTZ - = do sign <- (char '+' >> return 1) - <|> - (char '-' >> return (-1)) - hour <- read2 - minute <- read2 + = do sign ← (char '+' *> return 1) + <|> + (char '-' *> return (-1)) + hour ← read2 + minute ← read2 let tz = TimeZone { - timeZoneMinutes = (sign * (hour * 60 + minute)) + timeZoneMinutes = sign * (hour * 60 + minute) , timeZoneSummerOnly = False , timeZoneName = timeZoneOffsetString tz } return tz -assertWeekDayIsGood :: Stream s m t => Int -> Day -> ParsecT s u m () +assertWeekDayIsGood ∷ Monad m ⇒ Int → Day → m () +{-# INLINEABLE assertWeekDayIsGood #-} assertWeekDayIsGood givenWD gregDay = let (_, _, correctWD ) = toWeekDate gregDay (year, month, day) = toGregorian gregDay in - unless (givenWD == correctWD) - $ fail - $ concat [ "Gregorian day " + unless (givenWD ≡ correctWD) + $ fail + $ concat [ "Gregorian day " + , show year + , "-" + , show month + , "-" + , show day + , " is " + , longWeekDayName correctWD + , ", not " + , longWeekDayName givenWD + ] + +assertGregorianDateIsGood ∷ Monad m ⇒ Integer → Int → Int → m Day +{-# INLINEABLE assertGregorianDateIsGood #-} +assertGregorianDateIsGood year month day + = case fromGregorianValid year month day of + Nothing + → fail $ concat [ "Invalid gregorian day: " , show year , "-" , show month , "-" , show day - , " is " - , longWeekDayName correctWD - , ", not " - , longWeekDayName givenWD ] - -assertGregorianDateIsGood :: Stream s m t => Integer -> Int -> Int -> ParsecT s u m Day -assertGregorianDateIsGood year month day - = case fromGregorianValid year month day of - Nothing - -> fail $ concat [ "Invalid gregorian day: " - , show year - , "-" - , show month - , "-" - , show day - ] Just gregDay - -> return gregDay + → return gregDay -assertTimeOfDayIsGood :: Stream s m t => Int -> Int -> Pico -> ParsecT s u m TimeOfDay +assertTimeOfDayIsGood ∷ Monad m ⇒ Int → Int → Pico → m TimeOfDay +{-# INLINEABLE assertTimeOfDayIsGood #-} assertTimeOfDayIsGood hour minute second = case makeTimeOfDayValid hour minute second of Nothing - -> fail $ concat [ "Invalid time of day: " - , show hour - , ":" - , show minute - , ":" - , showFixed True second - ] + → fail $ concat [ "Invalid time of day: " + , show hour + , ":" + , show minute + , ":" + , showFixed True second + ] Just tod - -> return tod + → return tod + +optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a) +{-# INLINE optionMaybe #-} +optionMaybe p + = option Nothing (Just <$> p)