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

[Lucu.git] / Network / HTTP / Lucu / OrphanInstances.hs

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