git.iko.soy/servant
on master help sign in
Add default ToSample implementation for Generics
80f235bNickolay Kudasov
servant-docs/src/Servant/Docs/Internal.hs+47−6
compare with master
unifiedsplit
@@ -1,6 +1,7 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
@@ -19,10 +20,9 @@
19#endif
20#endif
20module Servant.Docs.Internal where
21module Servant.Docs.Internal where
21
22
22−#if !MIN_VERSION_base(4,8,0)
23import Control.Applicative
23import Control.Applicative
24−#endif
24+import Control.Arrow (second)
25−import Control.Lens hiding (List)
25+import Control.Lens hiding (List, to, from)
26import Data.ByteString.Conversion (ToByteString, toByteString)
26import Data.ByteString.Conversion (ToByteString, toByteString)
27import Data.ByteString.Lazy.Char8 (ByteString)
27import Data.ByteString.Lazy.Char8 (ByteString)
28import qualified Data.CaseInsensitive as CI
28import qualified Data.CaseInsensitive as CI
@@ -382,14 +382,55 @@ class HasDocs layout where
382-- some context (as 'Text') that explains when you're supposed to
382-- some context (as 'Text') that explains when you're supposed to
383-- get the corresponding response.
383-- get the corresponding response.
384class ToSample a b | a -> b where
384class ToSample a b | a -> b where
385− {-# MINIMAL (toSample | toSamples) #-}
386 toSample :: Proxy a -> Maybe b
385 toSample :: Proxy a -> Maybe b
387 toSample _ = snd <$> listToMaybe samples
386 toSample _ = snd <$> listToMaybe samples
388 where samples = toSamples (Proxy :: Proxy a)
387 where samples = toSamples (Proxy :: Proxy a)
389
388
390 toSamples :: Proxy a -> [(Text, b)]
389 toSamples :: Proxy a -> [(Text, b)]
390+ default toSamples :: (Generic a, Generic b, GToSample (Rep a) (Rep b)) => Proxy a -> [(Text, b)]
391− toSamples _ = maybe [] (return . ("",)) s
391+ toSamples = defaultSamples
392+
393+defaultSample :: forall a b. (Generic a, Generic b, GToSample (Rep a) (Rep b)) => Proxy a -> Maybe b
394+defaultSample _ = to <$> gtoSample (Proxy :: Proxy (Rep a))
395+
396+defaultSamples :: forall a b. (Generic a, Generic b, GToSample (Rep a) (Rep b)) => Proxy a -> [(Text, b)]
397+defaultSamples _ = second to <$> gtoSamples (Proxy :: Proxy (Rep a))
398+
399+class GToSample t s where
400+ gtoSample :: proxy t -> Maybe (s x)
401+ gtoSample _ = snd <$> listToMaybe (gtoSamples (Proxy :: Proxy t))
402+ gtoSamples :: proxy t -> [(Text, s x)]
403+ gtoSamples _ = maybe empty (pure . ("",)) (gtoSample (Proxy :: Proxy t))
404+
405+instance GToSample U1 U1 where
406+ gtoSample _ = Just U1
407+
408+instance GToSample V1 V1 where
409+ gtoSample _ = Nothing
410+
411+instance (GToSample p p', GToSample q q') => GToSample (p :*: q) (p' :*: q') where
412+ gtoSample _ = (:*:) <$> gtoSample (Proxy :: Proxy p) <*> gtoSample (Proxy :: Proxy q)
413+ gtoSamples _ = render <$> ps <*> qs
414+ where
415+ ps = gtoSamples (Proxy :: Proxy p)
416+ qs = gtoSamples (Proxy :: Proxy q)
417+ render (ta, a) (tb, b)
418+ | T.null ta || T.null tb = (ta <> tb, a :*: b)
419+ | otherwise = (ta <> ", " <> tb, a :*: b)
420+
421+instance (GToSample p p', GToSample q q') => GToSample (p :+: q) (p' :+: q') where
422+ gtoSamples _ = lefts <|> rights
423+ where
424+ lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)
425+ rights = second R1 <$> gtoSamples (Proxy :: Proxy q)
426+
427+instance ToSample a b => GToSample (K1 i a) (K1 i b) where
392− where s = toSample (Proxy :: Proxy a)
428+ gtoSample _ = K1 <$> toSample (Proxy :: Proxy a)
429+ gtoSamples _ = second K1 <$> toSamples (Proxy :: Proxy a)
430+
431+instance (GToSample f g) => GToSample (M1 i a f) (M1 i a g) where
432+ gtoSample _ = M1 <$> gtoSample (Proxy :: Proxy f)
433+ gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)
393
434
394instance ToSample a b => ToSample (Headers ls a) b where
435instance ToSample a b => ToSample (Headers ls a) b where
395 toSample _ = toSample (Proxy :: Proxy a)
436 toSample _ = toSample (Proxy :: Proxy a)