git.iko.soy/typeable/http-api-data
on master help sign in
Merge pull request #14 from fizruk/more-instances-#10
743ba33Nickolay Kudasov
Web/HttpApiData.hs+80
compare with master
unifiedsplit
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
@@ -36,8 +37,14 @@ import qualified Data.Text as T
36import qualified Data.Text.Lazy as L
37import qualified Data.Text.Lazy as L
37
38
38import Data.Time (Day)
39import Data.Time (Day)
40+import Data.Version
41+
42+#if MIN_VERSION_base(4,8,0)
43+import Data.Void
44+#endif
39
45
40import Text.Read (readMaybe)
46import Text.Read (readMaybe)
47+import Text.ParserCombinators.ReadP (readP_to_S)
41
48
42-- $setup
49-- $setup
43--
50--
@@ -124,7 +131,21 @@ parseBounded reader input = do
124instance ToHttpApiData () where
131instance ToHttpApiData () where
125 toUrlPiece () = "_"
132 toUrlPiece () = "_"
126
133
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+
127instance ToHttpApiData Bool where toUrlPiece = showUrlPiece
147instance ToHttpApiData Bool where toUrlPiece = showUrlPiece
148+instance ToHttpApiData Ordering where toUrlPiece = showUrlPiece
128instance ToHttpApiData Double where toUrlPiece = showUrlPiece
149instance ToHttpApiData Double where toUrlPiece = showUrlPiece
129instance ToHttpApiData Float where toUrlPiece = showUrlPiece
150instance ToHttpApiData Float where toUrlPiece = showUrlPiece
130instance ToHttpApiData Int where toUrlPiece = showUrlPiece
151instance ToHttpApiData Int where toUrlPiece = showUrlPiece
@@ -143,6 +164,15 @@ instance ToHttpApiData Text where toUrlPiece = id
143instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
164instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
144instance ToHttpApiData Day where toUrlPiece = showUrlPiece
165instance ToHttpApiData Day where toUrlPiece = showUrlPiece
145
166
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+
146-- |
176-- |
147-- >>> toUrlPiece (Just "Hello")
177-- >>> toUrlPiece (Just "Hello")
148-- "Just Hello"
178-- "Just Hello"
@@ -150,6 +180,15 @@ instance ToHttpApiData a => ToHttpApiData (Maybe a) where
150 toUrlPiece (Just x) = "Just " <> toUrlPiece x
180 toUrlPiece (Just x) = "Just " <> toUrlPiece x
151 toUrlPiece Nothing = "Nothing"
181 toUrlPiece Nothing = "Nothing"
152
182
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+
153-- |
192-- |
154-- >>> parseUrlPiece "_" :: Either Text ()
193-- >>> parseUrlPiece "_" :: Either Text ()
155-- Right ()
194-- Right ()
@@ -157,7 +196,28 @@ instance FromHttpApiData () where
157 parseUrlPiece "_" = return ()
196 parseUrlPiece "_" = return ()
158 parseUrlPiece s = defaultParseError s
197 parseUrlPiece s = defaultParseError s
159
198
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+
160instance FromHttpApiData Bool where parseUrlPiece = readEitherUrlPiece
219instance FromHttpApiData Bool where parseUrlPiece = readEitherUrlPiece
220+instance FromHttpApiData Ordering where parseUrlPiece = readEitherUrlPiece
161instance FromHttpApiData Double where parseUrlPiece = runReader rational
221instance FromHttpApiData Double where parseUrlPiece = runReader rational
162instance FromHttpApiData Float where parseUrlPiece = runReader rational
222instance FromHttpApiData Float where parseUrlPiece = runReader rational
163instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
223instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
@@ -176,6 +236,15 @@ instance FromHttpApiData Text where parseUrlPiece = Right
176instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
236instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
177instance FromHttpApiData Day where parseUrlPiece = readEitherUrlPiece
237instance FromHttpApiData Day where parseUrlPiece = readEitherUrlPiece
178
238
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+
179-- |
248-- |
180-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
249-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
181-- Right (Just 123)
250-- Right (Just 123)
@@ -186,6 +255,17 @@ instance FromHttpApiData a => FromHttpApiData (Maybe a) where
186 Nothing -> defaultParseError s
255 Nothing -> defaultParseError s
187 Just x -> Just <$> parseUrlPiece x
256 Just x -> Just <$> parseUrlPiece x
188
257
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+
189-- $examples
269-- $examples
190--
270--
191-- Booleans:
271-- Booleans:
Web/PathPieces.hs+65−3
@@ -1,6 +1,9 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE Rank2Types #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TypeSynonymInstances #-}
7{-# LANGUAGE TypeSynonymInstances #-}
5-- |
8-- |
6-- Convert Haskell values to and from route pieces.
9-- Convert Haskell values to and from route pieces.
@@ -12,13 +15,21 @@ module Web.PathPieces (
12 WrappedPathPiece(..),
15 WrappedPathPiece(..),
13) where
16) where
14
17
18+import Data.Monoid
15import Data.Int
19import Data.Int
16import Data.Word
20import Data.Word
17import qualified Data.Text as S
21import qualified Data.Text as S
18import qualified Data.Text.Lazy as L
22import qualified Data.Text.Lazy as L
23+import Data.Version (Version)
19import Data.Time (Day)
24import Data.Time (Day)
20import Text.Read (readMaybe)
25import Text.Read (readMaybe)
21
26
27+import Unsafe.Coerce
28+
29+#if MIN_VERSION_base(4,8,0)
30+import Data.Void (Void)
31+#endif
32+
22import Web.HttpApiData
33import Web.HttpApiData
23
34
24-- | Convert Haskell values to and from route piece.
35-- | Convert Haskell values to and from route piece.
@@ -34,7 +45,9 @@ class PathPiece s where
34 toPathPiece = toUrlPiece
45 toPathPiece = toUrlPiece
35
46
36instance PathPiece ()
47instance PathPiece ()
48+instance PathPiece Char
37instance PathPiece Bool
49instance PathPiece Bool
50+instance PathPiece Ordering
38instance PathPiece Double
51instance PathPiece Double
39instance PathPiece Float
52instance PathPiece Float
40instance PathPiece Int
53instance PathPiece Int
@@ -42,6 +55,7 @@ instance PathPiece Int8
42instance PathPiece Int16
55instance PathPiece Int16
43instance PathPiece Int32
56instance PathPiece Int32
44instance PathPiece Int64
57instance PathPiece Int64
58+instance PathPiece Integer
45instance PathPiece Word
59instance PathPiece Word
46instance PathPiece Word8
60instance PathPiece Word8
47instance PathPiece Word16
61instance PathPiece Word16
@@ -51,6 +65,42 @@ instance PathPiece String
51instance PathPiece S.Text
65instance PathPiece S.Text
52instance PathPiece L.Text
66instance PathPiece L.Text
53instance PathPiece Day
67instance 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
54
104
55-- | Wrapped @'PathPiece'@ value.
105-- | Wrapped @'PathPiece'@ value.
56newtype WrappedPathPiece a = WrappedPathPiece { unwrapPathPiece :: a }
106newtype WrappedPathPiece a = WrappedPathPiece { unwrapPathPiece :: a }
@@ -61,9 +111,21 @@ instance PathPiece a => ToHttpApiData (WrappedPathPiece a) where
61instance PathPiece a => FromHttpApiData (WrappedPathPiece a) where
111instance PathPiece a => FromHttpApiData (WrappedPathPiece a) where
62 parseUrlPiece = fmap WrappedPathPiece . parseMaybeHttpApiData fromPathPiece
112 parseUrlPiece = fmap WrappedPathPiece . parseMaybeHttpApiData fromPathPiece
63
113
64−instance PathPiece a => PathPiece (Maybe a) where
114+-- | Convert value to route piece using @'PathPiece'@ instance for its parameter.
65− toPathPiece = toUrlPiece . fmap WrappedPathPiece
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)
66− fromPathPiece = either (const Nothing) (Just . fmap unwrapPathPiece) . parseUrlPiece
128+fromPathPiece2 = either (const Nothing) (Just . (unsafeCoerce :: f (WrappedPathPiece a) (WrappedPathPiece b) -> f a b)) . parseUrlPiece
67
129
68-- | Convert Haskell values to and from sequence of route pieces.
130-- | Convert Haskell values to and from sequence of route pieces.
69class PathMultiPiece s where
131class PathMultiPiece s where
test/main.hs+31−18
@@ -9,6 +9,7 @@ import Data.Word
9import Data.Time
9import Data.Time
10import qualified Data.Text as T
10import qualified Data.Text as T
11import qualified Data.Text.Lazy as L
11import qualified Data.Text.Lazy as L
12+import Data.Version
12
13
13import Test.Hspec
14import Test.Hspec
14import Test.Hspec.QuickCheck(prop)
15import Test.Hspec.QuickCheck(prop)
@@ -25,6 +26,12 @@ instance Arbitrary L.Text where
25instance Arbitrary Day where
26instance Arbitrary Day where
26 arbitrary = liftA3 fromGregorian (fmap abs arbitrary) arbitrary arbitrary
27 arbitrary = liftA3 fromGregorian (fmap abs arbitrary) arbitrary arbitrary
27
28
29+instance Arbitrary Version where
30+ arbitrary = (version . map abs) <$> nonempty
31+ where
32+ version branch = Version branch []
33+ nonempty = liftA2 (:) arbitrary arbitrary
34+
28main :: IO ()
35main :: IO ()
29main = hspec spec
36main = hspec spec
30
37
@@ -34,24 +41,30 @@ main = hspec spec
34spec :: Spec
41spec :: Spec
35spec = do
42spec = do
36 describe "PathPiece" $ do
43 describe "PathPiece" $ do
37− prop "toPathPiece <=> fromPathPiece ()" $ \(p :: ()) -> (toPathPiece <=> fromPathPiece) p
44+ prop "toPathPiece <=> fromPathPiece ()" $ \(p :: ()) -> (toPathPiece <=> fromPathPiece) p
45+ prop "toPathPiece <=> fromPathPiece Char" $ \(p :: Char) -> (toPathPiece <=> fromPathPiece) p
38− prop "toPathPiece <=> fromPathPiece Bool" $ \(p :: Bool) -> (toPathPiece <=> fromPathPiece) p
46+ prop "toPathPiece <=> fromPathPiece Bool" $ \(p :: Bool) -> (toPathPiece <=> fromPathPiece) p
47+ prop "toPathPiece <=> fromPathPiece Ordering" $ \(p :: Ordering) -> (toPathPiece <=> fromPathPiece) p
39− prop "toPathPiece <=> fromPathPiece Int" $ \(p :: Int) -> (toPathPiece <=> fromPathPiece) p
48+ prop "toPathPiece <=> fromPathPiece Int" $ \(p :: Int) -> (toPathPiece <=> fromPathPiece) p
40− prop "toPathPiece <=> fromPathPiece Int8" $ \(p :: Int8) -> (toPathPiece <=> fromPathPiece) p
49+ prop "toPathPiece <=> fromPathPiece Int8" $ \(p :: Int8) -> (toPathPiece <=> fromPathPiece) p
41− prop "toPathPiece <=> fromPathPiece Int16" $ \(p :: Int16) -> (toPathPiece <=> fromPathPiece) p
50+ prop "toPathPiece <=> fromPathPiece Int16" $ \(p :: Int16) -> (toPathPiece <=> fromPathPiece) p
42− prop "toPathPiece <=> fromPathPiece Int32" $ \(p :: Int32) -> (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
43− prop "toPathPiece <=> fromPathPiece Word" $ \(p :: Word) -> (toPathPiece <=> fromPathPiece) p
54+ prop "toPathPiece <=> fromPathPiece Word" $ \(p :: Word) -> (toPathPiece <=> fromPathPiece) p
44− prop "toPathPiece <=> fromPathPiece Word8" $ \(p :: Word8) -> (toPathPiece <=> fromPathPiece) p
55+ prop "toPathPiece <=> fromPathPiece Word8" $ \(p :: Word8) -> (toPathPiece <=> fromPathPiece) p
45− prop "toPathPiece <=> fromPathPiece Word16" $ \(p :: Word16) -> (toPathPiece <=> fromPathPiece) p
56+ prop "toPathPiece <=> fromPathPiece Word16" $ \(p :: Word16) -> (toPathPiece <=> fromPathPiece) p
46− prop "toPathPiece <=> fromPathPiece Word32" $ \(p :: Word32) -> (toPathPiece <=> fromPathPiece) p
57+ prop "toPathPiece <=> fromPathPiece Word32" $ \(p :: Word32) -> (toPathPiece <=> fromPathPiece) p
47− prop "toPathPiece <=> fromPathPiece Word64" $ \(p :: Word64) -> (toPathPiece <=> fromPathPiece) p
58+ prop "toPathPiece <=> fromPathPiece Word64" $ \(p :: Word64) -> (toPathPiece <=> fromPathPiece) p
48− prop "toPathPiece <=> fromPathPiece Word64" $ \(p :: Word64) -> (toPathPiece <=> fromPathPiece) p
59+ prop "toPathPiece <=> fromPathPiece Word64" $ \(p :: Word64) -> (toPathPiece <=> fromPathPiece) p
49− prop "toPathPiece <=> fromPathPiece String" $ \(p :: String) -> (toPathPiece <=> fromPathPiece) p
60+ prop "toPathPiece <=> fromPathPiece String" $ \(p :: String) -> (toPathPiece <=> fromPathPiece) p
50− prop "toPathPiece <=> fromPathPiece Text.Strict" $ \(p :: T.Text) -> (toPathPiece <=> fromPathPiece) p
61+ prop "toPathPiece <=> fromPathPiece Text.Strict" $ \(p :: T.Text) -> (toPathPiece <=> fromPathPiece) p
51− prop "toPathPiece <=> fromPathPiece Text.Lazy" $ \(p :: L.Text) -> (toPathPiece <=> fromPathPiece) p
62+ prop "toPathPiece <=> fromPathPiece Text.Lazy" $ \(p :: L.Text) -> (toPathPiece <=> fromPathPiece) p
52− prop "toPathPiece <=> fromPathPiece Day" $ \(p :: Day) -> (toPathPiece <=> fromPathPiece) p
63+ prop "toPathPiece <=> fromPathPiece Day" $ \(p :: Day) -> (toPathPiece <=> fromPathPiece) p
53−
64+ prop "toPathPiece <=> fromPathPiece Version" $ \(p :: Version) -> (toPathPiece <=> fromPathPiece) p
65+
54− prop "toPathPiece <=> fromPathPiece Maybe String" $ \(p::Maybe String) -> (toPathPiece <=> fromPathPiece) p
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
55
68
56 describe "PathMultiPiece" $ do
69 describe "PathMultiPiece" $ do
57 prop "toPathMultiPiece <=> fromPathMultiPiece String" $ \(p::[String]) -> (toPathMultiPiece <=> fromPathMultiPiece) p
70 prop "toPathMultiPiece <=> fromPathMultiPiece String" $ \(p::[String]) -> (toPathMultiPiece <=> fromPathMultiPiece) p