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 Control.Monad
  16 import Data.Ascii (Ascii)
  17 import qualified Data.Ascii as A
  18 import Data.ByteString (ByteString)
  19 import qualified Data.ByteString.Char8 as Strict
  20 import qualified Data.ByteString.Lazy.Internal as Lazy
  21 import Data.CaseInsensitive (CI, FoldCase)
  22 import qualified Data.CaseInsensitive as CI
  23 import Data.Collections
  24 import Data.Collections.BaseInstances ()
  25 import qualified Data.Map as M
  26 import Data.Ratio
  27 import Data.Text (Text)
  28 import qualified Data.Text as T
  29 import Data.Time
  30 import Language.Haskell.TH.Lib
  31 import Language.Haskell.TH.Syntax
  32 import Prelude hiding (last, mapM, null, reverse)
  33 import Prelude.Unicode
  34
  35 instance Applicative Q where
  36     {-# INLINE pure #-}
  37     pure = return
  38     {-# INLINE (<*>) #-}
  39     (<*>) = ap
  40
  41 instance Lift ByteString where
  42     lift bs = [| Strict.pack $(litE ∘ stringL $ Strict.unpack bs) |]
  43
  44 instance Lift Lazy.ByteString where
  45     lift = Lazy.foldrChunks f [| Lazy.Empty |]
  46         where
  47           f ∷ ByteString → Q Exp → Q Exp
  48           f bs e = [| Lazy.Chunk $(lift bs) $e |]
  49
  50 instance Lift Ascii where
  51     lift a = [| A.unsafeFromByteString $(lift $ A.toByteString a) |]
  52
  53 instance (Lift s, FoldCase s) ⇒ Lift (CI s) where
  54     lift s = [| CI.mk $(lift $ CI.original s) |]
  55
  56 instance Lift Text where
  57     lift t = [| T.pack $(litE ∘ stringL $ T.unpack t) |]
  58
  59 instance (Lift k, Lift v) ⇒ Lift (M.Map k v) where
  60     lift m
  61         | null m    = [| empty |]
  62         | otherwise = [| fromAscList $(liftPairs (M.toAscList m)) |]
  63         where
  64           liftPairs ∷ [(k, v)] → Q Exp
  65           liftPairs = listE ∘ (liftPair <$>)
  66
  67           liftPair ∷ (k, v) → Q Exp
  68           liftPair (k, v) = tupE [lift k, lift v]
  69
  70 instance Lift UTCTime where
  71     lift (UTCTime {..})
  72         = [| UTCTime $(lift utctDay) $(lift utctDayTime) |]
  73
  74 instance Lift Day where
  75     lift (ModifiedJulianDay {..})
  76         = [| ModifiedJulianDay $(lift toModifiedJulianDay) |]
  77
  78 instance Lift DiffTime where
  79     lift dt = [| fromRational ($n % $d) ∷ DiffTime |]
  80         where
  81           n, d ∷ Q Exp
  82           n = lift ∘ numerator   $ toRational dt
  83           d = lift ∘ denominator $ toRational dt