From 512f9a871149c7dd20d0c1c86cb230fbb7dc43f6 Mon Sep 17 00:00:00 2001 From: PHO Date: Wed, 28 Sep 2011 02:01:34 +0900 Subject: [PATCH] Data.Time.RFC{733,822} now compiles. Ditz-issue: 85eb4c20935bf29db052a35d75039c638817227b --- Data/Time/HTTP/Common.hs | 116 +++++++++++++++++--------------- Data/Time/RFC1123/Internal.hs | 7 +- Data/Time/RFC733/Internal.hs | 122 +++++++++++++++++----------------- Data/Time/RFC822/Internal.hs | 95 +++++++++++++------------- cabal-package.mk | 17 +++-- time-http.cabal | 3 + 6 files changed, 190 insertions(+), 170 deletions(-) diff --git a/Data/Time/HTTP/Common.hs b/Data/Time/HTTP/Common.hs index 6a45805..bb4ac16 100644 --- a/Data/Time/HTTP/Common.hs +++ b/Data/Time/HTTP/Common.hs @@ -27,13 +27,14 @@ 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 Control.Monad.Unicode import Data.Ascii (AsciiBuilder) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P @@ -57,17 +58,17 @@ shortWeekDayName n = error ("shortWeekDayName: invalid week day: " ⧺ show n) 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 ∷ Num n ⇒ n → String @@ -84,17 +85,17 @@ longWeekDayName n = error ("longWeekDayName: invalid week day: " ⧺ show n) 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 ∷ Num n ⇒ n → String @@ -117,25 +118,25 @@ 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 ∷ Num n ⇒ n → String @@ -158,25 +159,25 @@ 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 → AsciiBuilder @@ -242,9 +243,9 @@ show4digitsTZ tz read4digitsTZ ∷ Parser TimeZone read4digitsTZ - = do sign ← (char '+' ≫ return 1) + = do sign ← (char '+' *> return 1) <|> - (char '-' ≫ return (-1)) + (char '-' *> return (-1)) hour ← read2 minute ← read2 let tz = TimeZone { @@ -303,3 +304,8 @@ assertTimeOfDayIsGood hour minute second ] Just tod → return tod + +optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a) +{-# INLINE optionMaybe #-} +optionMaybe p + = option Nothing (Just <$> p) diff --git a/Data/Time/RFC1123/Internal.hs b/Data/Time/RFC1123/Internal.hs index b7bb6c9..1dc2a1d 100644 --- a/Data/Time/RFC1123/Internal.hs +++ b/Data/Time/RFC1123/Internal.hs @@ -4,17 +4,18 @@ module Data.Time.RFC1123.Internal ) where import Control.Monad +import Data.Attoparsec.Char8 import Data.Fixed import Data.Time import Data.Time.Calendar.WeekDate import Data.Time.HTTP.Common import Data.Time.RFC822.Internal --- |This is a parsec parser for RFC 1123 date and time strings. -rfc1123DateAndTime :: Stream s m Char => ParsecT s u m ZonedTime +-- |Parse an RFC 1123 date and time string. +rfc1123DateAndTime :: Parser ZonedTime rfc1123DateAndTime = dateTime -dateTime :: Stream s m Char => ParsecT s u m ZonedTime +dateTime :: Parser ZonedTime dateTime = do weekDay <- optionMaybe $ do w <- shortWeekDayNameP _ <- string ", " diff --git a/Data/Time/RFC733/Internal.hs b/Data/Time/RFC733/Internal.hs index 5002655..d1de6d8 100644 --- a/Data/Time/RFC733/Internal.hs +++ b/Data/Time/RFC733/Internal.hs @@ -1,105 +1,107 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} module Data.Time.RFC733.Internal ( rfc733DateAndTime ) where -import Control.Monad -import Data.Fixed +import Control.Applicative +import Data.Attoparsec.Char8 import Data.Time -import Data.Time.Calendar.WeekDate import Data.Time.HTTP.Common --- |This is a parsec parser for RFC 733 date and time strings. -rfc733DateAndTime :: Stream s m Char => ParsecT s u m ZonedTime +-- |Parse RFC 733 date and time strings. +rfc733DateAndTime ∷ Parser ZonedTime rfc733DateAndTime = dateTime -dateTime :: Stream s m Char => ParsecT s u m ZonedTime -dateTime = do weekDay <- optionMaybe $ - do w <- try longWeekDayNameP - <|> - shortWeekDayNameP - _ <- string ", " - return w - gregDay <- date +dateTime ∷ Parser ZonedTime +dateTime = do weekDay ← optionMaybe $ + do w ← longWeekDayNameP + <|> + shortWeekDayNameP + _ ← string ", " + return w + gregDay ← date case weekDay of Nothing - -> return () + → return () Just givenWD - -> assertWeekDayIsGood givenWD gregDay - (tod, timeZone) <- time + → assertWeekDayIsGood givenWD gregDay + (tod, timeZone) ← time let lt = LocalTime gregDay tod zt = ZonedTime lt timeZone return zt -date :: Stream s m Char => ParsecT s u m Day -date = do day <- read2 - _ <- char '-' <|> char ' ' - month <- try longMonthNameP - <|> - shortMonthNameP - _ <- char '-' <|> char ' ' - year <- try read4 - <|> - liftM (+ 1900) read2 - _ <- char ' ' +date ∷ Parser Day +date = do day ← read2 + _ ← char '-' <|> char ' ' + month ← try longMonthNameP + <|> + shortMonthNameP + _ ← char '-' <|> char ' ' + year ← try read4 + <|> + (+ 1900) <$> read2 + _ ← char ' ' assertGregorianDateIsGood year month day -time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone) -time = do tod <- hour - _ <- char '-' <|> char ' ' - tz <- zone +time ∷ Parser (TimeOfDay, TimeZone) +time = do tod ← hms + _ ← char '-' <|> char ' ' + tz ← zone return (tod, tz) -hour :: Stream s m Char => ParsecT s u m TimeOfDay -hour = do hour <- read2 - _ <- optional (char ':') - minute <- read2 - second <- option 0 $ - do _ <- optional (char ':') - read2 - assertTimeOfDayIsGood hour minute second +hms ∷ Parser TimeOfDay +hms = do hour ← read2 + _ ← optional (char ':') + minute ← read2 + second ← option 0 $ + do _ ← optional (char ':') + read2 + assertTimeOfDayIsGood hour minute second -zone :: Stream s m Char => ParsecT s u m TimeZone -zone = choice [ string "GMT" >> return (TimeZone 0 False "GMT") +zone ∷ Parser TimeZone +zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT") , char 'N' - >> choice [ string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST") + *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST") , return (TimeZone (1 * 60) False "N") ] , char 'A' - >> choice [ string "ST" >> return (TimeZone ((-4) * 60) False "AST") - , string "DT" >> return (TimeZone ((-3) * 60) False "AST") + *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST") + , string "DT" *> return (TimeZone ((-3) * 60) False "AST") , return (TimeZone ((-1) * 60) False "A") ] , char 'E' - >> choice [ string "ST" >> return (TimeZone ((-5) * 60) False "EST") - , string "DT" >> return (TimeZone ((-4) * 60) True "EDT") + *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST") + , string "DT" *> return (TimeZone ((-4) * 60) True "EDT") ] , char 'C' - >> choice [ string "ST" >> return (TimeZone ((-6) * 60) False "CST") - , string "DT" >> return (TimeZone ((-5) * 60) True "CDT") + *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST") + , string "DT" *> return (TimeZone ((-5) * 60) True "CDT") ] , char 'M' - >> choice [ string "ST" >> return (TimeZone ((-7) * 60) False "MST") - , string "DT" >> return (TimeZone ((-6) * 60) True "MDT") + *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST") + , string "DT" *> return (TimeZone ((-6) * 60) True "MDT") , return (TimeZone ((-12) * 60) False "M") ] , char 'P' - >> choice [ string "ST" >> return (TimeZone ((-8) * 60) False "PST") - , string "DT" >> return (TimeZone ((-7) * 60) True "PDT") + *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST") + , string "DT" *> return (TimeZone ((-7) * 60) True "PDT") ] , char 'Y' - >> choice [ string "ST" >> return (TimeZone ((-9) * 60) False "YST") - , string "DT" >> return (TimeZone ((-8) * 60) True "YDT") + *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST") + , string "DT" *> return (TimeZone ((-8) * 60) True "YDT") , return (TimeZone ( 12 * 60) False "Y") ] , char 'H' - >> choice [ string "ST" >> return (TimeZone ((-10) * 60) False "HST") - , string "DT" >> return (TimeZone (( -9) * 60) True "HDT") + *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST") + , string "DT" *> return (TimeZone (( -9) * 60) True "HDT") ] , char 'B' - >> choice [ string "ST" >> return (TimeZone ((-11) * 60) False "BST") - , string "DT" >> return (TimeZone ((-10) * 60) True "BDT") + *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST") + , string "DT" *> return (TimeZone ((-10) * 60) True "BDT") ] - , char 'Z' >> return (TimeZone 0 False "Z") + , char 'Z' *> return (TimeZone 0 False "Z") , read4digitsTZ ] diff --git a/Data/Time/RFC822/Internal.hs b/Data/Time/RFC822/Internal.hs index ed7549a..297120a 100644 --- a/Data/Time/RFC822/Internal.hs +++ b/Data/Time/RFC822/Internal.hs @@ -1,81 +1,82 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} module Data.Time.RFC822.Internal ( rfc822DateAndTime - - -- private , rfc822time ) where -import Control.Monad -import Data.Fixed +import Control.Applicative +import Data.Attoparsec.Char8 import Data.Time -import Data.Time.Calendar.WeekDate import Data.Time.HTTP.Common --- |This is a parsec parser for RFC 822 date and time strings. -rfc822DateAndTime :: Stream s m Char => ParsecT s u m ZonedTime +-- |Parse an RFC 822 date and time string. +rfc822DateAndTime ∷ Parser ZonedTime rfc822DateAndTime = dateTime -dateTime :: Stream s m Char => ParsecT s u m ZonedTime -dateTime = do weekDay <- optionMaybe $ - do w <- shortWeekDayNameP - _ <- string ", " - return w - gregDay <- date +dateTime ∷ Parser ZonedTime +dateTime = do weekDay ← optionMaybe $ + do w ← shortWeekDayNameP + _ ← string ", " + return w + gregDay ← date case weekDay of Nothing - -> return () -- No day in week exists. + -> return () Just givenWD -> assertWeekDayIsGood givenWD gregDay - (tod, timeZone) <- rfc822time + (tod, timeZone) ← rfc822time let lt = LocalTime gregDay tod zt = ZonedTime lt timeZone return zt -date :: Stream s m Char => ParsecT s u m Day -date = do day <- read2 - _ <- char ' ' - month <- shortMonthNameP - _ <- char ' ' - year <- liftM (+ 1900) read2 - _ <- char ' ' +date ∷ Parser Day +date = do day ← read2 + _ ← char ' ' + month ← shortMonthNameP + _ ← char ' ' + year ← (+ 1900) <$> read2 + _ ← char ' ' assertGregorianDateIsGood year month day -rfc822time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone) -rfc822time = do tod <- hour - _ <- char ' ' - tz <- zone +-- |Parse the time and time zone of an RFC 822 date and time string. +rfc822time ∷ Parser (TimeOfDay, TimeZone) +rfc822time = do tod ← hms + _ ← char ' ' + tz ← zone return (tod, tz) -hour :: Stream s m Char => ParsecT s u m TimeOfDay -hour = do hour <- read2 - minute <- char ':' >> read2 - second <- option 0 (char ':' >> read2) - assertTimeOfDayIsGood hour minute second +hms ∷ Parser TimeOfDay +hms = do hour ← read2 + minute ← char ':' *> read2 + second ← option 0 (char ':' *> read2) + assertTimeOfDayIsGood hour minute second -zone :: Stream s m Char => ParsecT s u m TimeZone -zone = choice [ string "UT" >> return (TimeZone 0 False "UT" ) - , string "GMT" >> return (TimeZone 0 False "GMT") +zone ∷ Parser TimeZone +zone = choice [ string "UT" *> return (TimeZone 0 False "UT" ) + , string "GMT" *> return (TimeZone 0 False "GMT") , char 'E' - >> choice [ string "ST" >> return (TimeZone ((-5) * 60) False "EST") - , string "DT" >> return (TimeZone ((-4) * 60) True "EDT") + *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST") + , string "DT" *> return (TimeZone ((-4) * 60) True "EDT") ] , char 'C' - >> choice [ string "ST" >> return (TimeZone ((-6) * 60) False "CST") - , string "DT" >> return (TimeZone ((-5) * 60) True "CDT") + *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST") + , string "DT" *> return (TimeZone ((-5) * 60) True "CDT") ] , char 'M' - >> choice [ string "ST" >> return (TimeZone ((-7) * 60) False "MST") - , string "DT" >> return (TimeZone ((-6) * 60) True "MDT") + *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST") + , string "DT" *> return (TimeZone ((-6) * 60) True "MDT") , return (TimeZone ((-12) * 60) False "M") ] , char 'P' - >> choice [ string "ST" >> return (TimeZone ((-8) * 60) False "PST") - , string "DT" >> return (TimeZone ((-7) * 60) True "PDT") + *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST") + , string "DT" *> return (TimeZone ((-7) * 60) True "PDT") ] - , char 'Z' >> return (TimeZone 0 False "Z") - , char 'A' >> return (TimeZone ((-1) * 60) False "A") - , char 'N' >> return (TimeZone ( 1 * 60) False "N") - , char 'Y' >> return (TimeZone ( 12 * 60) False "Y") + , char 'Z' *> return (TimeZone 0 False "Z") + , char 'A' *> return (TimeZone ((-1) * 60) False "A") + , char 'N' *> return (TimeZone ( 1 * 60) False "N") + , char 'Y' *> return (TimeZone ( 12 * 60) False "Y") , read4digitsTZ ] diff --git a/cabal-package.mk b/cabal-package.mk index 2363b98..572e5b6 100644 --- a/cabal-package.mk +++ b/cabal-package.mk @@ -112,19 +112,26 @@ fixme: lint: $(HLINT) . --report -push: doc ditz +push: push-repo push-ditz push-doc + +push-repo: if [ -d "_darcs" ]; then \ darcs push; \ elif [ -d ".git" ]; then \ git push --all && git push --tags; \ fi + +push-ditz: ditz + rsync -av --delete \ + dist/ditz/ \ + www@nem.cielonegro.org:static.cielonegro.org/htdocs/ditz/$(PKG_NAME) + +push-doc: doc if [ -d "dist/doc" ]; then \ rsync -av --delete \ dist/doc/html/$(PKG_NAME)/ \ www@nem.cielonegro.org:static.cielonegro.org/htdocs/doc/$(PKG_NAME); \ fi - rsync -av --delete \ - dist/ditz/ \ - www@nem.cielonegro.org:static.cielonegro.org/htdocs/ditz/$(PKG_NAME) -.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook install doc sdist test lint push +.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook \ + install doc sdist test lint push push-repo push-ditz push-doc diff --git a/time-http.cabal b/time-http.cabal index f708239..4687c0f 100644 --- a/time-http.cabal +++ b/time-http.cabal @@ -47,3 +47,6 @@ Library Extensions: FlexibleContexts + + GHC-Options: + -Wall \ No newline at end of file -- 2.40.0