Update clock dependency

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
 --

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)

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))

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)

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