From d39ace5728c981d8c9d83fe8eefcd811dbb1e8aa Mon Sep 17 00:00:00 2001 From: PHO Date: Wed, 28 Sep 2011 00:56:54 +0900 Subject: [PATCH] Data.Time.HTTP.Common now compiles. Ditz-issue: 85eb4c20935bf29db052a35d75039c638817227b --- Data/Time/HTTP/Common.hs | 285 ++++++++++++++++++++++----------------- time-http.cabal | 4 +- 2 files changed, 161 insertions(+), 128 deletions(-) diff --git a/Data/Time/HTTP/Common.hs b/Data/Time/HTTP/Common.hs index e0a899e..6a45805 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 @@ -26,12 +29,22 @@ module Data.Time.HTTP.Common , assertTimeOfDayIsGood ) where +import Blaze.ByteString.Builder.ByteString as B +import Blaze.Text.Int as BT +import Control.Applicative import Control.Monad +import Control.Monad.Unicode +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 Prelude.Unicode -shortWeekDayName :: Int -> String +shortWeekDayName ∷ Num n ⇒ n → String +{-# INLINEABLE shortWeekDayName #-} shortWeekDayName 1 = "Mon" shortWeekDayName 2 = "Tue" shortWeekDayName 3 = "Wed" @@ -39,24 +52,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 - ] - , string "Wed" >> return 3 - , string "Fri" >> return 5 + ≫ choice [ string "ue" ≫ return 2 + , string "hu" ≫ return 4 + ] + , 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" @@ -64,23 +79,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 - ] - , string "Wednesday" >> return 3 - , string "Friday" >> return 5 + ≫ choice [ string "uesday" ≫ return 2 + , string "hursday" ≫ return 4 + ] + , 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" @@ -93,33 +111,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 - , char 'u' - >> choice [ char 'n' >> return 6 - , char 'l' >> return 7 - ] - ] - , string "Feb" >> return 2 + ≫ choice [ string "an" ≫ return 1 + , char 'u' + ≫ choice [ char 'n' ≫ return 6 + , char 'l' ≫ return 7 + ] + ] + , 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 - ] - , string "Sep" >> return 9 - , string "Oct" >> return 10 - , string "Nov" >> return 11 - , string "Dec" >> return 12 + ≫ 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 ] -longMonthName :: Int -> String +longMonthName ∷ Num n ⇒ n → String +{-# INLINEABLE longMonthName #-} longMonthName 1 = "January" longMonthName 2 = "February" longMonthName 3 = "March" @@ -132,62 +152,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 - , char 'u' - >> choice [ string "ne" >> return 6 - , string "ly" >> return 7 - ] - ] - , string "February" >> return 2 + ≫ choice [ string "anuary" ≫ return 1 + , char 'u' + ≫ choice [ string "ne" ≫ return 6 + , string "ly" ≫ return 7 + ] + ] + , 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 - ] - , string "September" >> return 9 - , string "October" >> return 10 - , string "November" >> return 11 - , string "December" >> return 12 + ≫ 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 ] -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 @@ -200,25 +228,25 @@ 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 - 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) , timeZoneSummerOnly = False @@ -226,49 +254,52 @@ read4digitsTZ } 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 diff --git a/time-http.cabal b/time-http.cabal index f22e117..f708239 100644 --- a/time-http.cabal +++ b/time-http.cabal @@ -38,8 +38,10 @@ Library Build-depends: ascii == 0.0.*, + blaze-builder == 0.3.*, + blaze-textual == 0.2.*, attoparsec == 0.9.*, - base == 4.3.*, + base == 4.*, base-unicode-symbols == 0.2.*, time == 1.2.* -- 2.40.0