diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,29 @@ + + + + + w3cdatetime + + + PHO + + + + + + + + + + + + diff --git a/Data/Time/W3C.hs b/Data/Time/W3C.hs new file mode 100644 --- /dev/null +++ b/Data/Time/W3C.hs @@ -0,0 +1,16 @@ +-- | This package provides functionalities to parse and format W3C +-- Date and Time. The package can also be used to convert it from/to +-- 'Data.Time.Calendar.Day' and 'Data.Time.LocalTime.ZonedTime'. +-- +-- See: + +module Data.Time.W3C + ( W3CDateTime(..) + , format + , parse + ) + where + +import Data.Time.W3C.Format +import Data.Time.W3C.Parser +import Data.Time.W3C.Types diff --git a/Data/Time/W3C/Format.hs b/Data/Time/W3C/Format.hs new file mode 100644 --- /dev/null +++ b/Data/Time/W3C/Format.hs @@ -0,0 +1,85 @@ +-- | Format W3C Date and Time strings. +module Data.Time.W3C.Format + ( format + ) + where + +import Data.Convertible +import Data.Fixed +import Data.Time +import Data.Time.W3C.Types + + +-- | Format W3C Date and Time string from anything convertible to +-- 'W3CDateTime' type. The most obvious acceptable type is the +-- 'W3CDateTime' itself. +format :: Convertible t W3CDateTime => t -> String +format = format' . convert + where + format' (W3CDateTime year Nothing Nothing Nothing Nothing Nothing Nothing) + = show4 year + + format' (W3CDateTime year (Just month) Nothing Nothing Nothing Nothing Nothing) + = concat [show4 year, "-", show2 month] + + format' (W3CDateTime year (Just month) (Just day) Nothing Nothing Nothing Nothing) + = concat [show4 year, "-", show2 month, "-", show2 day] + + format' (W3CDateTime year (Just month) (Just day) (Just hour) (Just minute) Nothing (Just tz)) + = concat [ show4 year + , "-" + , show2 month + , "-" + , show2 day + , "T" + , show2 hour + , ":" + , show2 minute + , showTZ tz + ] + + format' (W3CDateTime year (Just month) (Just day) (Just hour) (Just minute) (Just second) (Just tz)) + = concat [ show4 year + , "-" + , show2 month + , "-" + , show2 day + , "T" + , show2 hour + , ":" + , show2 minute + , ":" + , case properFraction second :: (Int, Pico) of + (int, 0 ) -> show2 int + (int, frac) -> show2 int ++ tail (showFixed True frac) + , showTZ tz + ] + + format' w = error ("Invalid W3C Date and Time: " ++ show w) + +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) + +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) + +showTZ :: TimeZone -> String +showTZ tz + = case timeZoneMinutes tz of + offset | offset < 0 -> '-' : showTZ' (negate offset) + | offset == 0 -> "Z" + | otherwise -> '+' : showTZ' offset + where + showTZ' offset + = let h = offset `div` 60 + m = offset - h * 60 + in + concat [show2 h, ":", show2 m] diff --git a/Data/Time/W3C/Parser.hs b/Data/Time/W3C/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/Time/W3C/Parser.hs @@ -0,0 +1,24 @@ +-- | Parse W3C Date and Time string. +module Data.Time.W3C.Parser + ( parse + ) + where + +import qualified Text.Parsec as P + +import Data.Convertible +import Data.Time.W3C.Parser.Parsec +import Data.Time.W3C.Types + +-- | Parse W3C Date and Time string to anything convertible from +-- 'W3CDateTime' type. The most obvious acceptable type is the +-- 'W3CDateTime' itself. If the given string is ill-formatted, 'parse' +-- returns 'Prelude.Nothing'. +parse :: Convertible W3CDateTime t => String -> Maybe t +parse src = case P.parse p "" src of + Right w3c -> Just (convert w3c) + Left _ -> Nothing + where + p = do w3c <- w3cDateTime + _ <- P.eof + return w3c diff --git a/Data/Time/W3C/Parser/Parsec.hs b/Data/Time/W3C/Parser/Parsec.hs new file mode 100644 --- /dev/null +++ b/Data/Time/W3C/Parser/Parsec.hs @@ -0,0 +1,137 @@ +-- | W3C Date and Time parser combinator for "Text.Parsec". +module Data.Time.W3C.Parser.Parsec + ( w3cDateTime + ) + where + +import Control.Monad +import Data.Time +import Data.Time.W3C.Types +import Text.Parsec + +-- | This is a parser combinator for "Text.Parsec". +w3cDateTime :: Stream s m Char => ParsecT s u m W3CDateTime +w3cDateTime = read4 >>= mdhmst + where + mdhmst year + = ( char '-' >> read2 >>= dhmst year ) + <|> + return W3CDateTime { + w3cYear = year + , w3cMonth = Nothing + , w3cDay = Nothing + , w3cHour = Nothing + , w3cMinute = Nothing + , w3cSecond = Nothing + , w3cTimeZone = Nothing + } + dhmst year month + = ( char '-' >> read2 >>= hmst year month ) + <|> + return W3CDateTime { + w3cYear = year + , w3cMonth = Just month + , w3cDay = Nothing + , w3cHour = Nothing + , w3cMinute = Nothing + , w3cSecond = Nothing + , w3cTimeZone = Nothing + } + hmst year month day + = ( do _ <- char 'T' + h <- read2 + _ <- char ':' + m <- read2 + st year month day h m + ) + <|> + return W3CDateTime { + w3cYear = year + , w3cMonth = Just month + , w3cDay = Just day + , w3cHour = Nothing + , w3cMinute = Nothing + , w3cSecond = Nothing + , w3cTimeZone = Nothing + } + st year month day hour minute + = ( do _ <- char ':' + s <- second + t <- timezone + return W3CDateTime { + w3cYear = year + , w3cMonth = Just month + , w3cDay = Just day + , w3cHour = Just hour + , w3cMinute = Just minute + , w3cSecond = Just s + , w3cTimeZone = Just t + } + ) + <|> + ( do t <- timezone + return W3CDateTime { + w3cYear = year + , w3cMonth = Just month + , w3cDay = Just day + , w3cHour = Just hour + , w3cMinute = Just minute + , w3cSecond = Nothing + , w3cTimeZone = Just t + } + ) + + second = do int <- read2 + frac <- option 0 (char '.' >> liftM parseFrac (many1 digit)) + return (int + frac) + + timezone = liftM minutesToTimeZone + ( ( char 'Z' >> return 0 ) + <|> + do sign <- ( char '+' >> return 1 ) + <|> + ( char '-' >> return (-1) ) + h <- read2 + _ <- char ':' + m <- read2 + return (sign * (h * 60 + m)) + ) + +{- 0.152 => 2,5,1 --> + * (0 / 10) + 0.2 = 0.2 + * (0.2 / 10) + 0.5 = 0.52 + * (0.52 / 10) + 0.1 = 0.152 *done* + -} +parseFrac :: RealFrac r => String -> r +parseFrac = parseFrac' 0 . reverse . map fromC + where + parseFrac' r [] = r + parseFrac' r (d:ds) = parseFrac' (r / 10 + d / 10) ds + +read4 :: (Stream s m Char, Num n) => ParsecT s u m n +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' + return (n1 * 10 + n2) + +digit' :: (Stream s m Char, Num n) => ParsecT s u m n +digit' = liftM fromC digit + +fromC :: Num n => Char -> n +fromC '0' = 0 +fromC '1' = 1 +fromC '2' = 2 +fromC '3' = 3 +fromC '4' = 4 +fromC '5' = 5 +fromC '6' = 6 +fromC '7' = 7 +fromC '8' = 8 +fromC '9' = 9 +fromC _ = undefined diff --git a/Data/Time/W3C/Types.hs b/Data/Time/W3C/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Time/W3C/Types.hs @@ -0,0 +1,108 @@ +-- | Data types defined by this package. +module Data.Time.W3C.Types + ( W3CDateTime(..) + ) + where + +import Data.Convertible +import Data.Fixed +import Data.Time +import Data.Typeable + + +-- |'W3CDateTime' represents a W3C Date and Time format. +-- +-- The field 'w3cYear' is mandatory while other fields are +-- optional. But you should be careful about combinations of such +-- optional fields. No combinations are allowed except for the +-- following list: +-- +-- * YYYY +-- +-- * YYYY-MM +-- +-- * YYYY-MM-DD +-- +-- * YYYY-MM-DDThh:mmTZD +-- +-- * YYYY-MM-DDThh:mm:ss.sTZD +-- +-- This data type is /partially ordered/ so we can't make it an +-- instance of Ord (e.g. @\"2010\"@ and @\"2010-01\"@ can't be +-- compared). +data W3CDateTime + = W3CDateTime { + w3cYear :: !Integer + , w3cMonth :: !(Maybe Int) + , w3cDay :: !(Maybe Int) + , w3cHour :: !(Maybe Int) + , w3cMinute :: !(Maybe Int) + , w3cSecond :: !(Maybe Pico) + , w3cTimeZone :: !(Maybe TimeZone) + } + deriving (Show, Eq, Typeable) + +fetch :: (Show a, Typeable a, Typeable b) => + String + -> (a -> Maybe b) + -> a + -> ConvertResult b +fetch name f a + = case f a of + Nothing -> convError ("No " ++ name ++ " information in the given value") a + Just b -> return b + +instance Convertible W3CDateTime W3CDateTime where + safeConvert = return + +instance Convertible Day W3CDateTime where + safeConvert day + = case toGregorian day of + (y, m, d) -> return W3CDateTime { + w3cYear = y + , w3cMonth = Just m + , w3cDay = Just d + , w3cHour = Nothing + , w3cMinute = Nothing + , w3cSecond = Nothing + , w3cTimeZone = Nothing + } + +instance Convertible W3CDateTime Day where + safeConvert w3c + = do let y = w3cYear w3c + m <- fetch "month" w3cMonth w3c + d <- fetch "day" w3cDay w3c + return (fromGregorian y m d) + +instance Convertible ZonedTime W3CDateTime where + safeConvert zt + = let lt = zonedTimeToLocalTime zt + tz = zonedTimeZone zt + ymd = localDay lt + hms = localTimeOfDay lt + in + return W3CDateTime { + w3cYear = case toGregorian ymd of (y, _, _) -> y + , w3cMonth = Just (case toGregorian ymd of (_, m, _) -> m) + , w3cDay = Just (case toGregorian ymd of (_, _, d) -> d) + , w3cHour = Just (todHour hms) + , w3cMinute = Just (todMin hms) + , w3cSecond = Just (todSec hms) + , w3cTimeZone = Just tz + } + +instance Convertible W3CDateTime ZonedTime where + safeConvert w3c + = do day <- safeConvert w3c + tod <- do h <- fetch "hour" w3cHour w3c + m <- fetch "minute" w3cMinute w3c + s <- fetch "second" w3cSecond w3c + case makeTimeOfDayValid h m s of + Just tod -> return tod + Nothing -> convError "Invalid time of day" w3c + tz <- fetch "timezone" w3cTimeZone w3c + return ZonedTime { + zonedTimeToLocalTime = LocalTime day tod + , zonedTimeZone = tz + } diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,9 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +import System.Cmd +import System.Exit + +main = defaultMainWithHooks (simpleUserHooks { runTests = runTestUnit }) + where + runTestUnit _ _ _ _ + = system "./dist/build/W3CDateTimeUnitTest/W3CDateTimeUnitTest" >> return () diff --git a/tests/ConversionTest.hs b/tests/ConversionTest.hs new file mode 100644 --- /dev/null +++ b/tests/ConversionTest.hs @@ -0,0 +1,45 @@ +module ConversionTest + ( testData + ) + where + +import Data.Convertible +import Data.Time +import Data.Time.W3C +import Test.HUnit + + +instance Eq ZonedTime where + a == b + = zonedTimeToUTC a == zonedTimeToUTC b + + +testData :: [Test] +testData = [ convert (W3CDateTime 2010 (Just 1) (Just 2) Nothing Nothing Nothing Nothing) + ~?= + fromGregorian 2010 1 2 + + , convert (W3CDateTime 2010 (Just 1) (Just 2) (Just 3) (Just 4) (Just 5.666666) (Just utc)) + ~?= + ZonedTime { + zonedTimeToLocalTime = let day = fromGregorian 2010 1 2 + tod = TimeOfDay 3 4 5.666666 + in + LocalTime day tod + , zonedTimeZone = utc + } + + , convert (fromGregorian 2010 1 2) + ~?= + W3CDateTime 2010 (Just 1) (Just 2) Nothing Nothing Nothing Nothing + + , convert ZonedTime { + zonedTimeToLocalTime = let day = fromGregorian 2010 1 2 + tod = TimeOfDay 3 4 5.666666 + in + LocalTime day tod + , zonedTimeZone = utc + } + ~?= + W3CDateTime 2010 (Just 1) (Just 2) (Just 3) (Just 4) (Just 5.666666) (Just utc) + ] diff --git a/tests/FormatterTest.hs b/tests/FormatterTest.hs new file mode 100644 --- /dev/null +++ b/tests/FormatterTest.hs @@ -0,0 +1,35 @@ +module FormatterTest + ( testData + ) + where + +import Data.Time +import Data.Time.W3C +import Test.HUnit + + +testData :: [Test] +testData = [ format (W3CDateTime 2010 Nothing Nothing Nothing Nothing Nothing Nothing) + ~?= + "2010" + + , format (W3CDateTime 2010 (Just 12) Nothing Nothing Nothing Nothing Nothing) + ~?= + "2010-12" + + , format (W3CDateTime 2010 (Just 12) (Just 31) Nothing Nothing Nothing Nothing) + ~?= + "2010-12-31" + + , format (W3CDateTime 2010 (Just 12) (Just 31) (Just 1) (Just 23) Nothing (Just utc)) + ~?= + "2010-12-31T01:23Z" + + , format (W3CDateTime 2010 (Just 12) (Just 31) (Just 1) (Just 23) (Just 45) (Just (hoursToTimeZone 9))) + ~?= + "2010-12-31T01:23:45+09:00" + + , format (W3CDateTime 2010 (Just 12) (Just 31) (Just 1) (Just 23) (Just 45.666666) (Just (hoursToTimeZone 9))) + ~?= + "2010-12-31T01:23:45.666666+09:00" + ] diff --git a/tests/ParsecParserTest.hs b/tests/ParsecParserTest.hs new file mode 100644 --- /dev/null +++ b/tests/ParsecParserTest.hs @@ -0,0 +1,76 @@ +module ParsecParserTest + ( testData + ) + where + +import Data.Time +import Data.Time.W3C hiding (parse) +import Data.Time.W3C.Parser.Parsec +import Test.HUnit +import Text.Parsec + + +parseW3C :: String -> Either String W3CDateTime +parseW3C src = case parse w3cDateTime "" src of + Left err -> Left (show err) + Right w3c -> Right w3c + +parseW3C' :: String -> Maybe W3CDateTime +parseW3C' src = case parse w3cDateTime "" src of + Left _ -> Nothing + Right w3c -> Just w3c + + +testData :: [Test] +testData = [ parseW3C "2010" + ~?= + Right (W3CDateTime 2010 Nothing Nothing Nothing Nothing Nothing Nothing) + + , parseW3C "2010-12" + ~?= + Right (W3CDateTime 2010 (Just 12) Nothing Nothing Nothing Nothing Nothing) + + , parseW3C "2010-12-31" + ~?= + Right (W3CDateTime 2010 (Just 12) (Just 31) Nothing Nothing Nothing Nothing) + + , parseW3C "2010-12-31T01:23Z" + ~?= + Right (W3CDateTime 2010 (Just 12) (Just 31) (Just 1) (Just 23) Nothing (Just (hoursToTimeZone 0))) + + , parseW3C "2010-12-31T01:23:45+09:00" + ~?= + Right (W3CDateTime 2010 (Just 12) (Just 31) (Just 1) (Just 23) (Just 45) (Just (hoursToTimeZone 9))) + + , parseW3C "2010-12-31T01:23:45.666666+09:00" + ~?= + Right (W3CDateTime 2010 (Just 12) (Just 31) (Just 1) (Just 23) (Just 45.666666) (Just (hoursToTimeZone 9))) + + , parseW3C' "" + ~?= + Nothing + + , parseW3C' "99-01-01" + ~?= + Nothing + + , parseW3C' "2010-01-01T" + ~?= + Nothing + + , parseW3C' "2010-01-01T10Z" + ~?= + Nothing + + , parseW3C' "2010-01-01T11:22" + ~?= + Nothing + + , parseW3C' "2010-01-01T11:22:33" + ~?= + Nothing + + , parseW3C' "2010-01-01T11:22:33.Z" + ~?= + Nothing + ] diff --git a/tests/W3CDateTimeUnitTest.hs b/tests/W3CDateTimeUnitTest.hs new file mode 100644 --- /dev/null +++ b/tests/W3CDateTimeUnitTest.hs @@ -0,0 +1,13 @@ +import Test.HUnit +import qualified ConversionTest +import qualified FormatterTest +import qualified ParsecParserTest + +main :: IO () +main = do runTestTT (test testData) >> return () + +testData :: [Test] +testData = [ "conversion" ~: ConversionTest.testData + , "parser" ~: ParsecParserTest.testData + , "formatter" ~: FormatterTest.testData + ] diff --git a/time-w3c.cabal b/time-w3c.cabal new file mode 100644 --- /dev/null +++ b/time-w3c.cabal @@ -0,0 +1,77 @@ +Name: time-w3c +Version: 0.1 +Synopsis: Parse, format and convert W3C Date and Time +Description: + This package provides functionalities to parse and format W3C + Date and Time. The package can also be used to convert it + from/to 'Data.Time.Calendar.Day' and + 'Data.Time.LocalTime.ZonedTime'. + + See: + +License: PublicDomain +License-file: COPYING +Author: PHO +Maintainer: PHO +Stability: Experimental +Homepage: http://cielonegro.org/W3CDateTime.html +Category: Web +Build-type: Simple +Cabal-version: >= 1.6 +Extra-source-files: + +Source-Repository head + Type: git + Location: git://git.cielonegro.org/time-w3c.git + +Flag build-test-suite + Description: Build the tst suite. + Default: False + +Library + Exposed-modules: + Data.Time.W3C + Data.Time.W3C.Format + Data.Time.W3C.Parser + Data.Time.W3C.Parser.Parsec + Data.Time.W3C.Types + + Build-depends: + base >= 4 && < 5, + convertible >= 1.0 && < 2, + parsec >= 3 && < 4, + time >= 1.1 && < 2 + + Extensions: + DeriveDataTypeable + FlexibleContexts + MultiParamTypeClasses + + GHC-Options: + -Wall + +Executable W3CDateTimeUnitTest + Main-Is: + W3CDateTimeUnitTest.hs + + if flag(build-test-suite) + Buildable: True + Build-Depends: HUnit >= 1.2 && < 2 + else + Buildable: False + + Hs-Source-Dirs: + ., tests + + Other-Modules: + ConversionTest + FormatterTest + ParsecParserTest + + Extensions: + DeriveDataTypeable + FlexibleContexts + MultiParamTypeClasses + + GHC-Options: + -Wall