{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This module provides helper functions to generate Swagger schemas that
-- describe JSONPB encodings for protobuf types.
module Proto3.Suite.DotProto.Generate.Swagger
  ( ppSchema
  , asProxy
  , insOrdFromList
  )
where

#if MIN_VERSION_swagger2(2,4,0)
import           Control.Lens                    ((&), (?~))
#else
import           Control.Lens                    ((&), (.~), (?~))
#endif
import           Data.Aeson                      (Value (String))
import           Data.Aeson.Encode.Pretty        (encodePretty)
import qualified Data.ByteString.Lazy.Char8      as LC8
import           Data.Hashable                   (Hashable)
import           Data.HashMap.Strict.InsOrd      (InsOrdHashMap)
import qualified Data.HashMap.Strict.InsOrd
import           Data.Swagger
import qualified Data.Text                       as T
import           Data.Proxy
import qualified Data.Vector                     as V
import           GHC.Exts                        (Proxy#, proxy#)
import           Google.Protobuf.Wrappers.Polymorphic (Wrapped(..))
import           Proto3.Suite                    (Enumerated (..), Finite (..),
                                                  Fixed (..), Named (..),
                                                  Nested (..), NestedVec (..),
                                                  PackedVec (..), Signed (..),
                                                  UnpackedVec (..), enumerate)
import qualified Proto3.Suite.Types
import           Proto3.Suite.DotProto.Generate.Swagger.Wrappers ()

-- | Convenience re-export so that users of generated code don't have to add
--   an explicit dependency on @insert-ordered-containers@
insOrdFromList :: (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
insOrdFromList :: [(k, v)] -> InsOrdHashMap k v
insOrdFromList = [(k, v)] -> InsOrdHashMap k v
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
Data.HashMap.Strict.InsOrd.fromList

-- Distinctions between varint and fixed-width formats do not matter to JSONPB.
deriving newtype instance ToSchema a => ToSchema (Fixed a)

-- Zig-zag encoding issues do not matter to JSONPB.
deriving newtype instance ToSchema a => ToSchema (Signed a)

-- Packed/unpacked distinctions do not matter to JSONPB.
deriving via (V.Vector a) instance ToSchema a => ToSchema (NestedVec a)
deriving via (V.Vector a) instance ToSchema a => ToSchema (PackedVec a)
deriving via (V.Vector a) instance ToSchema a => ToSchema (UnpackedVec a)

-- Unless and until the overlapping instances for @Maybe (Wrapped _)@
-- are selected, the schema is unaffected by 'Wrapped'.
deriving newtype instance ToSchema a => ToSchema (Wrapped a)

instance ToSchema (Proto3.Suite.Types.String a) where
  declareNamedSchema :: Proxy (String a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (String a)
_ = Proxy String -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy String
forall k (t :: k). Proxy t
Proxy :: Proxy String)

instance ToSchema (Proto3.Suite.Types.Bytes a) where
  declareNamedSchema :: Proxy (Bytes a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Bytes a)
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing Schema
byteSchema)

-- Note that the context is @ToSchema (Maybe a)@, NOT @ToSchema a@.
-- This design keeps this instance from bypassing overlapping
-- instances such as @ToSchema (Maybe (Wrapped Bool))@ that
-- are included by cabal flag @-fswagger-wrapper-format@.
-- We use MonoLocalBinds to avoid the resultant compiler warning.
deriving via (Maybe a) instance ToSchema (Maybe a) => ToSchema (Nested a)

{-| This is a convenience function that uses type inference to select the
    correct instance of `ToSchema` to use for fields of a message
-}
asProxy :: (Proxy a -> b) -> Proxy a
asProxy :: (Proxy a -> b) -> Proxy a
asProxy Proxy a -> b
_ = Proxy a
forall k (t :: k). Proxy t
Proxy

-- | Pretty-prints a schema. Useful when playing around with schemas in the
-- REPL.
ppSchema :: ToSchema a => Proxy a -> IO ()
ppSchema :: Proxy a -> IO ()
ppSchema = ByteString -> IO ()
LC8.putStrLn (ByteString -> IO ())
-> (Proxy a -> ByteString) -> Proxy a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (Schema -> ByteString)
-> (Proxy a -> Schema) -> Proxy a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> Schema
forall a. ToSchema a => Proxy a -> Schema
toSchema

-- | JSONPB schemas for protobuf enumerations
instance (Finite e, Named e) => ToSchema (Enumerated e) where
  declareNamedSchema :: Proxy (Enumerated e) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Enumerated e)
_ = do
    let enumName :: Text
enumName        = Proxy# e -> Text
forall a string. (Named a, IsString string) => Proxy# a -> string
nameOf (Proxy# e
forall k (a :: k). Proxy# a
proxy# :: Proxy# e)
    let dropPrefix :: Text -> Text
dropPrefix      = Int -> Text -> Text
T.drop (Text -> Int
T.length Text
enumName)
    let enumMemberNames :: [Text]
enumMemberNames = Text -> Text
dropPrefix (Text -> Text) -> ((Text, Int32) -> Text) -> (Text, Int32) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Int32) -> Text
forall a b. (a, b) -> a
fst ((Text, Int32) -> Text) -> [(Text, Int32)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy# e -> [(Text, Int32)]
forall a string.
(Finite a, IsString string) =>
Proxy# a -> [(string, Int32)]
enumerate (Proxy# e
forall k (a :: k). Proxy# a
proxy# :: Proxy# e)
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
enumName)
           (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
#if MIN_VERSION_swagger2(2,4,0)
             Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe (SwaggerType 'SwaggerKindSchema)
 -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
type_ ((Maybe (SwaggerType 'SwaggerKindSchema)
  -> Identity (Maybe (SwaggerType 'SwaggerKindSchema)))
 -> Schema -> Identity Schema)
-> SwaggerType 'SwaggerKindSchema -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SwaggerType 'SwaggerKindSchema
forall (t :: SwaggerKind *). SwaggerType t
SwaggerString
#else
             & type_ .~ SwaggerString
#endif
             Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Text -> Value) -> [Text] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Value
String [Text]
enumMemberNames