{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE DerivingStrategies        #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE ImplicitParams            #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE MultiWayIf                #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE QuasiQuotes               #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE StandaloneDeriving        #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeApplications          #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE ViewPatterns              #-}

{-| This module provides functions to generate Haskell declarations for protobuf
    messages
-}

module Proto3.Suite.DotProto.Generate
  ( CompileError(..)
  , StringType(..)
  , parseStringType
  , TypeContext
  , CompileArgs(..)
  , compileDotProtoFile
  , compileDotProtoFileOrDie
  , renameProtoFile
  , hsModuleForDotProto
  , renderHsModuleForDotProto
  , readDotProtoWithContext
  ) where

import           Control.Applicative
import           Control.Lens                   ((&), ix, over, has, filtered)
import           Control.Monad                  (when)
import           Control.Monad.Except           (MonadError(..), runExceptT)
import           Control.Monad.IO.Class         (MonadIO(..))
import           Control.Monad.Writer           (WriterT, runWriterT, tell)
import           Data.Char
import           Data.Coerce
import           Data.Either                    (partitionEithers)
import           Data.Foldable                  (fold)
import           Data.Function                  (on)
import           Data.Functor                   ((<&>))
import           Data.List                      (find, intercalate, nub, sort, sortBy, stripPrefix)
import qualified Data.List.NonEmpty             as NE
import           Data.List.Split                (splitOn)
import           Data.List.NonEmpty             (NonEmpty (..))
import qualified Data.Map                       as M
import           Data.Maybe
import           Data.Monoid
import           Data.Ord                       (comparing)
import qualified Data.Set                       as S
import           Data.String                    (fromString)
import           GHC.Hs                         (HsSigType(..))
import           GHC.Parser.Annotation          (noLocA)
import           GHC.Types.Name.Occurrence      (dataName, tcName, varName)
import qualified Data.Text                      as T
import qualified GHC.Data.FastString            as GHC
import qualified GHC.Data.StringBuffer          as GHC
import qualified GHC.Hs                         as GHC
import qualified GHC.Types.Name                 as GHC
import qualified GHC.Types.Name.Reader          as GHC
import qualified GHC.Types.SrcLoc               as GHC
import qualified GHC.Utils.Outputable           as GHC
import qualified NeatInterpolation              as Neat
import           Prelude                        hiding (FilePath)
import           Proto3.Suite.DotProto
import           Proto3.Suite.DotProto.AST.Lens
import qualified Proto3.Suite.DotProto.Generate.Record as Record
import           Proto3.Suite.DotProto.Generate.Syntax
import           Proto3.Suite.Haskell.Parser    (Logger, parseModule, renderSDoc)
import           Proto3.Suite.DotProto.Internal
import           Proto3.Wire.Types              (FieldNumber (..))
import Text.Parsec (Parsec, alphaNum, eof, parse, satisfy, try)
import qualified Text.Parsec as Parsec
import qualified Turtle hiding (encodeString)
import qualified Turtle.Compat as Turtle (encodeString)
import           Turtle                         (FilePath, (</>), (<.>))

#if !MIN_VERSION_ghc_lib_parser(9,6,0)
import qualified GHC.Unit.Module.Name           as GHC
import qualified GHC.Types.Basic                as GHC (PromotionFlag(..))
#endif


-- $setup
-- >>> :set -XTypeApplications

--------------------------------------------------------------------------------

--
-- * Public interface
--
data CompileArgs = CompileArgs
  { CompileArgs -> [String]
includeDir         :: [FilePath]
  , CompileArgs -> [String]
extraInstanceFiles :: [FilePath]
  , CompileArgs -> String
inputProto         :: FilePath
  , CompileArgs -> String
outputDir          :: FilePath
  , CompileArgs -> StringType
stringType         :: StringType
  , CompileArgs -> Bool
typeLevelFormat    :: Bool
  }

data StringType = StringType String String
  -- ^ Qualified module name, then unqualified type name.

parseStringType :: String -> Either String StringType
parseStringType :: String -> Either String StringType
parseStringType String
str = case String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
str of
  xs :: [String]
xs@(String
_ : String
_ : [String]
_) -> StringType -> Either String StringType
forall a b. b -> Either a b
Right (StringType -> Either String StringType)
-> StringType -> Either String StringType
forall a b. (a -> b) -> a -> b
$ String -> String -> StringType
StringType (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. HasCallStack => [a] -> [a]
init [String]
xs) ([String] -> String
forall a. HasCallStack => [a] -> a
last [String]
xs)
  [String]
_ -> String -> Either String StringType
forall a b. a -> Either a b
Left String
"must be in the form Module.Type"

-- | Generate a Haskell module corresponding to a @.proto@ file
compileDotProtoFile :: Logger -> CompileArgs -> IO (Either CompileError ())
compileDotProtoFile :: Logger -> CompileArgs -> IO (Either CompileError ())
compileDotProtoFile Logger
logger CompileArgs{Bool
String
[String]
StringType
includeDir :: CompileArgs -> [String]
extraInstanceFiles :: CompileArgs -> [String]
inputProto :: CompileArgs -> String
outputDir :: CompileArgs -> String
stringType :: CompileArgs -> StringType
typeLevelFormat :: CompileArgs -> Bool
includeDir :: [String]
extraInstanceFiles :: [String]
inputProto :: String
outputDir :: String
stringType :: StringType
typeLevelFormat :: Bool
..} = ExceptT CompileError IO () -> IO (Either CompileError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT CompileError IO () -> IO (Either CompileError ()))
-> ExceptT CompileError IO () -> IO (Either CompileError ())
forall a b. (a -> b) -> a -> b
$ do
  (DotProto
dotProto, TypeContext
importTypeContext) <- [String]
-> String -> ExceptT CompileError IO (DotProto, TypeContext)
forall (m :: * -> *).
(MonadError CompileError m, MonadIO m) =>
[String] -> String -> m (DotProto, TypeContext)
readDotProtoWithContext [String]
includeDir String
inputProto
  NonEmpty String
modulePathPieces <- (String -> ExceptT CompileError IO String)
-> NonEmpty String -> ExceptT CompileError IO (NonEmpty String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse String -> ExceptT CompileError IO String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
renameProtoFile (DotProto -> NonEmpty String
toModuleComponents DotProto
dotProto)

  let relativePath :: String
relativePath = (String -> String -> String) -> String -> [String] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> String -> String
combine String
forall a. Monoid a => a
mempty ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. IsString a => String -> a
fromString ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
modulePathPieces) String -> String -> String
<.> String
"hs"
      combine :: String -> String -> String
combine String
p1 String
p2 | String
p2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
forall a. Monoid a => a
mempty = String
p1
      combine String
p1 String
p2 = String
p1 String -> String -> String
</> String
p2
  let modulePath :: String
modulePath = String
outputDir String -> String -> String
</> String
relativePath

  String -> ExceptT CompileError IO ()
forall (io :: * -> *). MonadIO io => String -> io ()
Turtle.mktree (String -> String
Turtle.directory String
modulePath)

  ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
 [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
extraInstances <- (String
 -> ExceptT
      CompileError
      IO
      ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
       [GenLocated SrcSpanAnnA (HsDecl GhcPs)]))
-> [String]
-> ExceptT
     CompileError
     IO
     ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
      [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM (Logger
-> String -> ExceptT CompileError IO ([HsImportDecl], [HsDecl])
forall (m :: * -> *).
(MonadIO m, MonadError CompileError m) =>
Logger -> String -> m ([HsImportDecl], [HsDecl])
getExtraInstances Logger
logger) [String]
extraInstanceFiles
  String
haskellModule <-
    let ?stringType = ?stringType::StringType
StringType
stringType
        ?typeLevelFormat = ?typeLevelFormat::Bool
Bool
typeLevelFormat
    in ([HsImportDecl], [HsDecl])
-> DotProto -> TypeContext -> ExceptT CompileError IO String
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType,
 ?typeLevelFormat::Bool) =>
([HsImportDecl], [HsDecl]) -> DotProto -> TypeContext -> m String
renderHsModuleForDotProto ([HsImportDecl], [HsDecl])
([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
 [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
extraInstances DotProto
dotProto TypeContext
importTypeContext

  IO () -> ExceptT CompileError IO ()
forall a. IO a -> ExceptT CompileError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO ()
writeFile (String -> String
Turtle.encodeString String
modulePath) String
haskellModule)
  where
    toModuleComponents :: DotProto -> NonEmpty String
    toModuleComponents :: DotProto -> NonEmpty String
toModuleComponents = Path -> NonEmpty String
components (Path -> NonEmpty String)
-> (DotProto -> Path) -> DotProto -> NonEmpty String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotProtoMeta -> Path
metaModulePath (DotProtoMeta -> Path)
-> (DotProto -> DotProtoMeta) -> DotProto -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotProto -> DotProtoMeta
protoMeta

-- | Same as 'compileDotProtoFile', except terminates the program with an error
-- message on failure.
compileDotProtoFileOrDie :: Logger -> CompileArgs -> IO ()
compileDotProtoFileOrDie :: Logger -> CompileArgs -> IO ()
compileDotProtoFileOrDie Logger
logger CompileArgs
args = Logger -> CompileArgs -> IO (Either CompileError ())
compileDotProtoFile Logger
logger CompileArgs
args IO (Either CompileError ())
-> (Either CompileError () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left CompileError
e -> do
    -- TODO: pretty print the error messages
    let errText :: Text
errText          = Format Text (CompileError -> Text) -> CompileError -> Text
forall r. Format Text r -> r
Turtle.format Format Text (CompileError -> Text)
forall a r. Show a => Format r (a -> r)
Turtle.w  CompileError
e
    let dotProtoPathText :: Text
dotProtoPathText = Format Text (String -> Text) -> String -> Text
forall r. Format Text r -> r
Turtle.format Format Text (String -> Text)
forall r. Format r (String -> r)
Turtle.fp (CompileArgs -> String
inputProto CompileArgs
args)
    Text -> IO ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
dieLines [Neat.text|
      Error: failed to compile "${dotProtoPathText}":

      ${errText}
    |]
  Either CompileError ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Renaming protobuf file names to valid Haskell module names.
--
-- By convention, protobuf filenames are snake case. 'rnProtoFile' renames
-- snake-cased protobuf filenames by:
--
-- * Replacing occurrences of one or more underscores followed by an
-- alphabetical character with one less underscore.
--
-- * Capitalizing the first character following the string of underscores.
--
-- ==== __Examples__
--
-- >>> renameProtoFile @(Either CompileError) "abc_xyz"
-- Right "AbcXyz"
--
-- >>> renameProtoFile @(Either CompileError) "abc_1bc"
-- Left (InvalidModuleName "abc_1bc")
--
-- >>> renameProtoFile @(Either CompileError) "_"
-- Left (InvalidModuleName "_")
renameProtoFile :: MonadError CompileError m => String -> m String
renameProtoFile :: forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
renameProtoFile String
filename =
  case Parsec String () (String, [(String, String)], String)
-> String
-> String
-> Either ParseError (String, [(String, String)], String)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () (String, [(String, String)], String)
parser String
"" String
filename of
    Left {} -> CompileError -> m String
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> CompileError
InvalidModuleName String
filename)
    Right (String
nm, [(String, String)]
ps, String
sn) -> String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String
toUpperFirst String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
rename [(String, String)]
ps String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sn)
  where
    rename :: [(String, String)] -> String
    rename :: [(String, String)] -> String
rename = ((String, String) -> String) -> [(String, String)] -> String
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((String, String) -> String) -> [(String, String)] -> String)
-> ((String, String) -> String) -> [(String, String)] -> String
forall a b. (a -> b) -> a -> b
$ \(String
us, String
nm) ->
      Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
us String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
toUpperFirst String
nm

    parser :: Parsec String () (String, [(String, String)], String)
    parser :: Parsec String () (String, [(String, String)], String)
parser = do
      String
nm <- Parsec String () String
pName
      [(String, String)]
ps <- ParsecT String () Identity (String, String)
-> ParsecT String () Identity [(String, String)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
Parsec.many (ParsecT String () Identity (String, String)
-> ParsecT String () Identity (String, String)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String () Identity (String, String)
pNamePart)
      String
sn <- ParsecT String () Identity Char -> Parsec String () String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
Parsec.many ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'))
      (String, [(String, String)], String)
-> Parsec String () (String, [(String, String)], String)
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
nm, [(String, String)]
ps, String
sn) Parsec String () (String, [(String, String)], String)
-> ParsecT String () Identity ()
-> Parsec String () (String, [(String, String)], String)
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

    pNamePart :: Parsec String () (String, String)
    pNamePart :: ParsecT String () Identity (String, String)
pNamePart = (String -> String -> (String, String))
-> Parsec String () String
-> Parsec String () String
-> ParsecT String () Identity (String, String)
forall a b c.
(a -> b -> c)
-> ParsecT String () Identity a
-> ParsecT String () Identity b
-> ParsecT String () Identity c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (ParsecT String () Identity Char -> Parsec String () String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
Parsec.many1 ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'))) Parsec String () String
pName

    pName :: Parsec String () String
    pName :: Parsec String () String
pName = (Char -> String -> String)
-> ParsecT String () Identity Char
-> Parsec String () String
-> Parsec String () String
forall a b c.
(a -> b -> c)
-> ParsecT String () Identity a
-> ParsecT String () Identity b
-> ParsecT String () Identity c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isAlpha) (ParsecT String () Identity Char -> Parsec String () String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
Parsec.many ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum)

-- | Compile a 'DotProto' AST into a 'String' representing the Haskell
--   source of a module implementing types and instances for the .proto
--   messages and enums.
renderHsModuleForDotProto ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  , (?typeLevelFormat :: Bool)
  ) =>
  ([HsImportDecl],[HsDecl]) ->
  DotProto ->
  TypeContext ->
  m String
renderHsModuleForDotProto :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType,
 ?typeLevelFormat::Bool) =>
([HsImportDecl], [HsDecl]) -> DotProto -> TypeContext -> m String
renderHsModuleForDotProto ([HsImportDecl], [HsDecl])
extraInstanceFiles DotProto
dotProto TypeContext
importCtxt = do
    HsModule GhcPs
haskellModule <- ([HsImportDecl], [HsDecl])
-> DotProto -> TypeContext -> m (HsModule GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType,
 ?typeLevelFormat::Bool) =>
([HsImportDecl], [HsDecl])
-> DotProto -> TypeContext -> m (HsModule GhcPs)
hsModuleForDotProto ([HsImportDecl], [HsDecl])
extraInstanceFiles DotProto
dotProto TypeContext
importCtxt

    let languagePragmas :: Text
languagePragmas = [Text] -> Text
textUnlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
extn -> Text
"{-# LANGUAGE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
extn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [Text]
extensions
        ghcOptionPragmas :: Text
ghcOptionPragmas = [Text] -> Text
textUnlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
opt -> Text
"{-# OPTIONS_GHC " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
opt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [Text]
options

        extensions :: [T.Text]
        extensions :: [Text]
extensions = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
          [ Text
"DataKinds"
          , Text
"DeriveAnyClass"
          , Text
"DeriveGeneric"
          , Text
"GADTs"
          , Text
"NamedFieldPuns"
          , Text
"NegativeLiterals"
          , Text
"OverloadedStrings"
          , Text
"TypeApplications"
          , Text
"TypeOperators"
          ] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
          (if ?typeLevelFormat::Bool
Bool
?typeLevelFormat then [ Text
"TypeFamilies", Text
"UndecidableInstances" ] else [])
        options :: [T.Text]
        options :: [Text]
options = [ Text
"-fno-warn-unused-imports"
                  , Text
"-fno-warn-name-shadowing"
                  , Text
"-fno-warn-unused-matches"
                  , Text
"-fno-warn-missing-export-lists"
                  ]

        moduleContent :: T.Text
        moduleContent :: Text
moduleContent = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SDoc -> String
renderSDoc (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr HsModule GhcPs
haskellModule

        textUnlines :: [T.Text] -> T.Text
        textUnlines :: [Text] -> Text
textUnlines = Text -> [Text] -> Text
T.intercalate Text
"\n"

    String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Neat.text|
      $languagePragmas
      $ghcOptionPragmas

      -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!
      $moduleContent
    |]

-- | Compile a Haskell module AST given a 'DotProto' package AST.
-- Instances given in @eis@ override those otherwise generated.
hsModuleForDotProto ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  , (?typeLevelFormat :: Bool)
  ) =>
  -- | Extra user-define instances that override default generated instances
  ([HsImportDecl], [HsDecl]) ->
  -- |
  DotProto ->
  -- |
  TypeContext ->
  m (GHC.HsModule
#if MIN_VERSION_ghc_lib_parser(9,6,0)
                  GHC.GhcPs
#endif
                           )
hsModuleForDotProto :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType,
 ?typeLevelFormat::Bool) =>
([HsImportDecl], [HsDecl])
-> DotProto -> TypeContext -> m (HsModule GhcPs)
hsModuleForDotProto
    ([HsImportDecl]
extraImports, [HsDecl]
extraInstances)
    dotProto :: DotProto
dotProto@DotProto{ protoMeta :: DotProto -> DotProtoMeta
protoMeta = DotProtoMeta { metaModulePath :: DotProtoMeta -> Path
metaModulePath = Path
modulePath }
                     , DotProtoPackageSpec
protoPackage :: DotProtoPackageSpec
protoPackage :: DotProto -> DotProtoPackageSpec
protoPackage
                     , [DotProtoDefinition]
protoDefinitions :: [DotProtoDefinition]
protoDefinitions :: DotProto -> [DotProtoDefinition]
protoDefinitions
                     }
    TypeContext
importTypeContext
  = do
       Module
moduleName <- Path -> m Module
forall (m :: * -> *). MonadError CompileError m => Path -> m Module
modulePathModName Path
modulePath

       [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
typeContextImports <- TypeContext -> m [HsImportDecl]
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> m [HsImportDecl]
ctxtImports TypeContext
importTypeContext

       let icUsesGrpc :: Bool
icUsesGrpc = Getting
  Any
  [DotProtoDefinition]
  (String, DotProtoIdentifier, [DotProtoServicePart])
-> [DotProtoDefinition] -> Bool
forall s a. Getting Any s a -> s -> Bool
has ((DotProtoDefinition -> Const Any DotProtoDefinition)
-> [DotProtoDefinition] -> Const Any [DotProtoDefinition]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse((DotProtoDefinition -> Const Any DotProtoDefinition)
 -> [DotProtoDefinition] -> Const Any [DotProtoDefinition])
-> (((String, DotProtoIdentifier, [DotProtoServicePart])
     -> Const Any (String, DotProtoIdentifier, [DotProtoServicePart]))
    -> DotProtoDefinition -> Const Any DotProtoDefinition)
-> Getting
     Any
     [DotProtoDefinition]
     (String, DotProtoIdentifier, [DotProtoServicePart])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((String, DotProtoIdentifier, [DotProtoServicePart])
 -> Const Any (String, DotProtoIdentifier, [DotProtoServicePart]))
-> DotProtoDefinition -> Const Any DotProtoDefinition
Prism'
  DotProtoDefinition
  (String, DotProtoIdentifier, [DotProtoServicePart])
_DotProtoService) [DotProtoDefinition]
protoDefinitions

       let importDeclarations :: [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
importDeclarations = [[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ (?stringType::StringType, ?typeLevelFormat::Bool) =>
Bool -> [HsImportDecl]
Bool -> [HsImportDecl]
defaultImports Bool
icUsesGrpc
              , [HsImportDecl]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
extraImports
              , [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
typeContextImports ]

       TypeContext
typeContext <- DotProto -> m TypeContext
forall (m :: * -> *).
MonadError CompileError m =>
DotProto -> m TypeContext
dotProtoTypeContext DotProto
dotProto

       let toDotProtoDeclaration :: DotProtoDefinition -> m [HsDecl]
toDotProtoDeclaration =
             DotProtoPackageSpec
-> TypeContext -> DotProtoDefinition -> m [HsDecl]
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType,
 ?typeLevelFormat::Bool) =>
DotProtoPackageSpec
-> TypeContext -> DotProtoDefinition -> m [HsDecl]
dotProtoDefinitionD DotProtoPackageSpec
protoPackage (TypeContext
typeContext TypeContext -> TypeContext -> TypeContext
forall a. Semigroup a => a -> a -> a
<> TypeContext
importTypeContext)

       let extraInstances' :: [HsDecl]
extraInstances' = Module -> [HsDecl] -> [HsDecl]
instancesForModule Module
moduleName [HsDecl]
extraInstances

       [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls <- [HsDecl] -> [HsDecl] -> [HsDecl]
replaceHsInstDecls [HsDecl]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
extraInstances' ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                (DotProtoDefinition -> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [DotProtoDefinition]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM DotProtoDefinition -> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
toDotProtoDeclaration [DotProtoDefinition]
protoDefinitions

       HsModule GhcPs -> m (HsModule GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Module
-> Maybe [HsExportSpec]
-> [HsImportDecl]
-> [HsDecl]
-> HsModule GhcPs
module_ Module
moduleName Maybe [HsExportSpec]
Maybe [GenLocated SrcSpanAnnA (IE GhcPs)]
forall a. Maybe a
Nothing [HsImportDecl]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
importDeclarations [HsDecl]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls)

getExtraInstances
    :: (MonadIO m, MonadError CompileError m)
    => Logger -> FilePath -> m ([HsImportDecl], [HsDecl])
getExtraInstances :: forall (m :: * -> *).
(MonadIO m, MonadError CompileError m) =>
Logger -> String -> m ([HsImportDecl], [HsDecl])
getExtraInstances Logger
logger (String -> String
Turtle.encodeString -> String
extraInstanceFile) = do
  StringBuffer
contents <- IO StringBuffer -> m StringBuffer
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> m StringBuffer)
-> IO StringBuffer -> m StringBuffer
forall a b. (a -> b) -> a -> b
$ String -> IO StringBuffer
GHC.hGetStringBuffer String
extraInstanceFile
  let location :: RealSrcLoc
location = FastString -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (String -> FastString
GHC.mkFastString String
extraInstanceFile) Int
1 Int
1
  Maybe (Located (HsModule GhcPs))
maybeModule <- IO (Maybe (Located (HsModule GhcPs)))
-> m (Maybe (Located (HsModule GhcPs)))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Located (HsModule GhcPs)))
 -> m (Maybe (Located (HsModule GhcPs))))
-> IO (Maybe (Located (HsModule GhcPs)))
-> m (Maybe (Located (HsModule GhcPs)))
forall a b. (a -> b) -> a -> b
$ Logger
-> RealSrcLoc
-> StringBuffer
-> IO (Maybe (Located (HsModule GhcPs)))
parseModule Logger
logger RealSrcLoc
location StringBuffer
contents
  case Maybe (Located (HsModule GhcPs))
maybeModule of
    Maybe (Located (HsModule GhcPs))
Nothing ->
      String
-> m ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
      [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError (Text -> String
T.unpack Text
"Error: Failed to parse instance file")
    Just (GHC.L SrcSpan
_ HsModule GhcPs
m) -> do
      let isInstDecl :: GenLocated l (HsDecl p) -> Bool
isInstDecl (GHC.L l
_ GHC.InstD{}) = Bool
True
          isInstDecl GenLocated l (HsDecl p)
_                     = Bool
False
      ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
 [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> m ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
      [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsModule GhcPs -> [HsImportDecl]
forall p. HsModule p -> [LImportDecl p]
GHC.hsmodImports HsModule GhcPs
m, (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. (a -> Bool) -> [a] -> [a]
filter GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Bool
forall {l} {p}. GenLocated l (HsDecl p) -> Bool
isInstDecl (HsModule GhcPs -> [HsDecl]
forall p. HsModule p -> [LHsDecl p]
GHC.hsmodDecls HsModule GhcPs
m))

-- | This very specific function will only work for the qualification on the very first type
-- in the object of an instance declaration. Those are the only sort of instance declarations
-- generated within this code, so it suffices.
instancesForModule :: Module -> [HsDecl] -> [HsDecl]
instancesForModule :: Module -> [HsDecl] -> [HsDecl]
instancesForModule Module
m = (GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall {l}.
GenLocated l (HsDecl GhcPs) -> Maybe (GenLocated l (HsDecl GhcPs))
go
  where
    go :: GenLocated l (HsDecl GhcPs) -> Maybe (GenLocated l (HsDecl GhcPs))
go ( GHC.L l
instX
         ( GHC.InstD XInstD GhcPs
clsInstX
           ( GHC.ClsInstD XClsInstD GhcPs
clsInstDeclX clsInstDecl :: ClsInstDecl GhcPs
clsInstDecl@GHC.ClsInstDecl
             { cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_poly_ty = GHC.L SrcSpanAnnA
tyX (HsSig XHsSig GhcPs
ext HsOuterSigTyVarBndrs GhcPs
bndrs LHsType GhcPs
ty) } ) ) )
      | Just (HsName
tc, GHC.L SrcSpanAnnA
_ (GHC.HsTyVar XTyVar GhcPs
_ PromotionFlag
GHC.NotPromoted (GHC.L SrcSpanAnnN
_ (GHC.Qual Module
tm OccName
i))) : [LHsType GhcPs]
ts) <-
          LHsType GhcPs -> Maybe (HsName, [LHsType GhcPs])
splitTyConApp LHsType GhcPs
ty, Module
m Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
tm =
        GenLocated l (HsDecl GhcPs) -> Maybe (GenLocated l (HsDecl GhcPs))
forall a. a -> Maybe a
Just ( l -> HsDecl GhcPs -> GenLocated l (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L l
instX
               ( XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
GHC.InstD XInstD GhcPs
clsInstX
                 ( XClsInstD GhcPs -> ClsInstDecl GhcPs -> InstDecl GhcPs
forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
GHC.ClsInstD XClsInstD GhcPs
clsInstDeclX ClsInstDecl GhcPs
clsInstDecl
                   { GHC.cid_poly_ty = GHC.L tyX (HsSig ext bndrs (tyConApply tc (typeNamed_ (noLocA (GHC.Unqual i)) : ts)))
                   } ) ) )
    go GenLocated l (HsDecl GhcPs)
_ = Maybe (GenLocated l (HsDecl GhcPs))
forall a. Maybe a
Nothing

-- | For each thing in @base@ replaces it if it finds a matching @override@.
--
-- Current Limitations: The type of the type class instance and the corresponding
-- override must both be monomorphic; otherwise they will not match each other.
-- Furthermore, comparison is based on unqualified names, so please ensure that
-- those unqualified names are unambiguous or false matches may occur.
replaceHsInstDecls :: [HsDecl] -> [HsDecl] -> [HsDecl]
replaceHsInstDecls :: [HsDecl] -> [HsDecl] -> [HsDecl]
replaceHsInstDecls [HsDecl]
overrides [HsDecl]
base = (GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HsDecl -> [HsDecl]
GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
mbReplace) [HsDecl]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
base
  where
    -- instances defined separately from data type definition:
    mbReplace :: HsDecl -> [HsDecl]
    mbReplace :: HsDecl -> [HsDecl]
mbReplace hid :: HsDecl
hid@(HsDecl -> Maybe (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
typeOfInstDecl -> Just (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
classSig) =
        [GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a. a -> Maybe a -> a
fromMaybe HsDecl
GenLocated SrcSpanAnnA (HsDecl GhcPs)
hid ((HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) -> Maybe HsDecl
search (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
classSig)]

    -- instances listed in "deriving" clause of data type or newtype definition:
    mbReplace ( GHC.L SrcSpanAnnA
tyClDX
                ( GHC.TyClD XTyClD GhcPs
dataDeclX
                  ( dataDecl :: TyClDecl GhcPs
dataDecl@GHC.DataDecl
                    { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = HsName
tyn
                    , tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = dd :: HsDataDefn GhcPs
dd@GHC.HsDataDefn
                      { dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcPs
clauses
                      }
                    } ) ) ) =
        let ty :: LHsType GhcPs
ty = HsName -> LHsType GhcPs
typeNamed_ HsName
tyn
            ([GenLocated EpAnnCO (HsDerivingClause GhcPs)]
uncustomized, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
customized) = [Either
   (GenLocated EpAnnCO (HsDerivingClause GhcPs))
   (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> ([GenLocated EpAnnCO (HsDerivingClause GhcPs)],
    [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((GenLocated EpAnnCO (HsDerivingClause GhcPs)
 -> [Either
       (GenLocated EpAnnCO (HsDerivingClause GhcPs))
       (GenLocated SrcSpanAnnA (HsDecl GhcPs))])
-> [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
-> [Either
      (GenLocated EpAnnCO (HsDerivingClause GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LHsType GhcPs
-> HsDerivingClause -> [Either HsDerivingClause HsDecl]
clause LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty) HsDeriving GhcPs
[GenLocated EpAnnCO (HsDerivingClause GhcPs)]
clauses)
        in ( SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
tyClDX
             ( XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
GHC.TyClD XTyClD GhcPs
dataDeclX
               ( TyClDecl GhcPs
dataDecl { GHC.tcdDataDefn = dd
                            { GHC.dd_derivs = uncustomized
                            } } ) ) )
           GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
customized

    -- irrelevant declarations remain unchanged:
    mbReplace HsDecl
hid = [HsDecl
hid]

    clause :: HsType -> HsDerivingClause -> [Either HsDerivingClause HsDecl]
    clause :: LHsType GhcPs
-> HsDerivingClause -> [Either HsDerivingClause HsDecl]
clause LHsType GhcPs
ty (HsDerivingClause
-> (Maybe HsDerivStrategy,
    [(HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)])
splitDerivingClause -> (Maybe HsDerivStrategy
strategy, [(HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)]
classSigs)) =
      let ([(HsOuterSigTyVarBndrs GhcPs,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
uncustomized, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
customized) = [Either
   (HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> ([(HsOuterSigTyVarBndrs GhcPs,
      GenLocated SrcSpanAnnA (HsType GhcPs))],
    [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (((HsOuterSigTyVarBndrs GhcPs,
  GenLocated SrcSpanAnnA (HsType GhcPs))
 -> Either
      (HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> [(HsOuterSigTyVarBndrs GhcPs,
     GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [Either
      (HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map (LHsType GhcPs
-> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
-> Either (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) HsDecl
deriv LHsType GhcPs
ty) [(HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)]
[(HsOuterSigTyVarBndrs GhcPs,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
classSigs)
      in ([Either
    (GenLocated EpAnnCO (HsDerivingClause GhcPs))
    (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
 -> [Either
       (GenLocated EpAnnCO (HsDerivingClause GhcPs))
       (GenLocated SrcSpanAnnA (HsDecl GhcPs))])
-> (GenLocated EpAnnCO (HsDerivingClause GhcPs)
    -> [Either
          (GenLocated EpAnnCO (HsDerivingClause GhcPs))
          (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
    -> [Either
          (GenLocated EpAnnCO (HsDerivingClause GhcPs))
          (GenLocated SrcSpanAnnA (HsDecl GhcPs))])
-> Maybe (GenLocated EpAnnCO (HsDerivingClause GhcPs))
-> [Either
      (GenLocated EpAnnCO (HsDerivingClause GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> [Either
      (GenLocated EpAnnCO (HsDerivingClause GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Either
   (GenLocated EpAnnCO (HsDerivingClause GhcPs))
   (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> [Either
      (GenLocated EpAnnCO (HsDerivingClause GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
forall a. a -> a
id ((:) (Either
   (GenLocated EpAnnCO (HsDerivingClause GhcPs))
   (GenLocated SrcSpanAnnA (HsDecl GhcPs))
 -> [Either
       (GenLocated EpAnnCO (HsDerivingClause GhcPs))
       (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
 -> [Either
       (GenLocated EpAnnCO (HsDerivingClause GhcPs))
       (GenLocated SrcSpanAnnA (HsDecl GhcPs))])
-> (GenLocated EpAnnCO (HsDerivingClause GhcPs)
    -> Either
         (GenLocated EpAnnCO (HsDerivingClause GhcPs))
         (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> GenLocated EpAnnCO (HsDerivingClause GhcPs)
-> [Either
      (GenLocated EpAnnCO (HsDerivingClause GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> [Either
      (GenLocated EpAnnCO (HsDerivingClause GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated EpAnnCO (HsDerivingClause GhcPs)
-> Either
     (GenLocated EpAnnCO (HsDerivingClause GhcPs))
     (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a b. a -> Either a b
Left) (Maybe HsDerivStrategy
-> [(HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)]
-> Maybe HsDerivingClause
derivingClause_ Maybe HsDerivStrategy
strategy [(HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)]
[(HsOuterSigTyVarBndrs GhcPs,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
uncustomized) ((GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> Either
      (GenLocated EpAnnCO (HsDerivingClause GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [Either
      (GenLocated EpAnnCO (HsDerivingClause GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Either
     (GenLocated EpAnnCO (HsDerivingClause GhcPs))
     (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a b. b -> Either a b
Right [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
customized)

    deriv ::
      HsType ->
      (HsOuterSigTyVarBndrs, HsType) ->
      Either (HsOuterSigTyVarBndrs, HsType) HsDecl
    deriv :: LHsType GhcPs
-> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
-> Either (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) HsDecl
deriv LHsType GhcPs
ty classSig :: (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
classSig@(HsOuterSigTyVarBndrs GhcPs
bindings, LHsType GhcPs
classType) =
        Either
  (HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
  (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs)
    -> Either
         (HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> Either
     (HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
-> Either
     (HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a b. a -> Either a b
Left (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
(HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
classSig) GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Either
     (HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
     (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a b. b -> Either a b
Right ((HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) -> Maybe HsDecl
search (HsOuterSigTyVarBndrs GhcPs
bindings, LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
classType LHsType GhcPs
ty))

    -- | NOTE: 'getSig' must return 'Just' for *both* the goal and the override
    -- in order for there to be a match: 'Nothing' for both means no match.
    search :: (HsOuterSigTyVarBndrs, HsType) -> Maybe HsDecl
    search :: (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) -> Maybe HsDecl
search (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
y = do
      SimpleTypeName
desired <- (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) -> Maybe SimpleTypeName
getSig (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
y
      (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\GenLocated SrcSpanAnnA (HsDecl GhcPs)
x -> SimpleTypeName -> Maybe SimpleTypeName
forall a. a -> Maybe a
Just SimpleTypeName
desired Maybe SimpleTypeName -> Maybe SimpleTypeName -> Bool
forall a. Eq a => a -> a -> Bool
== ((HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) -> Maybe SimpleTypeName
(HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
-> Maybe SimpleTypeName
getSig ((HsOuterSigTyVarBndrs GhcPs,
  GenLocated SrcSpanAnnA (HsType GhcPs))
 -> Maybe SimpleTypeName)
-> Maybe
     (HsOuterSigTyVarBndrs GhcPs, GenLocated SrcSpanAnnA (HsType GhcPs))
-> Maybe SimpleTypeName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HsDecl -> Maybe (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
typeOfInstDecl HsDecl
GenLocated SrcSpanAnnA (HsDecl GhcPs)
x)) [HsDecl]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
overrides

    getSig :: (HsOuterSigTyVarBndrs, HsType) -> Maybe SimpleTypeName
    getSig :: (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) -> Maybe SimpleTypeName
getSig (GHC.HsOuterImplicit XHsOuterImplicit GhcPs
_, LHsType GhcPs
x) = LHsType GhcPs -> Maybe SimpleTypeName
simpleType LHsType GhcPs
x
    getSig (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
_ = Maybe SimpleTypeName
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | A simplified representation of certain Haskell types.
data SimpleTypeName = SimpleTypeName GHC.OccName [SimpleTypeName]
  deriving SimpleTypeName -> SimpleTypeName -> Bool
(SimpleTypeName -> SimpleTypeName -> Bool)
-> (SimpleTypeName -> SimpleTypeName -> Bool) -> Eq SimpleTypeName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SimpleTypeName -> SimpleTypeName -> Bool
== :: SimpleTypeName -> SimpleTypeName -> Bool
$c/= :: SimpleTypeName -> SimpleTypeName -> Bool
/= :: SimpleTypeName -> SimpleTypeName -> Bool
Eq

-- | Types are difficult to compare in general, but for many
-- of the simpler types we can find a corresponding simple
-- description that is practical for us to compare.
--
-- WARNING: As legacy behavior we remove all qualifiers, rather than
-- normalizing them in some way that considers equivalence of module
-- qualifiers.  This behavior could potentially cause incorrect
-- results if two modules provide the same type name.
simpleType :: HsType -> Maybe SimpleTypeName
simpleType :: LHsType GhcPs -> Maybe SimpleTypeName
simpleType (GHC.L SrcSpanAnnA
_ (GHC.HsParTy XParTy GhcPs
_ LHsType GhcPs
x)) = LHsType GhcPs -> Maybe SimpleTypeName
simpleType LHsType GhcPs
x
simpleType LHsType GhcPs
x = do
    (GenLocated SrcSpanAnnN RdrName
tc, [GenLocated SrcSpanAnnA (HsType GhcPs)]
as) <- LHsType GhcPs -> Maybe (HsName, [LHsType GhcPs])
splitTyConApp LHsType GhcPs
x
    [SimpleTypeName]
sas <- (GenLocated SrcSpanAnnA (HsType GhcPs) -> Maybe SimpleTypeName)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe [SimpleTypeName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LHsType GhcPs -> Maybe SimpleTypeName
GenLocated SrcSpanAnnA (HsType GhcPs) -> Maybe SimpleTypeName
simpleType [GenLocated SrcSpanAnnA (HsType GhcPs)]
as
    SimpleTypeName -> Maybe SimpleTypeName
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OccName -> [SimpleTypeName] -> SimpleTypeName
SimpleTypeName (HsName -> OccName
unQual HsName
GenLocated SrcSpanAnnN RdrName
tc) [SimpleTypeName]
sas)
  where
    unQual :: HsName -> GHC.OccName
    unQual :: HsName -> OccName
unQual (GHC.L SrcSpanAnnN
_ (GHC.Unqual OccName
n)) = OccName
n
    unQual (GHC.L SrcSpanAnnN
_ (GHC.Qual Module
_ OccName
n)) = OccName
n
    unQual (GHC.L SrcSpanAnnN
_ (GHC.Orig Module
_ OccName
n)) = OccName
n
    unQual (GHC.L SrcSpanAnnN
_ (GHC.Exact Name
n)) = Name -> OccName
GHC.nameOccName Name
n

-- | If both types are sufficiently simple,
-- then return the result of an equality test.
--
-- WARNING: As legacy behavior we remove all qualifiers, rather than
-- normalizing them in some way that considers equivalence of module
-- qualifiers.  This behavior could potentially cause incorrect
-- results if two modules provide the same type name.
simpleTypeEq :: HsType -> HsType -> Maybe Bool
simpleTypeEq :: LHsType GhcPs -> LHsType GhcPs -> Maybe Bool
simpleTypeEq LHsType GhcPs
a LHsType GhcPs
b = SimpleTypeName -> SimpleTypeName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (SimpleTypeName -> SimpleTypeName -> Bool)
-> Maybe SimpleTypeName -> Maybe (SimpleTypeName -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcPs -> Maybe SimpleTypeName
simpleType LHsType GhcPs
a Maybe (SimpleTypeName -> Bool)
-> Maybe SimpleTypeName -> Maybe Bool
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsType GhcPs -> Maybe SimpleTypeName
simpleType LHsType GhcPs
b

-- | Parses the file at the given path and produces an AST along with a
-- 'TypeContext' representing all types from imported @.proto@ files, using the
-- first parameter as a list of paths to search for imported files. Terminates
-- with exit code 1 when an included file cannot be found in the search path.
readDotProtoWithContext
    :: (MonadError CompileError m, MonadIO m)
    => [FilePath]
    -> FilePath
    -> m (DotProto, TypeContext)
readDotProtoWithContext :: forall (m :: * -> *).
(MonadError CompileError m, MonadIO m) =>
[String] -> String -> m (DotProto, TypeContext)
readDotProtoWithContext [] String
toplevelProto = do
  -- If we're not given a search path, default to using the current working
  -- directory, as `protoc` does
  String
cwd <- m String
forall (io :: * -> *). MonadIO io => io String
Turtle.pwd
  [String] -> String -> m (DotProto, TypeContext)
forall (m :: * -> *).
(MonadError CompileError m, MonadIO m) =>
[String] -> String -> m (DotProto, TypeContext)
readDotProtoWithContext [String
cwd] String
toplevelProto

readDotProtoWithContext [String]
searchPaths String
toplevelProto = do
  DotProto
dp <- [String] -> String -> String -> m DotProto
forall (m :: * -> *).
(MonadIO m, MonadError CompileError m) =>
[String] -> String -> String -> m DotProto
importProto [String]
searchPaths String
toplevelProto String
toplevelProto
  let importIt :: DotProtoImport -> m TypeContext
importIt = [String] -> String -> Set String -> DotProtoImport -> m TypeContext
forall (m :: * -> *).
(MonadError CompileError m, MonadIO m) =>
[String] -> String -> Set String -> DotProtoImport -> m TypeContext
readImportTypeContext [String]
searchPaths String
toplevelProto (String -> Set String
forall a. a -> Set a
S.singleton String
toplevelProto)
  TypeContext
tc <- (DotProtoImport -> m TypeContext)
-> [DotProtoImport] -> m TypeContext
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM DotProtoImport -> m TypeContext
importIt (DotProto -> [DotProtoImport]
protoImports DotProto
dp)
  (DotProto, TypeContext) -> m (DotProto, TypeContext)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DotProto
dp, TypeContext
tc)

-- | Build the type context for an import, resolving transitive imports.
readImportTypeContext
    :: (MonadError CompileError m, MonadIO m)
    => [FilePath]
    -> FilePath
    -> S.Set FilePath
    -> DotProtoImport
    -> m TypeContext
readImportTypeContext :: forall (m :: * -> *).
(MonadError CompileError m, MonadIO m) =>
[String] -> String -> Set String -> DotProtoImport -> m TypeContext
readImportTypeContext [String]
searchPaths String
toplevelFP Set String
alreadyRead (DotProtoImport DotProtoImportQualifier
_ String
path)
  | String
path String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set String
alreadyRead = CompileError -> m TypeContext
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> CompileError
CircularImport String
path)
  | Bool
otherwise = do
      DotProto
import_ <- [String] -> String -> String -> m DotProto
forall (m :: * -> *).
(MonadIO m, MonadError CompileError m) =>
[String] -> String -> String -> m DotProto
importProto [String]
searchPaths String
toplevelFP String
path
      let importPkgSpec :: DotProtoPackageSpec
importPkgSpec = DotProto -> DotProtoPackageSpec
protoPackage DotProto
import_

      let fixImportTyInfo :: DotProtoTypeInfo -> DotProtoTypeInfo
fixImportTyInfo DotProtoTypeInfo
tyInfo =
             DotProtoTypeInfo
tyInfo { dotProtoTypeInfoPackage    = importPkgSpec
                    , dotProtoTypeInfoModulePath = metaModulePath . protoMeta $ import_
                    }
      TypeContext
importTypeContext <- (DotProtoTypeInfo -> DotProtoTypeInfo)
-> TypeContext -> TypeContext
forall a b.
(a -> b) -> Map DotProtoIdentifier a -> Map DotProtoIdentifier b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DotProtoTypeInfo -> DotProtoTypeInfo
fixImportTyInfo (TypeContext -> TypeContext) -> m TypeContext -> m TypeContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProto -> m TypeContext
forall (m :: * -> *).
MonadError CompileError m =>
DotProto -> m TypeContext
dotProtoTypeContext DotProto
import_

      let prefixWithPackageName :: DotProtoIdentifier -> m DotProtoIdentifier
prefixWithPackageName =
            case DotProtoPackageSpec
importPkgSpec of
              DotProtoPackageSpec DotProtoIdentifier
packageName -> DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
packageName
              DotProtoPackageSpec
DotProtoNoPackage -> DotProtoIdentifier -> m DotProtoIdentifier
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

      TypeContext
qualifiedTypeContext <- (DotProtoIdentifier -> m DotProtoIdentifier)
-> TypeContext -> m TypeContext
forall (m :: * -> *) k2 k1 a.
(Monad m, Ord k2) =>
(k1 -> m k2) -> Map k1 a -> m (Map k2 a)
mapKeysM DotProtoIdentifier -> m DotProtoIdentifier
prefixWithPackageName TypeContext
importTypeContext

      let isPublic :: DotProtoImport -> Bool
isPublic (DotProtoImport DotProtoImportQualifier
q String
_) = DotProtoImportQualifier
q DotProtoImportQualifier -> DotProtoImportQualifier -> Bool
forall a. Eq a => a -> a -> Bool
== DotProtoImportQualifier
DotProtoImportPublic
      TypeContext
transitiveImportsTC <-
        GettingM TypeContext [DotProtoImport] DotProtoImport
-> (DotProtoImport -> m TypeContext)
-> [DotProtoImport]
-> m TypeContext
forall (m :: * -> *) r s a.
(Applicative m, Monoid r) =>
GettingM r s a -> (a -> m r) -> s -> m r
foldMapOfM ((DotProtoImport -> Compose m (Const TypeContext) DotProtoImport)
-> [DotProtoImport]
-> Compose m (Const TypeContext) [DotProtoImport]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((DotProtoImport -> Compose m (Const TypeContext) DotProtoImport)
 -> [DotProtoImport]
 -> Compose m (Const TypeContext) [DotProtoImport])
-> ((DotProtoImport
     -> Compose m (Const TypeContext) DotProtoImport)
    -> DotProtoImport -> Compose m (Const TypeContext) DotProtoImport)
-> (DotProtoImport -> Compose m (Const TypeContext) DotProtoImport)
-> [DotProtoImport]
-> Compose m (Const TypeContext) [DotProtoImport]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DotProtoImport -> Bool)
-> (DotProtoImport -> Compose m (Const TypeContext) DotProtoImport)
-> DotProtoImport
-> Compose m (Const TypeContext) DotProtoImport
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered DotProtoImport -> Bool
isPublic)
                   ([String] -> String -> Set String -> DotProtoImport -> m TypeContext
forall (m :: * -> *).
(MonadError CompileError m, MonadIO m) =>
[String] -> String -> Set String -> DotProtoImport -> m TypeContext
readImportTypeContext [String]
searchPaths String
toplevelFP (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert String
path Set String
alreadyRead))
                   (DotProto -> [DotProtoImport]
protoImports DotProto
import_)

      TypeContext -> m TypeContext
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeContext -> m TypeContext) -> TypeContext -> m TypeContext
forall a b. (a -> b) -> a -> b
$ TypeContext
importTypeContext TypeContext -> TypeContext -> TypeContext
forall a. Semigroup a => a -> a -> a
<> TypeContext
qualifiedTypeContext TypeContext -> TypeContext -> TypeContext
forall a. Semigroup a => a -> a -> a
<> TypeContext
transitiveImportsTC

-- | Given a type context, generates the Haskell import statements necessary to
--   import all the required types.  Excludes module "Google.Protobuf.Wrappers"
--   because the generated code does not actually make use of wrapper types
--   as such; instead it uses @Maybe a@, where @a@ is the wrapped type.
ctxtImports :: MonadError CompileError m => TypeContext -> m [HsImportDecl]
ctxtImports :: forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> m [HsImportDecl]
ctxtImports =
    ([Module] -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> m [Module] -> m [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Module -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> [Module] -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map Module -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
mkImport ([Module] -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> ([Module] -> [Module])
-> [Module]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Module] -> [Module]
forall a. Eq a => [a] -> [a]
nub ([Module] -> [Module])
-> ([Module] -> [Module]) -> [Module] -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Module
GHC.mkModuleName String
"Google.Protobuf.Wrappers" Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/=))
    (m [Module] -> m [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> (TypeContext -> m [Module])
-> TypeContext
-> m [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DotProtoTypeInfo -> m Module) -> [DotProtoTypeInfo] -> m [Module]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Path -> m Module
forall (m :: * -> *). MonadError CompileError m => Path -> m Module
modulePathModName (Path -> m Module)
-> (DotProtoTypeInfo -> Path) -> DotProtoTypeInfo -> m Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotProtoTypeInfo -> Path
dotProtoTypeInfoModulePath)
    ([DotProtoTypeInfo] -> m [Module])
-> (TypeContext -> [DotProtoTypeInfo]) -> TypeContext -> m [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeContext -> [DotProtoTypeInfo]
forall k a. Map k a -> [a]
M.elems
  where
    mkImport :: Module -> HsImportDecl
mkImport Module
modName = Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ Module
modName Bool
True Maybe Module
forall a. Maybe a
Nothing Maybe (Bool, [HsExportSpec])
Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
--
-- * Helper functions for Haskell code generation
--

-- ** Names

-- | Generate the Haskell type name for a 'DotProtoTypeInfo' for a message /
--   enumeration being compiled. NB: We ignore the 'dotProtoTypeInfoPackage'
--   field of the 'DotProtoTypeInfo' parameter, instead demanding that we have
--   been provided with a valid module path in its 'dotProtoTypeInfoModulePath'
--   field. The latter describes the name of the Haskell module being generated.
msgTypeFromDpTypeInfo :: MonadError CompileError m
                      => TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo :: forall (m :: * -> *).
MonadError CompileError m =>
TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
msgTypeFromDpTypeInfo TypeContext
ctxt DotProtoTypeInfo{TypeContext
DotProtoPackageSpec
DotProtoIdentifier
Path
DotProtoKind
dotProtoTypeInfoPackage :: DotProtoTypeInfo -> DotProtoPackageSpec
dotProtoTypeInfoModulePath :: DotProtoTypeInfo -> Path
dotProtoTypeInfoPackage :: DotProtoPackageSpec
dotProtoTypeInfoParent :: DotProtoIdentifier
dotProtoTypeChildContext :: TypeContext
dotProtoTypeInfoKind :: DotProtoKind
dotProtoTypeInfoModulePath :: Path
dotProtoTypeInfoKind :: DotProtoTypeInfo -> DotProtoKind
dotProtoTypeChildContext :: DotProtoTypeInfo -> TypeContext
dotProtoTypeInfoParent :: DotProtoTypeInfo -> DotProtoIdentifier
..} DotProtoIdentifier
ident = do
    Module
modName   <- Path -> m Module
forall (m :: * -> *). MonadError CompileError m => Path -> m Module
modulePathModName Path
dotProtoTypeInfoModulePath
    String
identName <- TypeContext -> DotProtoIdentifier -> DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageTypeName TypeContext
ctxt DotProtoIdentifier
dotProtoTypeInfoParent DotProtoIdentifier
ident
    GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$ HsName -> LHsType GhcPs
typeNamed_ (HsName -> LHsType GhcPs) -> HsName -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ Module -> NameSpace -> String -> HsName
qual_ Module
modName NameSpace
tcName String
identName

modulePathModName :: MonadError CompileError m => Path -> m Module
modulePathModName :: forall (m :: * -> *). MonadError CompileError m => Path -> m Module
modulePathModName (Path NonEmpty String
comps) =
  String -> Module
GHC.mkModuleName (String -> Module) -> ([String] -> String) -> [String] -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> Module) -> m [String] -> m Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m String) -> [String] -> m [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
comps)

_pkgIdentModName :: MonadError CompileError m => DotProtoIdentifier -> m Module
_pkgIdentModName :: forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m Module
_pkgIdentModName (Single String
s)  = String -> Module
GHC.mkModuleName (String -> Module) -> m String -> m Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName String
s
_pkgIdentModName (Dots Path
path) = Path -> m Module
forall (m :: * -> *). MonadError CompileError m => Path -> m Module
modulePathModName Path
path
_pkgIdentModName DotProtoIdentifier
x           = CompileError -> m Module
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DotProtoIdentifier -> CompileError
InvalidPackageName DotProtoIdentifier
x)


-- ** Dhall

#ifdef DHALL
hsDhallPB :: String
hsDhallPB = "HsDhallPb"

dhallPBName :: GHC.NameSpace -> String -> HsQName
dhallPBName = qual_ (GHC.mkModuleName hsDhallPB)

-- *** Generate Dhall Interpret and Inject generic instances

fromDhall, toDhall :: String
(fromDhall, toDhall) =
#if MIN_VERSION_dhall(1,27,0)
  ("FromDhall", "ToDhall")
#else
  ("Interpret", "Inject")
#endif

dhallInterpretInstDecl :: String -> HsDecl
dhallInterpretInstDecl typeName =
  instDecl_ (dhallPBName tcName fromDhall)
            [ type_ typeName ]
            [ ]

dhallInjectInstDecl :: String -> HsDecl
dhallInjectInstDecl typeName =
  instDecl_ (dhallPBName tcName toDhall)
            [ type_ typeName ]
            [ ]
#endif

-- ** Helpers to wrap/unwrap types for protobuf (de-)serialization

data FieldContext = WithinMessage | WithinOneOf
  deriving (FieldContext -> FieldContext -> Bool
(FieldContext -> FieldContext -> Bool)
-> (FieldContext -> FieldContext -> Bool) -> Eq FieldContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldContext -> FieldContext -> Bool
== :: FieldContext -> FieldContext -> Bool
$c/= :: FieldContext -> FieldContext -> Bool
/= :: FieldContext -> FieldContext -> Bool
Eq, Int -> FieldContext -> String -> String
[FieldContext] -> String -> String
FieldContext -> String
(Int -> FieldContext -> String -> String)
-> (FieldContext -> String)
-> ([FieldContext] -> String -> String)
-> Show FieldContext
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FieldContext -> String -> String
showsPrec :: Int -> FieldContext -> String -> String
$cshow :: FieldContext -> String
show :: FieldContext -> String
$cshowList :: [FieldContext] -> String -> String
showList :: [FieldContext] -> String -> String
Show)

coerceE :: Bool -> Bool -> HsType -> HsType -> Maybe HsExp
coerceE :: Bool -> Bool -> LHsType GhcPs -> LHsType GhcPs -> Maybe HsExp
coerceE Bool
_ Bool
_ LHsType GhcPs
from LHsType GhcPs
to | Just Bool
True <- LHsType GhcPs -> LHsType GhcPs -> Maybe Bool
simpleTypeEq LHsType GhcPs
from LHsType GhcPs
to = Maybe HsExp
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Maybe a
Nothing
coerceE Bool
overTyCon Bool
unsafe LHsType GhcPs
from LHsType GhcPs
to =
    HsExp -> Maybe HsExp
forall a. a -> Maybe a
Just (HsExp -> Maybe HsExp) -> HsExp -> Maybe HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> [LHsType GhcPs] -> HsExp
applyAt HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
coerceF [LHsType GhcPs
from, LHsType GhcPs
to]
  where
    coerceF :: HsExp
coerceF | Bool
unsafe = HsName -> HsExp
var_ (String -> GenLocated SrcSpanAnnN RdrName
name String
"unsafeCoerce")
            | Bool
otherwise  = HsName -> HsExp
var_ (String -> GenLocated SrcSpanAnnN RdrName
name String
"coerce")
    name :: String -> GenLocated SrcSpanAnnN RdrName
name | Bool
overTyCon = NameSpace -> String -> HsName
protobufName NameSpace
varName (String -> GenLocated SrcSpanAnnN RdrName)
-> (String -> String) -> String -> GenLocated SrcSpanAnnN RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Over")
         | Bool
otherwise = NameSpace -> String -> HsName
haskellName NameSpace
varName

wrapFunE ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  Bool ->
  FieldContext ->
  TypeContext ->
  [DotProtoOption] ->
  DotProtoType ->
  m (Maybe HsExp)
wrapFunE :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
Bool
-> FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
wrapFunE Bool
overTyCon FieldContext
fc TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt =
  Bool -> Bool -> LHsType GhcPs -> LHsType GhcPs -> Maybe HsExp
coerceE Bool
overTyCon (DotProtoType -> Bool
isMap DotProtoType
dpt)
    (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs)
 -> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs)
      -> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldContext -> TypeContext -> DotProtoType -> m (LHsType GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext -> TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToHsType FieldContext
fc TypeContext
ctxt DotProtoType
dpt
    m (GenLocated SrcSpanAnnA (HsType GhcPs)
   -> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldContext
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
dptToHsTypeWrapped FieldContext
fc [DotProtoOption]
opts TypeContext
ctxt DotProtoType
dpt

wrapE ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  FieldContext ->
  TypeContext ->
  [DotProtoOption] ->
  DotProtoType ->
  HsExp ->
  m HsExp
wrapE :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
wrapE FieldContext
fc TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt HsExp
e =
  HsExp -> Maybe HsExp -> HsExp
maybeModify HsExp
e (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
Bool
-> FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
wrapFunE Bool
False FieldContext
fc TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt

unwrapFunE ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  Bool ->
  FieldContext ->
  TypeContext ->
  [DotProtoOption] ->
  DotProtoType ->
  m (Maybe HsExp)
unwrapFunE :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
Bool
-> FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
unwrapFunE Bool
overTyCon FieldContext
fc TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt =
  Bool -> Bool -> LHsType GhcPs -> LHsType GhcPs -> Maybe HsExp
coerceE Bool
overTyCon (DotProtoType -> Bool
isMap DotProtoType
dpt)
    (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs)
 -> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs)
      -> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldContext
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
dptToHsTypeWrapped FieldContext
fc [DotProtoOption]
opts TypeContext
ctxt DotProtoType
dpt
    m (GenLocated SrcSpanAnnA (HsType GhcPs)
   -> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldContext -> TypeContext -> DotProtoType -> m (LHsType GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext -> TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToHsType FieldContext
fc TypeContext
ctxt DotProtoType
dpt

unwrapE ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  FieldContext ->
  TypeContext ->
  [DotProtoOption] ->
  DotProtoType ->
  HsExp ->
  m HsExp
unwrapE :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
unwrapE FieldContext
fc TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt HsExp
e = do
  HsExp -> Maybe HsExp -> HsExp
maybeModify HsExp
e (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
Bool
-> FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
unwrapFunE Bool
True FieldContext
fc TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt

--------------------------------------------------------------------------------
--
-- * Functions to convert 'DotProtoType' into Haskell types
--

-- | Convert a dot proto type to a Haskell type
dptToHsType ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  FieldContext ->
  TypeContext ->
  DotProtoType ->
  m HsType
dptToHsType :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext -> TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToHsType FieldContext
fc = (TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs)
-> (TypeContext -> DotProtoPrimType -> m (LHsType GhcPs))
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
(TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs)
-> (TypeContext -> DotProtoPrimType -> m (LHsType GhcPs))
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
foldDPT (FieldContext
-> TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs
dptToHsContType FieldContext
fc) TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToHsType

-- | Convert a dot proto type to a wrapped Haskell type
dptToHsTypeWrapped ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  FieldContext ->
  [DotProtoOption] ->
  TypeContext ->
  DotProtoType ->
  m HsType
dptToHsTypeWrapped :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
dptToHsTypeWrapped FieldContext
fc [DotProtoOption]
opts =
  (TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs)
-> (TypeContext -> DotProtoPrimType -> m (LHsType GhcPs))
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
(TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs)
-> (TypeContext -> DotProtoPrimType -> m (LHsType GhcPs))
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
foldDPT
    -- The wrapper for the collection type replaces the native haskell
    -- collection type, so try that first.
    (\TypeContext
ctxt DotProtoType
ty -> (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> ((GenLocated SrcSpanAnnA (HsType GhcPs)
     -> GenLocated SrcSpanAnnA (HsType GhcPs))
    -> GenLocated SrcSpanAnnA (HsType GhcPs)
    -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> Maybe
     (GenLocated SrcSpanAnnA (HsType GhcPs)
      -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FieldContext
-> TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs
dptToHsContType FieldContext
fc TypeContext
ctxt DotProtoType
ty) (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a. a -> a
id (FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
dptToHsWrappedContType FieldContext
fc TypeContext
ctxt [DotProtoOption]
opts DotProtoType
ty))
    -- Always wrap the primitive type.
    TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToHsTypeWrapped

-- | Like 'dptToHsTypeWrapped' but without use of
-- 'dptToHsContType' or 'dptToHsWrappedContType'.
dpptToHsTypeWrapped ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  TypeContext ->
  DotProtoPrimType ->
  m HsType
dpptToHsTypeWrapped :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToHsTypeWrapped TypeContext
ctxt | StringType String
_ String
stringType <- ?stringType::StringType
StringType
?stringType = \case
  DotProtoPrimType
Int32 ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int32"
  DotProtoPrimType
Int64 ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int64"
  DotProtoPrimType
SInt32 ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufSignedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int32"
  DotProtoPrimType
SInt64 ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufSignedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int64"
  DotProtoPrimType
UInt32 ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word32"
  DotProtoPrimType
UInt64 ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word64"
  DotProtoPrimType
Fixed32 ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufFixedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word32"
  DotProtoPrimType
Fixed64 ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufFixedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word64"
  DotProtoPrimType
SFixed32 ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufSignedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufFixedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int32"
  DotProtoPrimType
SFixed64 ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufSignedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufFixedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int64"
  DotProtoPrimType
String ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
protobufStringType_ String
stringType
  DotProtoPrimType
Bytes  ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
protobufBytesType_ String
"ByteString"
  DotProtoPrimType
Bool ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Bool"
  DotProtoPrimType
Float ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Float"
  DotProtoPrimType
Double ->
    LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Double"
  Named (Dots (Path (String
"google" :| [String
"protobuf", String
x])))
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int32Value" ->
        LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufWrappedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int32"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int64Value" ->
        LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufWrappedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int64"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"UInt32Value" ->
        LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufWrappedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word32"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"UInt64Value" ->
        LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufWrappedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word64"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"StringValue" ->
        LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufWrappedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
protobufStringType_ String
stringType
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BytesValue" ->
        LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufWrappedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
protobufBytesType_ String
"ByteString"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BoolValue" ->
        LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufWrappedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Bool"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"FloatValue" ->
        LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufWrappedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Float"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"DoubleValue" ->
        LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs
protobufWrappedType_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Double"
  Named DotProtoIdentifier
msgName ->
    case DotProtoIdentifier -> TypeContext -> Maybe DotProtoTypeInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup DotProtoIdentifier
msgName TypeContext
ctxt of
      Just ty :: DotProtoTypeInfo
ty@(DotProtoTypeInfo { dotProtoTypeInfoKind :: DotProtoTypeInfo -> DotProtoKind
dotProtoTypeInfoKind = DotProtoKind
DotProtoKindEnum }) ->
        LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (String -> LHsType GhcPs
protobufType_ String
"Enumerated") (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
msgTypeFromDpTypeInfo TypeContext
ctxt DotProtoTypeInfo
ty DotProtoIdentifier
msgName
      Just DotProtoTypeInfo
ty -> TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
msgTypeFromDpTypeInfo TypeContext
ctxt DotProtoTypeInfo
ty DotProtoIdentifier
msgName
      Maybe DotProtoTypeInfo
Nothing -> DotProtoIdentifier -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (m :: * -> *) a.
MonadError CompileError m =>
DotProtoIdentifier -> m a
noSuchTypeError DotProtoIdentifier
msgName

foldDPT :: MonadError CompileError m
        => (TypeContext -> DotProtoType -> HsType -> HsType)
        -> (TypeContext -> DotProtoPrimType -> m HsType)
        -> TypeContext
        -> DotProtoType
        -> m HsType
foldDPT :: forall (m :: * -> *).
MonadError CompileError m =>
(TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs)
-> (TypeContext -> DotProtoPrimType -> m (LHsType GhcPs))
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
foldDPT TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs
dptToHsCont TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
foldPrim TypeContext
ctxt DotProtoType
dpt =
  let
      prim :: DotProtoPrimType -> m (LHsType GhcPs)
prim = TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
foldPrim TypeContext
ctxt
      go :: DotProtoType -> m (LHsType GhcPs)
go = (TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs)
-> (TypeContext -> DotProtoPrimType -> m (LHsType GhcPs))
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
(TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs)
-> (TypeContext -> DotProtoPrimType -> m (LHsType GhcPs))
-> TypeContext
-> DotProtoType
-> m (LHsType GhcPs)
foldDPT TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs
dptToHsCont TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
foldPrim TypeContext
ctxt
      cont :: LHsType GhcPs -> LHsType GhcPs
cont = TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs
dptToHsCont TypeContext
ctxt DotProtoType
dpt
  in
    case DotProtoType
dpt of
      Prim DotProtoPrimType
pType           -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
cont (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoPrimType -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
prim DotProtoPrimType
pType
      Optional DotProtoPrimType
pType       -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
cont (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoPrimType -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
prim DotProtoPrimType
pType
      Repeated DotProtoPrimType
pType       -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
cont (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoPrimType -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
prim DotProtoPrimType
pType
      NestedRepeated DotProtoPrimType
pType -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
cont (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoPrimType -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
prim DotProtoPrimType
pType
      Map DotProtoPrimType
k DotProtoPrimType
v  | DotProtoPrimType -> Bool
validMapKey DotProtoPrimType
k -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
tyApp (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (GenLocated SrcSpanAnnA (HsType GhcPs)
    -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
cont (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs)
      -> GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoPrimType -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
prim DotProtoPrimType
k m (GenLocated SrcSpanAnnA (HsType GhcPs)
   -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DotProtoType -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
go (DotProtoPrimType -> DotProtoType
Prim DotProtoPrimType
v) -- need to 'Nest' message types
               | Bool
otherwise -> CompileError -> m (LHsType GhcPs)
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m (LHsType GhcPs))
-> CompileError -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> CompileError
InvalidMapKeyType (Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ DotProtoPrimType -> Doc
forall a. Pretty a => a -> Doc
pPrint DotProtoPrimType
k)

-- | Translate DotProtoType constructors to wrapped Haskell container types
-- (for Message serde instances).
--
-- When the given 'FieldContext' is 'WithinOneOf' we do not wrap submessages
-- in "Maybe" because the entire oneof is already wrapped in a "Maybe".
dptToHsWrappedContType :: FieldContext -> TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType)
dptToHsWrappedContType :: FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
dptToHsWrappedContType FieldContext
fc TypeContext
ctxt [DotProtoOption]
opts = \case
  Prim (Named DotProtoIdentifier
tyName)
    | FieldContext
WithinMessage <- FieldContext
fc, TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName
                            -> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a. a -> Maybe a
Just ((LHsType GhcPs -> LHsType GhcPs)
 -> Maybe (LHsType GhcPs -> LHsType GhcPs))
-> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (String -> LHsType GhcPs
protobufType_ String
"Nested")
  Optional (Named DotProtoIdentifier
tyName)
    | TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName -> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a. a -> Maybe a
Just ((LHsType GhcPs -> LHsType GhcPs)
 -> Maybe (LHsType GhcPs -> LHsType GhcPs))
-> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (String -> LHsType GhcPs
protobufType_ String
"Nested")
  Optional DotProtoPrimType
_                -> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a. a -> Maybe a
Just ((LHsType GhcPs -> LHsType GhcPs)
 -> Maybe (LHsType GhcPs -> LHsType GhcPs))
-> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
maybeT (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (GenLocated SrcSpanAnnA (HsType GhcPs)
    -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
forceEmitT
  Repeated (Named DotProtoIdentifier
tyName)
    | TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName -> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a. a -> Maybe a
Just ((LHsType GhcPs -> LHsType GhcPs)
 -> Maybe (LHsType GhcPs -> LHsType GhcPs))
-> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (String -> LHsType GhcPs
protobufType_ String
"NestedVec")
  Repeated DotProtoPrimType
ty
    | [DotProtoOption] -> Bool
isUnpacked [DotProtoOption]
opts       -> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a. a -> Maybe a
Just ((LHsType GhcPs -> LHsType GhcPs)
 -> Maybe (LHsType GhcPs -> LHsType GhcPs))
-> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (String -> LHsType GhcPs
protobufType_ String
"UnpackedVec")
    | [DotProtoOption] -> Bool
isPacked [DotProtoOption]
opts         -> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a. a -> Maybe a
Just ((LHsType GhcPs -> LHsType GhcPs)
 -> Maybe (LHsType GhcPs -> LHsType GhcPs))
-> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (String -> LHsType GhcPs
protobufType_ String
"PackedVec")
    | TypeContext -> DotProtoPrimType -> Bool
isPackable TypeContext
ctxt DotProtoPrimType
ty    -> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a. a -> Maybe a
Just ((LHsType GhcPs -> LHsType GhcPs)
 -> Maybe (LHsType GhcPs -> LHsType GhcPs))
-> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (String -> LHsType GhcPs
protobufType_ String
"PackedVec")
    | Bool
otherwise             -> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a. a -> Maybe a
Just ((LHsType GhcPs -> LHsType GhcPs)
 -> Maybe (LHsType GhcPs -> LHsType GhcPs))
-> (LHsType GhcPs -> LHsType GhcPs)
-> Maybe (LHsType GhcPs -> LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (String -> LHsType GhcPs
protobufType_ String
"UnpackedVec")
  DotProtoType
_ -> Maybe (LHsType GhcPs -> LHsType GhcPs)
Maybe
  (GenLocated SrcSpanAnnA (HsType GhcPs)
   -> GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. Maybe a
Nothing

-- | Translate DotProtoType to Haskell container types.
--
-- When the given 'FieldContext' is 'WithinOneOf' we do not wrap submessages
-- in "Maybe" because the entire oneof is already wrapped in a "Maybe".
dptToHsContType :: FieldContext -> TypeContext -> DotProtoType -> HsType -> HsType
dptToHsContType :: FieldContext
-> TypeContext -> DotProtoType -> LHsType GhcPs -> LHsType GhcPs
dptToHsContType FieldContext
fc TypeContext
ctxt = \case
  Prim (Named DotProtoIdentifier
tyName) | FieldContext
WithinMessage <- FieldContext
fc, TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName
                     -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs)
-> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Maybe"
  Optional DotProtoPrimType
_         -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs)
-> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Maybe"
  Repeated DotProtoPrimType
_         -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs)
-> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Vector"
  NestedRepeated DotProtoPrimType
_   -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs)
-> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Vector"
  Map DotProtoPrimType
_ DotProtoPrimType
_            -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs)
-> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Map"
  DotProtoType
_                  -> LHsType GhcPs -> LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a. a -> a
id

-- | Convert a dot proto prim type to an unwrapped Haskell type
dpptToHsType ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  TypeContext ->
  DotProtoPrimType ->
  m HsType
dpptToHsType :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToHsType TypeContext
ctxt | StringType String
_ String
stringType <- ?stringType::StringType
StringType
?stringType = \case
  DotProtoPrimType
Int32    -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int32"
  DotProtoPrimType
Int64    -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int64"
  DotProtoPrimType
SInt32   -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int32"
  DotProtoPrimType
SInt64   -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int64"
  DotProtoPrimType
UInt32   -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word32"
  DotProtoPrimType
UInt64   -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word64"
  DotProtoPrimType
Fixed32  -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word32"
  DotProtoPrimType
Fixed64  -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word64"
  DotProtoPrimType
SFixed32 -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int32"
  DotProtoPrimType
SFixed64 -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int64"
  DotProtoPrimType
String   -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
stringType
  DotProtoPrimType
Bytes    -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"ByteString"
  DotProtoPrimType
Bool     -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Bool"
  DotProtoPrimType
Float    -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Float"
  DotProtoPrimType
Double   -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Double"
  Named (Dots (Path (String
"google" :| [String
"protobuf", String
x])))
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int32Value" -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int32"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int64Value" -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Int64"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"UInt32Value" -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word32"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"UInt64Value" -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Word64"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"StringValue" -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
stringType
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BytesValue" -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"ByteString"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BoolValue" -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Bool"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"FloatValue" -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Float"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"DoubleValue" -> LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
primType_ String
"Double"
  Named DotProtoIdentifier
msgName ->
    case DotProtoIdentifier -> TypeContext -> Maybe DotProtoTypeInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup DotProtoIdentifier
msgName TypeContext
ctxt of
      Just ty :: DotProtoTypeInfo
ty@(DotProtoTypeInfo { dotProtoTypeInfoKind :: DotProtoTypeInfo -> DotProtoKind
dotProtoTypeInfoKind = DotProtoKind
DotProtoKindEnum }) ->
        LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (String -> LHsType GhcPs
protobufType_ String
"Enumerated") (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
msgTypeFromDpTypeInfo TypeContext
ctxt DotProtoTypeInfo
ty DotProtoIdentifier
msgName
      Just DotProtoTypeInfo
ty -> TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
msgTypeFromDpTypeInfo TypeContext
ctxt DotProtoTypeInfo
ty DotProtoIdentifier
msgName
      Maybe DotProtoTypeInfo
Nothing -> DotProtoIdentifier -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (m :: * -> *) a.
MonadError CompileError m =>
DotProtoIdentifier -> m a
noSuchTypeError DotProtoIdentifier
msgName

validMapKey :: DotProtoPrimType -> Bool
validMapKey :: DotProtoPrimType -> Bool
validMapKey = (DotProtoPrimType -> [DotProtoPrimType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ DotProtoPrimType
Int32, DotProtoPrimType
Int64, DotProtoPrimType
SInt32, DotProtoPrimType
SInt64, DotProtoPrimType
UInt32, DotProtoPrimType
UInt64
                      , DotProtoPrimType
Fixed32, DotProtoPrimType
Fixed64, DotProtoPrimType
SFixed32, DotProtoPrimType
SFixed64
                      , DotProtoPrimType
String, DotProtoPrimType
Bool])

-- | Convert a dot proto type to a Haskell type of kind `Proto3.Suite.Form.Cardinality`.
-- It is ASSUMED that the field with this type is NOT part of a @oneof@.
dptToFormCardinality ::
  MonadError CompileError m => [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType
dptToFormCardinality :: forall (m :: * -> *).
MonadError CompileError m =>
[DotProtoOption]
-> TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToFormCardinality [DotProtoOption]
opts TypeContext
ctxt = \case
  Prim (Named DotProtoIdentifier
tyName)
    | TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formOptionalT
  Prim DotProtoPrimType
_                    -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formImplicitT
  Optional DotProtoPrimType
_                -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formOptionalT
  Repeated (Named DotProtoIdentifier
tyName)
    | TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsType GhcPs)
unpacked
  Repeated DotProtoPrimType
pType
    | [DotProtoOption] -> Bool
isUnpacked [DotProtoOption]
opts       -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsType GhcPs)
unpacked
    | [DotProtoOption] -> Bool
isPacked [DotProtoOption]
opts         -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsType GhcPs)
packed
    | TypeContext -> DotProtoPrimType -> Bool
isPackable TypeContext
ctxt DotProtoPrimType
pType -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsType GhcPs)
packed
    | Bool
otherwise             -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsType GhcPs)
unpacked
  NestedRepeated DotProtoPrimType
pType      -> String -> m (LHsType GhcPs)
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError (String -> m (LHsType GhcPs)) -> String -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String
"unexpected NestedRepeated on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DotProtoPrimType -> String
forall a. Show a => a -> String
show DotProtoPrimType
pType
  Map DotProtoPrimType
k DotProtoPrimType
_
    | DotProtoPrimType -> Bool
validMapKey DotProtoPrimType
k         -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsType GhcPs)
unpacked
    | Bool
otherwise             -> CompileError -> m (LHsType GhcPs)
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m (LHsType GhcPs))
-> CompileError -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> CompileError
InvalidMapKeyType (Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ DotProtoPrimType -> Doc
forall a. Pretty a => a -> Doc
pPrint DotProtoPrimType
k)
  where
    packed :: LHsType GhcPs
packed = LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
formRepeatedT LHsType GhcPs
formPackedT
    unpacked :: LHsType GhcPs
unpacked = LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
formRepeatedT LHsType GhcPs
formUnpackedT

-- | Convert a dot proto type to a Haskell type of kind `Proto3.Suite.Form.ProtoType`,
-- with `Proto3.Suite.Form.Optional` serving the role elsewhere served by wrapper types
-- and by `Proto3.Suite.Types.ForceEmit`.
dptToFormType :: MonadError CompileError m => TypeContext -> DotProtoType -> m HsType
dptToFormType :: forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToFormType TypeContext
ctxt = \case
  Prim DotProtoPrimType
pType -> TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToFormType TypeContext
ctxt DotProtoPrimType
pType
  Optional DotProtoPrimType
pType -> TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToFormType TypeContext
ctxt DotProtoPrimType
pType
  Repeated DotProtoPrimType
pType -> TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToFormType TypeContext
ctxt DotProtoPrimType
pType
  NestedRepeated DotProtoPrimType
pType -> String -> m (LHsType GhcPs)
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError (String -> m (LHsType GhcPs)) -> String -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String
"unexpected NestedRepeated on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DotProtoPrimType -> String
forall a. Show a => a -> String
show DotProtoPrimType
pType
  Map DotProtoPrimType
k DotProtoPrimType
v
    | DotProtoPrimType -> Bool
validMapKey DotProtoPrimType
k -> do
        GenLocated SrcSpanAnnA (HsType GhcPs)
k2 <- TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToFormType TypeContext
ctxt DotProtoPrimType
k
        GenLocated SrcSpanAnnA (HsType GhcPs)
v2 <- TypeContext -> DotProtoType -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToFormType TypeContext
ctxt (DotProtoPrimType -> DotProtoType
Prim DotProtoPrimType
v)
        LHsType GhcPs -> m (LHsType GhcPs)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsType GhcPs -> m (LHsType GhcPs))
-> LHsType GhcPs -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
tyApply LHsType GhcPs
formMapT [LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
k2, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
v2]
    | Bool
otherwise ->
        CompileError -> m (LHsType GhcPs)
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m (LHsType GhcPs))
-> CompileError -> m (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> CompileError
InvalidMapKeyType (Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ DotProtoPrimType -> Doc
forall a. Pretty a => a -> Doc
pPrint DotProtoPrimType
k)

-- | Like 'dptToFormType' but for primitive types.
dpptToFormType ::
  forall m .
  MonadError CompileError m =>
  TypeContext ->
  DotProtoPrimType ->
  m HsType
dpptToFormType :: forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToFormType TypeContext
ctxt = \case
    DotProtoPrimType
Int32 ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formInt32T
    DotProtoPrimType
Int64 ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formInt64T
    DotProtoPrimType
SInt32 ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formSInt32T
    DotProtoPrimType
SInt64 ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formSInt64T
    DotProtoPrimType
UInt32 ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formUInt32T
    DotProtoPrimType
UInt64 ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formUInt64T
    DotProtoPrimType
Fixed32 ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formFixed32T
    DotProtoPrimType
Fixed64 ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formFixed64T
    DotProtoPrimType
SFixed32 ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formSFixed32T
    DotProtoPrimType
SFixed64 ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formSFixed64T
    DotProtoPrimType
String ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formStringT
    DotProtoPrimType
Bytes ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formBytesT
    DotProtoPrimType
Bool ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formBoolT
    DotProtoPrimType
Float ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formFloatT
    DotProtoPrimType
Double ->
      GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formDoubleT
    Named (Dots (Path (String
"google" :| [String
"protobuf", String
x])))
      | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int32Value" ->
          LHsType GhcPs -> m (LHsType GhcPs)
wrapper LHsType GhcPs
formInt32T
      | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int64Value" ->
          LHsType GhcPs -> m (LHsType GhcPs)
wrapper LHsType GhcPs
formInt64T
      | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"UInt32Value" ->
          LHsType GhcPs -> m (LHsType GhcPs)
wrapper LHsType GhcPs
formUInt32T
      | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"UInt64Value" ->
          LHsType GhcPs -> m (LHsType GhcPs)
wrapper LHsType GhcPs
formUInt64T
      | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"StringValue" ->
          LHsType GhcPs -> m (LHsType GhcPs)
wrapper LHsType GhcPs
formStringT
      | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BytesValue" ->
          LHsType GhcPs -> m (LHsType GhcPs)
wrapper LHsType GhcPs
formBytesT
      | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BoolValue" ->
          LHsType GhcPs -> m (LHsType GhcPs)
wrapper LHsType GhcPs
formBoolT
      | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"FloatValue" ->
          LHsType GhcPs -> m (LHsType GhcPs)
wrapper LHsType GhcPs
formFloatT
      | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"DoubleValue" ->
          LHsType GhcPs -> m (LHsType GhcPs)
wrapper LHsType GhcPs
formDoubleT
    Named DotProtoIdentifier
msgName ->
      case DotProtoIdentifier -> TypeContext -> Maybe DotProtoTypeInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup DotProtoIdentifier
msgName TypeContext
ctxt of
        Just ty :: DotProtoTypeInfo
ty@(DotProtoTypeInfo { dotProtoTypeInfoKind :: DotProtoTypeInfo -> DotProtoKind
dotProtoTypeInfoKind = DotProtoKind
DotProtoKindEnum }) ->
          LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
formEnumerationT (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
msgTypeFromDpTypeInfo TypeContext
ctxt DotProtoTypeInfo
ty DotProtoIdentifier
msgName
        Just DotProtoTypeInfo
ty -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
formMessageT (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext
-> DotProtoTypeInfo -> DotProtoIdentifier -> m (LHsType GhcPs)
msgTypeFromDpTypeInfo TypeContext
ctxt DotProtoTypeInfo
ty DotProtoIdentifier
msgName
        Maybe DotProtoTypeInfo
Nothing -> DotProtoIdentifier -> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (m :: * -> *) a.
MonadError CompileError m =>
DotProtoIdentifier -> m a
noSuchTypeError DotProtoIdentifier
msgName
  where
    wrapper :: HsType -> m HsType
    wrapper :: LHsType GhcPs -> m (LHsType GhcPs)
wrapper = GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> (GenLocated SrcSpanAnnA (HsType GhcPs)
    -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> m (GenLocated SrcSpanAnnA (HsType GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
formMessageT (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (GenLocated SrcSpanAnnA (HsType GhcPs)
    -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
formWrapperT

--------------------------------------------------------------------------------
--
-- * Code generation
--

-- ** Generate instances for a 'DotProto' package

dotProtoDefinitionD ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  , (?typeLevelFormat :: Bool)
  ) =>
  DotProtoPackageSpec ->
  TypeContext ->
  DotProtoDefinition ->
  m [HsDecl]
dotProtoDefinitionD :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType,
 ?typeLevelFormat::Bool) =>
DotProtoPackageSpec
-> TypeContext -> DotProtoDefinition -> m [HsDecl]
dotProtoDefinitionD DotProtoPackageSpec
pkgSpec TypeContext
ctxt = \case
  DotProtoMessage String
_ DotProtoIdentifier
messageName [DotProtoMessagePart]
messageParts ->
    TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType,
 ?typeLevelFormat::Bool) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
dotProtoMessageD TypeContext
ctxt DotProtoIdentifier
Anonymous DotProtoIdentifier
messageName [DotProtoMessagePart]
messageParts

  DotProtoEnum String
_ DotProtoIdentifier
enumName [DotProtoEnumPart]
enumParts ->
    DotProtoIdentifier
-> DotProtoIdentifier -> [DotProtoEnumPart] -> m [HsDecl]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier
-> DotProtoIdentifier -> [DotProtoEnumPart] -> m [HsDecl]
dotProtoEnumD DotProtoIdentifier
Anonymous DotProtoIdentifier
enumName [DotProtoEnumPart]
enumParts

  DotProtoService String
_ DotProtoIdentifier
serviceName [DotProtoServicePart]
serviceParts ->
    DotProtoPackageSpec
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
DotProtoPackageSpec
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
dotProtoServiceD DotProtoPackageSpec
pkgSpec TypeContext
ctxt DotProtoIdentifier
serviceName [DotProtoServicePart]
serviceParts

-- | Generate 'Named' instance for a type in this package
namedInstD :: String -> HsDecl
namedInstD :: String -> HsDecl
namedInstD String
messageName =
    HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
protobufName NameSpace
tcName String
"Named")
              [ String -> LHsType GhcPs
type_ String
messageName ]
              [ String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"nameOf" [([HsPat], HsExp)
([GenLocated SrcSpanAnnA (Pat GhcPs)],
 GenLocated SrcSpanAnnA (HsExpr GhcPs))
nameOf] ]
  where
    nameOf :: ([GenLocated SrcSpanAnnA (Pat GhcPs)],
 GenLocated SrcSpanAnnA (HsExpr GhcPs))
nameOf = ([HsPat
GenLocated SrcSpanAnnA (Pat GhcPs)
wild_], HsExp -> [HsExp] -> HsExp
apply HsExp
fromStringE [ String -> HsExp
str_ String
messageName ])

hasDefaultInstD :: String -> HsDecl
hasDefaultInstD :: String -> HsDecl
hasDefaultInstD String
messageName =
  HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
protobufName NameSpace
tcName String
"HasDefault")
            [ String -> LHsType GhcPs
type_ String
messageName ]
            [ ]

-- ** Generate types and instances for .proto messages

-- | Generate data types, 'Bounded', 'Enum', 'FromJSONPB', 'Named', 'Message',
--   'ToJSONPB' instances as appropriate for the given 'DotProtoMessagePart's
dotProtoMessageD ::
  forall m .
  ( MonadError CompileError m
  , (?stringType :: StringType)
  , (?typeLevelFormat :: Bool)
  ) =>
  TypeContext ->
  DotProtoIdentifier ->
  DotProtoIdentifier ->
  [DotProtoMessagePart] ->
  m [HsDecl]
dotProtoMessageD :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType,
 ?typeLevelFormat::Bool) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
dotProtoMessageD TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent [DotProtoMessagePart]
messageParts = do
    String
messageName <- DotProtoIdentifier -> DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent

    let mkDataDecl :: [([GenLocated SrcSpanAnnN RdrName],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> HsDecl
mkDataDecl [([GenLocated SrcSpanAnnN RdrName],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
flds =
          String -> [HsTyVarBndrV] -> [HsConDecl] -> [HsName] -> HsDecl
dataDecl_ String
messageName
                    []
                    [ HsName -> [([HsName], LHsType GhcPs)] -> HsConDecl
recDecl_ (NameSpace -> String -> HsName
unqual_ NameSpace
varName String
messageName) [([HsName], LHsType GhcPs)]
[([GenLocated SrcSpanAnnN RdrName],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
flds ]
                    [HsName]
defaultMessageDeriving

#ifdef SWAGGER
    let getName :: DotProtoMessagePart
-> m [(Maybe ([DotProtoOption], DotProtoType), String)]
getName = \case
          DotProtoMessageField DotProtoField
fld -> ((Maybe ([DotProtoOption], DotProtoType), String)
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
forall a. a -> [a] -> [a]
: []) ((Maybe ([DotProtoOption], DotProtoType), String)
 -> [(Maybe ([DotProtoOption], DotProtoType), String)])
-> m (Maybe ([DotProtoOption], DotProtoType), String)
-> m [(Maybe ([DotProtoOption], DotProtoType), String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoField -> m (Maybe ([DotProtoOption], DotProtoType), String)
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoField -> m (Maybe ([DotProtoOption], DotProtoType), String)
getFieldNameForSchemaInstanceDeclaration DotProtoField
fld
          DotProtoMessageOneOf DotProtoIdentifier
ident [DotProtoField]
_ -> ((Maybe ([DotProtoOption], DotProtoType), String)
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
forall a. a -> [a] -> [a]
: []) ((Maybe ([DotProtoOption], DotProtoType), String)
 -> [(Maybe ([DotProtoOption], DotProtoType), String)])
-> (String -> (Maybe ([DotProtoOption], DotProtoType), String))
-> String
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ([DotProtoOption], DotProtoType)
forall a. Maybe a
Nothing, ) (String -> [(Maybe ([DotProtoOption], DotProtoType), String)])
-> m String -> m [(Maybe ([DotProtoOption], DotProtoType), String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
ident
          DotProtoMessagePart
_ -> [(Maybe ([DotProtoOption], DotProtoType), String)]
-> m [(Maybe ([DotProtoOption], DotProtoType), String)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
#endif

    GenLocated SrcSpanAnnA (HsDecl GhcPs)
messageDataDecl <- [([GenLocated SrcSpanAnnN RdrName],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
mkDataDecl ([([GenLocated SrcSpanAnnN RdrName],
   GenLocated SrcSpanAnnA (HsType GhcPs))]
 -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> m [([GenLocated SrcSpanAnnN RdrName],
       GenLocated SrcSpanAnnA (HsType GhcPs))]
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DotProtoMessagePart
 -> m [([GenLocated SrcSpanAnnN RdrName],
        GenLocated SrcSpanAnnA (HsType GhcPs))])
-> [DotProtoMessagePart]
-> m [([GenLocated SrcSpanAnnN RdrName],
       GenLocated SrcSpanAnnA (HsType GhcPs))]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM (String -> DotProtoMessagePart -> m [([HsName], LHsType GhcPs)]
messagePartFieldD String
messageName) [DotProtoMessagePart]
messageParts

    (m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> a
id
      [ [m (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsDecl GhcPs)
messageDataDecl
          , GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsDecl -> String -> HsDecl
Record.nfDataInstD HsDecl
GenLocated SrcSpanAnnA (HsDecl GhcPs)
messageDataDecl String
messageName)
          , GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> HsDecl
namedInstD String
messageName)
          , GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> HsDecl
hasDefaultInstD String
messageName)
          , TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
messageInstD TypeContext
ctxt' DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent [DotProtoMessagePart]
messageParts

          , TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
toJSONPBMessageInstD TypeContext
ctxt' DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent [DotProtoMessagePart]
messageParts
          , TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
fromJSONPBMessageInstD TypeContext
ctxt' DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent [DotProtoMessagePart]
messageParts

            -- Generate Aeson instances in terms of JSONPB instances
          , GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> HsDecl
toJSONInstDecl String
messageName)
          , GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> HsDecl
fromJSONInstDecl String
messageName)

#ifdef SWAGGER
          -- And the Swagger ToSchema instance corresponding to JSONPB encodings
          , TypeContext
-> String
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
-> m HsDecl
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> String
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
-> m HsDecl
toSchemaInstanceDeclaration TypeContext
ctxt' String
messageName Maybe [HsName]
Maybe [GenLocated SrcSpanAnnN RdrName]
forall a. Maybe a
Nothing
              ([(Maybe ([DotProtoOption], DotProtoType), String)]
 -> m (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> m [(Maybe ([DotProtoOption], DotProtoType), String)]
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (DotProtoMessagePart
 -> m [(Maybe ([DotProtoOption], DotProtoType), String)])
-> [DotProtoMessagePart]
-> m [(Maybe ([DotProtoOption], DotProtoType), String)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM DotProtoMessagePart
-> m [(Maybe ([DotProtoOption], DotProtoType), String)]
getName [DotProtoMessagePart]
messageParts
#endif

#ifdef DHALL
          -- Generate Dhall instances
          , pure (dhallInterpretInstDecl messageName)
          , pure (dhallInjectInstDecl messageName)
#endif
          ]

      , if ?typeLevelFormat::Bool
Bool
?typeLevelFormat
          then TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
typeLevelInstsD TypeContext
ctxt' DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent [DotProtoMessagePart]
messageParts
          else [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

      -- Nested regular and oneof message decls
      , GettingM
  [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
  [DotProtoMessagePart]
  DotProtoDefinition
-> (DotProtoDefinition
    -> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [DotProtoMessagePart]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (m :: * -> *) r s a.
(Applicative m, Monoid r) =>
GettingM r s a -> (a -> m r) -> s -> m r
foldMapOfM ((DotProtoMessagePart
 -> Compose
      m
      (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
      DotProtoMessagePart)
-> [DotProtoMessagePart]
-> Compose
     m
     (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
     [DotProtoMessagePart]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((DotProtoMessagePart
  -> Compose
       m
       (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
       DotProtoMessagePart)
 -> [DotProtoMessagePart]
 -> Compose
      m
      (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
      [DotProtoMessagePart])
-> ((DotProtoDefinition
     -> Compose
          m
          (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
          DotProtoDefinition)
    -> DotProtoMessagePart
    -> Compose
         m
         (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
         DotProtoMessagePart)
-> (DotProtoDefinition
    -> Compose
         m
         (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
         DotProtoDefinition)
-> [DotProtoMessagePart]
-> Compose
     m
     (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
     [DotProtoMessagePart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DotProtoDefinition
 -> Compose
      m
      (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
      DotProtoDefinition)
-> DotProtoMessagePart
-> Compose
     m
     (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
     DotProtoMessagePart
Prism' DotProtoMessagePart DotProtoDefinition
_DotProtoMessageDefinition)
                   DotProtoDefinition -> m [HsDecl]
DotProtoDefinition -> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
nestedDecls
                   [DotProtoMessagePart]
messageParts

      , GettingM
  [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
  [DotProtoMessagePart]
  (DotProtoIdentifier, [DotProtoField])
-> ((DotProtoIdentifier, [DotProtoField])
    -> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [DotProtoMessagePart]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (m :: * -> *) r s a.
(Applicative m, Monoid r) =>
GettingM r s a -> (a -> m r) -> s -> m r
foldMapOfM ((DotProtoMessagePart
 -> Compose
      m
      (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
      DotProtoMessagePart)
-> [DotProtoMessagePart]
-> Compose
     m
     (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
     [DotProtoMessagePart]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((DotProtoMessagePart
  -> Compose
       m
       (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
       DotProtoMessagePart)
 -> [DotProtoMessagePart]
 -> Compose
      m
      (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
      [DotProtoMessagePart])
-> (((DotProtoIdentifier, [DotProtoField])
     -> Compose
          m
          (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
          (DotProtoIdentifier, [DotProtoField]))
    -> DotProtoMessagePart
    -> Compose
         m
         (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
         DotProtoMessagePart)
-> ((DotProtoIdentifier, [DotProtoField])
    -> Compose
         m
         (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
         (DotProtoIdentifier, [DotProtoField]))
-> [DotProtoMessagePart]
-> Compose
     m
     (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
     [DotProtoMessagePart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DotProtoIdentifier, [DotProtoField])
 -> Compose
      m
      (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
      (DotProtoIdentifier, [DotProtoField]))
-> DotProtoMessagePart
-> Compose
     m
     (Const [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
     DotProtoMessagePart
Prism' DotProtoMessagePart (DotProtoIdentifier, [DotProtoField])
_DotProtoMessageOneOf)
                   ((DotProtoIdentifier -> [DotProtoField] -> m [HsDecl])
-> (DotProtoIdentifier, [DotProtoField]) -> m [HsDecl]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((DotProtoIdentifier -> [DotProtoField] -> m [HsDecl])
 -> (DotProtoIdentifier, [DotProtoField]) -> m [HsDecl])
-> (DotProtoIdentifier -> [DotProtoField] -> m [HsDecl])
-> (DotProtoIdentifier, [DotProtoField])
-> m [HsDecl]
forall a b. (a -> b) -> a -> b
$ String -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl]
nestedOneOfDecls String
messageName)
                   [DotProtoMessagePart]
messageParts
      ]

  where
    ctxt' :: TypeContext
    ctxt' :: TypeContext
ctxt' = TypeContext
-> (DotProtoTypeInfo -> TypeContext)
-> Maybe DotProtoTypeInfo
-> TypeContext
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeContext
forall a. Monoid a => a
mempty DotProtoTypeInfo -> TypeContext
dotProtoTypeChildContext (DotProtoIdentifier -> TypeContext -> Maybe DotProtoTypeInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup DotProtoIdentifier
messageIdent TypeContext
ctxt)
                TypeContext -> TypeContext -> TypeContext
forall a. Semigroup a => a -> a -> a
<> TypeContext
ctxt

    messagePartFieldD :: String -> DotProtoMessagePart -> m [([HsName], HsBangType)]
    messagePartFieldD :: String -> DotProtoMessagePart -> m [([HsName], LHsType GhcPs)]
messagePartFieldD String
messageName (DotProtoMessageField DotProtoField{String
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldNumber :: FieldNumber
dotProtoFieldType :: DotProtoType
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldComment :: String
dotProtoFieldComment :: DotProtoField -> String
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
..}) = do
      String
fullName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedFieldName String
messageName (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
dotProtoFieldName
      GenLocated SrcSpanAnnA (HsType GhcPs)
fullTy <- FieldContext -> TypeContext -> DotProtoType -> m (LHsType GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext -> TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToHsType FieldContext
WithinMessage TypeContext
ctxt' DotProtoType
dotProtoFieldType
      [([GenLocated SrcSpanAnnN RdrName],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> m [([GenLocated SrcSpanAnnN RdrName],
       GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ ([NameSpace -> String -> HsName
unqual_ NameSpace
varName String
fullName], LHsType GhcPs -> LHsType GhcPs
unbangedTy_ LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fullTy) ]

    messagePartFieldD String
messageName (DotProtoMessageOneOf DotProtoIdentifier
fieldName [DotProtoField]
_) = do
      String
fullName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedFieldName String
messageName (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
fieldName
      String
qualTyName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedConName String
messageName (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
fieldName
      let fullTy :: GenLocated SrcSpanAnnA (HsType GhcPs)
fullTy = HsName -> LHsType GhcPs -> LHsType GhcPs
tyConApp (NameSpace -> String -> HsName
haskellName NameSpace
tcName String
"Maybe") (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (String -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> String
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LHsType GhcPs
String -> GenLocated SrcSpanAnnA (HsType GhcPs)
type_ (String -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> String -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String
qualTyName
      [([GenLocated SrcSpanAnnN RdrName],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> m [([GenLocated SrcSpanAnnN RdrName],
       GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ ([NameSpace -> String -> HsName
unqual_ NameSpace
varName String
fullName], LHsType GhcPs -> LHsType GhcPs
unbangedTy_ LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fullTy) ]

    messagePartFieldD String
_ DotProtoMessagePart
_ = [([GenLocated SrcSpanAnnN RdrName],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> m [([GenLocated SrcSpanAnnN RdrName],
       GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

    nestedDecls :: DotProtoDefinition -> m [HsDecl]
    nestedDecls :: DotProtoDefinition -> m [HsDecl]
nestedDecls (DotProtoMessage String
_ DotProtoIdentifier
subMsgName [DotProtoMessagePart]
subMessageDef) = do
      DotProtoIdentifier
parentIdent' <- DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent
      TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType,
 ?typeLevelFormat::Bool) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
dotProtoMessageD TypeContext
ctxt' DotProtoIdentifier
parentIdent' DotProtoIdentifier
subMsgName [DotProtoMessagePart]
subMessageDef

    nestedDecls (DotProtoEnum String
_ DotProtoIdentifier
subEnumName [DotProtoEnumPart]
subEnumDef) = do
      DotProtoIdentifier
parentIdent' <- DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent
      DotProtoIdentifier
-> DotProtoIdentifier -> [DotProtoEnumPart] -> m [HsDecl]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier
-> DotProtoIdentifier -> [DotProtoEnumPart] -> m [HsDecl]
dotProtoEnumD DotProtoIdentifier
parentIdent' DotProtoIdentifier
subEnumName [DotProtoEnumPart]
subEnumDef

    nestedDecls DotProtoDefinition
_ = [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

    nestedOneOfDecls :: String -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl]
    nestedOneOfDecls :: String -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl]
nestedOneOfDecls String
messageName DotProtoIdentifier
identifier [DotProtoField]
fields = do
      String
fullName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedConName String
messageName (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
identifier

      ([GenLocated SrcSpanAnnA (ConDecl GhcPs)]
cons, [GenLocated SrcSpanAnnN RdrName]
_idents) <- ([(GenLocated SrcSpanAnnA (ConDecl GhcPs),
   GenLocated SrcSpanAnnN RdrName)]
 -> ([GenLocated SrcSpanAnnA (ConDecl GhcPs)],
     [GenLocated SrcSpanAnnN RdrName]))
-> m [(GenLocated SrcSpanAnnA (ConDecl GhcPs),
       GenLocated SrcSpanAnnN RdrName)]
-> m ([GenLocated SrcSpanAnnA (ConDecl GhcPs)],
      [GenLocated SrcSpanAnnN RdrName])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(GenLocated SrcSpanAnnA (ConDecl GhcPs),
  GenLocated SrcSpanAnnN RdrName)]
-> ([GenLocated SrcSpanAnnA (ConDecl GhcPs)],
    [GenLocated SrcSpanAnnN RdrName])
forall a b. [(a, b)] -> ([a], [b])
unzip ((DotProtoField
 -> m (GenLocated SrcSpanAnnA (ConDecl GhcPs),
       GenLocated SrcSpanAnnN RdrName))
-> [DotProtoField]
-> m [(GenLocated SrcSpanAnnA (ConDecl GhcPs),
       GenLocated SrcSpanAnnN RdrName)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> DotProtoField -> m (HsConDecl, HsName)
oneOfCons String
fullName) [DotProtoField]
fields)

#ifdef SWAGGER
      GenLocated SrcSpanAnnA (HsDecl GhcPs)
toSchemaInstance <- TypeContext
-> String
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
-> m HsDecl
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> String
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
-> m HsDecl
toSchemaInstanceDeclaration TypeContext
ctxt' String
fullName ([GenLocated SrcSpanAnnN RdrName]
-> Maybe [GenLocated SrcSpanAnnN RdrName]
forall a. a -> Maybe a
Just [GenLocated SrcSpanAnnN RdrName]
_idents)
                            ([(Maybe ([DotProtoOption], DotProtoType), String)]
 -> m (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> m [(Maybe ([DotProtoOption], DotProtoType), String)]
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (DotProtoField
 -> m (Maybe ([DotProtoOption], DotProtoType), String))
-> [DotProtoField]
-> m [(Maybe ([DotProtoOption], DotProtoType), String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DotProtoField -> m (Maybe ([DotProtoOption], DotProtoType), String)
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoField -> m (Maybe ([DotProtoOption], DotProtoType), String)
getFieldNameForSchemaInstanceDeclaration [DotProtoField]
fields
#endif

      let nestedDecl :: HsDecl
nestedDecl = String -> [HsTyVarBndrV] -> [HsConDecl] -> [HsName] -> HsDecl
dataDecl_ String
fullName [] [HsConDecl]
[GenLocated SrcSpanAnnA (ConDecl GhcPs)]
cons [HsName]
defaultMessageDeriving
      [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ GenLocated SrcSpanAnnA (HsDecl GhcPs)
nestedDecl
           , HsDecl -> String -> HsDecl
Record.nfDataInstD HsDecl
GenLocated SrcSpanAnnA (HsDecl GhcPs)
nestedDecl String
fullName
           , String -> HsDecl
namedInstD String
fullName
#ifdef SWAGGER
           , GenLocated SrcSpanAnnA (HsDecl GhcPs)
toSchemaInstance
#endif

#ifdef DHALL
           , dhallInterpretInstDecl fullName
           , dhallInjectInstDecl fullName
#endif
           ]

    oneOfCons :: String -> DotProtoField -> m (HsConDecl, HsName)
    oneOfCons :: String -> DotProtoField -> m (HsConDecl, HsName)
oneOfCons String
fullName DotProtoField{String
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldComment :: DotProtoField -> String
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
dotProtoFieldNumber :: FieldNumber
dotProtoFieldType :: DotProtoType
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldComment :: String
..} = do
       GenLocated SrcSpanAnnA (HsType GhcPs)
consTy <- FieldContext -> TypeContext -> DotProtoType -> m (LHsType GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext -> TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToHsType FieldContext
WithinOneOf TypeContext
ctxt' DotProtoType
dotProtoFieldType
       String
consName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedConName String
fullName (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
dotProtoFieldName
       let ident :: HsName
ident = NameSpace -> String -> HsName
unqual_ NameSpace
dataName String
consName
       (GenLocated SrcSpanAnnA (ConDecl GhcPs),
 GenLocated SrcSpanAnnN RdrName)
-> m (GenLocated SrcSpanAnnA (ConDecl GhcPs),
      GenLocated SrcSpanAnnN RdrName)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsName -> [LHsType GhcPs] -> HsConDecl
conDecl_ HsName
GenLocated SrcSpanAnnN RdrName
ident [LHsType GhcPs -> LHsType GhcPs
unbangedTy_ LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
consTy], GenLocated SrcSpanAnnN RdrName
ident)

-- *** Generate type family instances providing type-level information about protobuf formats.

type FieldOccurrences = (Histogram FieldName, Histogram FieldNumber)

data FieldSpec = FieldSpec
  { FieldSpec -> FieldName
fieldSpecName :: FieldName
  , FieldSpec -> FieldNumber
fieldSpecNumber :: FieldNumber
  , FieldSpec -> Maybe FieldName
fieldSpecOneOf :: Maybe FieldName
  , FieldSpec -> LHsType GhcPs
fieldSpecCardinality :: HsType
  , FieldSpec -> LHsType GhcPs
fieldSpecProtoType :: HsType
  }

typeLevelInstsD ::
  forall m .
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  TypeContext ->
  DotProtoIdentifier->
  DotProtoIdentifier ->
  [DotProtoMessagePart]->
  m [HsDecl]
typeLevelInstsD :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
typeLevelInstsD TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent [DotProtoMessagePart]
messageParts = do
    String
msgName <- DotProtoIdentifier -> DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent

    [QualifiedField]
qualifiedFields <- String -> [DotProtoMessagePart] -> m [QualifiedField]
forall (m :: * -> *).
MonadError CompileError m =>
String -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields String
msgName [DotProtoMessagePart]
messageParts

    ([([FieldName], [FieldSpec])]
fieldSpecLists, (Histogram FieldName
fieldNames, Histogram FieldNumber
fieldNumbers)) <-
      WriterT FieldOccurrences m [([FieldName], [FieldSpec])]
-> m ([([FieldName], [FieldSpec])], FieldOccurrences)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT ((QualifiedField
 -> WriterT FieldOccurrences m ([FieldName], [FieldSpec]))
-> [QualifiedField]
-> WriterT FieldOccurrences m [([FieldName], [FieldSpec])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM QualifiedField
-> WriterT FieldOccurrences m ([FieldName], [FieldSpec])
mkFieldSpecs [QualifiedField]
qualifiedFields)

    let ([FieldName] -> [FieldName]
forall a. Ord a => [a] -> [a]
sort -> [FieldName]
oneOfs, (FieldSpec -> FieldSpec -> Ordering) -> [FieldSpec] -> [FieldSpec]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (FieldName -> FieldName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (FieldName -> FieldName -> Ordering)
-> (FieldSpec -> FieldName) -> FieldSpec -> FieldSpec -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` FieldSpec -> FieldName
fieldSpecName) -> [FieldSpec]
fieldSpecs) = [([FieldName], [FieldSpec])] -> ([FieldName], [FieldSpec])
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [([FieldName], [FieldSpec])]
fieldSpecLists
        repeatedFieldNames :: Histogram FieldName
repeatedFieldNames = Histogram FieldName -> Histogram FieldName
forall a. Histogram a -> Histogram a
mulipleOccurrencesOnly Histogram FieldName
fieldNames
        repeatedFieldNumbers :: Histogram FieldNumber
repeatedFieldNumbers = Histogram FieldNumber -> Histogram FieldNumber
forall a. Histogram a -> Histogram a
mulipleOccurrencesOnly Histogram FieldNumber
fieldNumbers

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Histogram FieldName
repeatedFieldNames Histogram FieldName -> Histogram FieldName -> Bool
forall a. Eq a => a -> a -> Bool
/= Histogram FieldName
forall a. Monoid a => a
mempty Bool -> Bool -> Bool
|| Histogram FieldNumber
repeatedFieldNumbers Histogram FieldNumber -> Histogram FieldNumber -> Bool
forall a. Eq a => a -> a -> Bool
/= Histogram FieldNumber
forall a. Monoid a => a
mempty) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      CompileError -> m ()
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m ()) -> CompileError -> m ()
forall a b. (a -> b) -> a -> b
$ Histogram FieldName -> Histogram FieldNumber -> CompileError
RedefinedFields Histogram FieldName
repeatedFieldNames Histogram FieldNumber
repeatedFieldNumbers

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (let Histogram Map FieldName Int
m = Histogram FieldName
fieldNames in FieldName -> Map FieldName Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member FieldName
"" Map FieldName Int
m) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m ()
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"empty field name within message " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DotProtoIdentifier -> String
forall a. Show a => a -> String
show DotProtoIdentifier
msgIdent

    let msgNameT :: LHsType GhcPs
msgNameT = String -> LHsType GhcPs
type_ String
msgName
        msgNumberOf :: HsName
msgNumberOf = NameSpace -> String -> HsName
unqual_ NameSpace
tcName (String
msgName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_NumberOf")
        msgProtoTypeOf :: HsName
msgProtoTypeOf = NameSpace -> String -> HsName
unqual_ NameSpace
tcName (String
msgName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_ProtoTypeOf")
        msgOneOfOf :: HsName
msgOneOfOf = NameSpace -> String -> HsName
unqual_ NameSpace
tcName (String
msgName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_OneOfOf")
        msgCardinalityOf :: HsName
msgCardinalityOf = NameSpace -> String -> HsName
unqual_ NameSpace
tcName (String
msgName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_CardinalityOf")
        fieldNameVar :: HsName
fieldNameVar = String -> HsName
tvarn_ String
"name"
        fieldNameVarT :: LHsType GhcPs
fieldNameVarT = HsName -> LHsType GhcPs
typeNamed_ HsName
GenLocated SrcSpanAnnN RdrName
fieldNameVar
        fieldNameVarB :: HsTyVarBndrV
fieldNameVarB = HsBndrVis GhcPs -> HsName -> LHsType GhcPs -> HsTyVarBndrV
forall flag.
flag -> HsName -> LHsType GhcPs -> LHsTyVarBndr flag GhcPs
kindedTyVar_ HsBndrVis GhcPs
forall a. SyntaxDefault a => a
synDef HsName
GenLocated SrcSpanAnnN RdrName
fieldNameVar LHsType GhcPs
symbolT
        err :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> [(Maybe a, [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
err GenLocated SrcSpanAnnA (HsType GhcPs)
msg =
          [(Maybe a
forall a. Maybe a
Nothing, [GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameVarT], LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
typeErrorT (LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
tyApply LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
msg [LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
msgNameT, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameVarT]))]
        toSym :: FieldName -> GenLocated SrcSpanAnnA (HsType GhcPs)
toSym = String -> LHsType GhcPs
String -> GenLocated SrcSpanAnnA (HsType GhcPs)
symT (String -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (FieldName -> String)
-> FieldName
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> String
getFieldName
        fieldNameT :: FieldSpec -> GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameT = FieldName -> GenLocated SrcSpanAnnA (HsType GhcPs)
toSym (FieldName -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (FieldSpec -> FieldName)
-> FieldSpec
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldSpec -> FieldName
fieldSpecName
        fieldNumberT :: FieldSpec -> GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNumberT = Word64 -> LHsType GhcPs
Word64 -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a. Integral a => a -> LHsType GhcPs
natTLit (Word64 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (FieldSpec -> Word64)
-> FieldSpec
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNumber -> Word64
getFieldNumber (FieldNumber -> Word64)
-> (FieldSpec -> FieldNumber) -> FieldSpec -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldSpec -> FieldNumber
fieldSpecNumber
        oneOfT :: FieldSpec -> GenLocated SrcSpanAnnA (HsType GhcPs)
oneOfT = GenLocated SrcSpanAnnA (HsType GhcPs)
-> (FieldName -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> Maybe FieldName
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> LHsType GhcPs
symT String
"") FieldName -> GenLocated SrcSpanAnnA (HsType GhcPs)
toSym (Maybe FieldName -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (FieldSpec -> Maybe FieldName)
-> FieldSpec
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldSpec -> Maybe FieldName
fieldSpecOneOf

    let onFields :: (FieldSpec -> HsType) -> [(Maybe [HsTyVarBndrU], [HsType], HsType)]
        onFields :: (FieldSpec -> LHsType GhcPs)
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
onFields FieldSpec -> LHsType GhcPs
rhs = [FieldSpec]
fieldSpecs [FieldSpec]
-> (FieldSpec
    -> (Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
        [GenLocated SrcSpanAnnA (HsType GhcPs)],
        GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \FieldSpec
f -> (Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a. Maybe a
Nothing, [ FieldSpec -> GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameT FieldSpec
f ], FieldSpec -> LHsType GhcPs
rhs FieldSpec
f)

        onOneOfs :: (FieldName -> HsType) -> [(Maybe [HsTyVarBndrU], [HsType], HsType)]
        onOneOfs :: (FieldName -> LHsType GhcPs)
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
onOneOfs FieldName -> LHsType GhcPs
rhs = [FieldName]
oneOfs [FieldName]
-> (FieldName
    -> (Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
        [GenLocated SrcSpanAnnA (HsType GhcPs)],
        GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \FieldName
o -> (Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a. Maybe a
Nothing, [ FieldName -> GenLocated SrcSpanAnnA (HsType GhcPs)
toSym FieldName
o ], FieldName -> LHsType GhcPs
rhs FieldName
o)

    let namesOf :: HsDecl
        numberOf, protoTypeOf, oneOfOf, cardinalityOf :: [HsDecl]
        namesOf :: HsDecl
namesOf = HsName
-> Maybe [HsTyVarBndrU]
-> [LHsType GhcPs]
-> LHsType GhcPs
-> HsDecl
tyFamInstDecl_ HsName
formNamesOf Maybe [HsTyVarBndrU]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a. Maybe a
Nothing [ LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
msgNameT ]
          ([LHsType GhcPs] -> LHsType GhcPs
listT_ ((FieldSpec -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> [FieldSpec] -> [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map FieldSpec -> GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameT [FieldSpec]
fieldSpecs))
        numberOf :: [HsDecl]
numberOf =
          [ HsName
-> Maybe [HsTyVarBndrU]
-> [LHsType GhcPs]
-> LHsType GhcPs
-> HsDecl
tyFamInstDecl_ HsName
formNumberOf Maybe [HsTyVarBndrU]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a. Maybe a
Nothing [ LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
msgNameT, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameVarT ]
              (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (HsName -> LHsType GhcPs
typeNamed_ HsName
GenLocated SrcSpanAnnN RdrName
msgNumberOf) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameVarT)
          , HsName
-> [HsTyVarBndrV]
-> LHsType GhcPs
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
-> HsDecl
closedTyFamDecl_ HsName
GenLocated SrcSpanAnnN RdrName
msgNumberOf [ HsTyVarBndrV
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
fieldNameVarB ] LHsType GhcPs
natT
              ((FieldSpec -> LHsType GhcPs)
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
onFields FieldSpec -> LHsType GhcPs
FieldSpec -> GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNumberT [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
  [GenLocated SrcSpanAnnA (HsType GhcPs)],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. [a] -> [a] -> [a]
++ GenLocated SrcSpanAnnA (HsType GhcPs)
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall {a}.
GenLocated SrcSpanAnnA (HsType GhcPs)
-> [(Maybe a, [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
err LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formFieldNotFound)
          ]
        protoTypeOf :: [HsDecl]
protoTypeOf =
          [ HsName
-> Maybe [HsTyVarBndrU]
-> [LHsType GhcPs]
-> LHsType GhcPs
-> HsDecl
tyFamInstDecl_ HsName
formProtoTypeOf Maybe [HsTyVarBndrU]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a. Maybe a
Nothing [ LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
msgNameT, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameVarT ]
              (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (HsName -> LHsType GhcPs
typeNamed_ HsName
GenLocated SrcSpanAnnN RdrName
msgProtoTypeOf) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameVarT)
          , HsName
-> [HsTyVarBndrV]
-> LHsType GhcPs
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
-> HsDecl
closedTyFamDecl_ HsName
GenLocated SrcSpanAnnN RdrName
msgProtoTypeOf [ HsTyVarBndrV
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
fieldNameVarB ] LHsType GhcPs
formProtoTypeT
              ((FieldSpec -> LHsType GhcPs)
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
onFields FieldSpec -> LHsType GhcPs
fieldSpecProtoType [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
  [GenLocated SrcSpanAnnA (HsType GhcPs)],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. [a] -> [a] -> [a]
++ GenLocated SrcSpanAnnA (HsType GhcPs)
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall {a}.
GenLocated SrcSpanAnnA (HsType GhcPs)
-> [(Maybe a, [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
err LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formFieldNotFound)
          ]
        oneOfOf :: [HsDecl]
oneOfOf =
          [ HsName
-> Maybe [HsTyVarBndrU]
-> [LHsType GhcPs]
-> LHsType GhcPs
-> HsDecl
tyFamInstDecl_ HsName
formOneOfOf Maybe [HsTyVarBndrU]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a. Maybe a
Nothing [ LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
msgNameT, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameVarT ]
              (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (HsName -> LHsType GhcPs
typeNamed_ HsName
GenLocated SrcSpanAnnN RdrName
msgOneOfOf) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameVarT)
          , HsName
-> [HsTyVarBndrV]
-> LHsType GhcPs
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
-> HsDecl
closedTyFamDecl_ HsName
GenLocated SrcSpanAnnN RdrName
msgOneOfOf [ HsTyVarBndrV
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
fieldNameVarB ] LHsType GhcPs
symbolT
              ((FieldSpec -> LHsType GhcPs)
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
onFields FieldSpec -> LHsType GhcPs
FieldSpec -> GenLocated SrcSpanAnnA (HsType GhcPs)
oneOfT [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
  [GenLocated SrcSpanAnnA (HsType GhcPs)],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. [a] -> [a] -> [a]
++ (FieldName -> LHsType GhcPs)
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
onOneOfs FieldName -> LHsType GhcPs
FieldName -> GenLocated SrcSpanAnnA (HsType GhcPs)
toSym [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
  [GenLocated SrcSpanAnnA (HsType GhcPs)],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. [a] -> [a] -> [a]
++ GenLocated SrcSpanAnnA (HsType GhcPs)
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall {a}.
GenLocated SrcSpanAnnA (HsType GhcPs)
-> [(Maybe a, [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
err LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formFieldOrOneOfNotFound)
          ]
        cardinalityOf :: [HsDecl]
cardinalityOf =
          [ HsName
-> Maybe [HsTyVarBndrU]
-> [LHsType GhcPs]
-> LHsType GhcPs
-> HsDecl
tyFamInstDecl_ HsName
formCardinalityOf Maybe [HsTyVarBndrU]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall a. Maybe a
Nothing [ LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
msgNameT, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameVarT ]
              (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp (HsName -> LHsType GhcPs
typeNamed_ HsName
GenLocated SrcSpanAnnN RdrName
msgCardinalityOf) LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fieldNameVarT)
          , HsName
-> [HsTyVarBndrV]
-> LHsType GhcPs
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
-> HsDecl
closedTyFamDecl_ HsName
GenLocated SrcSpanAnnN RdrName
msgCardinalityOf [ HsTyVarBndrV
GenLocated SrcSpanAnnA (HsTyVarBndr (HsBndrVis GhcPs) GhcPs)
fieldNameVarB ] LHsType GhcPs
formCardinalityT
              ( (FieldSpec -> LHsType GhcPs)
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
onFields FieldSpec -> LHsType GhcPs
fieldSpecCardinality [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
  [GenLocated SrcSpanAnnA (HsType GhcPs)],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. [a] -> [a] -> [a]
++
                (FieldName -> LHsType GhcPs)
-> [(Maybe [HsTyVarBndrU], [LHsType GhcPs], LHsType GhcPs)]
onOneOfs (GenLocated SrcSpanAnnA (HsType GhcPs)
-> FieldName -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. a -> b -> a
const LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formOptionalT) [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
  [GenLocated SrcSpanAnnA (HsType GhcPs)],
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. [a] -> [a] -> [a]
++
                GenLocated SrcSpanAnnA (HsType GhcPs)
-> [(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
     [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
forall {a}.
GenLocated SrcSpanAnnA (HsType GhcPs)
-> [(Maybe a, [GenLocated SrcSpanAnnA (HsType GhcPs)],
     GenLocated SrcSpanAnnA (HsType GhcPs))]
err LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
formFieldOrOneOfNotFound
              )
          ]

    [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. (a -> b) -> a -> b
$ HsDecl
GenLocated SrcSpanAnnA (HsDecl GhcPs)
namesOf GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> [a] -> [a]
: [HsDecl]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
numberOf [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [HsDecl]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
protoTypeOf [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [HsDecl]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
oneOfOf [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [HsDecl]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
cardinalityOf
  where
    mkFieldSpecs :: QualifiedField -> WriterT FieldOccurrences m ([FieldName], [FieldSpec])
    mkFieldSpecs :: QualifiedField
-> WriterT FieldOccurrences m ([FieldName], [FieldSpec])
mkFieldSpecs QualifiedField{FieldInfo
fieldInfo :: FieldInfo
fieldInfo :: QualifiedField -> FieldInfo
fieldInfo} = case FieldInfo
fieldInfo of
      FieldNormal FieldName
fieldName FieldNumber
fieldNum DotProtoType
dpType [DotProtoOption]
options -> do
        FieldOccurrences -> WriterT FieldOccurrences m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (FieldName -> Histogram FieldName
forall a. a -> Histogram a
oneOccurrence FieldName
fieldName, FieldNumber -> Histogram FieldNumber
forall a. a -> Histogram a
oneOccurrence FieldNumber
fieldNum)
        GenLocated SrcSpanAnnA (HsType GhcPs)
cardinality <- [DotProtoOption]
-> TypeContext
-> DotProtoType
-> WriterT FieldOccurrences m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
[DotProtoOption]
-> TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToFormCardinality [DotProtoOption]
options TypeContext
ctxt DotProtoType
dpType
        GenLocated SrcSpanAnnA (HsType GhcPs)
protoType <- TypeContext
-> DotProtoType -> WriterT FieldOccurrences m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToFormType TypeContext
ctxt DotProtoType
dpType
        ([FieldName], [FieldSpec])
-> WriterT FieldOccurrences m ([FieldName], [FieldSpec])
forall a. a -> WriterT FieldOccurrences m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [], [ FieldSpec
                       { fieldSpecName :: FieldName
fieldSpecName = FieldName
fieldName
                       , fieldSpecNumber :: FieldNumber
fieldSpecNumber = FieldNumber
fieldNum
                       , fieldSpecOneOf :: Maybe FieldName
fieldSpecOneOf = Maybe FieldName
forall a. Maybe a
Nothing
                       , fieldSpecCardinality :: LHsType GhcPs
fieldSpecCardinality = LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
cardinality
                       , fieldSpecProtoType :: LHsType GhcPs
fieldSpecProtoType = LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
protoType
                       } ] )

      FieldOneOf FieldName
oneofName OneofField{[OneofSubfield]
subfields :: [OneofSubfield]
subfields :: OneofField -> [OneofSubfield]
subfields} -> do
          FieldOccurrences -> WriterT FieldOccurrences m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (FieldName -> Histogram FieldName
forall a. a -> Histogram a
oneOccurrence FieldName
oneofName, Histogram FieldNumber
forall a. Monoid a => a
mempty)
          ([FieldName
oneofName], ) ([FieldSpec] -> ([FieldName], [FieldSpec]))
-> WriterT FieldOccurrences m [FieldSpec]
-> WriterT FieldOccurrences m ([FieldName], [FieldSpec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OneofSubfield -> WriterT FieldOccurrences m FieldSpec)
-> [OneofSubfield] -> WriterT FieldOccurrences m [FieldSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM OneofSubfield -> WriterT FieldOccurrences m FieldSpec
mkSubfieldSpec [OneofSubfield]
subfields
        where
          mkSubfieldSpec :: OneofSubfield -> WriterT FieldOccurrences m FieldSpec
          mkSubfieldSpec :: OneofSubfield -> WriterT FieldOccurrences m FieldSpec
mkSubfieldSpec (OneofSubfield
                            { subfieldNumber :: OneofSubfield -> FieldNumber
subfieldNumber = FieldNumber
subfieldNum
                            , subfieldName :: OneofSubfield -> FieldName
subfieldName = FieldName
subfieldName
                            , subfieldType :: OneofSubfield -> DotProtoType
subfieldType = DotProtoType
dpType
                            }) = do
            FieldOccurrences -> WriterT FieldOccurrences m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (FieldName -> Histogram FieldName
forall a. a -> Histogram a
oneOccurrence FieldName
subfieldName, FieldNumber -> Histogram FieldNumber
forall a. a -> Histogram a
oneOccurrence FieldNumber
subfieldNum)
            GenLocated SrcSpanAnnA (HsType GhcPs)
protoType <- TypeContext
-> DotProtoType -> WriterT FieldOccurrences m (LHsType GhcPs)
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoType -> m (LHsType GhcPs)
dptToFormType TypeContext
ctxt DotProtoType
dpType
            FieldSpec -> WriterT FieldOccurrences m FieldSpec
forall a. a -> WriterT FieldOccurrences m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldSpec
                   { fieldSpecName :: FieldName
fieldSpecName = FieldName
subfieldName
                   , fieldSpecNumber :: FieldNumber
fieldSpecNumber = FieldNumber
subfieldNum
                   , fieldSpecOneOf :: Maybe FieldName
fieldSpecOneOf = FieldName -> Maybe FieldName
forall a. a -> Maybe a
Just FieldName
oneofName
                   , fieldSpecCardinality :: LHsType GhcPs
fieldSpecCardinality = LHsType GhcPs
formOptionalT
                   , fieldSpecProtoType :: LHsType GhcPs
fieldSpecProtoType = LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
protoType
                   }

-- *** Generate Protobuf 'Message' type class instances

messageInstD ::
  forall m .
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  TypeContext ->
  DotProtoIdentifier ->
  DotProtoIdentifier ->
  [DotProtoMessagePart] ->
  m HsDecl
messageInstD :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
messageInstD TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent [DotProtoMessagePart]
messageParts = do
     String
msgName         <- DotProtoIdentifier -> DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent
     [QualifiedField]
qualifiedFields <- String -> [DotProtoMessagePart] -> m [QualifiedField]
forall (m :: * -> *).
MonadError CompileError m =>
String -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields String
msgName [DotProtoMessagePart]
messageParts

     [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
encodedFields   <- (QualifiedField -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [QualifiedField] -> m [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM QualifiedField -> m HsExp
QualifiedField -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
encodeMessageField [QualifiedField]
qualifiedFields
     [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
decodedFields   <- (QualifiedField -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [QualifiedField] -> m [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM QualifiedField -> m HsExp
QualifiedField -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
decodeMessageField [QualifiedField]
qualifiedFields

     let encodeMessageBind :: HsBind
         encodeMessageBind :: HsBind
encodeMessageBind =
           String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"encodeMessage" [([HsPat
wild_, HsPat
recordPattern], HsExp
encodeMessageE)]

         encodeMessageE :: HsExp
         encodeMessageE :: HsExp
encodeMessageE = case [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
encodedFields of
           [] -> HsExp
memptyE
           (GenLocated SrcSpanAnnA (HsExpr GhcPs)
field : [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
fields) -> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
op (HsExp -> HsExp
paren HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
field) [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
fields
             where op :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExp
op GenLocated SrcSpanAnnA (HsExpr GhcPs)
fs GenLocated SrcSpanAnnA (HsExpr GhcPs)
f = HsExp -> [HsExp] -> HsExp
apply (HsExp -> [HsExp] -> HsExp
apply HsExp
mappendE [HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
fs]) [HsExp -> HsExp
paren HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
f]
             -- NOTE: We use a left fold because this way the leftmost field
             -- is the most nested and the rightmost field--the one to be written
             -- first by the right-to-left builder--is the one that is least nested.

         recordPattern :: HsPat
         recordPattern :: HsPat
recordPattern = HsName -> [LHsRecField GhcPs HsPat] -> HsPat
recPat (NameSpace -> String -> HsName
unqual_ NameSpace
dataName String
msgName) [LHsRecField GhcPs HsPat]
punnedFieldsP

         punnedFieldsP :: [GHC.LHsRecField GHC.GhcPs HsPat]
         punnedFieldsP :: [LHsRecField GhcPs HsPat]
punnedFieldsP = (QualifiedField
 -> GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (Pat GhcPs))))
-> [QualifiedField]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (Pat GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map (String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (Pat GhcPs)))
fp (String
 -> GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (Pat GhcPs))))
-> (QualifiedField -> String)
-> QualifiedField
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> String
forall a b. Coercible a b => a -> b
coerce (FieldName -> String)
-> (QualifiedField -> FieldName) -> QualifiedField -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedField -> FieldName
recordFieldName) [QualifiedField]
qualifiedFields
           where
             fp :: String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (Pat GhcPs)))
fp = HsName -> LHsRecField GhcPs HsPat
GenLocated SrcSpanAnnN RdrName
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (Pat GhcPs)))
fieldPunPat (GenLocated SrcSpanAnnN RdrName
 -> GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (Pat GhcPs))))
-> (String -> GenLocated SrcSpanAnnN RdrName)
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> String -> HsName
unqual_ NameSpace
varName

     let decodeMessageBind :: HsBind
         decodeMessageBind :: HsBind
decodeMessageBind = String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"decodeMessage" [([HsPat
wild_], HsExp
decodeMessageE)]

         decodeMessageE :: HsExp
         decodeMessageE :: HsExp
decodeMessageE = (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\GenLocated SrcSpanAnnA (HsExpr GhcPs)
f -> HsExp -> HsExp -> HsExp -> HsExp
opApp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
f HsExp
apOp)
                                (HsExp -> [HsExp] -> HsExp
apply HsExp
pureE [ String -> HsExp
uvar_ String
msgName ])
                                [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
decodedFields

     let dotProtoBind :: HsBind
         dotProtoBind :: HsBind
dotProtoBind = String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"dotProto" [([HsPat
wild_], HsExp
dotProtoE)]

         dotProtoE :: HsExp
         dotProtoE :: HsExp
dotProtoE = [HsExp] -> HsExp
list_ ([HsExp] -> HsExp) -> [HsExp] -> HsExp
forall a b. (a -> b) -> a -> b
$ do
           DotProtoMessageField DotProtoField{String
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldComment :: DotProtoField -> String
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
dotProtoFieldNumber :: FieldNumber
dotProtoFieldType :: DotProtoType
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldComment :: String
..} <- [DotProtoMessagePart]
messageParts
           HsExp -> [HsExp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> [HsExp]) -> HsExp -> [HsExp]
forall a b. (a -> b) -> a -> b
$ HsExp -> [HsExp] -> HsExp
apply HsExp
dotProtoFieldC
                        [ FieldNumber -> HsExp
fieldNumberE FieldNumber
dotProtoFieldNumber
                        , DotProtoType -> HsExp
dpTypeE DotProtoType
dotProtoFieldType
                        , DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
dotProtoFieldName
                        , [HsExp] -> HsExp
list_ ((DotProtoOption -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [DotProtoOption] -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map DotProtoOption -> HsExp
DotProtoOption -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
optionE [DotProtoOption]
dotProtoFieldOptions)
                        , String -> HsExp
str_ String
dotProtoFieldComment
                        ]

     HsDecl -> m HsDecl
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsDecl -> m HsDecl) -> HsDecl -> m HsDecl
forall a b. (a -> b) -> a -> b
$ HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
protobufName NameSpace
tcName String
"Message")
                      [ String -> LHsType GhcPs
type_ String
msgName ]
                      [ HsBind
encodeMessageBind
                      , HsBind
decodeMessageBind
                      , HsBind
dotProtoBind
                      ]
  where
    encodeMessageField :: QualifiedField -> m HsExp
    encodeMessageField :: QualifiedField -> m HsExp
encodeMessageField QualifiedField{FieldName
recordFieldName :: QualifiedField -> FieldName
recordFieldName :: FieldName
recordFieldName, FieldInfo
fieldInfo :: QualifiedField -> FieldInfo
fieldInfo :: FieldInfo
fieldInfo} =
      let recordFieldName' :: HsExp
recordFieldName' = String -> HsExp
uvar_ (FieldName -> String
forall a b. Coercible a b => a -> b
coerce FieldName
recordFieldName) in
      case FieldInfo
fieldInfo of
        FieldNormal FieldName
_fieldName FieldNumber
fieldNum DotProtoType
dpType [DotProtoOption]
options -> do
            GenLocated SrcSpanAnnA (HsExpr GhcPs)
fieldE <- FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
wrapE FieldContext
WithinMessage TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
recordFieldName'
            HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> [HsExp] -> HsExp
apply HsExp
encodeMessageFieldE [ FieldNumber -> HsExp
fieldNumberE FieldNumber
fieldNum, HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
fieldE ]

        FieldOneOf FieldName
_ OneofField{[OneofSubfield]
subfields :: OneofField -> [OneofSubfield]
subfields :: [OneofSubfield]
subfields} -> do
            [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts <- (OneofSubfield
 -> m (GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [OneofSubfield]
-> m [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM OneofSubfield
-> m (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall {m :: * -> *}.
(MonadError CompileError m, ?stringType::StringType) =>
OneofSubfield
-> m (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
mkAlt [OneofSubfield]
subfields
            HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> [HsAlt] -> HsExp
case_ HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
recordFieldName'
                    [ HsPat -> HsExp -> HsAlt
alt_ (HsName -> [HsPat] -> HsPat
conPat HsName
nothingN []) HsExp
memptyE
                    , HsPat -> HsExp -> HsAlt
alt_ (HsName -> [HsPat] -> HsPat
conPat HsName
justN [String -> HsPat
patVar String
"x"]) (HsExp -> [HsAlt] -> HsExp
case_ (String -> HsExp
uvar_ String
"x") [HsAlt]
[GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts)
                    ]
          where
            -- Create all pattern match & expr for each constructor:
            --    Constructor y -> encodeMessageField num (Nested (Just y)) -- for embedded messages
            --    Constructor y -> encodeMessageField num (ForceEmit y)     -- for everything else
            mkAlt :: OneofSubfield
-> m (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
mkAlt (OneofSubfield
                     { subfieldNumber :: OneofSubfield -> FieldNumber
subfieldNumber = FieldNumber
fieldNum
                     , subfieldConsName :: OneofSubfield -> String
subfieldConsName = String
conName
                     , subfieldType :: OneofSubfield -> DotProtoType
subfieldType = DotProtoType
dpType
                     , subfieldOptions :: OneofSubfield -> [DotProtoOption]
subfieldOptions = [DotProtoOption]
options
                     }) = do
              let isMaybe :: Bool
isMaybe
                     | Prim (Named DotProtoIdentifier
tyName) <- DotProtoType
dpType
                     = TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName
                     | Bool
otherwise
                     = Bool
False

              let wrapJust :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrapJust = HsExp -> HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
paren (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExp -> HsExp -> HsExp
app HsExp
justC

              GenLocated SrcSpanAnnA (HsExpr GhcPs)
xE <- (if Bool
isMaybe then m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> a
id else (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsExp -> HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forceEmitE)
                     (m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (HsExp -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> HsExp
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
wrapE FieldContext
WithinMessage TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType
                         -- For now we use 'WithinMessage' to preserve
                         -- the historical approach of treating this field
                         -- as if it were an ordinary non-oneof field that
                         -- just happens to be present, then forcing it to
                         -- be emitted.
                     (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isMaybe then GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrapJust else GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a. a -> a
id)
                     (HsExp -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> HsExp -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ String -> HsExp
uvar_ String
"y"

              HsAlt -> m HsAlt
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsAlt -> m HsAlt) -> HsAlt -> m HsAlt
forall a b. (a -> b) -> a -> b
$ HsPat -> HsExp -> HsAlt
alt_ (HsName -> [HsPat] -> HsPat
conPat (NameSpace -> String -> HsName
unqual_ NameSpace
dataName String
conName) [String -> HsPat
patVar String
"y"])
                          (HsExp -> [HsExp] -> HsExp
apply HsExp
encodeMessageFieldE [FieldNumber -> HsExp
fieldNumberE FieldNumber
fieldNum, HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
xE])

    decodeMessageField :: QualifiedField -> m HsExp
    decodeMessageField :: QualifiedField -> m HsExp
decodeMessageField QualifiedField{FieldInfo
fieldInfo :: QualifiedField -> FieldInfo
fieldInfo :: FieldInfo
fieldInfo} =
      case FieldInfo
fieldInfo of
        FieldNormal FieldName
_fieldName FieldNumber
fieldNum DotProtoType
dpType [DotProtoOption]
options ->
            FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
unwrapE FieldContext
WithinMessage TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$
              HsExp -> [HsExp] -> HsExp
apply HsExp
atE [ HsExp
decodeMessageFieldE, FieldNumber -> HsExp
fieldNumberE FieldNumber
fieldNum ]

        FieldOneOf FieldName
_ OneofField{[OneofSubfield]
subfields :: OneofField -> [OneofSubfield]
subfields :: [OneofSubfield]
subfields} -> do
            [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
parsers <- (OneofSubfield -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [OneofSubfield] -> m [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM OneofSubfield -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall {m :: * -> *}.
(MonadError CompileError m, ?stringType::StringType) =>
OneofSubfield -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
subfieldParserE [OneofSubfield]
subfields
            HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> [HsExp] -> HsExp
apply HsExp
oneofE [ HsExp
nothingC, [HsExp] -> HsExp
list_ [HsExp]
[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
parsers ]
          where
            -- create a list of (fieldNumber, Cons <$> parser)
            subfieldParserE :: OneofSubfield -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
subfieldParserE (OneofSubfield
                               { subfieldNumber :: OneofSubfield -> FieldNumber
subfieldNumber = FieldNumber
fieldNumber
                               , subfieldConsName :: OneofSubfield -> String
subfieldConsName = String
consName
                               , subfieldType :: OneofSubfield -> DotProtoType
subfieldType = DotProtoType
dpType
                               , subfieldOptions :: OneofSubfield -> [DotProtoOption]
subfieldOptions = [DotProtoOption]
options
                               }) = do
              let fE :: HsExp
fE | Prim (Named DotProtoIdentifier
tyName) <- DotProtoType
dpType, TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName =
                         HsExp -> HsExp
paren (HsExp -> HsExp -> HsExp
app HsExp
fmapE (String -> HsExp
uvar_ String
consName))
                     | Bool
otherwise =
                         HsExp -> HsExp
paren (HsExp -> HsExp -> HsExp -> HsExp
opApp HsExp
justC HsExp
composeOp (String -> HsExp
uvar_ String
consName))

              -- For now we continue the historical practice of parsing
              -- submessages within oneofs as if were outside of oneofs,
              -- and replacing the "Just . Ctor" with "fmap . Ctor".
              -- That is why we do not pass WithinOneOf.
              GenLocated SrcSpanAnnA (HsExpr GhcPs)
alts <- FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
unwrapE FieldContext
WithinMessage TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType HsExp
decodeMessageFieldE

              HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ [HsExp] -> HsExp
tuple_
                   [ FieldNumber -> HsExp
fieldNumberE FieldNumber
fieldNumber
                   , HsExp -> HsExp -> HsExp -> HsExp
opApp (HsExp -> [HsExp] -> HsExp
apply HsExp
pureE [ HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
fE ]) HsExp
apOp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
alts
                   ]


-- *** Generate ToJSONPB/FromJSONPB instances

toJSONPBMessageInstD ::
  forall m .
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  TypeContext ->
  DotProtoIdentifier ->
  DotProtoIdentifier ->
  [DotProtoMessagePart] ->
  m HsDecl
toJSONPBMessageInstD :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
toJSONPBMessageInstD TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent [DotProtoMessagePart]
messageParts = do
    String
msgName    <- DotProtoIdentifier -> DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent
    [QualifiedField]
qualFields <- String -> [DotProtoMessagePart] -> m [QualifiedField]
forall (m :: * -> *).
MonadError CompileError m =>
String -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields String
msgName [DotProtoMessagePart]
messageParts

    let applyE :: String -> String -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
applyE String
nm String
oneofNm = do
          [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
fs <- (QualifiedField -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [QualifiedField] -> m [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (String -> QualifiedField -> m HsExp
encodeMessageField String
oneofNm) [QualifiedField]
qualFields
          HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> [HsExp] -> HsExp
apply (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
nm)) [[HsExp] -> HsExp
list_ [HsExp]
[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
fs]

    let patBinder :: QualifiedField -> String
patBinder = (FieldName -> FieldNumber -> String)
-> (OneofField -> String) -> QualifiedField -> String
forall a.
(FieldName -> FieldNumber -> a)
-> (OneofField -> a) -> QualifiedField -> a
foldQF ((FieldNumber -> String) -> FieldName -> FieldNumber -> String
forall a b. a -> b -> a
const FieldNumber -> String
fieldBinder) ([OneofSubfield] -> String
oneofSubDisjunctBinder ([OneofSubfield] -> String)
-> (OneofField -> [OneofSubfield]) -> OneofField -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneofField -> [OneofSubfield]
subfields)
    let matchE :: String
-> String
-> String
-> m (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
matchE String
nm String
appNm String
oneofAppNm = do
          GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs <- String -> String -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
applyE String
appNm String
oneofAppNm
          HsBind -> m HsBind
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsBind -> m HsBind) -> HsBind -> m HsBind
forall a b. (a -> b) -> a -> b
$ String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
nm
            [ ( [HsName -> [HsPat] -> HsPat
conPat (NameSpace -> String -> HsName
unqual_ NameSpace
dataName String
msgName) (String -> HsPat
String -> GenLocated SrcSpanAnnA (Pat GhcPs)
patVar (String -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> (QualifiedField -> String)
-> QualifiedField
-> GenLocated SrcSpanAnnA (Pat GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedField -> String
patBinder (QualifiedField -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [QualifiedField] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QualifiedField]
qualFields)]
              , HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs
              )
            ]

    GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
toJSONPB <- String
-> String
-> String
-> m (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
matchE String
"toJSONPB" String
"object" String
"objectOrNull"
    GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
toEncoding <- String
-> String
-> String
-> m (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
matchE String
"toEncodingPB" String
"pairs" String
"pairsOrNull"

    HsDecl -> m HsDecl
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsDecl -> m HsDecl) -> HsDecl -> m HsDecl
forall a b. (a -> b) -> a -> b
$ HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
jsonpbName NameSpace
tcName String
"ToJSONPB")
                     [ String -> LHsType GhcPs
type_ String
msgName ]
                     [ HsBind
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
toJSONPB
                     , HsBind
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
toEncoding
                     ]

  where
    encodeMessageField :: String -> QualifiedField -> m HsExp
    encodeMessageField :: String -> QualifiedField -> m HsExp
encodeMessageField String
oneofNm (QualifiedField FieldName
_ FieldInfo
fieldInfo) =
      case FieldInfo
fieldInfo of
        FieldNormal FieldName
fldName FieldNumber
fldNum DotProtoType
dpType [DotProtoOption]
options ->
          FieldName
-> FieldNumber
-> DotProtoType
-> [DotProtoOption]
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall {a} {m :: * -> *}.
(Coercible a String, MonadError CompileError m,
 ?stringType::StringType) =>
a
-> FieldNumber
-> DotProtoType
-> [DotProtoOption]
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
defPairE FieldName
fldName FieldNumber
fldNum DotProtoType
dpType [DotProtoOption]
options
        FieldOneOf FieldName
_ OneofField
oo ->
          String -> OneofField -> m HsExp
oneofCaseE String
oneofNm OneofField
oo

    -- E.g.
    -- "another" .= f2 -- always succeeds (produces default value on missing field)
    defPairE :: a
-> FieldNumber
-> DotProtoType
-> [DotProtoOption]
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
defPairE a
fldName FieldNumber
fldNum DotProtoType
dpType [DotProtoOption]
options = do
      GenLocated SrcSpanAnnA (HsExpr GhcPs)
w <- FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
wrapE FieldContext
WithinMessage TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType (String -> HsExp
uvar_ (FieldNumber -> String
fieldBinder FieldNumber
fldNum))
      HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> HsExp -> HsExp -> HsExp
opApp (String -> HsExp
str_ (a -> String
forall a b. Coercible a b => a -> b
coerce a
fldName)) HsExp
toJSONPBOp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
w

    -- E.g.
    -- HsJSONPB.pair "name" f4 -- fails on missing field
    oneOfPairE :: a
-> String
-> [DotProtoOption]
-> DotProtoType
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oneOfPairE a
fldNm String
varNm [DotProtoOption]
options DotProtoType
dpType = do
      GenLocated SrcSpanAnnA (HsExpr GhcPs)
w <- FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
wrapE FieldContext
WithinOneOf TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType (String -> HsExp
uvar_ String
varNm)
      HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> [HsExp] -> HsExp
apply (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"pair")) [String -> HsExp
str_ (a -> String
forall a b. Coercible a b => a -> b
coerce a
fldNm), HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
w]

    -- Suppose we have a sum type Foo, nested inside a message Bar.
    -- We want to generate the following:
    --
    -- > toJSONPB (Bar foo more stuff) =
    -- >   HsJSONPB.object
    -- >     [ (let encodeFoo = (<case expr scrutinising foo> :: Options -> Value)
    -- >        in \option -> if optEmitNamedOneof option
    -- >                      then ("Foo" .= (PB.objectOrNull [encodeFoo] option)) option
    -- >                      else encodeFoo option
    -- >       )
    -- >     , <encode more>
    -- >     , <encode stuff>
    -- >     ]
    oneofCaseE :: String -> OneofField -> m HsExp
    oneofCaseE :: String -> OneofField -> m HsExp
oneofCaseE String
retJsonCtor (OneofField String
typeName [OneofSubfield]
subfields) = do
        [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
altEs <- (OneofSubfield
 -> m (GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [OneofSubfield]
-> m [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse OneofSubfield
-> m (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall {m :: * -> *}.
(MonadError CompileError m, ?stringType::StringType) =>
OneofSubfield
-> m (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
altE [OneofSubfield]
subfields
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ HsExp -> HsExp
paren
          (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$ [HsBind] -> HsExp -> HsExp
let_ [ String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
caseName [([], [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
caseExpr [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
altEs)] ]
          (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$ [HsPat] -> HsExp -> HsExp
lambda_ [String -> HsPat
patVar String
optsStr] (HsExp -> HsExp -> HsExp -> HsExp
if_ HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
dontInline HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
noInline HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
yesInline)
      where
        optsStr :: String
optsStr = String
"options"
        opts :: HsExp
opts    = String -> HsExp
uvar_ String
optsStr

        caseName :: String
caseName = String
"encode" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Index String -> Traversal' String (IxValue String)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index String
0) Char -> Char
toUpper String
typeName
        caseBnd :: HsExp
caseBnd = String -> HsExp
uvar_ String
caseName

        dontInline :: HsExp
dontInline = HsExp -> HsExp -> HsExp
app (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"optEmitNamedOneof")) HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
opts

        noInline :: HsExp
noInline = HsExp -> HsExp -> HsExp
app (HsExp -> HsExp
paren (HsExp -> HsExp -> HsExp -> HsExp
opApp (String -> HsExp
str_ String
typeName)
                                     HsExp
toJSONPBOp
                                     (HsExp -> [HsExp] -> HsExp
apply (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
retJsonCtor))
                                            [ [HsExp] -> HsExp
list_ [HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
caseBnd], HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
opts ])))
                       HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
opts

        yesInline :: HsExp
yesInline = HsExp -> HsExp -> HsExp
app HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
caseBnd HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
opts

        altE :: OneofSubfield
-> m (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
altE sub :: OneofSubfield
sub@(OneofSubfield
                    { subfieldConsName :: OneofSubfield -> String
subfieldConsName = String
conName
                    , subfieldName :: OneofSubfield -> FieldName
subfieldName = FieldName
pbFldNm
                    , subfieldType :: OneofSubfield -> DotProtoType
subfieldType = DotProtoType
dpType
                    , subfieldOptions :: OneofSubfield -> [DotProtoOption]
subfieldOptions = [DotProtoOption]
options
                    }) = do
          let patVarNm :: String
patVarNm = OneofSubfield -> String
oneofSubBinder OneofSubfield
sub
          GenLocated SrcSpanAnnA (HsExpr GhcPs)
p <- FieldName
-> String
-> [DotProtoOption]
-> DotProtoType
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall {a} {m :: * -> *}.
(Coercible a String, MonadError CompileError m,
 ?stringType::StringType) =>
a
-> String
-> [DotProtoOption]
-> DotProtoType
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
oneOfPairE FieldName
pbFldNm String
patVarNm [DotProtoOption]
options DotProtoType
dpType
          HsAlt -> m HsAlt
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsAlt -> m HsAlt) -> HsAlt -> m HsAlt
forall a b. (a -> b) -> a -> b
$
            HsPat -> HsExp -> HsAlt
alt_ (HsName -> [HsPat] -> HsPat
conPat HsName
justN [HsPat -> HsPat
parenPat (HsName -> [HsPat] -> HsPat
conPat (NameSpace -> String -> HsName
unqual_ NameSpace
dataName String
conName) [String -> HsPat
patVar String
patVarNm])]) HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
p

        -- E.g.
        -- case f4_or_f9 of
        --   Just (SomethingPickOneName f4)
        --     -> HsJSONPB.pair "name" f4
        --   Just (SomethingPickOneSomeid f9)
        --     -> HsJSONPB.pair "someid" f9
        --   Nothing
        --     -> mempty
        caseExpr :: [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> HsExp
caseExpr [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
altEs = HsExp -> HsExp
paren (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$
            HsExp -> [HsAlt] -> HsExp
case_ HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
disjunctName ([GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
altEs [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. Semigroup a => a -> a -> a
<> [GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
fallthroughE])
          where
            disjunctName :: HsExp
disjunctName = String -> HsExp
uvar_ ([OneofSubfield] -> String
oneofSubDisjunctBinder [OneofSubfield]
subfields)
            fallthroughE :: HsAlt
fallthroughE = HsPat -> HsExp -> HsAlt
alt_ (HsName -> [HsPat] -> HsPat
conPat HsName
nothingN []) HsExp
memptyE

fromJSONPBMessageInstD ::
  forall m .
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  TypeContext ->
  DotProtoIdentifier ->
  DotProtoIdentifier ->
  [DotProtoMessagePart] ->
  m HsDecl
fromJSONPBMessageInstD :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
fromJSONPBMessageInstD TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent [DotProtoMessagePart]
messageParts = do
    String
msgName    <- DotProtoIdentifier -> DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent
    [QualifiedField]
qualFields <- String -> [DotProtoMessagePart] -> m [QualifiedField]
forall (m :: * -> *).
MonadError CompileError m =>
String -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields String
msgName [DotProtoMessagePart]
messageParts

    [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
fieldParsers <- (QualifiedField -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [QualifiedField] -> m [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse QualifiedField -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
parseField [QualifiedField]
qualFields

    let parseJSONPBE :: HsExp
parseJSONPBE =
          HsExp -> [HsExp] -> HsExp
apply (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"withObject"))
                [ String -> HsExp
str_ String
msgName
                , HsExp -> HsExp
paren ([HsPat] -> HsExp -> HsExp
lambda_ [HsPat
GenLocated SrcSpanAnnA (Pat GhcPs)
lambdaPVar] HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
fieldAps)
                ]
          where
            fieldAps :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
fieldAps = (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\GenLocated SrcSpanAnnA (HsExpr GhcPs)
f -> HsExp -> HsExp -> HsExp -> HsExp
opApp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
f HsExp
apOp)
                             (HsExp -> [HsExp] -> HsExp
apply HsExp
pureE [ String -> HsExp
uvar_ String
msgName ])
                             [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
fieldParsers

    let parseJSONPBBind :: HsBind
parseJSONPBBind = String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"parseJSONPB" [([], HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
parseJSONPBE)]

    GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
jsonpbName NameSpace
tcName String
"FromJSONPB")
                    [ String -> LHsType GhcPs
type_ String
msgName ]
                    [ HsBind
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
parseJSONPBBind ])
  where
    lambdaPVar :: HsPat
lambdaPVar = String -> HsPat
patVar String
"obj"
    lambdaVar :: HsExp
lambdaVar  = String -> HsExp
uvar_ String
"obj"

    parseField :: QualifiedField -> m HsExp
parseField (QualifiedField FieldName
_ (FieldNormal FieldName
fldName FieldNumber
_ DotProtoType
dpType [DotProtoOption]
options)) =
      FieldName -> DotProtoType -> [DotProtoOption] -> m HsExp
normalParserE FieldName
fldName DotProtoType
dpType [DotProtoOption]
options
    parseField (QualifiedField FieldName
_ (FieldOneOf FieldName
_ OneofField
fld)) =
      OneofField -> m HsExp
oneofParserE OneofField
fld

    -- E.g., for message
    --   message Something { oneof name_or_id { string name = _; int32 someid = _; } }
    --
    -- ==>
    --
    -- (let parseSomethingNameOrId parseObj = <FUNCTION, see tryParseDisjunctsE>
    --  in ((obj .: "nameOrId") Hs.>>=
    --      (HsJSONPB.withObject "nameOrId" parseSomethingNameOrId))
    --     <|>
    --     (parseSomethingNameOrId obj)
    -- )
    oneofParserE :: OneofField -> m HsExp
    oneofParserE :: OneofField -> m HsExp
oneofParserE (OneofField String
oneofType [OneofSubfield]
fields) = do
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
ds <- m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
tryParseDisjunctsE
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ HsExp -> HsExp
paren (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$
          [HsBind] -> HsExp -> HsExp
let_ [ String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
letBndStr [([String -> HsPat
patVar String
letArgStr], HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
ds)] ]
               (HsExp -> HsExp -> HsExp -> HsExp
opApp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
parseWrapped HsExp
altOp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
parseUnwrapped)
      where
        oneofTyLit :: HsExp
oneofTyLit = String -> HsExp
str_ String
oneofType -- FIXME

        letBndStr :: String
letBndStr  = String
"parse" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Index String -> Traversal' String (IxValue String)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index String
0) Char -> Char
toUpper String
oneofType
        letBndName :: HsExp
letBndName = String -> HsExp
uvar_ String
letBndStr
        letArgStr :: String
letArgStr  = String
"parseObj"
        letArgName :: HsExp
letArgName = String -> HsExp
uvar_ String
letArgStr

        parseWrapped :: HsExp
parseWrapped = HsExp -> HsExp
paren (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$
          HsExp -> HsExp -> HsExp -> HsExp
opApp (HsExp -> HsExp -> HsExp -> HsExp
opApp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
lambdaVar HsExp
parseJSONPBOp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
oneofTyLit)
                HsExp
bindOp
                (HsExp -> [HsExp] -> HsExp
apply (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"withObject")) [ HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
oneofTyLit , HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
letBndName ])

        parseUnwrapped :: HsExp
parseUnwrapped = HsExp -> HsExp
paren (HsExp -> HsExp -> HsExp
app HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
letBndName HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
lambdaVar)

        -- parseSomethingNameOrId parseObj =
        --   Hs.msum
        --     [ (Just . SomethingPickOneName) <$> (HsJSONPB.parseField parseObj "name")
        --     , (Just . SomethingPickOneSomeid) <$> (HsJSONPB.parseField parseObj "someid")
        --     , pure Nothing
        --     ]
        tryParseDisjunctsE :: m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
tryParseDisjunctsE = do
          [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
fs <- (OneofSubfield -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [OneofSubfield] -> m [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse OneofSubfield -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall {m :: * -> *}.
(MonadError CompileError m, ?stringType::StringType) =>
OneofSubfield -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
subParserE [OneofSubfield]
fields
          HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> HsExp -> HsExp
app HsExp
msumE ([HsExp] -> HsExp
list_ ([GenLocated SrcSpanAnnA (HsExpr GhcPs)]
fs [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a. Semigroup a => a -> a -> a
<> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
fallThruE))

        fallThruE :: [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
fallThruE = [ HsExp -> HsExp -> HsExp
app HsExp
pureE HsExp
nothingC ]

        subParserE :: OneofSubfield -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
subParserE OneofSubfield{String
subfieldConsName :: OneofSubfield -> String
subfieldConsName :: String
subfieldConsName, FieldName
subfieldName :: OneofSubfield -> FieldName
subfieldName :: FieldName
subfieldName,
                                 DotProtoType
subfieldType :: OneofSubfield -> DotProtoType
subfieldType :: DotProtoType
subfieldType, [DotProtoOption]
subfieldOptions :: OneofSubfield -> [DotProtoOption]
subfieldOptions :: [DotProtoOption]
subfieldOptions} = do
          Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
maybeCoercion <-
            Bool
-> FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
Bool
-> FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
unwrapFunE Bool
False FieldContext
WithinOneOf TypeContext
ctxt [DotProtoOption]
subfieldOptions DotProtoType
subfieldType
          let inject :: HsExp
inject = HsExp -> HsExp -> HsExp -> HsExp
opApp HsExp
justC HsExp
composeOp (String -> HsExp
uvar_ String
subfieldConsName)
          HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> HsExp -> HsExp -> HsExp
opApp
              (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GenLocated SrcSpanAnnA (HsExpr GhcPs)
inject (HsExp -> HsExp -> HsExp -> HsExp
opApp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
inject HsExp
composeOp) Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
maybeCoercion)
              HsExp
fmapOp
              (HsExp -> [HsExp] -> HsExp
apply (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"parseField"))
                     [ HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
letArgName
                     , String -> HsExp
str_ (FieldName -> String
forall a b. Coercible a b => a -> b
coerce FieldName
subfieldName)])

    -- E.g. obj .: "someid"
    normalParserE :: FieldName -> DotProtoType -> [DotProtoOption] -> m HsExp
    normalParserE :: FieldName -> DotProtoType -> [DotProtoOption] -> m HsExp
normalParserE FieldName
fldName DotProtoType
dpType [DotProtoOption]
options =
      FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
unwrapE FieldContext
WithinMessage TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$
        HsExp -> HsExp -> HsExp -> HsExp
opApp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
lambdaVar
                   HsExp
parseJSONPBOp
                   (String -> HsExp
str_(FieldName -> String
forall a b. Coercible a b => a -> b
coerce FieldName
fldName))

-- *** Generate default Aeson To/FromJSON and Swagger ToSchema instances
-- (These are defined in terms of ToJSONPB)

toJSONInstDecl :: String -> HsDecl
toJSONInstDecl :: String -> HsDecl
toJSONInstDecl String
typeName =
  HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
jsonpbName NameSpace
tcName String
"ToJSON")
            [ String -> LHsType GhcPs
type_ String
typeName ]
            [ String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"toJSON"
                         [([], HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"toAesonValue"))]
            , String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"toEncoding"
                         [([], HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"toAesonEncoding"))]
            ]

fromJSONInstDecl :: String -> HsDecl
fromJSONInstDecl :: String -> HsDecl
fromJSONInstDecl String
typeName =
  HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
jsonpbName NameSpace
tcName String
"FromJSON")
            [ String -> LHsType GhcPs
type_ String
typeName ]
            [ String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"parseJSON"
                         [([], HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"parseJSONPB"))]
            ]


-- *** Generate `ToSchema` instance

#ifdef SWAGGER
getFieldNameForSchemaInstanceDeclaration
  :: MonadError CompileError m
  => DotProtoField
  -> m (Maybe ([DotProtoOption], DotProtoType), String)
getFieldNameForSchemaInstanceDeclaration :: forall (m :: * -> *).
MonadError CompileError m =>
DotProtoField -> m (Maybe ([DotProtoOption], DotProtoType), String)
getFieldNameForSchemaInstanceDeclaration DotProtoField
fld = do
  String
unqual <- DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName (DotProtoField -> DotProtoIdentifier
dotProtoFieldName DotProtoField
fld)
  let optsType :: ([DotProtoOption], DotProtoType)
optsType = (DotProtoField -> [DotProtoOption]
dotProtoFieldOptions DotProtoField
fld, DotProtoField -> DotProtoType
dotProtoFieldType DotProtoField
fld)
  (Maybe ([DotProtoOption], DotProtoType), String)
-> m (Maybe ([DotProtoOption], DotProtoType), String)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([DotProtoOption], DotProtoType)
-> Maybe ([DotProtoOption], DotProtoType)
forall a. a -> Maybe a
Just ([DotProtoOption], DotProtoType)
optsType, String
unqual)

toSchemaInstanceDeclaration ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  TypeContext ->
  -- | Name of the message type to create an instance for
  String ->
  -- | Oneof constructors
  Maybe [HsName] ->
  -- | Field names, with every field that is not actually a oneof
  -- combining fields paired with its options and protobuf type
  [(Maybe ([DotProtoOption], DotProtoType), String)] ->
  m HsDecl
toSchemaInstanceDeclaration :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext
-> String
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
-> m HsDecl
toSchemaInstanceDeclaration TypeContext
ctxt String
messageName Maybe [HsName]
maybeConstructors [(Maybe ([DotProtoOption], DotProtoType), String)]
fieldNamesEtc = do
  let fieldNames :: [String]
fieldNames = ((Maybe ([DotProtoOption], DotProtoType), String) -> String)
-> [(Maybe ([DotProtoOption], DotProtoType), String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe ([DotProtoOption], DotProtoType), String) -> String
forall a b. (a, b) -> b
snd [(Maybe ([DotProtoOption], DotProtoType), String)]
fieldNamesEtc

  [String]
qualifiedFieldNames <- (String -> m String) -> [String] -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedFieldName String
messageName) [String]
fieldNames

  let messageConstructor :: HsExp
messageConstructor = String -> HsExp
uvar_ String
messageName

  let _namedSchemaNameExpression :: HsExp
_namedSchemaNameExpression = HsExp -> HsExp -> HsExp
app HsExp
justC (String -> HsExp
str_ String
messageName)

#ifdef SWAGGER
      -- { _paramSchemaType = HsJSONPB.SwaggerObject
      -- }
  let paramSchemaUpdates :: [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
paramSchemaUpdates =
        [ HsName -> HsExp -> LHsRecUpdField GhcPs GhcPs
fieldUpd_ HsName
GenLocated SrcSpanAnnN RdrName
_paramSchemaType HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
_paramSchemaTypeExpression
        ]
        where
          _paramSchemaType :: HsName
_paramSchemaType = NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"_paramSchemaType"

#if MIN_VERSION_swagger2(2,4,0)
          _paramSchemaTypeExpression :: HsExp
_paramSchemaTypeExpression = HsExp -> HsExp -> HsExp
app HsExp
justC (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
dataName String
"SwaggerObject"))
#else
          _paramSchemaTypeExpression = var_ (jsonpbName dataName "SwaggerObject")
#endif
#else
  let paramSchemaUpdates = []
#endif

  let _schemaParamSchemaExpression :: HsExp
_schemaParamSchemaExpression = HsExp -> [LHsRecUpdField GhcPs GhcPs] -> HsExp
recordUpd_ HsExp
memptyE [LHsRecUpdField GhcPs GhcPs]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
paramSchemaUpdates

      -- [ ("fieldName0", qualifiedFieldName0)
      -- , ("fieldName1", qualifiedFieldName1)
      -- ...
      -- ]
  let properties :: HsExp
properties = [HsExp] -> HsExp
list_ ([HsExp] -> HsExp) -> [HsExp] -> HsExp
forall a b. (a -> b) -> a -> b
$ do
        (String
fieldName, String
qualifiedFieldName) <- [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
fieldNames [String]
qualifiedFieldNames
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HsExp] -> HsExp
tuple_ [ String -> HsExp
str_  String
fieldName, String -> HsExp
uvar_ String
qualifiedFieldName ])

  let _schemaPropertiesExpression :: HsExp
_schemaPropertiesExpression =
        HsExp -> HsExp -> HsExp
app (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"insOrdFromList")) HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
properties

      -- { _schemaParamSchema = ...
      -- , _schemaProperties  = ...
      -- , ...
      -- }
  let schemaUpdates :: [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
schemaUpdates = [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
normalUpdates [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
extraUpdates
        where
          normalUpdates :: [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
normalUpdates =
            [ HsName -> HsExp -> LHsRecUpdField GhcPs GhcPs
fieldUpd_ HsName
GenLocated SrcSpanAnnN RdrName
_schemaParamSchema HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
_schemaParamSchemaExpression
            , HsName -> HsExp -> LHsRecUpdField GhcPs GhcPs
fieldUpd_ HsName
GenLocated SrcSpanAnnN RdrName
_schemaProperties  HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
_schemaPropertiesExpression
            ]

          extraUpdates :: [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
extraUpdates =
            case Maybe [HsName]
maybeConstructors of
                Just [HsName]
_ ->
                  [ HsName -> HsExp -> LHsRecUpdField GhcPs GhcPs
fieldUpd_ HsName
GenLocated SrcSpanAnnN RdrName
_schemaMinProperties HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
justOne
                  , HsName -> HsExp -> LHsRecUpdField GhcPs GhcPs
fieldUpd_ HsName
GenLocated SrcSpanAnnN RdrName
_schemaMaxProperties HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
justOne
                  ]
                Maybe [HsName]
Nothing ->
                  []

          _schemaParamSchema :: HsName
_schemaParamSchema    = NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"_schemaParamSchema"
          _schemaProperties :: HsName
_schemaProperties     = NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"_schemaProperties"
          _schemaMinProperties :: HsName
_schemaMinProperties  = NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"_schemaMinProperties"
          _schemaMaxProperties :: HsName
_schemaMaxProperties  = NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"_schemaMaxProperties"

          justOne :: HsExp
justOne = HsExp -> HsExp -> HsExp
app HsExp
justC (Integer -> HsExp
forall a. Integral a => a -> HsExp
intE (Integer
1 :: Integer))

  let _namedSchemaSchemaExpression :: HsExp
_namedSchemaSchemaExpression = HsExp -> [LHsRecUpdField GhcPs GhcPs] -> HsExp
recordUpd_ HsExp
memptyE [LHsRecUpdField GhcPs GhcPs]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
schemaUpdates

      -- { _namedSchemaName   = ...
      -- , _namedSchemaSchema = ...
      -- }
  let namedSchemaBinds :: [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
namedSchemaBinds =
        [ HsName -> HsExp -> LHsRecField GhcPs HsExp
fieldBind_ HsName
GenLocated SrcSpanAnnN RdrName
_namedSchemaName   HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
_namedSchemaNameExpression
        , HsName -> HsExp -> LHsRecField GhcPs HsExp
fieldBind_ HsName
GenLocated SrcSpanAnnN RdrName
_namedSchemaSchema HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
_namedSchemaSchemaExpression
        ]
        where
          _namedSchemaName :: HsName
_namedSchemaName   = NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"_namedSchemaName"
          _namedSchemaSchema :: HsName
_namedSchemaSchema = NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"_namedSchemaSchema"

  let namedSchema :: HsExp
namedSchema = HsName -> [LHsRecField GhcPs HsExp] -> HsExp
recordCtor_ (NameSpace -> String -> HsName
jsonpbName NameSpace
dataName String
"NamedSchema") [LHsRecField GhcPs HsExp]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
namedSchemaBinds

  let toDeclareName :: String -> String
toDeclareName String
fieldName = String
"declare_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldName

  let toArgument :: FieldContext
-> (Maybe ([DotProtoOption], DotProtoType), String)
-> f (GenLocated SrcSpanAnnA (HsExpr GhcPs))
toArgument FieldContext
fc (Maybe ([DotProtoOption], DotProtoType)
maybeOptsType, String
fieldName) =
          (HsExp -> f (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (([DotProtoOption], DotProtoType)
    -> HsExp -> f (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe ([DotProtoOption], DotProtoType)
-> HsExp
-> f (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HsExp -> f (GenLocated SrcSpanAnnA (HsExpr GhcPs))
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> f (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([DotProtoOption]
 -> DotProtoType
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> f (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> ([DotProtoOption], DotProtoType)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> f (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> f HsExp
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
unwrapE FieldContext
fc TypeContext
ctxt)) Maybe ([DotProtoOption], DotProtoType)
maybeOptsType (HsExp -> f (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> HsExp -> f (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
            HsExp -> HsExp -> HsExp
app HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
asProxy HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
declare
        where
          declare :: HsExp
declare = String -> HsExp
uvar_ (String -> String
toDeclareName String
fieldName)
          asProxy :: HsExp
asProxy = HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"asProxy")

      -- do let declare_fieldName0 = HsJSONPB.declareSchemaRef
      --    qualifiedFieldName0 <- declare_fieldName0 Proxy.Proxy
      --    let declare_fieldName1 = HsJSONPB.declareSchemaRef
      --    qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy
      --    ...
      --    let _ = pure MessageName <*> HsJSONPB.asProxy declare_fieldName0 <*> HsJSONPB.asProxy declare_fieldName1 <*> ...
      --    return (...)
  let expressionForMessage :: m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
expressionForMessage = do
        let bindingStatements :: [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bindingStatements = do
              (String
fieldName, String
qualifiedFieldName) <- [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
fieldNames [String]
qualifiedFieldNames

              let declareIdentifier :: HsName
declareIdentifier = NameSpace -> String -> HsName
unqual_ NameSpace
varName (String -> String
toDeclareName String
fieldName)

              let stmt0 :: ExprLStmt GhcPs
stmt0 = [HsBind] -> ExprLStmt GhcPs
letStmt_
                    [ HsName -> [([HsPat], HsExp)] -> HsBind
function_ HsName
GenLocated SrcSpanAnnN RdrName
declareIdentifier
                        [([], HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"declareSchemaRef"))] ]

              let stmt1 :: ExprLStmt GhcPs
stmt1 = HsPat -> HsExp -> ExprLStmt GhcPs
bindStmt_ (String -> HsPat
patVar String
qualifiedFieldName)
                                    (HsExp -> HsExp -> HsExp
app (HsName -> HsExp
var_ HsName
GenLocated SrcSpanAnnN RdrName
declareIdentifier)
                                         (HsName -> HsExp
var_ (NameSpace -> String -> HsName
proxyName NameSpace
dataName String
"Proxy")))
              [ GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt0, GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt1]

        [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
inferenceStatement <- do
          [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
arguments <- ((Maybe ([DotProtoOption], DotProtoType), String)
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
-> m [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (FieldContext
-> (Maybe ([DotProtoOption], DotProtoType), String)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall {f :: * -> *}.
(MonadError CompileError f, ?stringType::StringType) =>
FieldContext
-> (Maybe ([DotProtoOption], DotProtoType), String)
-> f (GenLocated SrcSpanAnnA (HsExpr GhcPs))
toArgument FieldContext
WithinMessage) [(Maybe ([DotProtoOption], DotProtoType), String)]
fieldNamesEtc
          let patternBind :: HsBind
patternBind = HsPat -> HsExp -> HsBind
patBind_ HsPat
wild_ (HsExp -> [HsExp] -> HsExp
applicativeApply HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
messageConstructor [HsExp]
[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
arguments)
          [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated
    SrcSpanAnnA
    (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> m [GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
fieldNames then [] else [ [HsBind] -> ExprLStmt GhcPs
letStmt_ [ HsBind
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
patternBind ] ]

        let returnStatement :: ExprLStmt GhcPs
returnStatement = HsExp -> ExprLStmt GhcPs
lastStmt_ (HsExp -> HsExp -> HsExp
app HsExp
returnE (HsExp -> HsExp
paren HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
namedSchema))

        HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ [ExprLStmt GhcPs] -> HsExp
do_ ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bindingStatements [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
inferenceStatement [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [ GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
returnStatement ])

      -- do let declare_fieldName0 = HsJSONPB.declareSchemaRef
      --    let _ = pure ConstructorName0 <*> HsJSONPB.asProxy declare_fieldName0
      --    qualifiedFieldName0 <- declare_fieldName0 Proxy.Proxy
      --    let declare_fieldName1 = HsJSONPB.declareSchemaRef
      --    let _ = pure ConstructorName1 <*> HsJSONPB.asProxy declare_fieldName1
      --    qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy
      --    ...
      --    return (...)
  let expressionForOneOf :: [GenLocated SrcSpanAnnN RdrName]
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
expressionForOneOf [GenLocated SrcSpanAnnN RdrName]
constructors = do
        let bindingStatement :: ((Maybe ([DotProtoOption], DotProtoType), String), String,
 GenLocated SrcSpanAnnN RdrName)
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bindingStatement ((Maybe ([DotProtoOption], DotProtoType), String)
fieldNameEtc, String
qualifiedFieldName, GenLocated SrcSpanAnnN RdrName
constructor) = do
              let declareIdentifier :: HsName
declareIdentifier = NameSpace -> String -> HsName
unqual_ NameSpace
varName (String -> String
toDeclareName ((Maybe ([DotProtoOption], DotProtoType), String) -> String
forall a b. (a, b) -> b
snd (Maybe ([DotProtoOption], DotProtoType), String)
fieldNameEtc))

              let stmt0 :: ExprLStmt GhcPs
stmt0 = [HsBind] -> ExprLStmt GhcPs
letStmt_
                    [ HsName -> [([HsPat], HsExp)] -> HsBind
function_ HsName
GenLocated SrcSpanAnnN RdrName
declareIdentifier
                        [([], HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"declareSchemaRef"))] ]

              let stmt1 :: ExprLStmt GhcPs
stmt1 = HsPat -> HsExp -> ExprLStmt GhcPs
bindStmt_ (String -> HsPat
patVar String
qualifiedFieldName)
                                    (HsExp -> HsExp -> HsExp
app (HsName -> HsExp
var_ HsName
GenLocated SrcSpanAnnN RdrName
declareIdentifier)
                                         (HsName -> HsExp
var_ (NameSpace -> String -> HsName
proxyName NameSpace
dataName String
"Proxy")))

              [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
inferenceStatement <- do
                GenLocated SrcSpanAnnA (HsExpr GhcPs)
argument <- FieldContext
-> (Maybe ([DotProtoOption], DotProtoType), String)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall {f :: * -> *}.
(MonadError CompileError f, ?stringType::StringType) =>
FieldContext
-> (Maybe ([DotProtoOption], DotProtoType), String)
-> f (GenLocated SrcSpanAnnA (HsExpr GhcPs))
toArgument FieldContext
WithinOneOf (Maybe ([DotProtoOption], DotProtoType), String)
fieldNameEtc
                let patternBind :: HsBind
patternBind = HsPat -> HsExp -> HsBind
patBind_ HsPat
wild_ (HsExp -> [HsExp] -> HsExp
applicativeApply (HsName -> HsExp
var_ HsName
GenLocated SrcSpanAnnN RdrName
constructor) [ HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
argument ])
                [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated
    SrcSpanAnnA
    (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> m [GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
fieldNames then [] else [ [HsBind] -> ExprLStmt GhcPs
letStmt_ [ HsBind
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
patternBind ] ]

              [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated
    SrcSpanAnnA
    (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> m [GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ [GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt0, GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt1] [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
inferenceStatement

        [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bindingStatements <- (((Maybe ([DotProtoOption], DotProtoType), String), String,
  GenLocated SrcSpanAnnN RdrName)
 -> m [GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [((Maybe ([DotProtoOption], DotProtoType), String), String,
     GenLocated SrcSpanAnnN RdrName)]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM ((Maybe ([DotProtoOption], DotProtoType), String), String,
 GenLocated SrcSpanAnnN RdrName)
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall {m :: * -> *}.
(MonadError CompileError m, ?stringType::StringType) =>
((Maybe ([DotProtoOption], DotProtoType), String), String,
 GenLocated SrcSpanAnnN RdrName)
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bindingStatement ([((Maybe ([DotProtoOption], DotProtoType), String), String,
   GenLocated SrcSpanAnnN RdrName)]
 -> m [GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [((Maybe ([DotProtoOption], DotProtoType), String), String,
     GenLocated SrcSpanAnnN RdrName)]
-> m [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$
          [(Maybe ([DotProtoOption], DotProtoType), String)]
-> [String]
-> [GenLocated SrcSpanAnnN RdrName]
-> [((Maybe ([DotProtoOption], DotProtoType), String), String,
     GenLocated SrcSpanAnnN RdrName)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [(Maybe ([DotProtoOption], DotProtoType), String)]
fieldNamesEtc [String]
qualifiedFieldNames [GenLocated SrcSpanAnnN RdrName]
constructors

        let returnStatement :: ExprLStmt GhcPs
returnStatement = HsExp -> ExprLStmt GhcPs
lastStmt_ (HsExp -> HsExp -> HsExp
app HsExp
returnE (HsExp -> HsExp
paren HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
namedSchema))

        HsExp -> m HsExp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ [ExprLStmt GhcPs] -> HsExp
do_ ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bindingStatements [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [ GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
returnStatement ])

  GenLocated SrcSpanAnnA (HsExpr GhcPs)
expression <- case Maybe [HsName]
maybeConstructors of
    Maybe [HsName]
Nothing           -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
expressionForMessage
    Just [HsName]
constructors -> [GenLocated SrcSpanAnnN RdrName]
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall {m :: * -> *}.
(MonadError CompileError m, ?stringType::StringType) =>
[GenLocated SrcSpanAnnN RdrName]
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
expressionForOneOf [HsName]
[GenLocated SrcSpanAnnN RdrName]
constructors

  let instanceDeclaration :: HsDecl
instanceDeclaration =
          HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ HsName
GenLocated SrcSpanAnnN RdrName
className [ LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
classArgument ] [ HsBind
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
classDeclaration ]
        where
          className :: HsName
className = NameSpace -> String -> HsName
jsonpbName NameSpace
tcName String
"ToSchema"

          classArgument :: LHsType GhcPs
classArgument = String -> LHsType GhcPs
type_ String
messageName

          classDeclaration :: HsBind
classDeclaration =
            String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"declareNamedSchema" [([ HsPat
wild_ ], HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expression)]

  GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsDecl GhcPs)
instanceDeclaration
#endif


-- ** Generate types and instances for .proto enums

dotProtoEnumD
    :: MonadError CompileError m
    => DotProtoIdentifier
    -> DotProtoIdentifier
    -> [DotProtoEnumPart]
    -> m [HsDecl]
dotProtoEnumD :: forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier
-> DotProtoIdentifier -> [DotProtoEnumPart] -> m [HsDecl]
dotProtoEnumD DotProtoIdentifier
parentIdent DotProtoIdentifier
enumIdent [DotProtoEnumPart]
enumParts = do
  String
enumName <- DotProtoIdentifier -> DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
enumIdent

  let enumeratorDecls :: [(DotProtoEnumValue, DotProtoIdentifier)]
enumeratorDecls =
        [ (DotProtoEnumValue
i, DotProtoIdentifier
conIdent) | DotProtoEnumField DotProtoIdentifier
conIdent DotProtoEnumValue
i [DotProtoOption]
_options <- [DotProtoEnumPart]
enumParts ]

  NonEmpty (DotProtoEnumValue, DotProtoIdentifier)
enumeratorDeclsNE <- case [(DotProtoEnumValue, DotProtoIdentifier)]
enumeratorDecls of
    [] -> CompileError
-> m (NonEmpty (DotProtoEnumValue, DotProtoIdentifier))
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError
 -> m (NonEmpty (DotProtoEnumValue, DotProtoIdentifier)))
-> CompileError
-> m (NonEmpty (DotProtoEnumValue, DotProtoIdentifier))
forall a b. (a -> b) -> a -> b
$ String -> CompileError
EmptyEnumeration String
enumName
    h :: (DotProtoEnumValue, DotProtoIdentifier)
h@(DotProtoEnumValue
i, DotProtoIdentifier
conIdent) : [(DotProtoEnumValue, DotProtoIdentifier)]
t
      | DotProtoEnumValue
i DotProtoEnumValue -> DotProtoEnumValue -> Bool
forall a. Eq a => a -> a -> Bool
== DotProtoEnumValue
0 -> NonEmpty (DotProtoEnumValue, DotProtoIdentifier)
-> m (NonEmpty (DotProtoEnumValue, DotProtoIdentifier))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DotProtoEnumValue, DotProtoIdentifier)
h (DotProtoEnumValue, DotProtoIdentifier)
-> [(DotProtoEnumValue, DotProtoIdentifier)]
-> NonEmpty (DotProtoEnumValue, DotProtoIdentifier)
forall a. a -> [a] -> NonEmpty a
:| [(DotProtoEnumValue, DotProtoIdentifier)]
t)
      | Bool
otherwise -> CompileError
-> m (NonEmpty (DotProtoEnumValue, DotProtoIdentifier))
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError
 -> m (NonEmpty (DotProtoEnumValue, DotProtoIdentifier)))
-> CompileError
-> m (NonEmpty (DotProtoEnumValue, DotProtoIdentifier))
forall a b. (a -> b) -> a -> b
$ String -> DotProtoIdentifier -> DotProtoEnumValue -> CompileError
NonzeroFirstEnumeration String
enumName DotProtoIdentifier
conIdent DotProtoEnumValue
i

  NonEmpty (DotProtoEnumValue, String)
enumCons <- ((DotProtoEnumValue, String)
 -> (DotProtoEnumValue, String) -> Ordering)
-> NonEmpty (DotProtoEnumValue, String)
-> NonEmpty (DotProtoEnumValue, String)
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (((DotProtoEnumValue, String) -> DotProtoEnumValue)
-> (DotProtoEnumValue, String)
-> (DotProtoEnumValue, String)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (DotProtoEnumValue, String) -> DotProtoEnumValue
forall a b. (a, b) -> a
fst) (NonEmpty (DotProtoEnumValue, String)
 -> NonEmpty (DotProtoEnumValue, String))
-> m (NonEmpty (DotProtoEnumValue, String))
-> m (NonEmpty (DotProtoEnumValue, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ((DotProtoEnumValue, DotProtoIdentifier)
 -> m (DotProtoEnumValue, String))
-> NonEmpty (DotProtoEnumValue, DotProtoIdentifier)
-> m (NonEmpty (DotProtoEnumValue, String))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse ((DotProtoIdentifier -> m String)
-> (DotProtoEnumValue, DotProtoIdentifier)
-> m (DotProtoEnumValue, String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (DotProtoEnumValue, a) -> f (DotProtoEnumValue, b)
traverse ((String -> String) -> m String -> m String
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
prefixedEnumFieldName String
enumName) (m String -> m String)
-> (DotProtoIdentifier -> m String)
-> DotProtoIdentifier
-> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName))
             NonEmpty (DotProtoEnumValue, DotProtoIdentifier)
enumeratorDeclsNE

  let enumConNames :: NonEmpty String
enumConNames = ((DotProtoEnumValue, String) -> String)
-> NonEmpty (DotProtoEnumValue, String) -> NonEmpty String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DotProtoEnumValue, String) -> String
forall a b. (a, b) -> b
snd NonEmpty (DotProtoEnumValue, String)
enumCons

      minBoundD :: HsBind
      minBoundD :: HsBind
minBoundD = String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"minBound" [([], String -> HsExp
uvar_ (NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head NonEmpty String
enumConNames))]

      maxBoundD :: HsBind
      maxBoundD :: HsBind
maxBoundD = String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"maxBound" [([], String -> HsExp
uvar_ (NonEmpty String -> String
forall a. NonEmpty a -> a
NE.last NonEmpty String
enumConNames))]

      compareD :: HsBind
      compareD :: HsBind
compareD = String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"compare"
          [ ( [ String -> HsPat
patVar String
"x", String -> HsPat
patVar String
"y" ]
            , HsExp -> HsExp -> HsExp
app
                  (HsExp -> HsExp -> HsExp
app
                      (HsName -> HsExp
var_ (NameSpace -> String -> HsName
haskellName NameSpace
varName String
"compare"))
                      (HsExp -> HsExp
paren
                          (HsExp -> HsExp -> HsExp
app (HsName -> HsExp
var_ (NameSpace -> String -> HsName
protobufName NameSpace
varName String
"fromProtoEnum"))
                                 (String -> HsExp
uvar_ String
"x")
                          )
                      )
                  )
                  (HsExp -> HsExp
paren
                      (HsExp -> HsExp -> HsExp
app (HsName -> HsExp
var_ (NameSpace -> String -> HsName
protobufName NameSpace
varName String
"fromProtoEnum"))
                             (String -> HsExp
uvar_ String
"y")
                      )
                  )
            )
          ]

      fromProtoEnumD :: HsBind
      fromProtoEnumD :: HsBind
fromProtoEnumD = String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"fromProtoEnum"
          [ ([ HsName -> [HsPat] -> HsPat
conPat (NameSpace -> String -> HsName
unqual_ NameSpace
dataName String
conName) [] ], DotProtoEnumValue -> HsExp
forall a. Integral a => a -> HsExp
intE DotProtoEnumValue
conIdx)
          | (DotProtoEnumValue
conIdx, String
conName) <- NonEmpty (DotProtoEnumValue, String)
-> [(DotProtoEnumValue, String)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DotProtoEnumValue, String)
enumCons
          ]

      toProtoEnumMayD :: HsBind
      toProtoEnumMayD :: HsBind
toProtoEnumMayD = String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"toProtoEnumMay" ([([HsPat], HsExp)] -> HsBind) -> [([HsPat], HsExp)] -> HsBind
forall a b. (a -> b) -> a -> b
$
          [ ([ DotProtoEnumValue -> HsPat
forall a. Integral a => a -> HsPat
intP DotProtoEnumValue
conIdx ], HsExp -> HsExp -> HsExp
app HsExp
justC (String -> HsExp
uvar_ String
conName))
          | (DotProtoEnumValue
conIdx, String
conName) <- NonEmpty (DotProtoEnumValue, String)
-> [(DotProtoEnumValue, String)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (DotProtoEnumValue, String)
enumCons ] [([GenLocated SrcSpanAnnA (Pat GhcPs)],
  GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a. [a] -> [a] -> [a]
++
          [ ([ HsPat
GenLocated SrcSpanAnnA (Pat GhcPs)
wild_ ], HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
nothingC) ]

      parseJSONPBDecl :: HsBind
      parseJSONPBDecl :: HsBind
parseJSONPBDecl = String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"parseJSONPB" ([([HsPat], HsExp)] -> HsBind) -> [([HsPat], HsExp)] -> HsBind
forall a b. (a -> b) -> a -> b
$
          (String
 -> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
      GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
      GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> NonEmpty String
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (([GenLocated SrcSpanAnnA (Pat GhcPs)],
  GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
      GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
      GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> (String
    -> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
        GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> String
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
matchConName) [([GenLocated SrcSpanAnnA (Pat GhcPs)],
 GenLocated SrcSpanAnnA (HsExpr GhcPs))
mismatch] NonEmpty String
enumConNames
        where
          matchConName :: String
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr GhcPs))
matchConName String
conName = ([String -> GenLocated SrcSpanAnnA (Pat GhcPs)
pat String
conName], HsExp -> HsExp -> HsExp
app HsExp
pureE (String -> HsExp
uvar_ String
conName))

          pat :: String -> HsPat
pat String
nm = HsName -> [HsPat] -> HsPat
conPat (NameSpace -> String -> HsName
jsonpbName NameSpace
dataName String
"String") [ String -> HsPat
strPat (String -> String
tryStripEnumName String
nm) ]

          tryStripEnumName :: String -> String
tryStripEnumName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> Maybe String -> String)
-> (String -> Maybe String) -> String -> String
forall a b. (String -> a -> b) -> (String -> a) -> String -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
enumName

          mismatch :: ([GenLocated SrcSpanAnnA (Pat GhcPs)],
 GenLocated SrcSpanAnnA (HsExpr GhcPs))
mismatch =
            ( [String -> HsPat
patVar String
"v"]
            , HsExp -> [HsExp] -> HsExp
apply (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"typeMismatch"))
                    [ String -> HsExp
str_ String
enumName, String -> HsExp
uvar_ String
"v" ]
            )

      toJSONPBDecl :: HsBind
      toJSONPBDecl :: HsBind
toJSONPBDecl =
        String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"toJSONPB"
          [( [ String -> HsPat
patVar String
"x", HsPat
wild_ ]
           , HsExp -> HsExp -> HsExp
app (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"enumFieldString")) (String -> HsExp
uvar_ String
"x")
           )]

      toEncodingPBDecl :: HsBind
      toEncodingPBDecl :: HsBind
toEncodingPBDecl =
        String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
"toEncodingPB"
          [([ String -> HsPat
patVar String
"x", HsPat
wild_ ]
           , HsExp -> HsExp -> HsExp
app (HsName -> HsExp
var_ (NameSpace -> String -> HsName
jsonpbName NameSpace
varName String
"enumFieldEncoding")) (String -> HsExp
uvar_ String
"x")
           )]

  [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ String -> [HsTyVarBndrV] -> [HsConDecl] -> [HsName] -> HsDecl
dataDecl_ String
enumName
                   []
                   [ HsName -> [LHsType GhcPs] -> HsConDecl
conDecl_ (NameSpace -> String -> HsName
unqual_ NameSpace
dataName String
con) [] | String
con <- NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
enumConNames ]
                   [HsName]
defaultEnumDeriving
       , String -> HsDecl
namedInstD String
enumName
       , String -> HsDecl
hasDefaultInstD String
enumName
       , HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
haskellName NameSpace
tcName String
"Bounded") [ String -> LHsType GhcPs
type_ String
enumName ]
                   [ HsBind
minBoundD
                   , HsBind
maxBoundD
                   ]
       , HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
haskellName NameSpace
tcName String
"Ord") [ String -> LHsType GhcPs
type_ String
enumName ]
                   [ HsBind
compareD ]
       , HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
protobufName NameSpace
tcName String
"ProtoEnum") [ String -> LHsType GhcPs
type_ String
enumName ]
                   [ HsBind
toProtoEnumMayD
                   , HsBind
fromProtoEnumD
                   ]
       , HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
jsonpbName NameSpace
tcName String
"ToJSONPB") [ String -> LHsType GhcPs
type_ String
enumName ]
                   [ HsBind
toJSONPBDecl
                   , HsBind
toEncodingPBDecl
                   ]
       , HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
jsonpbName NameSpace
tcName String
"FromJSONPB") [ String -> LHsType GhcPs
type_ String
enumName ]
                   [ HsBind
parseJSONPBDecl ]
       -- Generate Aeson instances in terms of JSONPB instances
       , String -> HsDecl
toJSONInstDecl String
enumName
       , String -> HsDecl
fromJSONInstDecl String
enumName

#ifdef DHALL
       -- Generate Dhall instances
       , dhallInterpretInstDecl enumName
       , dhallInjectInstDecl enumName
#endif

       -- And the Finite instance, used to infer a Swagger ToSchema instance
       -- for this enumerated type.
       , HsName -> [LHsType GhcPs] -> [HsBind] -> HsDecl
instDecl_ (NameSpace -> String -> HsName
protobufName NameSpace
tcName String
"Finite") [ String -> LHsType GhcPs
type_ String
enumName ] []
       ]

-- ** Generate code for dot proto services

dotProtoServiceD ::
  ( MonadError CompileError m
  , (?stringType :: StringType)
  ) =>
  DotProtoPackageSpec ->
  TypeContext ->
  DotProtoIdentifier ->
  [DotProtoServicePart] ->
  m [HsDecl]
dotProtoServiceD :: forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
DotProtoPackageSpec
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
dotProtoServiceD DotProtoPackageSpec
pkgSpec TypeContext
ctxt DotProtoIdentifier
serviceIdent [DotProtoServicePart]
service = do
     String
serviceName <- String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
serviceIdent

     String
endpointPrefix <-
       case DotProtoPackageSpec
pkgSpec of
         DotProtoPackageSpec DotProtoIdentifier
pkgIdent -> do
           String
packageName <- DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentQualName DotProtoIdentifier
pkgIdent
           String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
packageName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
serviceName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
         DotProtoPackageSpec
DotProtoNoPackage -> String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
serviceName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"

     let serviceFieldD :: DotProtoServicePart
-> m [(String, String, Streaming, Streaming,
       GenLocated SrcSpanAnnA (HsType GhcPs))]
serviceFieldD (DotProtoServiceRPCMethod RPCMethod{[DotProtoOption]
Streaming
DotProtoIdentifier
rpcMethodName :: DotProtoIdentifier
rpcMethodRequestType :: DotProtoIdentifier
rpcMethodRequestStreaming :: Streaming
rpcMethodResponseType :: DotProtoIdentifier
rpcMethodResponseStreaming :: Streaming
rpcMethodOptions :: [DotProtoOption]
rpcMethodOptions :: RPCMethod -> [DotProtoOption]
rpcMethodResponseStreaming :: RPCMethod -> Streaming
rpcMethodResponseType :: RPCMethod -> DotProtoIdentifier
rpcMethodRequestStreaming :: RPCMethod -> Streaming
rpcMethodRequestType :: RPCMethod -> DotProtoIdentifier
rpcMethodName :: RPCMethod -> DotProtoIdentifier
..}) = do
           String
fullName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedMethodName String
serviceName (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
rpcMethodName

           String
methodName <- case DotProtoIdentifier
rpcMethodName of
                           Single String
nm -> String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
nm
                           DotProtoIdentifier
_ -> DotProtoIdentifier -> m String
forall (m :: * -> *) a.
MonadError CompileError m =>
DotProtoIdentifier -> m a
invalidMethodNameError DotProtoIdentifier
rpcMethodName

           GenLocated SrcSpanAnnA (HsType GhcPs)
requestTy  <- TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToHsType TypeContext
ctxt (DotProtoIdentifier -> DotProtoPrimType
Named DotProtoIdentifier
rpcMethodRequestType)

           GenLocated SrcSpanAnnA (HsType GhcPs)
responseTy <- TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
forall (m :: * -> *).
(MonadError CompileError m, ?stringType::StringType) =>
TypeContext -> DotProtoPrimType -> m (LHsType GhcPs)
dpptToHsType TypeContext
ctxt (DotProtoIdentifier -> DotProtoPrimType
Named DotProtoIdentifier
rpcMethodResponseType)

           let streamingType :: LHsType GhcPs
streamingType =
                 case (Streaming
rpcMethodRequestStreaming, Streaming
rpcMethodResponseStreaming) of
                   (Streaming
Streaming, Streaming
Streaming)       -> LHsType GhcPs
biDiStreamingC
                   (Streaming
Streaming, Streaming
NonStreaming)    -> LHsType GhcPs
clientStreamingC
                   (Streaming
NonStreaming, Streaming
Streaming)    -> LHsType GhcPs
serverStreamingC
                   (Streaming
NonStreaming, Streaming
NonStreaming) -> LHsType GhcPs
normalC

           [(String, String, Streaming, Streaming,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> m [(String, String, Streaming, Streaming,
       GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ ( String
endpointPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
methodName
                  , String
fullName, Streaming
rpcMethodRequestStreaming, Streaming
rpcMethodResponseStreaming
                  , LHsType GhcPs -> LHsType GhcPs
unbangedTy_ (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$
                    LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funTy (LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
tyApply (String -> LHsType GhcPs
tvar_ String
"request") [LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
streamingType, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
requestTy, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
responseTy])
                          (LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
tyApply LHsType GhcPs
ioT [LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
tyApply (String -> LHsType GhcPs
tvar_ String
"response") [LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
streamingType, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
responseTy]])
                  )
                ]

         serviceFieldD DotProtoServicePart
_ = [(String, String, Streaming, Streaming,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
-> m [(String, String, Streaming, Streaming,
       GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

     [(String, String, Streaming, Streaming,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
fieldsD <- (DotProtoServicePart
 -> m [(String, String, Streaming, Streaming,
        GenLocated SrcSpanAnnA (HsType GhcPs))])
-> [DotProtoServicePart]
-> m [(String, String, Streaming, Streaming,
       GenLocated SrcSpanAnnA (HsType GhcPs))]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM DotProtoServicePart
-> m [(String, String, Streaming, Streaming,
       GenLocated SrcSpanAnnA (HsType GhcPs))]
forall {m :: * -> *}.
(MonadError CompileError m, ?stringType::StringType) =>
DotProtoServicePart
-> m [(String, String, Streaming, Streaming,
       GenLocated SrcSpanAnnA (HsType GhcPs))]
serviceFieldD [DotProtoServicePart]
service

     String
serverFuncName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedFieldName String
serviceName String
"server"
     String
clientFuncName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedFieldName String
serviceName String
"client"

     let conDecl :: HsConDecl
conDecl = HsName -> [([HsName], LHsType GhcPs)] -> HsConDecl
recDecl_ (NameSpace -> String -> HsName
unqual_ NameSpace
dataName String
serviceName)
                            [ ([NameSpace -> String -> HsName
unqual_ NameSpace
varName String
hsName], LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty) | (String
_, String
hsName, Streaming
_, Streaming
_, GenLocated SrcSpanAnnA (HsType GhcPs)
ty) <- [(String, String, Streaming, Streaming,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
fieldsD ]

     let serverT :: LHsType GhcPs
serverT = LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
tyApply (HsName -> LHsType GhcPs
typeNamed_ (NameSpace -> String -> HsName
unqual_ NameSpace
tcName String
serviceName))
                           [ LHsType GhcPs
serverRequestT, LHsType GhcPs
serverResponseT ]

     let serviceServerTypeD :: HsDecl
serviceServerTypeD =
           [HsName] -> HsOuterSigTyVarBndrs GhcPs -> LHsType GhcPs -> HsDecl
typeSig_ [ NameSpace -> String -> HsName
unqual_ NameSpace
varName String
serverFuncName ] HsOuterSigTyVarBndrs GhcPs
implicitOuterSigTyVarBinders_
                    (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funTy LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
serverT (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funTy LHsType GhcPs
serviceOptionsC LHsType GhcPs
ioActionT))

     let serviceServerD :: HsDecl
serviceServerD = HsBind -> HsDecl
valDecl_ (HsBind -> HsDecl) -> HsBind -> HsDecl
forall a b. (a -> b) -> a -> b
$
             String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
serverFuncName [([HsPat]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
serverFuncPats, HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
serverFuncRhs)]
           where
             serverFuncPats :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
serverFuncPats =
                 [ HsName -> [LHsRecField GhcPs HsPat] -> HsPat
recPat (NameSpace -> String -> HsName
unqual_ NameSpace
dataName String
serviceName)
                          [ HsName -> LHsRecField GhcPs HsPat
fieldPunPat (NameSpace -> String -> HsName
unqual_ NameSpace
varName String
methodName)
                          | (String
_, String
methodName, Streaming
_, Streaming
_, GenLocated SrcSpanAnnA (HsType GhcPs)
_) <- [(String, String, Streaming, Streaming,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
fieldsD
                          ]
                 , HsName -> [HsPat] -> HsPat
conPat (NameSpace -> String -> HsName
unqual_ NameSpace
dataName String
"ServiceOptions")
                          [ String -> HsPat
patVar String
"serverHost"
                          , String -> HsPat
patVar String
"serverPort"
                          , String -> HsPat
patVar String
"useCompression"
                          , String -> HsPat
patVar String
"userAgentPrefix"
                          , String -> HsPat
patVar String
"userAgentSuffix"
                          , String -> HsPat
patVar String
"initialMetadata"
                          , String -> HsPat
patVar String
"sslConfig"
                          , String -> HsPat
patVar String
"logger"
                          , String -> HsPat
patVar String
"serverMaxReceiveMessageLength"
                          , String -> HsPat
patVar String
"serverMaxMetadataSize"
                          ]
                 ]

             serverFuncRhs :: HsExp
serverFuncRhs = HsExp -> [HsExp] -> HsExp
apply HsExp
serverLoopE [ HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
serverOptsE ]

             handlerE :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> String
-> String
-> HsExp
handlerE GenLocated SrcSpanAnnA (HsExpr GhcPs)
handlerC GenLocated SrcSpanAnnA (HsExpr GhcPs)
adapterE String
methodName String
hsName =
                 HsExp -> [HsExp] -> HsExp
apply HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
handlerC [ HsExp -> [HsExp] -> HsExp
apply HsExp
methodNameC [ String -> HsExp
str_ String
methodName ]
                                , HsExp -> [HsExp] -> HsExp
apply HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
adapterE [ String -> HsExp
uvar_ String
hsName ]
                                ]

             update :: String -> String -> LHsRecUpdField GhcPs GhcPs
update String
u String
v = HsName -> HsExp -> LHsRecUpdField GhcPs GhcPs
fieldUpd_ (NameSpace -> String -> HsName
unqual_ NameSpace
varName String
u) (String -> HsExp
uvar_ String
v)

             serverOptsE :: HsExp
serverOptsE = HsExp -> [LHsRecUpdField GhcPs GhcPs] -> HsExp
recordUpd_ HsExp
defaultOptionsE
                 [ HsName -> HsExp -> LHsRecUpdField GhcPs GhcPs
fieldUpd_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"optNormalHandlers") (HsExp -> LHsRecUpdField GhcPs GhcPs)
-> HsExp -> LHsRecUpdField GhcPs GhcPs
forall a b. (a -> b) -> a -> b
$
                       [HsExp] -> HsExp
list_ [ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> String
-> String
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
handlerE HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
unaryHandlerC HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
convertServerHandlerE String
endpointName String
hsName
                             | (String
endpointName, String
hsName, Streaming
NonStreaming, Streaming
NonStreaming, GenLocated SrcSpanAnnA (HsType GhcPs)
_) <- [(String, String, Streaming, Streaming,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
fieldsD
                             ]

                 , HsName -> HsExp -> LHsRecUpdField GhcPs GhcPs
fieldUpd_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"optClientStreamHandlers") (HsExp -> LHsRecUpdField GhcPs GhcPs)
-> HsExp -> LHsRecUpdField GhcPs GhcPs
forall a b. (a -> b) -> a -> b
$
                       [HsExp] -> HsExp
list_ [ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> String
-> String
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
handlerE HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
clientStreamHandlerC HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
convertServerReaderHandlerE String
endpointName String
hsName
                             | (String
endpointName, String
hsName, Streaming
Streaming, Streaming
NonStreaming, GenLocated SrcSpanAnnA (HsType GhcPs)
_) <- [(String, String, Streaming, Streaming,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
fieldsD
                             ]

                 , HsName -> HsExp -> LHsRecUpdField GhcPs GhcPs
fieldUpd_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"optServerStreamHandlers") (HsExp -> LHsRecUpdField GhcPs GhcPs)
-> HsExp -> LHsRecUpdField GhcPs GhcPs
forall a b. (a -> b) -> a -> b
$
                       [HsExp] -> HsExp
list_ [ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> String
-> String
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
handlerE HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
serverStreamHandlerC HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
convertServerWriterHandlerE String
endpointName String
hsName
                             | (String
endpointName, String
hsName, Streaming
NonStreaming, Streaming
Streaming, GenLocated SrcSpanAnnA (HsType GhcPs)
_) <- [(String, String, Streaming, Streaming,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
fieldsD
                             ]

                 , HsName -> HsExp -> LHsRecUpdField GhcPs GhcPs
fieldUpd_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"optBiDiStreamHandlers") (HsExp -> LHsRecUpdField GhcPs GhcPs)
-> HsExp -> LHsRecUpdField GhcPs GhcPs
forall a b. (a -> b) -> a -> b
$
                       [HsExp] -> HsExp
list_ [ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> String
-> String
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
handlerE HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
biDiStreamHandlerC HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
convertServerRWHandlerE String
endpointName String
hsName
                             | (String
endpointName, String
hsName, Streaming
Streaming, Streaming
Streaming, GenLocated SrcSpanAnnA (HsType GhcPs)
_) <- [(String, String, Streaming, Streaming,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
fieldsD
                             ]

                 , String
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
update String
"optServerHost" String
"serverHost"
                 , String
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
update String
"optServerPort" String
"serverPort"
                 , String
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
update String
"optUseCompression" String
"useCompression"
                 , String
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
update String
"optUserAgentPrefix" String
"userAgentPrefix"
                 , String
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
update String
"optUserAgentSuffix" String
"userAgentSuffix"
                 , String
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
update String
"optInitialMetadata" String
"initialMetadata"
                 , String
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
update String
"optSSLConfig" String
"sslConfig"
                 , String
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
update String
"optLogger" String
"logger"
                 , String
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
update String
"optMaxReceiveMessageLength" String
"serverMaxReceiveMessageLength"
                 , String
-> String
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated SrcSpanAnnA (AmbiguousFieldOcc GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
update String
"optMaxMetadataSize" String
"serverMaxMetadataSize"
                 ]

     let clientT :: LHsType GhcPs
clientT = LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
tyApply (String -> LHsType GhcPs
type_ String
serviceName) [ LHsType GhcPs
clientRequestT, LHsType GhcPs
clientResultT ]

     let serviceClientTypeD :: HsDecl
serviceClientTypeD =
            [HsName] -> HsOuterSigTyVarBndrs GhcPs -> LHsType GhcPs -> HsDecl
typeSig_ [ NameSpace -> String -> HsName
unqual_ NameSpace
varName String
clientFuncName ] HsOuterSigTyVarBndrs GhcPs
implicitOuterSigTyVarBinders_
                     (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funTy LHsType GhcPs
grpcClientT (LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
ioT LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
clientT))

     let serviceClientD :: HsDecl
serviceClientD = HsBind -> HsDecl
valDecl_ (HsBind -> HsDecl) -> HsBind -> HsDecl
forall a b. (a -> b) -> a -> b
$
              String -> [([HsPat], HsExp)] -> HsBind
functionS_ String
clientFuncName [([String -> HsPat
patVar String
"client"], HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
clientRecE)]
            where
              clientRecE :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
clientRecE = (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                (\GenLocated SrcSpanAnnA (HsExpr GhcPs)
f -> HsExp -> HsExp -> HsExp -> HsExp
opApp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
f HsExp
apOp)
                (HsExp -> [HsExp] -> HsExp
apply HsExp
pureE [ String -> HsExp
uvar_ String
serviceName ])
                [ HsExp -> HsExp
paren (HsExp -> HsExp -> HsExp -> HsExp
opApp HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
clientRequestE' HsExp
apOp (String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
registerClientMethodE String
endpointName))
                | (String
endpointName, String
_, Streaming
_, Streaming
_, GenLocated SrcSpanAnnA (HsType GhcPs)
_) <- [(String, String, Streaming, Streaming,
  GenLocated SrcSpanAnnA (HsType GhcPs))]
fieldsD
                ]

              clientRequestE' :: HsExp
clientRequestE' = HsExp -> [HsExp] -> HsExp
apply HsExp
pureE [ HsExp -> [HsExp] -> HsExp
apply HsExp
clientRequestE [ String -> HsExp
uvar_ String
"client" ] ]

              registerClientMethodE :: String -> HsExp
registerClientMethodE String
endpoint =
                HsExp -> [HsExp] -> HsExp
apply HsExp
clientRegisterMethodE [ String -> HsExp
uvar_ String
"client"
                                            , HsExp -> [HsExp] -> HsExp
apply HsExp
methodNameC [ String -> HsExp
str_ String
endpoint ]
                                            ]

     [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ String -> [HsTyVarBndrV] -> [HsConDecl] -> [HsName] -> HsDecl
dataDecl_ String
serviceName
                      [ HsBndrVis GhcPs -> HsName -> HsTyVarBndrV
forall flag. flag -> HsName -> LHsTyVarBndr flag GhcPs
userTyVar_ HsBndrVis GhcPs
forall a. SyntaxDefault a => a
synDef (NameSpace -> String -> HsName
unqual_ NameSpace
GHC.tvName String
"request")
                      , HsBndrVis GhcPs -> HsName -> HsTyVarBndrV
forall flag. flag -> HsName -> LHsTyVarBndr flag GhcPs
userTyVar_ HsBndrVis GhcPs
forall a. SyntaxDefault a => a
synDef (NameSpace -> String -> HsName
unqual_ NameSpace
GHC.tvName String
"response")
                      ]
                      [ HsConDecl
GenLocated SrcSpanAnnA (ConDecl GhcPs)
conDecl ]
                      [HsName]
defaultServiceDeriving

          , GenLocated SrcSpanAnnA (HsDecl GhcPs)
serviceServerTypeD
          , GenLocated SrcSpanAnnA (HsDecl GhcPs)
serviceServerD

          , GenLocated SrcSpanAnnA (HsDecl GhcPs)
serviceClientTypeD
          , GenLocated SrcSpanAnnA (HsDecl GhcPs)
serviceClientD
          ]

--------------------------------------------------------------------------------

--
-- * Common Haskell expressions, constructors, and operators
--

unaryHandlerC, clientStreamHandlerC, serverStreamHandlerC, biDiStreamHandlerC,
  methodNameC, defaultOptionsE, serverLoopE, convertServerHandlerE,
  convertServerReaderHandlerE, convertServerWriterHandlerE,
  convertServerRWHandlerE, clientRegisterMethodE, clientRequestE :: HsExp

unaryHandlerC :: HsExp
unaryHandlerC               = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
dataName String
"UnaryHandler")
clientStreamHandlerC :: HsExp
clientStreamHandlerC        = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
dataName String
"ClientStreamHandler")
serverStreamHandlerC :: HsExp
serverStreamHandlerC        = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
dataName String
"ServerStreamHandler")
biDiStreamHandlerC :: HsExp
biDiStreamHandlerC          = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
dataName String
"BiDiStreamHandler")
methodNameC :: HsExp
methodNameC                 = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
tcName String
"MethodName")
defaultOptionsE :: HsExp
defaultOptionsE             = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"defaultOptions")
serverLoopE :: HsExp
serverLoopE                 = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"serverLoop")
convertServerHandlerE :: HsExp
convertServerHandlerE       = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"convertGeneratedServerHandler")
convertServerReaderHandlerE :: HsExp
convertServerReaderHandlerE = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"convertGeneratedServerReaderHandler")
convertServerWriterHandlerE :: HsExp
convertServerWriterHandlerE = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"convertGeneratedServerWriterHandler")
convertServerRWHandlerE :: HsExp
convertServerRWHandlerE     = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"convertGeneratedServerRWHandler")
clientRegisterMethodE :: HsExp
clientRegisterMethodE       = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"clientRegisterMethod")
clientRequestE :: HsExp
clientRequestE              = HsName -> HsExp
var_ (NameSpace -> String -> HsName
grpcName NameSpace
varName String
"clientRequest")

biDiStreamingC, serverStreamingC, clientStreamingC, normalC, serviceOptionsC,
  ioActionT, serverRequestT, serverResponseT, clientRequestT, clientResultT,
  ioT, grpcClientT :: HsType
biDiStreamingC :: LHsType GhcPs
biDiStreamingC   = HsName -> LHsType GhcPs
typeNamed_ (Module -> NameSpace -> String -> HsName
qual_ Module
grpcModule NameSpace
dataName String
"BiDiStreaming")
serverStreamingC :: LHsType GhcPs
serverStreamingC = HsName -> LHsType GhcPs
typeNamed_ (Module -> NameSpace -> String -> HsName
qual_ Module
grpcModule NameSpace
dataName String
"ServerStreaming")
clientStreamingC :: LHsType GhcPs
clientStreamingC = HsName -> LHsType GhcPs
typeNamed_ (Module -> NameSpace -> String -> HsName
qual_ Module
grpcModule NameSpace
dataName String
"ClientStreaming")
normalC :: LHsType GhcPs
normalC          = HsName -> LHsType GhcPs
typeNamed_ (Module -> NameSpace -> String -> HsName
qual_ Module
grpcModule NameSpace
dataName String
"Normal")
serviceOptionsC :: LHsType GhcPs
serviceOptionsC  = HsName -> LHsType GhcPs
typeNamed_ (Module -> NameSpace -> String -> HsName
qual_ Module
grpcModule NameSpace
tcName String
"ServiceOptions")
serverRequestT :: LHsType GhcPs
serverRequestT   = HsName -> LHsType GhcPs
typeNamed_ (NameSpace -> String -> HsName
grpcName NameSpace
tcName String
"ServerRequest")
serverResponseT :: LHsType GhcPs
serverResponseT  = HsName -> LHsType GhcPs
typeNamed_ (NameSpace -> String -> HsName
grpcName NameSpace
tcName String
"ServerResponse")
clientRequestT :: LHsType GhcPs
clientRequestT   = HsName -> LHsType GhcPs
typeNamed_ (NameSpace -> String -> HsName
grpcName NameSpace
tcName String
"ClientRequest")
clientResultT :: LHsType GhcPs
clientResultT    = HsName -> LHsType GhcPs
typeNamed_ (NameSpace -> String -> HsName
grpcName NameSpace
tcName String
"ClientResult")
grpcClientT :: LHsType GhcPs
grpcClientT      = HsName -> LHsType GhcPs
typeNamed_ (NameSpace -> String -> HsName
grpcName NameSpace
tcName String
"Client")
ioActionT :: LHsType GhcPs
ioActionT        = LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyApp LHsType GhcPs
ioT ([LHsType GhcPs] -> LHsType GhcPs
tupleType_ [])
ioT :: LHsType GhcPs
ioT              = HsName -> LHsType GhcPs
typeNamed_ (NameSpace -> String -> HsName
haskellName NameSpace
tcName String
"IO")

grpcModule :: GHC.ModuleName
grpcModule :: Module
grpcModule = String -> Module
GHC.mkModuleName String
"HsGRPC"

-- ** Expressions for protobuf-wire types

forceEmitE :: HsExp -> HsExp
forceEmitE :: HsExp -> HsExp
forceEmitE = HsExp -> HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
paren (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExp -> HsExp -> HsExp
app HsExp
forceEmitC

fieldNumberE :: FieldNumber -> HsExp
fieldNumberE :: FieldNumber -> HsExp
fieldNumberE = HsExp -> HsExp
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
paren (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (FieldNumber -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> FieldNumber
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExp -> HsExp -> HsExp
app HsExp
fieldNumberC (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (FieldNumber -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> FieldNumber
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> HsExp
Word64 -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a. Integral a => a -> HsExp
intE (Word64 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (FieldNumber -> Word64)
-> FieldNumber
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNumber -> Word64
getFieldNumber

dpIdentE :: DotProtoIdentifier -> HsExp
dpIdentE :: DotProtoIdentifier -> HsExp
dpIdentE (Single String
n) = HsExp -> [HsExp] -> HsExp
apply HsExp
singleC [ String -> HsExp
str_ String
n ]
dpIdentE (Dots (Path (String
n NE.:| [String]
ns))) =
  HsExp -> [HsExp] -> HsExp
apply HsExp
dotsC [ HsExp -> [HsExp] -> HsExp
apply HsExp
pathC [ HsExp -> HsExp
paren (HsExp -> HsExp -> HsExp -> HsExp
opApp (String -> HsExp
str_ String
n) HsExp
neConsOp ([HsExp] -> HsExp
list_ ((String -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [String] -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map String -> HsExp
String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
str_ [String]
ns))) ] ]
dpIdentE (Qualified DotProtoIdentifier
a DotProtoIdentifier
b)  = HsExp -> [HsExp] -> HsExp
apply HsExp
qualifiedC [ DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
a, DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
b ]
dpIdentE DotProtoIdentifier
Anonymous        = HsExp
anonymousC

dpValueE :: DotProtoValue -> HsExp
dpValueE :: DotProtoValue -> HsExp
dpValueE (Identifier DotProtoIdentifier
nm) = HsExp -> [HsExp] -> HsExp
apply HsExp
identifierC [ DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
nm ]
dpValueE (StringLit String
s)   = HsExp -> [HsExp] -> HsExp
apply HsExp
stringLitC  [ String -> HsExp
str_ String
s ]
dpValueE (IntLit Int
i)      = HsExp -> [HsExp] -> HsExp
apply HsExp
intLitC     [ Int -> HsExp
forall a. Integral a => a -> HsExp
intE Int
i ]
dpValueE (FloatLit Double
f)    = HsExp -> [HsExp] -> HsExp
apply HsExp
floatLitC   [ Double -> HsExp
forall f. RealFloat f => f -> HsExp
floatE Double
f ]
dpValueE (BoolLit Bool
True)  = HsExp -> [HsExp] -> HsExp
apply HsExp
boolLitC    [ HsExp
trueC ]
dpValueE (BoolLit Bool
False) = HsExp -> [HsExp] -> HsExp
apply HsExp
boolLitC    [ HsExp
falseC ]

optionE :: DotProtoOption -> HsExp
optionE :: DotProtoOption -> HsExp
optionE (DotProtoOption DotProtoIdentifier
name DotProtoValue
value) =
  HsExp -> [HsExp] -> HsExp
apply HsExp
dotProtoOptionC [ DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
name, DotProtoValue -> HsExp
dpValueE DotProtoValue
value ]

-- | Translate a dot proto type to its Haskell AST type
dpTypeE :: DotProtoType -> HsExp
dpTypeE :: DotProtoType -> HsExp
dpTypeE (Prim DotProtoPrimType
p)           = HsExp -> [HsExp] -> HsExp
apply HsExp
primC           [ DotProtoPrimType -> HsExp
dpPrimTypeE DotProtoPrimType
p ]
dpTypeE (Optional DotProtoPrimType
p)       = HsExp -> [HsExp] -> HsExp
apply HsExp
optionalC       [ DotProtoPrimType -> HsExp
dpPrimTypeE DotProtoPrimType
p ]
dpTypeE (Repeated DotProtoPrimType
p)       = HsExp -> [HsExp] -> HsExp
apply HsExp
repeatedC       [ DotProtoPrimType -> HsExp
dpPrimTypeE DotProtoPrimType
p ]
dpTypeE (NestedRepeated DotProtoPrimType
p) = HsExp -> [HsExp] -> HsExp
apply HsExp
nestedRepeatedC [ DotProtoPrimType -> HsExp
dpPrimTypeE DotProtoPrimType
p ]
dpTypeE (Map DotProtoPrimType
k DotProtoPrimType
v)          = HsExp -> [HsExp] -> HsExp
apply HsExp
mapC            [ DotProtoPrimType -> HsExp
dpPrimTypeE DotProtoPrimType
k, DotProtoPrimType -> HsExp
dpPrimTypeE DotProtoPrimType
v]


-- | Translate a dot proto primitive type to a Haskell AST primitive type.
dpPrimTypeE :: DotProtoPrimType -> HsExp
dpPrimTypeE :: DotProtoPrimType -> HsExp
dpPrimTypeE DotProtoPrimType
ty =
    let wrap :: String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap = HsName -> HsExp
GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
var_ (GenLocated SrcSpanAnnN RdrName
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (String -> GenLocated SrcSpanAnnN RdrName)
-> String
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> String -> HsName
protobufASTName NameSpace
dataName in
    case DotProtoPrimType
ty of
        Named DotProtoIdentifier
n  -> HsExp -> [HsExp] -> HsExp
apply HsExp
namedC [ DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
n ]
        DotProtoPrimType
Int32    -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"Int32"
        DotProtoPrimType
Int64    -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"Int64"
        DotProtoPrimType
SInt32   -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"SInt32"
        DotProtoPrimType
SInt64   -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"SInt64"
        DotProtoPrimType
UInt32   -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"UInt32"
        DotProtoPrimType
UInt64   -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"UInt64"
        DotProtoPrimType
Fixed32  -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"Fixed32"
        DotProtoPrimType
Fixed64  -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"Fixed64"
        DotProtoPrimType
SFixed32 -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"SFixed32"
        DotProtoPrimType
SFixed64 -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"SFixed64"
        DotProtoPrimType
String   -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"String"
        DotProtoPrimType
Bytes    -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"Bytes"
        DotProtoPrimType
Bool     -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"Bool"
        DotProtoPrimType
Float    -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"Float"
        DotProtoPrimType
Double   -> String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
wrap String
"Double"

defaultImports ::
  ( (?stringType :: StringType)
  , (?typeLevelFormat :: Bool)
  ) =>
  -- | Uses GRPC?
  Bool ->
  [HsImportDecl]
defaultImports :: (?stringType::StringType, ?typeLevelFormat::Bool) =>
Bool -> [HsImportDecl]
defaultImports Bool
icUsesGrpc | StringType String
stringModule String
stringType <- ?stringType::StringType
StringType
?stringType =
    [ Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Prelude")               (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.Class")    (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
#ifdef DHALL
    , importDecl_ (m "Proto3.Suite.DhallPB")  & qualified (m hsDhallPB) & everything
#endif
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.DotProto") (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufASTNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.JSONPB")   (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
jsonpbNS   (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.JSONPB")   (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Bool -> Maybe Module -> a) -> a
unqualified          (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting  [String -> GenLocated SrcSpanAnnA (IE GhcPs)
sString
".=", String -> GenLocated SrcSpanAnnA (IE GhcPs)
sString
".:"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.Types")    (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Wire")           (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Wire.Decode")    (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting  [String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Parser", String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"RawField"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Control.Applicative")   (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Control.Applicative")   (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Bool -> Maybe Module -> a) -> a
unqualified          (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting  [String -> GenLocated SrcSpanAnnA (IE GhcPs)
sString
"<*>", String -> GenLocated SrcSpanAnnA (IE GhcPs)
sString
"<|>", String -> GenLocated SrcSpanAnnA (IE GhcPs)
sString
"<$>"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Control.DeepSeq")       (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Control.Monad")         (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.ByteString")       (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Coerce")           (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Int")              (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting  [String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Int16", String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Int32", String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Int64"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.List.NonEmpty")    (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting  [HsName -> HsExportSpec
ieNameAll_ (NameSpace -> String -> HsName
unqual_ NameSpace
tcName String
"NonEmpty")]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Map")              (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting  [String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Map", String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"mapKeysMonotonic"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Proxy")            (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
proxyNS    (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.String")           (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting  [String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"fromString"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
stringModule)            (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting  [String -> GenLocated SrcSpanAnnA (IE GhcPs)
i String
stringType]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Vector")           (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting  [String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Vector"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Word")             (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting  [String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Word16", String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Word32", String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Word64"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"GHC.Enum")              (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"GHC.Generics")          (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Google.Protobuf.Wrappers.Polymorphic") (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting [HsName -> HsExportSpec
ieNameAll_ (NameSpace -> String -> HsName
unqual_ NameSpace
tcName String
"Wrapped")]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Unsafe.Coerce")         (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    ]
    [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. Semigroup a => a -> a -> a
<>
    (if Bool -> Bool
not Bool
icUsesGrpc then [] else
    [ Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Network.GRPC.HighLevel.Generated")           (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
alias Module
grpcNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Network.GRPC.HighLevel.Client")              (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
alias Module
grpcNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Network.GRPC.HighLevel.Server")              (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
alias Module
grpcNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
hiding    [String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"serverLoop"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Network.GRPC.HighLevel.Server.Unregistered") (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
alias Module
grpcNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting [String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"serverLoop"]
    ])
    [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. Semigroup a => a -> a -> a
<>
    ( if Bool -> Bool
not ?typeLevelFormat::Bool
Bool
?typeLevelFormat then [] else
    [ Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.Form") (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufFormNS (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsExportSpec])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
(Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsExportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"GHC.TypeLits")      (Bool
 -> Maybe Module
 -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Bool
     -> Maybe Module
     -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module
    -> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS      (Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ((Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
     -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. a -> (a -> b) -> b
& [HsExportSpec]
-> (Maybe (Bool, [HsExportSpec])
    -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting [String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Nat", String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"Symbol", String -> GenLocated SrcSpanAnnA (IE GhcPs)
iString
"TypeError"]
    ])
  where
    m :: String -> Module
m = String -> Module
GHC.mkModuleName
    i :: String -> HsExportSpec
i String
n = HsName -> HsExportSpec
ieName_ (NameSpace -> String -> HsName
unqual_ (if (Char -> Bool -> Bool) -> Bool -> String -> Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Bool -> Bool
forall a b. a -> b -> a
const (Bool -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isLower) Bool
True String
n then NameSpace
varName else NameSpace
tcName) String
n)
    s :: String -> HsExportSpec
s String
n = HsName -> HsExportSpec
ieName_ (NameSpace -> String -> HsName
unqual_ NameSpace
varName String
n)

    grpcNS :: Module
grpcNS                    = String -> Module
m String
"HsGRPC"
    jsonpbNS :: Module
jsonpbNS                  = String -> Module
m String
"HsJSONPB"
    protobufNS :: Module
protobufNS                = String -> Module
m String
"HsProtobuf"
    protobufASTNS :: Module
protobufASTNS             = String -> Module
m String
"HsProtobufAST"
    proxyNS :: Module
proxyNS                   = String -> Module
m String
"Proxy"

    -- staged constructors for importDecl
    qualified :: Module -> (Bool -> Maybe Module -> a)  -> a
    qualified :: forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
m' Bool -> Maybe Module -> a
f = Bool -> Maybe Module -> a
f Bool
True (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
m')

    unqualified :: (Bool -> Maybe Module -> a) -> a
    unqualified :: forall a. (Bool -> Maybe Module -> a) -> a
unqualified Bool -> Maybe Module -> a
f = Bool -> Maybe Module -> a
f Bool
False Maybe Module
forall a. Maybe a
Nothing

    -- import unqualified AND also under a namespace
    alias :: Module -> (Bool -> Maybe Module -> a) -> a
    alias :: forall a. Module -> (Bool -> Maybe Module -> a) -> a
alias Module
m' Bool -> Maybe Module -> a
f = Bool -> Maybe Module -> a
f Bool
False (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
m')

    selecting :: [HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
    selecting :: forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
selecting [HsExportSpec]
is Maybe (Bool, [HsExportSpec]) -> a
f = Maybe (Bool, [HsExportSpec]) -> a
f ((Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. a -> Maybe a
Just (Bool
False, [HsExportSpec]
[GenLocated SrcSpanAnnA (IE GhcPs)]
is))

    hiding :: [HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
    hiding :: forall a.
[HsExportSpec] -> (Maybe (Bool, [HsExportSpec]) -> a) -> a
hiding [HsExportSpec]
is Maybe (Bool, [HsExportSpec]) -> a
f =  Maybe (Bool, [HsExportSpec]) -> a
f ((Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. a -> Maybe a
Just (Bool
True, [HsExportSpec]
[GenLocated SrcSpanAnnA (IE GhcPs)]
is))

    everything :: (Maybe (Bool, [HsImportSpec]) -> a) -> a
    everything :: forall a. (Maybe (Bool, [HsExportSpec]) -> a) -> a
everything Maybe (Bool, [HsExportSpec]) -> a
f = Maybe (Bool, [HsExportSpec]) -> a
f Maybe (Bool, [HsExportSpec])
Maybe (Bool, [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. Maybe a
Nothing

defaultMessageDeriving :: [HsQName]
defaultMessageDeriving :: [HsName]
defaultMessageDeriving = (String -> GenLocated SrcSpanAnnN RdrName)
-> [String] -> [GenLocated SrcSpanAnnN RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (NameSpace -> String -> HsName
haskellName NameSpace
tcName) [ String
"Show", String
"Eq", String
"Ord", String
"Generic" ]

defaultEnumDeriving :: [HsQName]
defaultEnumDeriving :: [HsName]
defaultEnumDeriving = (String -> GenLocated SrcSpanAnnN RdrName)
-> [String] -> [GenLocated SrcSpanAnnN RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (NameSpace -> String -> HsName
haskellName NameSpace
tcName) [ String
"Show", String
"Eq", String
"Generic", String
"NFData" ]

defaultServiceDeriving :: [HsQName]
defaultServiceDeriving :: [HsName]
defaultServiceDeriving = (String -> GenLocated SrcSpanAnnN RdrName)
-> [String] -> [GenLocated SrcSpanAnnN RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (NameSpace -> String -> HsName
haskellName NameSpace
tcName) [ String
"Generic" ]