Network/HTTP/Lucu/OrphanInstances.hs

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