Data.Ascii now uses convertible

Ditz-issue: 0a3272772c73cf31486eb2b6691fa38232d3c4c5

diff --git a/Data/Time/Asctime.hs b/Data/Time/Asctime.hs
index 39d9961a8f68b0cd2c62641c464e964d13a02d8d..f7d7bddaa64114ad20728428119d6d38b6ae2e49 100644 (file)
--- a/Data/Time/Asctime.hs
+++ b/Data/Time/Asctime.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE
-    OverloadedStrings
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , OverloadedStrings
   , UnicodeSyntax
   #-}
 -- |This module provides functions for ANSI C's asctime() format.
@@ -23,36 +25,45 @@
 -- As you can see, it has no time zone info. "Data.Time.HTTP" will
 -- treat it as UTC.
 module Data.Time.Asctime
-    ( -- * Formatting
-      toAscii
-    , toAsciiBuilder
-
-      -- * Parsing
-    , fromAscii
+    ( Asctime
     , asctime
     )
     where
+import Control.Applicative
 import Data.Ascii (Ascii, AsciiBuilder)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8
+import Data.Convertible.Base
 import Data.Monoid.Unicode
+import Data.Tagged
 import Data.Time
 import Data.Time.Calendar.WeekDate
 import Data.Time.HTTP.Common
 import Prelude.Unicode
 
--- |Convert a 'LocalTime' to ANSI C's @asctime()@ string.
-toAscii ∷ LocalTime → Ascii
-toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder
+-- |The phantom type for conversion between ANSI C's @asctime()@
+-- string and 'LocalTime'.
+data Asctime
 
--- |Parse an ANSI C's @asctime()@ string. When the string can't be
--- parsed, it returns @'Left' err@.
-fromAscii ∷ Ascii → Either String LocalTime
-fromAscii = parseOnly p ∘ A.toByteString
-    where
-      p = do zt ← asctime
-             endOfInput
-             return zt
+instance ConvertSuccess LocalTime (Tagged Asctime Ascii) where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
+
+instance ConvertAttempt LocalTime (Tagged Asctime Ascii) where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+
+instance ConvertSuccess LocalTime (Tagged Asctime AsciiBuilder) where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = Tagged ∘ toAsciiBuilder
+
+instance ConvertAttempt LocalTime (Tagged Asctime AsciiBuilder) where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = return ∘ cs
+
+instance ConvertAttempt (Tagged Asctime Ascii) LocalTime where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = parseAttempt' asctime ∘ untag
 
 -- |Parse an ANSI C's @asctime()@ string.
 asctime ∷ Parser LocalTime
@@ -76,7 +87,6 @@ asctime = do weekDay ← shortWeekDayNameP
 
              return (LocalTime gregDay tod)
 
--- |Convert a 'LocalTime' to ANSI C's @asctime()@ string.
 toAsciiBuilder ∷ LocalTime → AsciiBuilder
 toAsciiBuilder localTime
     = let (year, month, day) = toGregorian (localDay localTime)

diff --git a/Data/Time/HTTP/Common.hs b/Data/Time/HTTP/Common.hs
index f7c74c91e1326b5944ea06d5082c0415ac2f0044..84beeb3665cd9439f66f85bb5bae18197dfbe187 100644 (file)
--- a/Data/Time/HTTP/Common.hs
+++ b/Data/Time/HTTP/Common.hs
@@ -31,15 +31,23 @@ module Data.Time.HTTP.Common
     , assertTimeOfDayIsGood
 
     , optionMaybe
+    , finishOff
+
+    , parseAttempt
+    , parseAttempt'
     )
     where
 import Blaze.ByteString.Builder.ByteString as B
 import Blaze.Text.Int as BT
 import Control.Applicative
+import Control.Exception.Base
 import Control.Monad
-import Data.Ascii (AsciiBuilder)
+import Control.Monad.Unicode
+import Data.Ascii (Ascii, AsciiBuilder)
 import qualified Data.Ascii as A
+import Data.Attempt
 import Data.Attoparsec.Char8 as P
+import Data.ByteString (ByteString)
 import Data.Char
 import Data.Monoid.Unicode
 import Data.Fixed
@@ -282,7 +290,7 @@ assertWeekDayIsGood givenWD gregDay
           (year, month, day) = toGregorian gregDay
       in
         unless (givenWD ≡ correctWD)
-            $ fail
+            ∘ fail
             $ concat [ "Gregorian day "
                      , show year
                      , "-"
@@ -332,3 +340,28 @@ optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a)
 {-# INLINE optionMaybe #-}
 optionMaybe p
     = option Nothing (Just <$> p)
+
+finishOff ∷ Parser α → Parser α
+{-# INLINE finishOff #-}
+finishOff = ((endOfInput *>) ∘ return =≪)
+
+parseAttempt ∷ Exception e
+             ⇒ (String → e)
+             → Parser α
+             → ByteString
+             → Attempt α
+{-# INLINEABLE parseAttempt #-}
+parseAttempt f p bs
+    = case parseOnly (finishOff p) bs of
+        Right α → Success α
+        Left  e → Failure $ f e
+
+parseAttempt' ∷ Parser α → Ascii → Attempt α
+{-# INLINE parseAttempt' #-}
+parseAttempt' p a = parseAttempt h p bs
+    where
+      h ∷ String → StringException
+      h _ = StringException $ A.toString a
+
+      bs ∷ ByteString
+      bs = A.toByteString a

diff --git a/Test/Time/HTTP.hs b/Test/Time/HTTP.hs
index 0cf15d83736fa40d5f22620a88b84a0385702660..2f7225e15eaf2fe1e35d8eff196c0579c3917c32 100644 (file)
--- a/Test/Time/HTTP.hs
+++ b/Test/Time/HTTP.hs
@@ -5,8 +5,11 @@
 module Main (main) where
 import Control.Applicative
 import Control.Applicative.Unicode
+import Data.Ascii (Ascii)
+import Data.Convertible.Base
+import Data.Tagged
 import Data.Time
-import qualified Data.Time.Asctime as Asctime
+import Data.Time.Asctime
 import qualified Data.Time.HTTP    as HTTP
 import qualified Data.Time.RFC733  as RFC733
 import qualified Data.Time.RFC1123 as RFC1123
@@ -60,13 +63,21 @@ instance Arbitrary UTCTime where
 
 tests ∷ [Property]
 tests = [ -- Asctime
-          property ( Asctime.fromAscii "Sun Nov  6 08:49:37 1994"
-                     ≡ Right referenceLocalTime )
-
-        , property ( "Sun Nov  6 08:49:37 1994"
-                     ≡ Asctime.toAscii referenceLocalTime )
-
-        , property $ \lt → Right lt ≡ Asctime.fromAscii (Asctime.toAscii lt)
+          property ( convertUnsafe ( Tagged "Sun Nov  6 08:49:37 1994"
+                                     ∷ Tagged Asctime Ascii
+                                   )
+                     ≡ referenceLocalTime
+                   )
+
+        , property ( ( Tagged "Sun Nov  6 08:49:37 1994"
+                       ∷ Tagged Asctime Ascii
+                     )
+                     ≡ cs referenceLocalTime
+                   )
+
+        , property $ \lt → lt ≡ convertUnsafe ( cs (lt ∷ LocalTime)
+                                                ∷ Tagged Asctime Ascii
+                                              )
 
           -- RFC733
         , property ( RFC733.fromAscii "Sunday, 06-Nov-94 08:49:37 GMT"
@@ -88,7 +99,7 @@ tests = [ -- Asctime
 
           -- HTTP
         , property $ \ut → Right ut ≡ HTTP.fromAscii (HTTP.toAscii           ut )
-        , property $ \ut → Right ut ≡ HTTP.fromAscii (Asctime.toAscii (ut2lt ut))
+        , property $ \ut → Right ut ≡ HTTP.fromAscii (untag (cs (ut2lt ut) ∷ Tagged Asctime Ascii))
         , property $ \ut → Right ut ≡ HTTP.fromAscii (RFC733.toAscii  (ut2zt ut))
         , property $ \ut → Right ut ≡ HTTP.fromAscii (RFC1123.toAscii (ut2zt ut))
         ]

diff --git a/time-http.cabal b/time-http.cabal
index eae4ffaff88b8f460465bf32bac6f20af9659cd1..b6bc9aaec82101340626abda585af90ccecdd6fa 100644 (file)
--- a/time-http.cabal
+++ b/time-http.cabal
@@ -41,11 +41,13 @@ Library
 
     Build-depends:
         ascii                == 0.0.*,
+        attempt              == 0.3.*,
         attoparsec           == 0.9.*,
-        blaze-builder        == 0.3.*,
-        blaze-textual        == 0.2.*,
         base                 == 4.*,
         base-unicode-symbols == 0.2.*,
+        blaze-builder        == 0.3.*,
+        blaze-textual        == 0.2.*,
+        bytestring           == 0.9.*,
         convertible-text     == 0.3.*,
         tagged               == 0.2.*,
         time                 == 1.2.*
@@ -63,11 +65,13 @@ Test-Suite test-time-http
     Build-depends:
         QuickCheck           == 2.4.*,
         ascii                == 0.0.*,
+        attempt              == 0.3.*,
         attoparsec           == 0.9.*,
-        blaze-builder        == 0.3.*,
-        blaze-textual        == 0.2.*,
         base                 == 4.*,
         base-unicode-symbols == 0.2.*,
+        blaze-builder        == 0.3.*,
+        blaze-textual        == 0.2.*,
+        bytestring           == 0.9.*,
         convertible-text     == 0.3.*,
         tagged               == 0.2.*,
         time                 == 1.2.*