X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FOrphanInstances.hs;h=8fa7e68714437b8270abb7b42d13e3ab35d360dc;hb=243b99439640480fc148d2e175247dacce04a222;hp=47db98b7dee176f73da96f3ac9e79556c53fdc0f;hpb=2bcf36a739341aaaf56d812286d57233fff81ad5;p=Lucu.git diff --git a/Network/HTTP/Lucu/OrphanInstances.hs b/Network/HTTP/Lucu/OrphanInstances.hs index 47db98b..8fa7e68 100644 --- a/Network/HTTP/Lucu/OrphanInstances.hs +++ b/Network/HTTP/Lucu/OrphanInstances.hs @@ -1,10 +1,9 @@ {-# LANGUAGE FlexibleContexts , FlexibleInstances - , OverlappingInstances , RecordWildCards + , ScopedTypeVariables , TemplateHaskell - , UndecidableInstances , UnicodeSyntax #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -13,6 +12,7 @@ module Network.HTTP.Lucu.OrphanInstances ) where import Control.Applicative hiding (empty) +import Control.Monad import Data.Ascii (Ascii) import qualified Data.Ascii as A import Data.ByteString (ByteString) @@ -22,6 +22,7 @@ import Data.CaseInsensitive (CI, FoldCase) import qualified Data.CaseInsensitive as CI import Data.Collections import Data.Collections.BaseInstances () +import qualified Data.Map as M import Data.Ratio import Data.Text (Text) import qualified Data.Text as T @@ -31,6 +32,12 @@ import Language.Haskell.TH.Syntax import Prelude hiding (last, mapM, null, reverse) import Prelude.Unicode +instance Applicative Q where + {-# INLINE pure #-} + pure = return + {-# INLINE (<*>) #-} + (<*>) = ap + instance Lift ByteString where lift bs = [| Strict.pack $(litE ∘ stringL $ Strict.unpack bs) |] @@ -49,12 +56,15 @@ instance (Lift s, FoldCase s) ⇒ Lift (CI s) where instance Lift Text where lift t = [| T.pack $(litE ∘ stringL $ T.unpack t) |] -instance (Lift k, Lift v, Collection c (k, v)) ⇒ Lift c where - lift c - | null c = [| empty |] - | otherwise = [| fromList $(liftPairs (fromFoldable c)) |] +instance (Lift k, Lift v) ⇒ Lift (M.Map k v) where + lift m + | null m = [| empty |] + | otherwise = [| fromAscList $(liftPairs (M.toAscList m)) |] where - liftPairs = listE ∘ (liftPair <$>) + liftPairs ∷ [(k, v)] → Q Exp + liftPairs = listE ∘ (liftPair <$>) + + liftPair ∷ (k, v) → Q Exp liftPair (k, v) = tupE [lift k, lift v] instance Lift UTCTime where