git.iko.soy/typeable/http-api-data
on master help sign in
Merge pull request #14 from fizruk/more-instances-#10

More instances

commit743ba339f5d9ce51977fabc0d7887fe305d6d88f authorNickolay Kudasov <fizruk@users.noreply.github.com> dateTue 6 Oct 2015, 18:00 (11 years ago) parent9b260fb978b80a
3 files changed+176−21
compare with master
unifiedsplit
Web/HttpApiData.hs+80 Web/PathPieces.hs+65−3 test/main.hs+31−18
Web/HttpApiData.hs+80
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DefaultSignatures #-}
23{-# LANGUAGE FlexibleInstances #-}
34{-# LANGUAGE OverloadedStrings #-}
@@ -36,8 +37,14 @@ import qualified Data.Text as T
3637import qualified Data.Text.Lazy as L
3738
3839import Data.Time (Day)
40+import Data.Version
41+
42+#if MIN_VERSION_base(4,8,0)
43+import Data.Void
44+#endif
3945
4046import Text.Read (readMaybe)
47+import Text.ParserCombinators.ReadP (readP_to_S)
4148
4249-- $setup
4350--
@@ -124,7 +131,21 @@ parseBounded reader input = do
124131instance ToHttpApiData () where
125132 toUrlPiece () = "_"
126133
134+instance ToHttpApiData Char where toUrlPiece = T.singleton
135+
136+-- |
137+-- >>> toUrlPiece (Version [1, 2, 3] [])
138+-- "1.2.3"
139+instance ToHttpApiData Version where
140+ toUrlPiece = T.pack . showVersion
141+
142+#if MIN_VERSION_base(4,8,0)
143+instance ToHttpApiData Void where
144+ toUrlPiece = absurd
145+#endif
146+
127147instance ToHttpApiData Bool where toUrlPiece = showUrlPiece
148+instance ToHttpApiData Ordering where toUrlPiece = showUrlPiece
128149instance ToHttpApiData Double where toUrlPiece = showUrlPiece
129150instance ToHttpApiData Float where toUrlPiece = showUrlPiece
130151instance ToHttpApiData Int where toUrlPiece = showUrlPiece
@@ -143,6 +164,15 @@ instance ToHttpApiData Text where toUrlPiece = id
143164instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
144165instance ToHttpApiData Day where toUrlPiece = showUrlPiece
145166
167+instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll
168+instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny
169+
170+instance ToHttpApiData a => ToHttpApiData (Dual a) where toUrlPiece = toUrlPiece . getDual
171+instance ToHttpApiData a => ToHttpApiData (Sum a) where toUrlPiece = toUrlPiece . getSum
172+instance ToHttpApiData a => ToHttpApiData (Product a) where toUrlPiece = toUrlPiece . getProduct
173+instance ToHttpApiData a => ToHttpApiData (First a) where toUrlPiece = toUrlPiece . getFirst
174+instance ToHttpApiData a => ToHttpApiData (Last a) where toUrlPiece = toUrlPiece . getLast
175+
146176-- |
147177-- >>> toUrlPiece (Just "Hello")
148178-- "Just Hello"
@@ -150,6 +180,15 @@ instance ToHttpApiData a => ToHttpApiData (Maybe a) where
150180 toUrlPiece (Just x) = "Just " <> toUrlPiece x
151181 toUrlPiece Nothing = "Nothing"
152182
183+-- |
184+-- >>> toUrlPiece (Left "err" :: Either String Int)
185+-- "Left err"
186+-- >>> toUrlPiece (Right 3 :: Either String Int)
187+-- "Right 3"
188+instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
189+ toUrlPiece (Left x) = "Left " <> toUrlPiece x
190+ toUrlPiece (Right x) = "Right " <> toUrlPiece x
191+
153192-- |
154193-- >>> parseUrlPiece "_" :: Either Text ()
155194-- Right ()
@@ -157,7 +196,28 @@ instance FromHttpApiData () where
157196 parseUrlPiece "_" = return ()
158197 parseUrlPiece s = defaultParseError s
159198
199+instance FromHttpApiData Char where
200+ parseUrlPiece s =
201+ case T.uncons s of
202+ Just (c, s') | T.null s' -> return c
203+ _ -> defaultParseError s
204+
205+-- |
206+-- >>> showVersion <$> parseUrlPiece "1.2.3"
207+-- Right "1.2.3"
208+instance FromHttpApiData Version where
209+ parseUrlPiece s =
210+ case reverse (readP_to_S parseVersion (T.unpack s)) of
211+ ((x, ""):_) -> return x
212+ _ -> defaultParseError s
213+
214+#if MIN_VERSION_base(4,8,0)
215+instance FromHttpApiData Void where
216+ parseUrlPiece _ = Left "Void cannot be parsed!"
217+#endif
218+
160219instance FromHttpApiData Bool where parseUrlPiece = readEitherUrlPiece
220+instance FromHttpApiData Ordering where parseUrlPiece = readEitherUrlPiece
161221instance FromHttpApiData Double where parseUrlPiece = runReader rational
162222instance FromHttpApiData Float where parseUrlPiece = runReader rational
163223instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
@@ -176,6 +236,15 @@ instance FromHttpApiData Text where parseUrlPiece = Right
176236instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
177237instance FromHttpApiData Day where parseUrlPiece = readEitherUrlPiece
178238
239+instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
240+instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
241+
242+instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece
243+instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece
244+instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece
245+instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece
246+instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece
247+
179248-- |
180249-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
181250-- Right (Just 123)
@@ -186,6 +255,17 @@ instance FromHttpApiData a => FromHttpApiData (Maybe a) where
186255 Nothing -> defaultParseError s
187256 Just x -> Just <$> parseUrlPiece x
188257
258+-- |
259+-- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int)
260+-- Right (Right 123)
261+instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where
262+ parseUrlPiece s =
263+ case T.stripPrefix "Right " s of
264+ Just r -> Right <$> parseUrlPiece r
265+ _ -> case T.stripPrefix "Left " s of
266+ Just l -> Left <$> parseUrlPiece l
267+ _ -> defaultParseError s
268+
189269-- $examples
190270--
191271-- Booleans:
Web/PathPieces.hs+65−3
@@ -1,6 +1,9 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DefaultSignatures #-}
23{-# LANGUAGE FlexibleInstances #-}
34{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE Rank2Types #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
47{-# LANGUAGE TypeSynonymInstances #-}
58-- |
69-- Convert Haskell values to and from route pieces.
@@ -12,13 +15,21 @@ module Web.PathPieces (
1215 WrappedPathPiece(..),
1316) where
1417
18+import Data.Monoid
1519import Data.Int
1620import Data.Word
1721import qualified Data.Text as S
1822import qualified Data.Text.Lazy as L
23+import Data.Version (Version)
1924import Data.Time (Day)
2025import Text.Read (readMaybe)
2126
27+import Unsafe.Coerce
28+
29+#if MIN_VERSION_base(4,8,0)
30+import Data.Void (Void)
31+#endif
32+
2233import Web.HttpApiData
2334
2435-- | Convert Haskell values to and from route piece.
@@ -34,7 +45,9 @@ class PathPiece s where
3445 toPathPiece = toUrlPiece
3546
3647instance PathPiece ()
48+instance PathPiece Char
3749instance PathPiece Bool
50+instance PathPiece Ordering
3851instance PathPiece Double
3952instance PathPiece Float
4053instance PathPiece Int
@@ -42,6 +55,7 @@ instance PathPiece Int8
4255instance PathPiece Int16
4356instance PathPiece Int32
4457instance PathPiece Int64
58+instance PathPiece Integer
4559instance PathPiece Word
4660instance PathPiece Word8
4761instance PathPiece Word16
@@ -51,6 +65,42 @@ instance PathPiece String
5165instance PathPiece S.Text
5266instance PathPiece L.Text
5367instance PathPiece Day
68+instance PathPiece Version
69+
70+#if MIN_VERSION_base(4,8,0)
71+instance PathPiece Void
72+#endif
73+
74+instance PathPiece All
75+instance PathPiece Any
76+
77+instance PathPiece a => PathPiece (Dual a) where
78+ toPathPiece = toPathPiece1
79+ fromPathPiece = fromPathPiece1
80+
81+instance PathPiece a => PathPiece (Sum a) where
82+ toPathPiece = toPathPiece1
83+ fromPathPiece = fromPathPiece1
84+
85+instance PathPiece a => PathPiece (Product a) where
86+ toPathPiece = toPathPiece1
87+ fromPathPiece = fromPathPiece1
88+
89+instance PathPiece a => PathPiece (First a) where
90+ toPathPiece = toPathPiece1
91+ fromPathPiece = fromPathPiece1
92+
93+instance PathPiece a => PathPiece (Last a) where
94+ toPathPiece = toPathPiece1
95+ fromPathPiece = fromPathPiece1
96+
97+instance PathPiece a => PathPiece (Maybe a) where
98+ toPathPiece = toPathPiece1
99+ fromPathPiece = fromPathPiece1
100+
101+instance (PathPiece a, PathPiece b) => PathPiece (Either a b) where
102+ toPathPiece = toPathPiece2
103+ fromPathPiece = fromPathPiece2
54104
55105-- | Wrapped @'PathPiece'@ value.
56106newtype WrappedPathPiece a = WrappedPathPiece { unwrapPathPiece :: a }
@@ -61,9 +111,21 @@ instance PathPiece a => ToHttpApiData (WrappedPathPiece a) where
61111instance PathPiece a => FromHttpApiData (WrappedPathPiece a) where
62112 parseUrlPiece = fmap WrappedPathPiece . parseMaybeHttpApiData fromPathPiece
63113
64−instance PathPiece a => PathPiece (Maybe a) where
65− toPathPiece = toUrlPiece . fmap WrappedPathPiece
66− fromPathPiece = either (const Nothing) (Just . fmap unwrapPathPiece) . parseUrlPiece
114+-- | Convert value to route piece using @'PathPiece'@ instance for its parameter.
115+toPathPiece1 :: forall f a. (PathPiece a, ToHttpApiData (f (WrappedPathPiece a))) => f a -> S.Text
116+toPathPiece1 = toUrlPiece . (unsafeCoerce :: f a -> f (WrappedPathPiece a))
117+
118+-- | Parse value from route piece using @'PathPiece'@ instance for its parameter.
119+fromPathPiece1 :: forall f a. (PathPiece a, FromHttpApiData (f (WrappedPathPiece a))) => S.Text -> Maybe (f a)
120+fromPathPiece1 = either (const Nothing) (Just . (unsafeCoerce :: f (WrappedPathPiece a) -> f a)) . parseUrlPiece
121+
122+-- | Convert value to route piece using @'PathPiece'@ instance for its parameters.
123+toPathPiece2 :: forall f a b. (PathPiece a, PathPiece b, ToHttpApiData (f (WrappedPathPiece a) (WrappedPathPiece b))) => f a b -> S.Text
124+toPathPiece2 = toUrlPiece . (unsafeCoerce :: f a b -> f (WrappedPathPiece a) (WrappedPathPiece b))
125+
126+-- | Parse value from route piece using @'PathPiece'@ instance for its parameters.
127+fromPathPiece2 :: forall f a b. (PathPiece a, PathPiece b, FromHttpApiData (f (WrappedPathPiece a) (WrappedPathPiece b))) => S.Text -> Maybe (f a b)
128+fromPathPiece2 = either (const Nothing) (Just . (unsafeCoerce :: f (WrappedPathPiece a) (WrappedPathPiece b) -> f a b)) . parseUrlPiece
67129
68130-- | Convert Haskell values to and from sequence of route pieces.
69131class PathMultiPiece s where
test/main.hs+31−18
@@ -9,6 +9,7 @@ import Data.Word
99import Data.Time
1010import qualified Data.Text as T
1111import qualified Data.Text.Lazy as L
12+import Data.Version
1213
1314import Test.Hspec
1415import Test.Hspec.QuickCheck(prop)
@@ -25,6 +26,12 @@ instance Arbitrary L.Text where
2526instance Arbitrary Day where
2627 arbitrary = liftA3 fromGregorian (fmap abs arbitrary) arbitrary arbitrary
2728
29+instance Arbitrary Version where
30+ arbitrary = (version . map abs) <$> nonempty
31+ where
32+ version branch = Version branch []
33+ nonempty = liftA2 (:) arbitrary arbitrary
34+
2835main :: IO ()
2936main = hspec spec
3037
@@ -34,24 +41,30 @@ main = hspec spec
3441spec :: Spec
3542spec = do
3643 describe "PathPiece" $ do
37− prop "toPathPiece <=> fromPathPiece ()" $ \(p :: ()) -> (toPathPiece <=> fromPathPiece) p
38− prop "toPathPiece <=> fromPathPiece Bool" $ \(p :: Bool) -> (toPathPiece <=> fromPathPiece) p
39− prop "toPathPiece <=> fromPathPiece Int" $ \(p :: Int) -> (toPathPiece <=> fromPathPiece) p
40− prop "toPathPiece <=> fromPathPiece Int8" $ \(p :: Int8) -> (toPathPiece <=> fromPathPiece) p
41− prop "toPathPiece <=> fromPathPiece Int16" $ \(p :: Int16) -> (toPathPiece <=> fromPathPiece) p
42− prop "toPathPiece <=> fromPathPiece Int32" $ \(p :: Int32) -> (toPathPiece <=> fromPathPiece) p
43− prop "toPathPiece <=> fromPathPiece Word" $ \(p :: Word) -> (toPathPiece <=> fromPathPiece) p
44− prop "toPathPiece <=> fromPathPiece Word8" $ \(p :: Word8) -> (toPathPiece <=> fromPathPiece) p
45− prop "toPathPiece <=> fromPathPiece Word16" $ \(p :: Word16) -> (toPathPiece <=> fromPathPiece) p
46− prop "toPathPiece <=> fromPathPiece Word32" $ \(p :: Word32) -> (toPathPiece <=> fromPathPiece) p
47− prop "toPathPiece <=> fromPathPiece Word64" $ \(p :: Word64) -> (toPathPiece <=> fromPathPiece) p
48− prop "toPathPiece <=> fromPathPiece Word64" $ \(p :: Word64) -> (toPathPiece <=> fromPathPiece) p
49− prop "toPathPiece <=> fromPathPiece String" $ \(p :: String) -> (toPathPiece <=> fromPathPiece) p
50− prop "toPathPiece <=> fromPathPiece Text.Strict" $ \(p :: T.Text) -> (toPathPiece <=> fromPathPiece) p
51− prop "toPathPiece <=> fromPathPiece Text.Lazy" $ \(p :: L.Text) -> (toPathPiece <=> fromPathPiece) p
52− prop "toPathPiece <=> fromPathPiece Day" $ \(p :: Day) -> (toPathPiece <=> fromPathPiece) p
53−
54− prop "toPathPiece <=> fromPathPiece Maybe String" $ \(p::Maybe String) -> (toPathPiece <=> fromPathPiece) p
44+ prop "toPathPiece <=> fromPathPiece ()" $ \(p :: ()) -> (toPathPiece <=> fromPathPiece) p
45+ prop "toPathPiece <=> fromPathPiece Char" $ \(p :: Char) -> (toPathPiece <=> fromPathPiece) p
46+ prop "toPathPiece <=> fromPathPiece Bool" $ \(p :: Bool) -> (toPathPiece <=> fromPathPiece) p
47+ prop "toPathPiece <=> fromPathPiece Ordering" $ \(p :: Ordering) -> (toPathPiece <=> fromPathPiece) p
48+ prop "toPathPiece <=> fromPathPiece Int" $ \(p :: Int) -> (toPathPiece <=> fromPathPiece) p
49+ prop "toPathPiece <=> fromPathPiece Int8" $ \(p :: Int8) -> (toPathPiece <=> fromPathPiece) p
50+ prop "toPathPiece <=> fromPathPiece Int16" $ \(p :: Int16) -> (toPathPiece <=> fromPathPiece) p
51+ prop "toPathPiece <=> fromPathPiece Int32" $ \(p :: Int32) -> (toPathPiece <=> fromPathPiece) p
52+ prop "toPathPiece <=> fromPathPiece Int64" $ \(p :: Int64) -> (toPathPiece <=> fromPathPiece) p
53+ prop "toPathPiece <=> fromPathPiece Integer" $ \(p :: Integer) -> (toPathPiece <=> fromPathPiece) p
54+ prop "toPathPiece <=> fromPathPiece Word" $ \(p :: Word) -> (toPathPiece <=> fromPathPiece) p
55+ prop "toPathPiece <=> fromPathPiece Word8" $ \(p :: Word8) -> (toPathPiece <=> fromPathPiece) p
56+ prop "toPathPiece <=> fromPathPiece Word16" $ \(p :: Word16) -> (toPathPiece <=> fromPathPiece) p
57+ prop "toPathPiece <=> fromPathPiece Word32" $ \(p :: Word32) -> (toPathPiece <=> fromPathPiece) p
58+ prop "toPathPiece <=> fromPathPiece Word64" $ \(p :: Word64) -> (toPathPiece <=> fromPathPiece) p
59+ prop "toPathPiece <=> fromPathPiece Word64" $ \(p :: Word64) -> (toPathPiece <=> fromPathPiece) p
60+ prop "toPathPiece <=> fromPathPiece String" $ \(p :: String) -> (toPathPiece <=> fromPathPiece) p
61+ prop "toPathPiece <=> fromPathPiece Text.Strict" $ \(p :: T.Text) -> (toPathPiece <=> fromPathPiece) p
62+ prop "toPathPiece <=> fromPathPiece Text.Lazy" $ \(p :: L.Text) -> (toPathPiece <=> fromPathPiece) p
63+ prop "toPathPiece <=> fromPathPiece Day" $ \(p :: Day) -> (toPathPiece <=> fromPathPiece) p
64+ prop "toPathPiece <=> fromPathPiece Version" $ \(p :: Version) -> (toPathPiece <=> fromPathPiece) p
65+
66+ prop "toPathPiece <=> fromPathPiece Maybe String" $ \(p::Maybe String) -> (toPathPiece <=> fromPathPiece) p
67+ prop "toPathPiece <=> fromPathPiece Either Integer Text" $ \(p::Either Integer T.Text) -> (toPathPiece <=> fromPathPiece) p
5568
5669 describe "PathMultiPiece" $ do
5770 prop "toPathMultiPiece <=> fromPathMultiPiece String" $ \(p::[String]) -> (toPathMultiPiece <=> fromPathMultiPiece) p