diff --git a/Data/UTC.hs b/Data/UTC.hs index 15829a7..ebdf64e 100644 --- a/Data/UTC.hs +++ b/Data/UTC.hs @@ -61,6 +61,8 @@ import Data.UTC.Type.Local import Data.UTC.Type.Exception import Data.UTC.Format.Rfc3339 import Data.UTC.Format.Iso8601 +import Data.UTC.Format.Iso8601 +import Data.UTC.Literals () -- $quickstart -- diff --git a/Data/UTC/Literals.hs b/Data/UTC/Literals.hs new file mode 100644 index 0000000..7667ea3 --- /dev/null +++ b/Data/UTC/Literals.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.UTC.Literals + ( Date + , Time + , DateTime + ) where + +import Control.Applicative (liftA2, (*>), (<*)) +import Control.Monad (guard) +import Data.Attoparsec.Combinator +import Data.Attoparsec.Text (Parser, decimal, digit, parseOnly, + skip, char) +import Data.Char (ord) +import Data.Maybe (fromJust, isJust) +import Data.Monoid ((<>)) +import Data.Ratio +import qualified Data.Text as T +import GHC.Exts (IsString (..)) + +import Data.UTC.Class.Epoch +import Data.UTC.Class.IsDate +import Data.UTC.Class.IsTime +import Data.UTC.Type.Date +import Data.UTC.Type.DateTime +import Data.UTC.Type.Time + + +instance IsString Date where + fromString s = case parseOnly (iso8601Parser <* endOfInput) (T.pack s) of + Right d -> d + _ -> error ("Could not parse date '" <> s <> "' (expected YYYY-MM-DD)") + +decimal1 :: Parser Integer +decimal1 = do + d <- digit + return (fromIntegral (ord d - 48)) + +decimal2 :: Parser Integer +decimal2 = + do d1 <- decimal1 + d2 <- decimal1 + return $ d1 * 10 + d2 + +iso8601Parser :: Parser Date +iso8601Parser = do + y <- decimal <* skip (=='-') + m <- decimal2 <* skip (=='-') + d <- decimal2 + let r = setYear y epoch >>= setMonth m >>= setDay d + guard (isJust r) + return (fromJust r) + + +instance IsString Time where + fromString s = case parseOnly (timeParser <* endOfInput) (T.pack s) of + Right t -> t + _ -> error ("Could not parse time '"<> s <> "' (expected HH:MM:SS[.mmm])") + +timeParser :: Parser Time +timeParser = do + h <- decimal2 <* skip (==':') + m <- decimal2 <* skip (==':') + s <- decimal2 + f <- option 0 timeSecfrac "time fraction" + let r = setHour h epoch >>= setMinute m >>= setSecond s >>= setSecondFraction f + guard (isJust r) + return (fromJust r) + +timeSecfrac :: Parser (Ratio Integer) +timeSecfrac = do + decs <- char '.' *> many1 digit + return $ (read decs :: Integer) % (10 ^ length decs) + + +instance IsString DateTime where + fromString s = case parseOnly datetimeParser (T.pack s) of + Right dt -> dt + _ -> error ("Could not parse datetime '"<> s <> "' (expected YYYY-MM-DD HH:MM:SS[.mmm])") + +datetimeParser :: Parser DateTime +datetimeParser = liftA2 DateTime (iso8601Parser <* char ' ') (timeParser <* endOfInput) diff --git a/Data/UTC/Literals/Test.hs b/Data/UTC/Literals/Test.hs new file mode 100644 index 0000000..9c55611 --- /dev/null +++ b/Data/UTC/Literals/Test.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.UTC.Literals.Test where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Test.QuickCheck.Property (protect) + +import Control.Applicative (liftA2) +import Data.Monoid ((<>)) +import Data.Ratio ((%)) +import Data.UTC.Literals () +import GHC.Exts (IsString (..)) + +import Data.UTC.Class.Epoch +import Data.UTC.Class.IsDate +import Data.UTC.Class.IsTime +import Data.UTC.Type.Date +import Data.UTC.Type.DateTime +import Data.UTC.Type.Time + +test :: Test +test + = testGroup "Data.UTC.Literals" + [ testValidLiteral "2016-02-01" (setYear 2016 (epoch :: Date) >>= setMonth 2 >>= setDay 1) + , testInvalidDateLiteral "2016-02-010" + , testInvalidDateLiteral "2016-002-01" + , testInvalidDateLiteral "2016-02-30" + , testInvalidDateLiteral "2016-13-30" + , testValidLiteral "12:30:59" (setHour 12 (epoch :: Time) >>= setMinute 30 >>= setSecond 59) + , testValidLiteral "12:30:59.8234" (setHour 12 (epoch :: Time) >>= setMinute 30 >>= setSecond 59 >>= setSecondFraction (8234 % 10000)) + , testInvalidTimeLiteral "12:30:59.82u34" + , testInvalidTimeLiteral "12:30:60" + , testInvalidTimeLiteral "012:30:59" + , testInvalidTimeLiteral "12:030:59" + , testInvalidTimeLiteral "12:30:059" + , testValidLiteral "2016-02-01 12:30:59" $ Just (DateTime "2016-02-01" "12:30:59") + , testValidLiteral "2016-02-01 12:30:59.8234" $ liftA2 DateTime (setYear 2016 (epoch :: Date) >>= setMonth 2 >>= setDay 1) (setHour 12 (epoch :: Time) >>= setMinute 30 >>= setSecond 59 >>= setSecondFraction (8234 % 10000)) + , testInvalidDateTimeLiteral "2016-02-30 12:30:59.8234" + , testInvalidDateTimeLiteral "2016-02-01 12:30:60.8234" + ] + +testValidLiteral :: (Eq a, Show a, IsString a) => String -> Maybe a -> Test +testValidLiteral s expected = testProperty ("'" <> s <> "' is a valid literal") $ Just (fromString s) === expected + +testInvalidDateLiteral :: String -> Test +testInvalidDateLiteral s = testProperty ("'" <> s <> "' is an invalid literal Date") $ monadicIO (do a <- run x; assert (a == epoch)) + where x = protect (const epoch) (return (fromString s :: Date)) + +testInvalidTimeLiteral :: String -> Test +testInvalidTimeLiteral s = testProperty ("'" <> s <> "' is an invalid literal Time") $ monadicIO (do a <- run x; assert (a == epoch)) + where x = protect (const epoch) (return (fromString s :: Time)) + +testInvalidDateTimeLiteral :: String -> Test +testInvalidDateTimeLiteral s = testProperty ("'" <> s <> "' is an invalid literal DateTime") $ monadicIO (do a <- run x; assert (a == epoch)) + where x = protect (const epoch) (return (fromString s :: DateTime)) diff --git a/tests/Test.hs b/tests/Test.hs index 5ee3151..7d63337 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -9,6 +9,7 @@ import Data.UTC import Data.UTC.Internal.Test (test) import Data.UTC.Class.IsDate.Test (test) +import Data.UTC.Literals.Test (test) main :: IO () main @@ -24,6 +25,7 @@ main , Data.UTC.Internal.Test.test , Data.UTC.Class.IsDate.Test.test + , Data.UTC.Literals.Test.test , testProperty "(parseRfc3339 \"2014-12-24T13:37:00Z\" :: Maybe (Local DateTime)) >>= addHours 25 >>= setMonth 1 >>= renderRfc3339" $ ((parseRfc3339 "2014-12-24T13:37:00Z" :: Maybe (Local DateTime)) >>= addHours 25 >>= setMonth 1 >>= renderRfc3339) diff --git a/utc.cabal b/utc.cabal index e36ab38..3fe3535 100644 --- a/utc.cabal +++ b/utc.cabal @@ -1,5 +1,5 @@ name: utc -version: 0.2.0.1 +version: 0.2.0.2 stability: experimental synopsis: A pragmatic time and date library. description: This library aims to supply you with common @@ -55,6 +55,7 @@ Library , Data.UTC.Internal , Data.UTC.Format.Rfc3339.Parser , Data.UTC.Format.Rfc3339.Builder + , Data.UTC.Literals Test-Suite test type: exitcode-stdio-1.0 @@ -82,11 +83,13 @@ Test-Suite test , Data.UTC.Format.Rfc3339.Builder , Data.UTC.Internal , Data.UTC.Internal.Test + , Data.UTC.Literals + , Data.UTC.Literals.Test build-depends: base < 5 , text , bytestring >= 0.10.4.0 , attoparsec - , clock >= 0.3 && < 0.5 + , clock >= 0.3 && < 1 , exceptions >= 0.4 -- additional deps for testing , Cabal