Network/HTTP/Lucu/OrphanInstances.hs

   1 {-# LANGUAGE
   2     FlexibleContexts
   3   , FlexibleInstances
   4   , OverlappingInstances
   5   , RecordWildCards
   6   , TemplateHaskell
   7   , UndecidableInstances
   8   , UnicodeSyntax
   9   #-}
  10 {-# OPTIONS_GHC -fno-warn-orphans #-}
  11 module Network.HTTP.Lucu.OrphanInstances
  12     (
  13     )
  14     where
  15 import Data.Ascii (Ascii)
  16 import qualified Data.Ascii as A
  17 import Data.ByteString (ByteString)
  18 import qualified Data.ByteString.Char8 as Strict
  19 import qualified Data.ByteString.Lazy.Internal as Lazy
  20 import Data.CaseInsensitive (CI, FoldCase)
  21 import qualified Data.CaseInsensitive as CI
  22 import Data.Collections
  23 import Data.Collections.BaseInstances ()
  24 import Data.Ratio
  25 import Data.Text (Text)
  26 import qualified Data.Text as T
  27 import Data.Time
  28 import Language.Haskell.TH.Lib
  29 import Language.Haskell.TH.Syntax
  30 import Prelude hiding (last, mapM, null, reverse)
  31 import Prelude.Unicode
  32
  33 instance Lift ByteString where
  34     lift bs = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |]
  35
  36 instance Lift Lazy.ByteString where
  37     lift = Lazy.foldrChunks f [| Lazy.Empty |]
  38         where
  39           f ∷ ByteString → Q Exp → Q Exp
  40           f bs e = [| Lazy.Chunk $(lift bs) $e |]
  41
  42 instance Lift Ascii where
  43     lift a = [| A.unsafeFromByteString $(lift $ A.toByteString a) |]
  44
  45 instance (Lift s, FoldCase s) ⇒ Lift (CI s) where
  46     lift s = [| CI.mk $(lift $ CI.original s) |]
  47
  48 instance Lift Text where
  49     lift t = [| T.pack $(litE $ stringL $ T.unpack t) |]
  50
  51 instance (Lift k, Lift v, Collection c (k, v)) ⇒ Lift c where
  52     lift c
  53         | null c    = [| empty |]
  54         | otherwise = [| fromList $(liftPairs (fromFoldable c)) |]
  55         where
  56           liftPairs       = listE ∘ map liftPair
  57           liftPair (k, v) = tupE [lift k, lift v]
  58
  59 instance Lift UTCTime where
  60     lift (UTCTime {..})
  61         = [| UTCTime $(lift utctDay) $(lift utctDayTime) |]
  62
  63 instance Lift Day where
  64     lift (ModifiedJulianDay {..})
  65         = [| ModifiedJulianDay $(lift toModifiedJulianDay) |]
  66
  67 instance Lift DiffTime where
  68     lift dt = [| fromRational ($n % $d) ∷ DiffTime |]
  69         where
  70           n, d ∷ Q Exp
  71           n = lift $ numerator   $ toRational dt
  72           d = lift $ denominator $ toRational dt