MIMEParams is now an instance of collections-api's type classes.

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a

diff --git a/Lucu.cabal b/Lucu.cabal
index 1c71aa8cac1c7a00c55aad787bf0cfc2a3f25ad1..bdc0b719355d5be829b04d74080bb2912c36a5f7 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -61,7 +61,6 @@ Library
         collections-api            == 1.0.*,
         collections-base-instances == 1.0.*,
         containers                 == 0.4.*,
         collections-api            == 1.0.*,
         collections-base-instances == 1.0.*,
         containers                 == 0.4.*,

-        containers-unicode-symbols == 0.3.*,

         directory                  == 1.1.*,
         filepath                   == 1.2.*,
         hxt                        == 9.1.*,
         directory                  == 1.1.*,
         filepath                   == 1.2.*,
         hxt                        == 9.1.*,


@@ -120,6 +119,7 @@ Library
         Network.HTTP.Lucu.ContentCoding
         Network.HTTP.Lucu.DefaultPage
         Network.HTTP.Lucu.Interaction
         Network.HTTP.Lucu.ContentCoding
         Network.HTTP.Lucu.DefaultPage
         Network.HTTP.Lucu.Interaction

+        Network.HTTP.Lucu.OrphanInstances

         Network.HTTP.Lucu.Postprocess
         Network.HTTP.Lucu.Preprocess
         Network.HTTP.Lucu.RequestReader
         Network.HTTP.Lucu.Postprocess
         Network.HTTP.Lucu.Preprocess
         Network.HTTP.Lucu.RequestReader

diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs
index 682e91f04d163ca2af6a6e691611350b4ffa8f79..5a1a9501bc22e60b3e6dd8b8bbac794790044fb0 100644 (file)
--- a/Network/HTTP/Lucu.hs
+++ b/Network/HTTP/Lucu.hs
@@ -57,7 +57,7 @@ module Network.HTTP.Lucu
 
       -- *** MIME Type
     , MIMEType(..)
 
       -- *** MIME Type
     , MIMEType(..)

-    , MIMEParams(..)
+    , MIMEParams

     , parseMIMEType
     , mimeType
 
     , parseMIMEType
     , mimeType
 

diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs
index 13357383941c983896e7481c24f627c5264f4b85..08c10602174cca93d03da0bc6e6540afb03574da 100644 (file)
--- a/Network/HTTP/Lucu/ETag.hs
+++ b/Network/HTTP/Lucu/ETag.hs
@@ -25,6 +25,7 @@ import Data.Attoparsec.Char8
 import Data.Data
 import Data.Monoid.Unicode
 import Language.Haskell.TH.Syntax
 import Data.Data
 import Data.Monoid.Unicode
 import Language.Haskell.TH.Syntax

+import Network.HTTP.Lucu.OrphanInstances ()

 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http hiding (token)
 import Network.HTTP.Lucu.Utils
 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http hiding (token)
 import Network.HTTP.Lucu.Utils


@@ -32,8 +33,8 @@ import Prelude.Unicode
 
 -- |An entity tag consists of a weakness flag and an opaque string.
 data ETag = ETag {
 
 -- |An entity tag consists of a weakness flag and an opaque string.
 data ETag = ETag {

-      -- |The weakness flag. Weak tags looks like W\/\"blahblah\" and
-      -- strong tags are like \"blahblah\". See:
+      -- |The weakness flag. Weak tags looks like @W\/\"blahblah\"@
+      -- and strong tags are like @\"blahblah\"@. See:

       -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec13.html#sec13.3.3>
       etagIsWeak ∷ !Bool
       -- |An opaque string. Only characters from 0x20 (sp) to 0x7e (~)
       -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec13.html#sec13.3.3>
       etagIsWeak ∷ !Bool
       -- |An opaque string. Only characters from 0x20 (sp) to 0x7e (~)


@@ -45,7 +46,7 @@ instance Lift ETag where
     lift (ETag {..})
         = [| ETag {
                etagIsWeak = $(lift etagIsWeak)
     lift (ETag {..})
         = [| ETag {
                etagIsWeak = $(lift etagIsWeak)

-             , etagToken  = $(liftAscii etagToken)
+             , etagToken  = $(lift etagToken )

              }
            |]
 
              }
            |]
 

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 2ee9cbb8ce60e39311b496aa2b8ebfe7666e9cbc..97a7603611937c3b16109c4332f743823bf7281c 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -23,7 +23,7 @@ import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import Data.List (intersperse)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import Data.List (intersperse)

-import qualified Data.Map as M
+import qualified Data.Map as M (Map)

 import Data.Collections
 import Data.Collections.BaseInstances ()
 import Data.Monoid
 import Data.Collections
 import Data.Collections.BaseInstances ()
 import Data.Monoid


@@ -77,8 +77,8 @@ instance Unfoldable Headers (CIAscii, Ascii) where
     empty
         = Headers empty
     {-# INLINE singleton #-}
     empty
         = Headers empty
     {-# INLINE singleton #-}

-    singleton v
-        = Headers $ singleton v
+    singleton p
+        = Headers $ singleton p

     {-# INLINE insertMany #-}
     insertMany f (Headers m)
         = Headers $ insertMany f m
     {-# INLINE insertMany #-}
     insertMany f (Headers m)
         = Headers $ insertMany f m


@@ -87,6 +87,10 @@ instance Unfoldable Headers (CIAscii, Ascii) where
         = Headers $ insertManySorted f m
 
 instance Foldable Headers (CIAscii, Ascii) where
         = Headers $ insertManySorted f m
 
 instance Foldable Headers (CIAscii, Ascii) where

+    {-# INLINE null #-}
+    null (Headers m) = null m
+    {-# INLINE size #-}
+    size (Headers m) = size m

     {-# INLINE foldr #-}
     foldr f b (Headers m) = foldr f b m
 
     {-# INLINE foldr #-}
     foldr f b (Headers m) = foldr f b m
 

diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs
index 85af3cbd9fb6520a223b6af85331c43fff56c2e4..fa842a174f53989b6f286fe0fb2cf9b18c2297ec 100644 (file)
--- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs
+++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs
@@ -30,8 +30,8 @@ import Network.HTTP.Lucu.ETag
 import Network.HTTP.Lucu.Implant
 import Network.HTTP.Lucu.Implant.Rewrite
 import Network.HTTP.Lucu.MIMEType
 import Network.HTTP.Lucu.Implant
 import Network.HTTP.Lucu.Implant.Rewrite
 import Network.HTTP.Lucu.MIMEType

+import Network.HTTP.Lucu.OrphanInstances ()

 import Network.HTTP.Lucu.Resource
 import Network.HTTP.Lucu.Resource

-import Network.HTTP.Lucu.Utils

 import Prelude hiding (head)
 import Prelude.Unicode
 
 import Prelude hiding (head)
 import Prelude.Unicode
 


@@ -146,7 +146,7 @@ resourceDecl i symName
       decls ∷ [Q Dec]
       decls | useGZip i
                 = [ sigD gzipEncoding [t| CIAscii |]
       decls ∷ [Q Dec]
       decls | useGZip i
                 = [ sigD gzipEncoding [t| CIAscii |]

-                  , valD (varP gzipEncoding) (normalB (liftCIAscii "gzip")) []
+                  , valD (varP gzipEncoding) (normalB (lift ("gzip" ∷ CIAscii))) []

                   ]
             | otherwise
                 = []
                   ]
             | otherwise
                 = []


@@ -204,7 +204,7 @@ eTagDecl (Input {..})
 lastModDecl ∷ Input → Q [Dec]
 lastModDecl (Input {..})
     = sequence [ sigD lastModified [t| UTCTime |]
 lastModDecl ∷ Input → Q [Dec]
 lastModDecl (Input {..})
     = sequence [ sigD lastModified [t| UTCTime |]

-               , valD (varP lastModified) (normalB (liftUTCTime iLastMod)) []
+               , valD (varP lastModified) (normalB (lift iLastMod)) []

                ]
 
 contTypeDecl ∷ Input → Q [Dec]
                ]
 
 contTypeDecl ∷ Input → Q [Dec]


@@ -217,11 +217,11 @@ binDecl ∷ Input → Q [Dec]
 binDecl i@(Input {..})
     | useGZip i
         = sequence [ sigD gzippedData [t| L.ByteString |]
 binDecl i@(Input {..})
     | useGZip i
         = sequence [ sigD gzippedData [t| L.ByteString |]

-                   , valD (varP gzippedData) (normalB (liftLazyByteString iGZipped)) []
+                   , valD (varP gzippedData) (normalB (lift iGZipped)) []

                    ]
     | otherwise
         = sequence [ sigD rawData [t| L.ByteString |]
                    ]
     | otherwise
         = sequence [ sigD rawData [t| L.ByteString |]

-                   , valD (varP rawData) (normalB (liftLazyByteString iRawData)) []
+                   , valD (varP rawData) (normalB (lift iRawData)) []

                    ]
 
 rules ∷ Rules
                    ]
 
 rules ∷ Rules

diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs
index 69b8aee28ecfb276d139d4c434cc05e01cd01e2e..9abf628b50c3f6c0142d71d28f81215cbfa6dc3c 100644 (file)
--- a/Network/HTTP/Lucu/Implant/Rewrite.hs
+++ b/Network/HTTP/Lucu/Implant/Rewrite.hs
@@ -33,7 +33,7 @@ import Data.Generics.Aliases hiding (GT)
 import Data.Generics.Schemes
 import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Generics.Schemes
 import Data.Monoid
 import Data.Monoid.Unicode

-import qualified Data.Set as S
+import qualified Data.Set as S (Set)

 import Language.Haskell.TH.Syntax
 import Prelude hiding (filter, foldr, lookup)
 import Prelude.Unicode
 import Language.Haskell.TH.Syntax
 import Prelude hiding (filter, foldr, lookup)
 import Prelude.Unicode

diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs
index 9e5b938b384f4b3e24157a8ead92e24fb94041a1..f4b503ee6ddd176d3febb9e61aa0691967844070 100644 (file)
--- a/Network/HTTP/Lucu/MIMEParams.hs
+++ b/Network/HTTP/Lucu/MIMEParams.hs
@@ -1,22 +1,25 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    CPP
-  , DeriveDataTypeable
+    DeriveDataTypeable

   , DoAndIfThenElse
   , DoAndIfThenElse

+  , FlexibleInstances

   , GeneralizedNewtypeDeriving
   , GeneralizedNewtypeDeriving

+  , MultiParamTypeClasses

   , OverloadedStrings
   , RecordWildCards
   , TemplateHaskell
   , OverloadedStrings
   , RecordWildCards
   , TemplateHaskell

+  , TypeSynonymInstances

   , UnicodeSyntax
   #-}
 -- |Parsing and printing MIME parameter values
 -- (<http://tools.ietf.org/html/rfc2231>).
 module Network.HTTP.Lucu.MIMEParams
   , UnicodeSyntax
   #-}
 -- |Parsing and printing MIME parameter values
 -- (<http://tools.ietf.org/html/rfc2231>).
 module Network.HTTP.Lucu.MIMEParams

-    ( MIMEParams(..)
+    ( MIMEParams

     , printMIMEParams
     , mimeParams
     )
     where
     , printMIMEParams
     , mimeParams
     )
     where

-import Control.Applicative
+import Control.Applicative hiding (empty)
+import Control.Arrow

 import Control.Monad hiding (mapM)
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import Control.Monad hiding (mapM)
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)


@@ -25,52 +28,106 @@ import Data.Attoparsec.Char8 as P
 import Data.Bits
 import qualified Data.ByteString.Char8 as BS
 import Data.Char
 import Data.Bits
 import qualified Data.ByteString.Char8 as BS
 import Data.Char

-import Data.Data
-import Data.Foldable
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Collections
+import Data.Collections.BaseInstances ()
+import qualified Data.Map as M (Map)

 import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Monoid
 import Data.Monoid.Unicode

-import Data.Sequence (Seq, ViewL(..))
-import qualified Data.Sequence as S
-import Data.Sequence.Unicode hiding ((∅))
+import Data.Sequence (Seq)

 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding
 import Data.Text.Encoding.Error
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding
 import Data.Text.Encoding.Error

-import Data.Traversable
+import Data.Typeable

 import Data.Word
 import Language.Haskell.TH.Syntax
 import Data.Word
 import Language.Haskell.TH.Syntax

+import Network.HTTP.Lucu.OrphanInstances ()

 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils

-import Prelude hiding (concat, mapM, takeWhile)
+import Prelude hiding (concat, filter, foldr, lookup, mapM, null, takeWhile)

 import Prelude.Unicode
 
 -- |A 'Map' from MIME parameter attributes to values. Attributes are
 -- always case-insensitive according to RFC 2045
 -- (<http://tools.ietf.org/html/rfc2045#section-5.1>).
 newtype MIMEParams
 import Prelude.Unicode
 
 -- |A 'Map' from MIME parameter attributes to values. Attributes are
 -- always case-insensitive according to RFC 2045
 -- (<http://tools.ietf.org/html/rfc2045#section-5.1>).
 newtype MIMEParams

-    = MIMEParams (Map CIAscii Text)
+    = MIMEParams (M.Map CIAscii Text)

     deriving (Eq, Show, Read, Monoid, Typeable)
 
 instance Lift MIMEParams where
     deriving (Eq, Show, Read, Monoid, Typeable)
 
 instance Lift MIMEParams where

-    lift (MIMEParams m) = [| MIMEParams $(liftParams m) |]
-        where
-          liftParams ∷ Map CIAscii Text → Q Exp
-          liftParams = liftMap liftCIAscii liftText
+    lift (MIMEParams m) = [| MIMEParams $(lift m) |]
+
+instance Unfoldable MIMEParams (CIAscii, Text) where
+    {-# INLINE insert #-}
+    insert p (MIMEParams m)
+        = MIMEParams $ insert p m
+    {-# INLINE empty #-}
+    empty
+        = MIMEParams empty
+    {-# INLINE singleton #-}
+    singleton p
+        = MIMEParams $ singleton p
+    {-# INLINE insertMany #-}
+    insertMany f (MIMEParams m)
+        = MIMEParams $ insertMany f m
+    {-# INLINE insertManySorted #-}
+    insertManySorted f (MIMEParams m)
+        = MIMEParams $ insertManySorted f m
+
+instance Foldable MIMEParams (CIAscii, Text) where
+    {-# INLINE null #-}
+    null (MIMEParams m) = null m
+    {-# INLINE size #-}
+    size (MIMEParams m) = size m
+    {-# INLINE foldr #-}
+    foldr f b (MIMEParams m) = foldr f b m
+
+instance Collection MIMEParams (CIAscii, Text) where
+    {-# INLINE filter #-}
+    filter f (MIMEParams m) = MIMEParams $ filter f m
+
+instance Indexed MIMEParams CIAscii Text where
+    {-# INLINE index #-}
+    index k (MIMEParams m) = index k m
+    {-# INLINE adjust #-}
+    adjust f k (MIMEParams m) = MIMEParams $ adjust f k m
+    {-# INLINE inDomain #-}
+    inDomain k (MIMEParams m) = inDomain k m
+
+instance Map MIMEParams CIAscii Text where
+    {-# INLINE lookup #-}
+    lookup k (MIMEParams m) = lookup k m
+    {-# INLINE mapWithKey #-}
+    mapWithKey f (MIMEParams m)
+        = MIMEParams $ mapWithKey f m
+    {-# INLINE unionWith #-}
+    unionWith f (MIMEParams α) (MIMEParams β)
+        = MIMEParams $ unionWith f α β
+    {-# INLINE intersectionWith #-}
+    intersectionWith f (MIMEParams α) (MIMEParams β)
+        = MIMEParams $ intersectionWith f α β
+    {-# INLINE differenceWith #-}
+    differenceWith f (MIMEParams α) (MIMEParams β)
+        = MIMEParams $ differenceWith f α β
+    {-# INLINE isSubmapBy #-}
+    isSubmapBy f (MIMEParams α) (MIMEParams β)
+        = isSubmapBy f α β
+    {-# INLINE isProperSubmapBy #-}
+    isProperSubmapBy f (MIMEParams α) (MIMEParams β)
+        = isProperSubmapBy f α β
+
+instance SortingCollection MIMEParams (CIAscii, Text) where
+    {-# INLINE minView #-}
+    minView (MIMEParams m) = second MIMEParams <$> minView m

 
 -- |Convert MIME parameter values to an 'AsciiBuilder'.
 printMIMEParams ∷ MIMEParams → AsciiBuilder
 {-# INLINEABLE printMIMEParams #-}
 
 -- |Convert MIME parameter values to an 'AsciiBuilder'.
 printMIMEParams ∷ MIMEParams → AsciiBuilder
 {-# INLINEABLE printMIMEParams #-}

-#if MIN_VERSION_containers(0, 4, 1)
-printMIMEParams (MIMEParams m) = M.foldlWithKey' f (∅) m
-#else
-printMIMEParams (MIMEParams m) = M.foldlWithKey f (∅) m
-#endif
+printMIMEParams = foldl' f (∅)

     where
     where

-      f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder
+      f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder

       {-# INLINE f #-}
       {-# INLINE f #-}

-      f ab k v = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v
+      f ab (k, v) = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v

 
 printPair ∷ CIAscii → Text → AsciiBuilder
 {-# INLINEABLE printPair #-}
 
 printPair ∷ CIAscii → Text → AsciiBuilder
 {-# INLINEABLE printPair #-}


@@ -224,30 +281,32 @@ rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%')
 
 decodeParams ∷ (Functor m, Monad m) ⇒ [ExtendedParam] → m MIMEParams
 {-# INLINE decodeParams #-}
 
 decodeParams ∷ (Functor m, Monad m) ⇒ [ExtendedParam] → m MIMEParams
 {-# INLINE decodeParams #-}

-decodeParams = (MIMEParams <$>) ∘ (mapM decodeSections =≪) ∘ sortBySection
+decodeParams = (MIMEParams <$>)
+               ∘ (mapM (\(k, v) → ((,) k) <$> decodeSections v) =≪)
+               ∘ sortBySection

 
 sortBySection ∷ Monad m
               ⇒ [ExtendedParam]
 
 sortBySection ∷ Monad m
               ⇒ [ExtendedParam]

-              → m (Map CIAscii (Map Integer ExtendedParam))
+              → m (M.Map CIAscii (M.Map Integer ExtendedParam))

 sortBySection = flip go (∅)
     where
       go ∷ Monad m
          ⇒ [ExtendedParam]
 sortBySection = flip go (∅)
     where
       go ∷ Monad m
          ⇒ [ExtendedParam]

-         → Map CIAscii (Map Integer ExtendedParam)
-         → m (Map CIAscii (Map Integer ExtendedParam))
+         → M.Map CIAscii (M.Map Integer ExtendedParam)
+         → m (M.Map CIAscii (M.Map Integer ExtendedParam))

       go []     m = return m
       go (x:xs) m
       go []     m = return m
       go (x:xs) m

-          = case M.lookup (epName x) m of
+          = case lookup (epName x) m of

               Nothing
               Nothing

-                  → let s  = M.singleton (section x) x
-                        m' = M.insert (epName x) s m
+                  → let s  = singleton (section x, x)
+                        m' = insert (epName x, s) m

                     in
                       go xs m'
               Just s
                     in
                       go xs m'
               Just s

-                  → case M.lookup (section x) s of
+                  → case lookup (section x) s of

                        Nothing
                        Nothing

-                           → let s' = M.insert (section x) x  s
-                                 m' = M.insert (epName  x) s' m
+                           → let s' = insert (section x, x ) s
+                                 m' = insert (epName  x, s') m

                              in
                                go xs m'
                        Just _
                              in
                                go xs m'
                        Just _


@@ -258,16 +317,16 @@ sortBySection = flip go (∅)
                                           , "'"
                                           ])
 
                                           , "'"
                                           ])
 

-decodeSections ∷ Monad m ⇒ Map Integer ExtendedParam → m Text
+decodeSections ∷ Monad m ⇒ M.Map Integer ExtendedParam → m Text

 decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
     where
       toSeq ∷ Monad m
 decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
     where
       toSeq ∷ Monad m

-            ⇒ Map Integer ExtendedParam
+            ⇒ M.Map Integer ExtendedParam

             → Integer
             → Seq ExtendedParam
             → m (Seq ExtendedParam)
       toSeq m expectedSect sects
             → Integer
             → Seq ExtendedParam
             → m (Seq ExtendedParam)
       toSeq m expectedSect sects

-          = case M.minViewWithKey m of
+          = case minView m of

               Nothing
                   → return sects
               Just ((sect, p), m')
               Nothing
                   → return sects
               Just ((sect, p), m')


@@ -283,19 +342,19 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
 
       decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text
       decodeSeq sects
 
       decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text
       decodeSeq sects

-          = case S.viewl sects of
-              EmptyL
+          = case front sects of
+              Nothing

                   → fail "decodeSeq: internal error: empty seq"
                   → fail "decodeSeq: internal error: empty seq"

-              InitialEncodedParam {..} :< xs
+              Just (InitialEncodedParam {..}, xs)

                   → do d ← getDecoder epCharset
                        t ← decodeStr d epPayload
                   → do d ← getDecoder epCharset
                        t ← decodeStr d epPayload

-                       decodeSeq' (Just d) xs $ S.singleton t
-              ContinuedEncodedParam {..} :< _
+                       decodeSeq' (Just d) xs $ singleton t
+              Just (ContinuedEncodedParam {..}, _)

                   → fail "decodeSeq: internal error: CEP at section 0"
                   → fail "decodeSeq: internal error: CEP at section 0"

-              AsciiParam {..} :< xs
+              Just (AsciiParam {..}, xs)

                   → let t = A.toText apPayload
                     in
                   → let t = A.toText apPayload
                     in

-                      decodeSeq' Nothing xs $ S.singleton t
+                      decodeSeq' Nothing xs $ singleton t

 
       decodeSeq' ∷ Monad m
                  ⇒ Maybe Decoder
 
       decodeSeq' ∷ Monad m
                  ⇒ Maybe Decoder


@@ -303,12 +362,12 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                  → Seq Text
                  → m Text
       decodeSeq' decoder sects chunks
                  → Seq Text
                  → m Text
       decodeSeq' decoder sects chunks

-          = case S.viewl sects of
-              EmptyL
+          = case front sects of
+              Nothing

                   → return $ T.concat $ toList chunks
                   → return $ T.concat $ toList chunks

-              InitialEncodedParam {..} :< _
+              Just (InitialEncodedParam {}, _)

                   → fail "decodeSeq': internal error: IEP at section > 0"
                   → fail "decodeSeq': internal error: IEP at section > 0"

-              ContinuedEncodedParam {..} :< xs
+              Just (ContinuedEncodedParam {..}, xs)

                   → case decoder of
                        Just d
                            → do t ← decodeStr d epPayload
                   → case decoder of
                        Just d
                            → do t ← decodeStr d epPayload


@@ -320,7 +379,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                                           , A.toString $ A.fromCIAscii epName
                                           , "' is encoded but its first section is not"
                                           ])
                                           , A.toString $ A.fromCIAscii epName
                                           , "' is encoded but its first section is not"
                                           ])

-              AsciiParam {..} :< xs
+              Just (AsciiParam {..}, xs)

                   → let t = A.toText apPayload
                     in
                       decodeSeq' decoder xs $ chunks ⊳ t
                   → let t = A.toText apPayload
                     in
                       decodeSeq' decoder xs $ chunks ⊳ t

diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs
index 88bd5e7a600b1afd24b5a61b253db5befc8bfff4..2861d2670e15e55d00881a6ac69d34731abf0803 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType.hs
+++ b/Network/HTTP/Lucu/MIMEType.hs
@@ -25,9 +25,9 @@ import Data.Monoid.Unicode
 import Data.Typeable
 import Language.Haskell.TH.Syntax
 import Network.HTTP.Lucu.MIMEParams
 import Data.Typeable
 import Language.Haskell.TH.Syntax
 import Network.HTTP.Lucu.MIMEParams

+import Network.HTTP.Lucu.OrphanInstances ()

 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http

-import Network.HTTP.Lucu.Utils

 import Prelude.Unicode
 
 -- |A media type, subtype, and parameters.
 import Prelude.Unicode
 
 -- |A media type, subtype, and parameters.


@@ -42,8 +42,8 @@ data MIMEType
 instance Lift MIMEType where
     lift (MIMEType {..})
         = [| MIMEType {
 instance Lift MIMEType where
     lift (MIMEType {..})
         = [| MIMEType {

-               mtMedia  = $(liftCIAscii mtMedia)
-             , mtSub    = $(liftCIAscii mtSub)
+               mtMedia  = $(lift mtMedia )
+             , mtSub    = $(lift mtSub   )

              , mtParams = $(lift mtParams)
              }
            |]
              , mtParams = $(lift mtParams)
              }
            |]

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index edf177276eecc6feaf98be043ce13f96b3083e0d..7c3c64d17816d6ef2aea5a73aba001dc4ce600b0 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -32,8 +32,8 @@ import Data.Text.Encoding
 import Language.Haskell.TH.Syntax
 import Language.Haskell.TH.Quote
 import Network.HTTP.Lucu.MIMEType
 import Language.Haskell.TH.Syntax
 import Language.Haskell.TH.Quote
 import Network.HTTP.Lucu.MIMEType

+import Network.HTTP.Lucu.OrphanInstances ()

 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser

-import Network.HTTP.Lucu.Utils

 import Prelude.Unicode
 import System.FilePath
 
 import Prelude.Unicode
 import System.FilePath
 


@@ -43,8 +43,7 @@ newtype ExtMap
     deriving (Eq, Show, Read, Monoid, Typeable)
 
 instance Lift ExtMap where
     deriving (Eq, Show, Read, Monoid, Typeable)
 
 instance Lift ExtMap where

-    lift (ExtMap m)
-        = [| ExtMap $(liftMap liftText lift m) |]
+    lift (ExtMap m) = [| ExtMap $(lift m) |]

 
 -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
 --
 
 -- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
 --

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 155003024b9c2e82989bc017bdcb0f58ed8541f6..a5280c043f6bf252bf0095ba2792c3959ab26247 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -17,7 +17,7 @@ module Network.HTTP.Lucu.MultipartForm
     where
 import Control.Applicative hiding (many)
 import Control.Applicative.Unicode hiding ((∅))
     where
 import Control.Applicative hiding (many)
 import Control.Applicative.Unicode hiding ((∅))

-import Control.Monad.Error
+import Control.Monad.Error (MonadError, throwError)

 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A


@@ -26,13 +26,11 @@ import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LS
 import Data.ByteString.Lazy.Search
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LS
 import Data.ByteString.Lazy.Search

-import Data.Foldable
-import Data.List
-import qualified Data.Map as M
+import Data.Collections
+import Data.List (intercalate)

 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)

-import Data.Sequence.Unicode hiding ((∅))

 import Data.Text (Text)
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Headers
 import Data.Text (Text)
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Headers


@@ -42,6 +40,8 @@ import qualified Network.HTTP.Lucu.MIMEType as MT
 import Network.HTTP.Lucu.MIMEType.TH
 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.MIMEType.TH
 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http

+import Network.HTTP.Lucu.Utils
+import Prelude hiding (lookup, mapM)

 import Prelude.Unicode
 
 -- |'FormData' represents a form value and possibly an uploaded file
 import Prelude.Unicode
 
 -- |'FormData' represents a form value and possibly an uploaded file


@@ -229,7 +229,7 @@ partToFormPair pt@(Part {..})
 partName ∷ MonadError String m ⇒ Part → m Ascii
 {-# INLINEABLE partName #-}
 partName (Part {..})
 partName ∷ MonadError String m ⇒ Part → m Ascii
 {-# INLINEABLE partName #-}
 partName (Part {..})

-    = case M.lookup "name" params of
+    = case lookup "name" $ dParams ptContDispo of

         Just name
             → case A.fromText name of
                  Just a  → return a
         Just name
             → case A.fromText name of
                  Just a  → return a


@@ -238,10 +238,7 @@ partName (Part {..})
         Nothing
             → throwError $ "form-data without name: "
                          ⧺ A.toString (printContDispo ptContDispo)
         Nothing
             → throwError $ "form-data without name: "
                          ⧺ A.toString (printContDispo ptContDispo)

-    where
-      params = case dParams ptContDispo of
-                 MIMEParams m → m

 
 partFileName ∷ Part → Maybe Text
 
 partFileName ∷ Part → Maybe Text

-partFileName (dParams ∘ ptContDispo → MIMEParams m)
-    = M.lookup "filename" m
+partFileName (ptContDispo → ContDispo {..})
+    = lookup "filename" dParams

diff --git a/Network/HTTP/Lucu/OrphanInstances.hs b/Network/HTTP/Lucu/OrphanInstances.hs
new file mode 100644 (file)
index 0000000..a7e7b7e
--- /dev/null
+++ b/Network/HTTP/Lucu/OrphanInstances.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE
+    RecordWildCards
+  , TemplateHaskell
+  , UnicodeSyntax
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.HTTP.Lucu.OrphanInstances
+    (
+    )
+    where
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as Strict
+import qualified Data.ByteString.Lazy.Internal as Lazy
+import Data.CaseInsensitive (CI, FoldCase)
+import qualified Data.CaseInsensitive as CI
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Ratio
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax
+import Prelude hiding (last, mapM, null, reverse)
+import Prelude.Unicode
+
+instance Lift ByteString where
+    lift bs = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |]
+
+instance Lift Lazy.ByteString where
+    lift = Lazy.foldrChunks f [| Lazy.Empty |]
+        where
+          f ∷ ByteString → Q Exp → Q Exp
+          f bs e = [| Lazy.Chunk $(lift bs) $e |]
+
+instance Lift Ascii where
+    lift a = [| A.unsafeFromByteString $(lift $ A.toByteString a) |]
+
+instance (Lift s, FoldCase s) ⇒ Lift (CI s) where
+    lift s = [| CI.mk $(lift $ CI.original s) |]
+
+instance Lift Text where
+    lift t = [| T.pack $(litE $ stringL $ T.unpack t) |]
+
+instance (Lift k, Lift v) ⇒ Lift (Map k v) where
+    lift m
+        | M.null m = [| M.empty |]
+        | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |]
+        where
+          liftPairs       = listE ∘ map liftPair
+          liftPair (k, v) = tupE [lift k, lift v]
+
+instance Lift UTCTime where
+    lift (UTCTime {..})
+        = [| UTCTime $(lift utctDay) $(lift utctDayTime) |]
+
+instance Lift Day where
+    lift (ModifiedJulianDay {..})
+        = [| ModifiedJulianDay $(lift toModifiedJulianDay) |]
+
+instance Lift DiffTime where
+    lift dt = [| fromRational ($n % $d) ∷ DiffTime |]
+        where
+          n, d ∷ Q Exp
+          n = lift $ numerator   $ toRational dt
+          d = lift $ denominator $ toRational dt

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 5ef7acc296ed18f68736d4cc802ce6730ce4e70e..ab70998d648e30a0e4a7f1ac74d62d190423c5d7 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -21,7 +21,6 @@ import Data.List
 import Data.Maybe
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Maybe
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S

-import Data.Sequence.Unicode hiding ((∅))

 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config


@@ -33,6 +32,7 @@ import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Resource.Tree
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Resource.Tree

+import Network.HTTP.Lucu.Utils

 import Network.Socket
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
 import Network.Socket
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index ec3447e7f488585570b4e8891b4da5abdbdad0f0..4cf43e0c5b7f831a45da2487e7c23fd482bf374d 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -155,8 +155,8 @@ import qualified Data.Attoparsec.Char8 as P
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy

-import Data.List
-import qualified Data.Map as M
+import Data.Collections
+import Data.List (intersperse, sort)

 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode


@@ -177,13 +177,13 @@ import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Response

-import Network.HTTP.Lucu.MIMEParams

 import Network.HTTP.Lucu.MIMEType (MIMEType(..))
 import qualified Network.HTTP.Lucu.MIMEType as MT
 import Network.HTTP.Lucu.MIMEType.TH
 import Network.HTTP.Lucu.Utils
 import Network.Socket hiding (accept)
 import Network.URI hiding (path)
 import Network.HTTP.Lucu.MIMEType (MIMEType(..))
 import qualified Network.HTTP.Lucu.MIMEType as MT
 import Network.HTTP.Lucu.MIMEType.TH
 import Network.HTTP.Lucu.Utils
 import Network.Socket hiding (accept)
 import Network.URI hiding (path)

+import Prelude hiding (any, drop, lookup, reverse)

 import Prelude.Unicode
 
 -- |Get the string representation of the address of remote host. If
 import Prelude.Unicode
 
 -- |Get the string representation of the address of remote host. If


@@ -598,8 +598,8 @@ getForm limit
               Just a  → return a
               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 
               Just a  → return a
               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 

-      readMultipartFormData (MIMEParams m)
-          = case M.lookup "boundary" m of
+      readMultipartFormData m
+          = case lookup "boundary" m of

               Nothing
                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
               Just boundary
               Nothing
                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
               Just boundary

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index f3fca16b50520ff154775e1bcc3db58918a09ba9..9434cfbbe9f9cbd7e7ad3dbb4a4e2f1cf2f150d8 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -25,7 +25,6 @@ import Data.Map (Map)
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)

-import Data.Sequence.Unicode hiding ((∅))

 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Utils
 import Network.URI hiding (path)
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Utils
 import Network.URI hiding (path)

diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
index c07c9c9cf94891bf82213f5c24edf293ef534f12..8722ecb1a7264ebd450dff106aa283b0d423de0b 100644 (file)
--- a/Network/HTTP/Lucu/Utils.hs
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    OverloadedStrings
-  , RecordWildCards
-  , TemplateHaskell
+    FlexibleContexts
+  , OverloadedStrings

   , UnicodeSyntax
   #-}
 -- |Utility functions used internally in this package.
   , UnicodeSyntax
   #-}
 -- |Utility functions used internally in this package.


@@ -12,38 +11,29 @@ module Network.HTTP.Lucu.Utils
     , splitPathInfo
     , trim
 
     , splitPathInfo
     , trim
 

-    , getLastModified
+    , (⊲)
+    , (⊳)
+    , (⋈)
+    , mapM

 
 

-    , liftByteString
-    , liftLazyByteString
-    , liftAscii
-    , liftCIAscii
-    , liftText
-    , liftMap
-    , liftUTCTime
+    , getLastModified

     )
     where
     )
     where

-import Control.Applicative
-import Control.Monad
-import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import Control.Applicative hiding (empty)
+import Control.Monad hiding (mapM)
+import Data.Ascii (Ascii, AsciiBuilder)

 import qualified Data.Ascii as A
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as Strict
 import qualified Data.Ascii as A
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as Strict

-import qualified Data.ByteString.Lazy.Internal as Lazy

 import Data.Char
 import Data.Char

-import Data.List hiding (last)
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Collections
+import Data.Collections.BaseInstances ()

 import Data.Monoid.Unicode
 import Data.Ratio
 import Data.Monoid.Unicode
 import Data.Ratio

-import Data.Text (Text)
-import qualified Data.Text as T

 import Data.Time
 import Data.Time.Clock.POSIX
 import Data.Time
 import Data.Time.Clock.POSIX

-import Language.Haskell.TH.Lib
-import Language.Haskell.TH.Syntax

 import Network.URI
 import Network.URI

-import Prelude hiding (last)
+import Prelude hiding (last, mapM, null, reverse)

 import Prelude.Unicode
 import System.Directory
 import System.Time (ClockTime(..))
 import Prelude.Unicode
 import System.Directory
 import System.Time (ClockTime(..))


@@ -118,6 +108,34 @@ trim = reverse ∘ f ∘ reverse ∘ f
     where
       f = dropWhile isSpace
 
     where
       f = dropWhile isSpace
 

+infixr 5 ⊲
+-- | (&#22B2;) = ('<|')
+--
+-- U+22B2, NORMAL SUBGROUP OF
+(⊲) ∷ Sequence α a ⇒ a → α → α
+(⊲) = (<|)
+
+infixl 5 ⊳
+-- | (&#22B3;) = ('|>')
+--
+-- U+22B3, CONTAINS AS NORMAL SUBGROUP
+(⊳) ∷ Sequence α a ⇒ α → a → α
+(⊳) = (|>)
+
+infixr 5 ⋈
+-- | (&#22C8;) = ('><')
+--
+-- U+22C8, BOWTIE
+(⋈) ∷ Sequence α a ⇒ α → α → α
+(⋈) = (><)
+
+-- |Generalised @mapM@ from any 'Foldable' to 'Unfoldable'. Why isn't
+-- this in the @collections-api@?
+mapM ∷ (Foldable α a, Unfoldable β b, Functor m, Monad m)
+     ⇒ (a → m b) → α → m β
+{-# INLINE mapM #-}
+mapM = flip foldrM empty ∘ (flip ((<$>) ∘ flip insert) ∘)
+

 -- |Get the modification time of a given file.
 getLastModified ∷ FilePath → IO UTCTime
 getLastModified = (clockTimeToUTC <$>) ∘ getModificationTime
 -- |Get the modification time of a given file.
 getLastModified ∷ FilePath → IO UTCTime
 getLastModified = (clockTimeToUTC <$>) ∘ getModificationTime


@@ -127,54 +145,3 @@ getLastModified = (clockTimeToUTC <$>) ∘ getModificationTime
           = posixSecondsToUTCTime
             $ fromRational
             $ sec % 1 + picoSec % (1000 ⋅ 1000 ⋅ 1000 ⋅ 1000)
           = posixSecondsToUTCTime
             $ fromRational
             $ sec % 1 + picoSec % (1000 ⋅ 1000 ⋅ 1000 ⋅ 1000)

-
--- |Convert a 'ByteString' to an 'Exp' representing it as a literal.
-liftByteString ∷ ByteString → Q Exp
-liftByteString bs
-    = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |]
-
--- |Convert a 'Lazy.ByteString' to an 'Exp' representing it as a
--- literal.
-liftLazyByteString ∷ Lazy.ByteString → Q Exp
-liftLazyByteString = Lazy.foldrChunks f [| Lazy.Empty |]
-    where
-      f ∷ ByteString → Q Exp → Q Exp
-      f bs e = [| Lazy.Chunk $(liftByteString bs) $e |]
-
--- |Convert an 'Ascii' to an 'Exp' representing it as a literal.
-liftAscii ∷ Ascii → Q Exp
-liftAscii a = [| A.unsafeFromByteString $(liftByteString $ A.toByteString a) |]
-
--- |Convert a 'CIAscii' to an 'Exp' representing it as a literal.
-liftCIAscii ∷ CIAscii → Q Exp
-liftCIAscii a = [| A.toCIAscii $(liftAscii $ A.fromCIAscii a) |]
-
--- |Convert a 'Text' to an 'Exp' representing it as a literal.
-liftText ∷ Text → Q Exp
-liftText t = [| T.pack $(litE $ stringL $ T.unpack t) |]
-
--- |Convert an arbitrary 'Map' to an 'Exp' representing it as a
--- literal, using a given key lifter and a value lifter.
-liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp
-liftMap liftK liftV m
-    | M.null m  = [| M.empty |]
-    | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |]
-    where
-      liftPairs       = listE ∘ map liftPair
-      liftPair (k, v) = tupE [liftK k, liftV v]
-
--- |Convert an 'UTCTime' to an 'Exp' representing it as a literal.
-liftUTCTime ∷ UTCTime → Q Exp
-liftUTCTime (UTCTime {..})
-    = [| UTCTime $(liftDay utctDay) $(liftDiffTime utctDayTime) |]
-
-liftDay ∷ Day → Q Exp
-liftDay (ModifiedJulianDay {..})
-    = [| ModifiedJulianDay $(lift toModifiedJulianDay) |]
-
-liftDiffTime ∷ DiffTime → Q Exp
-liftDiffTime dt = [| fromRational ($n % $d) ∷ DiffTime |]
-    where
-      n, d ∷ Q Exp
-      n = lift $ numerator   $ toRational dt
-      d = lift $ denominator $ toRational dt