{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# 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(..)
  , TypeContext
  , CompileArgs(..)
  , compileDotProtoFile
  , compileDotProtoFileOrDie
  , hsModuleForDotProto
  , renderHsModuleForDotProto
  , readDotProtoWithContext
  ) where

import           Control.Applicative
import           Control.Lens                   ((&), ix, over, has, filtered)
import           Control.Monad.Except
import           Data.Char
import           Data.Coerce
import           Data.Either                    (partitionEithers)
import           Data.List                      (find, intercalate, nub, sortBy, stripPrefix)
import qualified Data.List.NonEmpty             as NE
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map                       as M
import           Data.Maybe                     (fromMaybe)
import           Data.Monoid
import           Data.Ord                       (comparing)
import qualified Data.Set                       as S
import           Data.String                    (fromString)
import qualified Data.Text                      as T
import           Filesystem.Path.CurrentOS      ((</>), (<.>))
import qualified Filesystem.Path.CurrentOS      as FP
import           Language.Haskell.Parser        (ParseResult(..), parseModule)
import           Language.Haskell.Pretty
import           Language.Haskell.Syntax
import qualified NeatInterpolation              as Neat
import           Prelude                        hiding (FilePath)
import           Proto3.Suite.DotProto
import           Proto3.Suite.DotProto.AST.Lens
import           Proto3.Suite.DotProto.Internal
import           Proto3.Suite.DotProto.Rendering (Pretty(..))
import           Proto3.Wire.Types              (FieldNumber (..))
import           System.IO                      (writeFile, readFile)
import qualified Turtle
import           Turtle                         (FilePath)


--
-- * Public interface
--
data CompileArgs = CompileArgs
  { CompileArgs -> [FilePath]
includeDir         :: [FilePath]
  , CompileArgs -> [FilePath]
extraInstanceFiles :: [FilePath]
  , CompileArgs -> FilePath
inputProto         :: FilePath
  , CompileArgs -> FilePath
outputDir          :: FilePath
  }

-- | Generate a Haskell module corresponding to a @.proto@ file
compileDotProtoFile :: CompileArgs -> IO (Either CompileError ())
compileDotProtoFile :: CompileArgs -> IO (Either CompileError ())
compileDotProtoFile CompileArgs{[FilePath]
FilePath
outputDir :: FilePath
inputProto :: FilePath
extraInstanceFiles :: [FilePath]
includeDir :: [FilePath]
outputDir :: CompileArgs -> FilePath
inputProto :: CompileArgs -> FilePath
extraInstanceFiles :: CompileArgs -> [FilePath]
includeDir :: CompileArgs -> [FilePath]
..} = 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) <- [FilePath]
-> FilePath -> ExceptT CompileError IO (DotProto, TypeContext)
forall (m :: * -> *).
(MonadError CompileError m, MonadIO m) =>
[FilePath] -> FilePath -> m (DotProto, TypeContext)
readDotProtoWithContext [FilePath]
includeDir FilePath
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)
traverse String -> ExceptT CompileError IO String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName (NonEmpty String -> ExceptT CompileError IO (NonEmpty String))
-> (DotProto -> NonEmpty String)
-> DotProto
-> ExceptT CompileError IO (NonEmpty String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (DotProto -> ExceptT CompileError IO (NonEmpty String))
-> DotProto -> ExceptT CompileError IO (NonEmpty String)
forall a b. (a -> b) -> a -> b
$ DotProto
dotProto

    let relativePath :: FilePath
relativePath = [FilePath] -> FilePath
FP.concat ((String -> FilePath) -> [String] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map String -> FilePath
forall a. IsString a => String -> a
fromString ([String] -> [FilePath]) -> [String] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
modulePathPieces) FilePath -> Text -> FilePath
<.> Text
"hs"
    let modulePath :: FilePath
modulePath   = FilePath
outputDir FilePath -> FilePath -> FilePath
</> FilePath
relativePath

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

    ([HsImportDecl], [HsDecl])
extraInstances <- (FilePath -> ExceptT CompileError IO ([HsImportDecl], [HsDecl]))
-> [FilePath] -> ExceptT CompileError IO ([HsImportDecl], [HsDecl])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM FilePath -> ExceptT CompileError IO ([HsImportDecl], [HsDecl])
forall (m :: * -> *).
(MonadIO m, MonadError CompileError m) =>
FilePath -> m ([HsImportDecl], [HsDecl])
getExtraInstances [FilePath]
extraInstanceFiles

    String
haskellModule <- ([HsImportDecl], [HsDecl])
-> DotProto -> TypeContext -> ExceptT CompileError IO String
forall (m :: * -> *).
MonadError CompileError m =>
([HsImportDecl], [HsDecl]) -> DotProto -> TypeContext -> m String
renderHsModuleForDotProto ([HsImportDecl], [HsDecl])
extraInstances DotProto
dotProto TypeContext
importTypeContext

    IO () -> ExceptT CompileError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO ()
writeFile (FilePath -> String
FP.encodeString FilePath
modulePath) String
haskellModule)

-- | Same as 'compileDotProtoFile', except terminates the program with an error
-- message on failure.
compileDotProtoFileOrDie :: CompileArgs -> IO ()
compileDotProtoFileOrDie :: CompileArgs -> IO ()
compileDotProtoFileOrDie CompileArgs
args = CompileArgs -> IO (Either CompileError ())
compileDotProtoFile CompileArgs
args IO (Either CompileError ())
-> (Either CompileError () -> IO ()) -> IO ()
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 (FilePath -> Text) -> FilePath -> Text
forall r. Format Text r -> r
Turtle.format Format Text (FilePath -> Text)
forall r. Format r (FilePath -> r)
Turtle.fp (CompileArgs -> FilePath
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | 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
    => ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String
renderHsModuleForDotProto :: ([HsImportDecl], [HsDecl]) -> DotProto -> TypeContext -> m String
renderHsModuleForDotProto ([HsImportDecl], [HsDecl])
extraInstanceFiles DotProto
dotProto TypeContext
importCtxt = do
    HsModule
haskellModule <- ([HsImportDecl], [HsDecl]) -> DotProto -> TypeContext -> m HsModule
forall (m :: * -> *).
MonadError CompileError m =>
([HsImportDecl], [HsDecl]) -> DotProto -> TypeContext -> m HsModule
hsModuleForDotProto ([HsImportDecl], [HsDecl])
extraInstanceFiles DotProto
dotProto TypeContext
importCtxt
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> String
T.unpack Text
header String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsModule -> String
forall a. Pretty a => a -> String
prettyPrint HsModule
haskellModule)
  where
    header :: Text
header = [Neat.text|
      {-# LANGUAGE DeriveGeneric     #-}
      {-# LANGUAGE DeriveAnyClass    #-}
      {-# LANGUAGE DataKinds         #-}
      {-# LANGUAGE GADTs             #-}
      {-# LANGUAGE TypeApplications  #-}
      {-# LANGUAGE OverloadedStrings #-}
      {-# OPTIONS_GHC -fno-warn-unused-imports       #-}
      {-# OPTIONS_GHC -fno-warn-name-shadowing       #-}
      {-# OPTIONS_GHC -fno-warn-unused-matches       #-}
      {-# OPTIONS_GHC -fno-warn-missing-export-lists #-}

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

-- | Compile a Haskell module AST given a 'DotProto' package AST.
-- Instances given in @eis@ override those otherwise generated.
hsModuleForDotProto
    :: MonadError CompileError m
    => ([HsImportDecl], [HsDecl])
    -- ^ Extra user-define instances that override default generated instances
    -> DotProto
    -- ^
    -> TypeContext
    -- ^
    -> m HsModule
hsModuleForDotProto :: ([HsImportDecl], [HsDecl]) -> DotProto -> TypeContext -> m HsModule
hsModuleForDotProto
    ([HsImportDecl]
extraImports, [HsDecl]
extraInstances)
    dotProto :: DotProto
dotProto@DotProto{ protoMeta :: DotProto -> DotProtoMeta
protoMeta = DotProtoMeta { metaModulePath :: DotProtoMeta -> Path
metaModulePath = Path
modulePath }
                     , DotProtoPackageSpec
protoPackage :: DotProto -> DotProtoPackageSpec
protoPackage :: DotProtoPackageSpec
protoPackage
                     , [DotProtoDefinition]
protoDefinitions :: DotProto -> [DotProtoDefinition]
protoDefinitions :: [DotProtoDefinition]
protoDefinitions
                     }
    TypeContext
importTypeContext
  = do
       DotProtoIdentifier
packageIdentifier <- DotProtoPackageSpec -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoPackageSpec -> m DotProtoIdentifier
protoPackageName DotProtoPackageSpec
protoPackage
       Module
moduleName <- Path -> m Module
forall (m :: * -> *). MonadError CompileError m => Path -> m Module
modulePathModName Path
modulePath

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

       let hasService :: Bool
hasService = 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)
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 :: [HsImportDecl]
importDeclarations = [[HsImportDecl]] -> [HsImportDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Bool -> [HsImportDecl]
defaultImports Bool
hasService, [HsImportDecl]
extraImports, [HsImportDecl]
typeContextImports ]

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

       let toDotProtoDeclaration :: DotProtoDefinition -> m [HsDecl]
toDotProtoDeclaration =
             DotProtoIdentifier
-> TypeContext -> DotProtoDefinition -> m [HsDecl]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier
-> TypeContext -> DotProtoDefinition -> m [HsDecl]
dotProtoDefinitionD DotProtoIdentifier
packageIdentifier (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

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

       HsModule -> m HsModule
forall (m :: * -> *) a. Monad m => a -> m a
return (Module
-> Maybe [HsExportSpec] -> [HsImportDecl] -> [HsDecl] -> HsModule
module_ Module
moduleName Maybe [HsExportSpec]
forall a. Maybe a
Nothing [HsImportDecl]
importDeclarations [HsDecl]
decls)

getExtraInstances
    :: (MonadIO m, MonadError CompileError m)
    => FilePath -> m ([HsImportDecl], [HsDecl])
getExtraInstances :: FilePath -> m ([HsImportDecl], [HsDecl])
getExtraInstances FilePath
extraInstanceFile = do

  String
contents <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO String
readFile (FilePath -> String
FP.encodeString FilePath
extraInstanceFile))

  case String -> ParseResult HsModule
parseModule String
contents of
    ParseOk (HsModule SrcLoc
_srcloc Module
_mod Maybe [HsExportSpec]
_es [HsImportDecl]
idecls [HsDecl]
decls) -> do
      let isInstDecl :: HsDecl -> Bool
isInstDecl HsInstDecl{} = Bool
True
          isInstDecl HsDecl
_            = Bool
False

      ([HsImportDecl], [HsDecl]) -> m ([HsImportDecl], [HsDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsImportDecl]
idecls, (HsDecl -> Bool) -> [HsDecl] -> [HsDecl]
forall a. (a -> Bool) -> [a] -> [a]
filter HsDecl -> Bool
isInstDecl [HsDecl]
decls) --TODO give compile result

    ParseFailed SrcLoc
srcLoc String
err -> do
      let srcLocText :: Text
srcLocText = Format Text (SrcLoc -> Text) -> SrcLoc -> Text
forall r. Format Text r -> r
Turtle.format Format Text (SrcLoc -> Text)
forall a r. Show a => Format r (a -> r)
Turtle.w SrcLoc
srcLoc

      let errText :: Text
errText = String -> Text
T.pack String
err

      let message :: Text
message = [Neat.text|
            Error: Failed to parse instance file

            ${srcLocText}: ${errText}
          |]

      String -> m ([HsImportDecl], [HsDecl])
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError (Text -> String
T.unpack Text
message)

-- | 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 = (HsDecl -> [HsDecl] -> [HsDecl])
-> [HsDecl] -> [HsDecl] -> [HsDecl]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HsDecl -> [HsDecl] -> [HsDecl]
go []
   where go :: HsDecl -> [HsDecl] -> [HsDecl]
go HsDecl
x [HsDecl]
xs = case HsDecl
x of
             HsInstDecl SrcLoc
a HsContext
b HsQName
c (HsTyCon (Qual Module
tm  HsName
i):[HsType]
ts) [HsDecl]
d ->
                        if Module
m Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
tm then SrcLoc -> HsContext -> HsQName -> [HsType] -> [HsDecl] -> HsDecl
HsInstDecl SrcLoc
a HsContext
b HsQName
c (HsQName -> HsType
HsTyCon (HsName -> HsQName
UnQual HsName
i)HsType -> [HsType] -> [HsType]
forall a. a -> [a] -> [a]
:[HsType]
ts) [HsDecl]
dHsDecl -> [HsDecl] -> [HsDecl]
forall a. a -> [a] -> [a]
:[HsDecl]
xs else [HsDecl]
xs
             HsDecl
_ -> [HsDecl]
xs

-- | For each thing in @base@ replaces it if it finds a matching @override@
replaceHsInstDecls :: [HsDecl] -> [HsDecl] -> [HsDecl]
replaceHsInstDecls :: [HsDecl] -> [HsDecl] -> [HsDecl]
replaceHsInstDecls [HsDecl]
overrides [HsDecl]
base = (HsDecl -> [HsDecl]) -> [HsDecl] -> [HsDecl]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HsDecl -> [HsDecl]
mbReplace [HsDecl]
base
  where
    -- instances defined separately from data type definition:
    mbReplace :: HsDecl -> [HsDecl]
mbReplace hid :: HsDecl
hid@(HsInstDecl SrcLoc
_ HsContext
_ HsQName
qn [HsType]
tys [HsDecl]
_) =
        (HsDecl -> [HsDecl] -> [HsDecl]
forall a. a -> [a] -> [a]
: []) (HsDecl -> [HsDecl])
-> (Maybe HsDecl -> HsDecl) -> Maybe HsDecl -> [HsDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDecl -> Maybe HsDecl -> HsDecl
forall a. a -> Maybe a -> a
fromMaybe HsDecl
hid (Maybe HsDecl -> [HsDecl]) -> Maybe HsDecl -> [HsDecl]
forall a b. (a -> b) -> a -> b
$ HsQName -> [HsType] -> Maybe HsDecl
search HsQName
qn [HsType]
tys

    -- instances listed in "deriving" clause of data type definition:
    mbReplace (HsDataDecl SrcLoc
loc HsContext
ctx HsName
tyn [HsName]
names [HsConDecl]
def [HsQName]
insts) =
        let ([HsQName]
uncustomized, [HsDecl]
customized) = [Either HsQName HsDecl] -> ([HsQName], [HsDecl])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((HsQName -> Either HsQName HsDecl)
-> [HsQName] -> [Either HsQName HsDecl]
forall a b. (a -> b) -> [a] -> [b]
map (HsName -> HsQName -> Either HsQName HsDecl
deriv HsName
tyn) [HsQName]
insts)
        in SrcLoc
-> HsContext
-> HsName
-> [HsName]
-> [HsConDecl]
-> [HsQName]
-> HsDecl
HsDataDecl SrcLoc
loc HsContext
ctx HsName
tyn [HsName]
names [HsConDecl]
def [HsQName]
uncustomized HsDecl -> [HsDecl] -> [HsDecl]
forall a. a -> [a] -> [a]
: [HsDecl]
customized

    -- instances listed in "deriving" clause of newtype definition:
    mbReplace (HsNewTypeDecl SrcLoc
loc HsContext
ctx HsName
tyn [HsName]
names HsConDecl
def [HsQName]
insts) =
        let ([HsQName]
uncustomized, [HsDecl]
customized) = [Either HsQName HsDecl] -> ([HsQName], [HsDecl])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((HsQName -> Either HsQName HsDecl)
-> [HsQName] -> [Either HsQName HsDecl]
forall a b. (a -> b) -> [a] -> [b]
map (HsName -> HsQName -> Either HsQName HsDecl
deriv HsName
tyn) [HsQName]
insts)
        in SrcLoc
-> HsContext
-> HsName
-> [HsName]
-> HsConDecl
-> [HsQName]
-> HsDecl
HsNewTypeDecl SrcLoc
loc HsContext
ctx HsName
tyn [HsName]
names HsConDecl
def [HsQName]
uncustomized HsDecl -> [HsDecl] -> [HsDecl]
forall a. a -> [a] -> [a]
: [HsDecl]
customized

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

    deriv :: HsName -> HsQName -> Either HsQName HsDecl
deriv HsName
tyn HsQName
qn = Either HsQName HsDecl
-> (HsDecl -> Either HsQName HsDecl)
-> Maybe HsDecl
-> Either HsQName HsDecl
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HsQName -> Either HsQName HsDecl
forall a b. a -> Either a b
Left HsQName
qn) HsDecl -> Either HsQName HsDecl
forall a b. b -> Either a b
Right (Maybe HsDecl -> Either HsQName HsDecl)
-> Maybe HsDecl -> Either HsQName HsDecl
forall a b. (a -> b) -> a -> b
$ HsQName -> [HsType] -> Maybe HsDecl
search HsQName
qn [HsQName -> HsType
HsTyCon (HsName -> HsQName
UnQual HsName
tyn)]

    search :: HsQName -> [HsType] -> Maybe HsDecl
search HsQName
qn [HsType]
tys = (HsDecl -> Bool) -> [HsDecl] -> Maybe HsDecl
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\HsDecl
x -> (Maybe HsName, [HsType]) -> Maybe (Maybe HsName, [HsType])
forall a. a -> Maybe a
Just (HsQName -> Maybe HsName
unQual HsQName
qn,[HsType]
tys) Maybe (Maybe HsName, [HsType])
-> Maybe (Maybe HsName, [HsType]) -> Bool
forall a. Eq a => a -> a -> Bool
== HsDecl -> Maybe (Maybe HsName, [HsType])
getSig HsDecl
x) [HsDecl]
overrides

    getSig :: HsDecl -> Maybe (Maybe HsName, [HsType])
getSig (HsInstDecl SrcLoc
_ HsContext
_ HsQName
qn [HsType]
tys [HsDecl]
_) = (Maybe HsName, [HsType]) -> Maybe (Maybe HsName, [HsType])
forall a. a -> Maybe a
Just (HsQName -> Maybe HsName
unQual HsQName
qn,[HsType]
tys)
    getSig HsDecl
_ = Maybe (Maybe HsName, [HsType])
forall a. Maybe a
Nothing

    unQual :: HsQName -> Maybe HsName
unQual (Qual Module
_ HsName
n) = HsName -> Maybe HsName
forall a. a -> Maybe a
Just HsName
n
    unQual (UnQual HsName
n) = HsName -> Maybe HsName
forall a. a -> Maybe a
Just HsName
n
    unQual (Special HsSpecialCon
_) = Maybe HsName
forall a. Maybe a
Nothing

-- | 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 :: [FilePath] -> FilePath -> m (DotProto, TypeContext)
readDotProtoWithContext [] FilePath
toplevelProto = do
  -- If we're not given a search path, default to using the current working
  -- directory, as `protoc` does
  FilePath
cwd <- m FilePath
forall (io :: * -> *). MonadIO io => io FilePath
Turtle.pwd
  [FilePath] -> FilePath -> m (DotProto, TypeContext)
forall (m :: * -> *).
(MonadError CompileError m, MonadIO m) =>
[FilePath] -> FilePath -> m (DotProto, TypeContext)
readDotProtoWithContext [FilePath
cwd] FilePath
toplevelProto

readDotProtoWithContext [FilePath]
searchPaths FilePath
toplevelProto = do
  DotProto
dp <- [FilePath] -> FilePath -> FilePath -> m DotProto
forall (m :: * -> *).
(MonadIO m, MonadError CompileError m) =>
[FilePath] -> FilePath -> FilePath -> m DotProto
importProto [FilePath]
searchPaths FilePath
toplevelProto FilePath
toplevelProto
  let importIt :: DotProtoImport -> m TypeContext
importIt = [FilePath]
-> FilePath -> Set FilePath -> DotProtoImport -> m TypeContext
forall (m :: * -> *).
(MonadError CompileError m, MonadIO m) =>
[FilePath]
-> FilePath -> Set FilePath -> DotProtoImport -> m TypeContext
readImportTypeContext [FilePath]
searchPaths FilePath
toplevelProto (FilePath -> Set FilePath
forall a. a -> Set a
S.singleton FilePath
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 (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 :: [FilePath]
-> FilePath -> Set FilePath -> DotProtoImport -> m TypeContext
readImportTypeContext [FilePath]
searchPaths FilePath
toplevelFP Set FilePath
alreadyRead (DotProtoImport DotProtoImportQualifier
_ FilePath
path)
  | FilePath
path FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set FilePath
alreadyRead = CompileError -> m TypeContext
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FilePath -> CompileError
CircularImport FilePath
path)
  | Bool
otherwise = do
      DotProto
import_ <- [FilePath] -> FilePath -> FilePath -> m DotProto
forall (m :: * -> *).
(MonadIO m, MonadError CompileError m) =>
[FilePath] -> FilePath -> FilePath -> m DotProto
importProto [FilePath]
searchPaths FilePath
toplevelFP FilePath
path
      DotProtoIdentifier
importPkg <- DotProtoPackageSpec -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoPackageSpec -> m DotProtoIdentifier
protoPackageName (DotProto -> DotProtoPackageSpec
protoPackage DotProto
import_)

      let fixImportTyInfo :: DotProtoTypeInfo -> DotProtoTypeInfo
fixImportTyInfo DotProtoTypeInfo
tyInfo =
             DotProtoTypeInfo
tyInfo { dotProtoTypeInfoPackage :: DotProtoPackageSpec
dotProtoTypeInfoPackage    = DotProtoIdentifier -> DotProtoPackageSpec
DotProtoPackageSpec DotProtoIdentifier
importPkg
                    , dotProtoTypeInfoModulePath :: Path
dotProtoTypeInfoModulePath = DotProtoMeta -> Path
metaModulePath (DotProtoMeta -> Path)
-> (DotProto -> DotProtoMeta) -> DotProto -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotProto -> DotProtoMeta
protoMeta (DotProto -> Path) -> DotProto -> Path
forall a b. (a -> b) -> a -> b
$ DotProto
import_
                    }
      TypeContext
importTypeContext <- (DotProtoTypeInfo -> DotProtoTypeInfo)
-> TypeContext -> TypeContext
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_

      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 -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
importPkg) TypeContext
importTypeContext

      let isPublic :: DotProtoImport -> Bool
isPublic (DotProtoImport DotProtoImportQualifier
q FilePath
_) = 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)
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)
                   ([FilePath]
-> FilePath -> Set FilePath -> DotProtoImport -> m TypeContext
forall (m :: * -> *).
(MonadError CompileError m, MonadIO m) =>
[FilePath]
-> FilePath -> Set FilePath -> DotProtoImport -> m TypeContext
readImportTypeContext [FilePath]
searchPaths FilePath
toplevelFP (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
S.insert FilePath
path Set FilePath
alreadyRead))
                   (DotProto -> [DotProtoImport]
protoImports DotProto
import_)

      TypeContext -> m TypeContext
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.
ctxtImports :: MonadError CompileError m => TypeContext -> m [HsImportDecl]
ctxtImports :: TypeContext -> m [HsImportDecl]
ctxtImports = ([Module] -> [HsImportDecl]) -> m [Module] -> m [HsImportDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Module -> HsImportDecl) -> [Module] -> [HsImportDecl]
forall a b. (a -> b) -> [a] -> [b]
map Module -> HsImportDecl
mkImport ([Module] -> [HsImportDecl])
-> ([Module] -> [Module]) -> [Module] -> [HsImportDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Module] -> [Module]
forall a. Eq a => [a] -> [a]
nub)
            (m [Module] -> m [HsImportDecl])
-> (TypeContext -> m [Module]) -> TypeContext -> m [HsImportDecl]
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)
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, [HsImportSpec])
-> HsImportDecl
importDecl_ Module
modName Bool
True Maybe Module
forall a. Maybe a
Nothing Maybe (Bool, [HsImportSpec])
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
                      => DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo :: DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo DotProtoTypeInfo{TypeContext
DotProtoPackageSpec
DotProtoIdentifier
Path
DotProtoKind
dotProtoTypeInfoKind :: DotProtoTypeInfo -> DotProtoKind
dotProtoTypeChildContext :: DotProtoTypeInfo -> TypeContext
dotProtoTypeInfoParent :: DotProtoTypeInfo -> DotProtoIdentifier
dotProtoTypeInfoModulePath :: Path
dotProtoTypeInfoKind :: DotProtoKind
dotProtoTypeChildContext :: TypeContext
dotProtoTypeInfoParent :: DotProtoIdentifier
dotProtoTypeInfoPackage :: DotProtoPackageSpec
dotProtoTypeInfoModulePath :: DotProtoTypeInfo -> Path
dotProtoTypeInfoPackage :: DotProtoTypeInfo -> DotProtoPackageSpec
..} DotProtoIdentifier
ident = do
    Module
modName   <- Path -> m Module
forall (m :: * -> *). MonadError CompileError m => Path -> m Module
modulePathModName Path
dotProtoTypeInfoModulePath
    String
identName <- DotProtoIdentifier -> DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName DotProtoIdentifier
dotProtoTypeInfoParent DotProtoIdentifier
ident
    HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual Module
modName (String -> HsName
HsIdent String
identName))

haskellName, jsonpbName, grpcName, protobufName, protobufWrapperName, proxyName :: String -> HsQName
haskellName :: String -> HsQName
haskellName  String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"Hs")         (String -> HsName
HsIdent String
name)
jsonpbName :: String -> HsQName
jsonpbName   String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"HsJSONPB")   (String -> HsName
HsIdent String
name)
grpcName :: String -> HsQName
grpcName     String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"HsGRPC")     (String -> HsName
HsIdent String
name)
protobufName :: String -> HsQName
protobufName String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"HsProtobuf") (String -> HsName
HsIdent String
name)
proxyName :: String -> HsQName
proxyName    String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"Proxy")      (String -> HsName
HsIdent String
name)
protobufWrapperName :: String -> HsQName
protobufWrapperName String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"Google.Protobuf.Wrappers") (String -> HsName
HsIdent String
name)

modulePathModName :: MonadError CompileError m => Path -> m Module
modulePathModName :: Path -> m Module
modulePathModName (Path NonEmpty String
comps) = String -> Module
Module (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)
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 :: DotProtoIdentifier -> m Module
_pkgIdentModName (Single String
s)  = String -> Module
Module (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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DotProtoIdentifier -> CompileError
InvalidPackageName DotProtoIdentifier
x)


-- ** Dhall

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

dhallPBName :: String -> HsQName
dhallPBName name = Qual (Module hsDhallPB) (HsIdent name)

-- *** 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 fromDhall)
            [ type_ typeName ]
            [ ]

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

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

coerceE :: Bool -> HsType -> HsType -> Maybe HsExp
coerceE :: Bool -> HsType -> HsType -> Maybe HsExp
coerceE Bool
_ HsType
from HsType
to | HsType
from HsType -> HsType -> Bool
forall a. Eq a => a -> a -> Bool
== HsType
to = Maybe HsExp
forall a. Maybe a
Nothing
coerceE Bool
unsafe HsType
from HsType
to = HsExp -> Maybe HsExp
forall a. a -> Maybe a
Just (HsExp -> Maybe HsExp) -> HsExp -> Maybe HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> HsExp -> HsExp
HsApp (HsExp -> HsExp -> HsExp
HsApp HsExp
coerceF (HsType -> HsExp
typeApp HsType
from)) (HsType -> HsExp
typeApp HsType
to)
  where
    -- Do not add linebreaks to typeapps as that causes parse errors
    pp :: HsType -> String
pp = Style -> PPHsMode -> HsType -> String
forall a. Pretty a => Style -> PPHsMode -> a -> String
prettyPrintStyleMode Style
style{mode :: Mode
mode=Mode
OneLineMode} PPHsMode
defaultMode
    typeApp :: HsType -> HsExp
typeApp HsType
ty = String -> HsExp
uvar_ (String
"@("String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsType -> String
pp HsType
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
    coerceF :: HsExp
coerceF | Bool
unsafe = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"unsafeCoerce")
            | Bool
otherwise  = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"coerce")

wrapE :: MonadError CompileError m => TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
wrapE :: TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
wrapE TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt HsExp
e = HsExp -> (HsExp -> HsExp) -> Maybe HsExp -> HsExp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HsExp
e (\HsExp
f -> HsExp -> [HsExp] -> HsExp
apply HsExp
f [HsExp
e]) (Maybe HsExp -> HsExp) -> m (Maybe HsExp) -> m HsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (Bool -> HsType -> HsType -> Maybe HsExp
coerceE (DotProtoType -> Bool
isMap DotProtoType
dpt) (HsType -> HsType -> Maybe HsExp)
-> m HsType -> m (HsType -> Maybe HsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeContext -> DotProtoType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoType -> m HsType
dptToHsType TypeContext
ctxt DotProtoType
dpt m (HsType -> Maybe HsExp) -> m HsType -> m (Maybe HsExp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
[DotProtoOption] -> TypeContext -> DotProtoType -> m HsType
dptToHsTypeWrapped [DotProtoOption]
opts TypeContext
ctxt DotProtoType
dpt)

unwrapE :: MonadError CompileError m => TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
unwrapE :: TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
unwrapE TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt HsExp
e = HsExp -> (HsExp -> HsExp) -> Maybe HsExp -> HsExp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HsExp
e (\HsExp
f -> HsExp -> [HsExp] -> HsExp
apply HsExp
f [HsExp
e]) (Maybe HsExp -> HsExp) -> m (Maybe HsExp) -> m HsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
   (Bool -> HsType -> HsType -> Maybe HsExp
coerceE (DotProtoType -> Bool
isMap DotProtoType
dpt) (HsType -> HsType -> Maybe HsExp)
-> m HsType -> m (HsType -> Maybe HsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
     m HsType -> m HsType
overParser ([DotProtoOption] -> TypeContext -> DotProtoType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
[DotProtoOption] -> TypeContext -> DotProtoType -> m HsType
dptToHsTypeWrapped [DotProtoOption]
opts TypeContext
ctxt DotProtoType
dpt) m (HsType -> Maybe HsExp) -> m HsType -> m (Maybe HsExp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
       m HsType -> m HsType
overParser (TypeContext -> DotProtoType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoType -> m HsType
dptToHsType TypeContext
ctxt DotProtoType
dpt))
  where
    overParser :: m HsType -> m HsType
overParser = (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HsType -> HsType) -> m HsType -> m HsType)
-> (HsType -> HsType) -> m HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (HsName -> HsType
HsTyVar (String -> HsName
HsIdent String
"_"))


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

-- | Convert a dot proto type to a Haskell type
dptToHsType :: MonadError CompileError m => TypeContext -> DotProtoType -> m HsType
dptToHsType :: TypeContext -> DotProtoType -> m HsType
dptToHsType = (TypeContext -> DotProtoType -> HsType -> HsType)
-> (TypeContext -> DotProtoPrimType -> m HsType)
-> TypeContext
-> DotProtoType
-> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
(TypeContext -> DotProtoType -> HsType -> HsType)
-> (TypeContext -> DotProtoPrimType -> m HsType)
-> TypeContext
-> DotProtoType
-> m HsType
foldDPT TypeContext -> DotProtoType -> HsType -> HsType
dptToHsContType TypeContext -> DotProtoPrimType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType

-- | Convert a dot proto type to a wrapped Haskell type
dptToHsTypeWrapped :: MonadError CompileError m => [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType
dptToHsTypeWrapped :: [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType
dptToHsTypeWrapped [DotProtoOption]
opts =
   (TypeContext -> DotProtoType -> HsType -> HsType)
-> (TypeContext -> DotProtoPrimType -> m HsType)
-> TypeContext
-> DotProtoType
-> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
(TypeContext -> DotProtoType -> HsType -> HsType)
-> (TypeContext -> DotProtoPrimType -> m HsType)
-> TypeContext
-> DotProtoType
-> m HsType
foldDPT
     -- The wrapper for the collection type replaces the native haskell
     -- collection type, so try that first.
     (\TypeContext
ctxt DotProtoType
ty -> (HsType -> HsType)
-> ((HsType -> HsType) -> HsType -> HsType)
-> Maybe (HsType -> HsType)
-> HsType
-> HsType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TypeContext -> DotProtoType -> HsType -> HsType
dptToHsContType TypeContext
ctxt DotProtoType
ty) (HsType -> HsType) -> HsType -> HsType
forall a. a -> a
id (TypeContext
-> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType)
dptToHsWrappedContType TypeContext
ctxt [DotProtoOption]
opts DotProtoType
ty))
     -- Always wrap the primitive type.
     (\TypeContext
ctxt DotProtoPrimType
ty -> DotProtoPrimType -> HsType -> HsType
dpptToHsTypeWrapper DotProtoPrimType
ty (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeContext -> DotProtoPrimType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType' TypeContext
ctxt DotProtoPrimType
ty)
  where
    dpptToHsType' :: MonadError CompileError m
                  => TypeContext
                  -> DotProtoPrimType
                  -> m HsType
    dpptToHsType' :: TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType' TypeContext
ctxt =  \case
      DotProtoPrimType
Int32    -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int32"
      DotProtoPrimType
Int64    -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int64"
      DotProtoPrimType
SInt32   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int32"
      DotProtoPrimType
SInt64   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int64"
      DotProtoPrimType
UInt32   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Word32"
      DotProtoPrimType
UInt64   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Word64"
      DotProtoPrimType
Fixed32  -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Word32"
      DotProtoPrimType
Fixed64  -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Word64"
      DotProtoPrimType
SFixed32 -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int32"
      DotProtoPrimType
SFixed64 -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int64"
      DotProtoPrimType
String   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Text"
      DotProtoPrimType
Bytes    -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"ByteString"
      DotProtoPrimType
Bool     -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Bool"
      DotProtoPrimType
Float    -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Float"
      DotProtoPrimType
Double   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
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" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
protobufWrapperType_ String
x
        | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int64Value" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
protobufWrapperType_ String
x
        | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"UInt32Value" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
protobufWrapperType_ String
x
        | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"UInt64Value" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
protobufWrapperType_ String
x
        | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"StringValue" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
protobufWrapperType_ String
x
        | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BytesValue" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
protobufWrapperType_ String
x
        | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BoolValue" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
protobufWrapperType_ String
x
        | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"FloatValue" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
protobufWrapperType_ String
x
        | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"DoubleValue" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
protobufWrapperType_ String
x
      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 }) ->
              HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Enumerated") (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo DotProtoTypeInfo
ty DotProtoIdentifier
msgName
          Just DotProtoTypeInfo
ty -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo DotProtoTypeInfo
ty DotProtoIdentifier
msgName
          Maybe DotProtoTypeInfo
Nothing -> DotProtoIdentifier -> m HsType
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 :: (TypeContext -> DotProtoType -> HsType -> HsType)
-> (TypeContext -> DotProtoPrimType -> m HsType)
-> TypeContext
-> DotProtoType
-> m HsType
foldDPT TypeContext -> DotProtoType -> HsType -> HsType
dptToHsCont TypeContext -> DotProtoPrimType -> m HsType
foldPrim TypeContext
ctxt DotProtoType
dpt =
  let
      prim :: DotProtoPrimType -> m HsType
prim = TypeContext -> DotProtoPrimType -> m HsType
foldPrim TypeContext
ctxt
      go :: DotProtoType -> m HsType
go = (TypeContext -> DotProtoType -> HsType -> HsType)
-> (TypeContext -> DotProtoPrimType -> m HsType)
-> TypeContext
-> DotProtoType
-> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
(TypeContext -> DotProtoType -> HsType -> HsType)
-> (TypeContext -> DotProtoPrimType -> m HsType)
-> TypeContext
-> DotProtoType
-> m HsType
foldDPT TypeContext -> DotProtoType -> HsType -> HsType
dptToHsCont TypeContext -> DotProtoPrimType -> m HsType
foldPrim TypeContext
ctxt
      cont :: HsType -> HsType
cont = TypeContext -> DotProtoType -> HsType -> HsType
dptToHsCont TypeContext
ctxt DotProtoType
dpt
  in
    case DotProtoType
dpt of
      Prim DotProtoPrimType
pType           -> HsType -> HsType
cont (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoPrimType -> m HsType
prim DotProtoPrimType
pType
      Optional DotProtoPrimType
pType       -> HsType -> HsType
cont (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoPrimType -> m HsType
prim DotProtoPrimType
pType
      Repeated DotProtoPrimType
pType       -> HsType -> HsType
cont (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoPrimType -> m HsType
prim DotProtoPrimType
pType
      NestedRepeated DotProtoPrimType
pType -> HsType -> HsType
cont (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoPrimType -> m HsType
prim DotProtoPrimType
pType
      Map DotProtoPrimType
k DotProtoPrimType
v  | DotProtoPrimType -> Bool
validMapKey DotProtoPrimType
k -> HsType -> HsType -> HsType
HsTyApp (HsType -> HsType -> HsType)
-> (HsType -> HsType) -> HsType -> HsType -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType -> HsType
cont (HsType -> HsType -> HsType) -> m HsType -> m (HsType -> HsType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoPrimType -> m HsType
prim DotProtoPrimType
k m (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DotProtoType -> m HsType
go (DotProtoPrimType -> DotProtoType
Prim DotProtoPrimType
v) -- need to 'Nest' message types
               | Bool
otherwise -> CompileError -> m HsType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m HsType) -> CompileError -> m HsType
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).
dptToHsWrappedContType :: TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType)
dptToHsWrappedContType :: TypeContext
-> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType)
dptToHsWrappedContType TypeContext
ctxt [DotProtoOption]
opts = \case
  Prim (Named DotProtoIdentifier
tyName)
    | TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName -> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a. a -> Maybe a
Just ((HsType -> HsType) -> Maybe (HsType -> HsType))
-> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Nested")
  Repeated (Named DotProtoIdentifier
tyName)
    | TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName -> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a. a -> Maybe a
Just ((HsType -> HsType) -> Maybe (HsType -> HsType))
-> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"NestedVec")
  Repeated DotProtoPrimType
ty
    | [DotProtoOption] -> Bool
isUnpacked [DotProtoOption]
opts       -> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a. a -> Maybe a
Just ((HsType -> HsType) -> Maybe (HsType -> HsType))
-> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"UnpackedVec")
    | [DotProtoOption] -> Bool
isPacked [DotProtoOption]
opts         -> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a. a -> Maybe a
Just ((HsType -> HsType) -> Maybe (HsType -> HsType))
-> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"PackedVec")
    | TypeContext -> DotProtoPrimType -> Bool
isPackable TypeContext
ctxt DotProtoPrimType
ty    -> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a. a -> Maybe a
Just ((HsType -> HsType) -> Maybe (HsType -> HsType))
-> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"PackedVec")
    | Bool
otherwise             -> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a. a -> Maybe a
Just ((HsType -> HsType) -> Maybe (HsType -> HsType))
-> (HsType -> HsType) -> Maybe (HsType -> HsType)
forall a b. (a -> b) -> a -> b
$ HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"UnpackedVec")
  DotProtoType
_ -> Maybe (HsType -> HsType)
forall a. Maybe a
Nothing

-- | Translate DotProtoType to Haskell container types.
dptToHsContType :: TypeContext -> DotProtoType -> HsType -> HsType
dptToHsContType :: TypeContext -> DotProtoType -> HsType -> HsType
dptToHsContType TypeContext
ctxt = \case
  Prim (Named DotProtoIdentifier
tyName) | TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName
                     -> HsType -> HsType -> HsType
HsTyApp (HsType -> HsType -> HsType) -> HsType -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Maybe"
  Optional DotProtoPrimType
_         -> HsType -> HsType -> HsType
HsTyApp (HsType -> HsType -> HsType) -> HsType -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Maybe"
  Repeated DotProtoPrimType
_         -> HsType -> HsType -> HsType
HsTyApp (HsType -> HsType -> HsType) -> HsType -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Vector"
  NestedRepeated DotProtoPrimType
_   -> HsType -> HsType -> HsType
HsTyApp (HsType -> HsType -> HsType) -> HsType -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Vector"
  Map DotProtoPrimType
_ DotProtoPrimType
_            -> HsType -> HsType -> HsType
HsTyApp (HsType -> HsType -> HsType) -> HsType -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Map"
  DotProtoType
_                  -> HsType -> HsType
forall a. a -> a
id

-- | Haskell wrapper for primitive dot proto types
dpptToHsTypeWrapper :: DotProtoPrimType -> HsType -> HsType
dpptToHsTypeWrapper :: DotProtoPrimType -> HsType -> HsType
dpptToHsTypeWrapper = \case
  DotProtoPrimType
SInt32   -> HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Signed")
  DotProtoPrimType
SInt64   -> HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Signed")
  DotProtoPrimType
SFixed32 -> HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Signed") (HsType -> HsType) -> (HsType -> HsType) -> HsType -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Fixed")
  DotProtoPrimType
SFixed64 -> HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Signed") (HsType -> HsType) -> (HsType -> HsType) -> HsType -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Fixed")
  DotProtoPrimType
Fixed32  -> HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Fixed")
  DotProtoPrimType
Fixed64  -> HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Fixed")
  DotProtoPrimType
_        -> HsType -> HsType
forall a. a -> a
id

-- | Convert a dot proto prim type to an unwrapped Haskell type
dpptToHsType :: MonadError CompileError m
             => TypeContext
             -> DotProtoPrimType
             -> m HsType
dpptToHsType :: TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType TypeContext
ctxt = \case
  DotProtoPrimType
Int32    -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int32"
  DotProtoPrimType
Int64    -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int64"
  DotProtoPrimType
SInt32   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int32"
  DotProtoPrimType
SInt64   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int64"
  DotProtoPrimType
UInt32   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Word32"
  DotProtoPrimType
UInt64   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Word64"
  DotProtoPrimType
Fixed32  -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Word32"
  DotProtoPrimType
Fixed64  -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Word64"
  DotProtoPrimType
SFixed32 -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int32"
  DotProtoPrimType
SFixed64 -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int64"
  DotProtoPrimType
String   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Text"
  DotProtoPrimType
Bytes    -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"ByteString"
  DotProtoPrimType
Bool     -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Bool"
  DotProtoPrimType
Float    -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Float"
  DotProtoPrimType
Double   -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
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" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int32"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int64Value" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Int64"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"UInt32Value" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Word32"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"UInt64Value" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Word64"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"StringValue" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Text"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BytesValue" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"ByteString"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"BoolValue" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Bool"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"FloatValue" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
primType_ String
"Float"
    | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"DoubleValue" -> HsType -> m HsType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsType -> m HsType) -> HsType -> m HsType
forall a b. (a -> b) -> a -> b
$ String -> HsType
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 }) ->
          HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Enumerated") (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo DotProtoTypeInfo
ty DotProtoIdentifier
msgName
      Just DotProtoTypeInfo
ty -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo DotProtoTypeInfo
ty DotProtoIdentifier
msgName
      Maybe DotProtoTypeInfo
Nothing -> DotProtoIdentifier -> m HsType
forall (m :: * -> *) a.
MonadError CompileError m =>
DotProtoIdentifier -> m a
noSuchTypeError DotProtoIdentifier
msgName

validMapKey :: DotProtoPrimType -> Bool
validMapKey :: DotProtoPrimType -> Bool
validMapKey = (DotProtoPrimType -> [DotProtoPrimType] -> 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])


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

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

dotProtoDefinitionD :: MonadError CompileError m
                    => DotProtoIdentifier -> TypeContext -> DotProtoDefinition -> m [HsDecl]
dotProtoDefinitionD :: DotProtoIdentifier
-> TypeContext -> DotProtoDefinition -> m [HsDecl]
dotProtoDefinitionD DotProtoIdentifier
pkgIdent TypeContext
ctxt = \case
  DotProtoMessage String
_ DotProtoIdentifier
messageName [DotProtoMessagePart]
messageParts ->
    TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
forall (m :: * -> *).
MonadError CompileError m =>
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 ->
    DotProtoIdentifier
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
dotProtoServiceD DotProtoIdentifier
pkgIdent TypeContext
ctxt DotProtoIdentifier
serviceName [DotProtoServicePart]
serviceParts

-- | Generate 'Named' instance for a type in this package
namedInstD :: String -> HsDecl
namedInstD :: String -> HsDecl
namedInstD String
messageName =
  HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
protobufName String
"Named")
      [ String -> HsType
type_ String
messageName ]
      [ [HsMatch] -> HsDecl
HsFunBind [HsMatch
nameOfDecl] ]
  where
    nameOfDecl :: HsMatch
nameOfDecl = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"nameOf") [HsPat
HsPWildCard]
                        (HsExp -> HsRhs
HsUnGuardedRhs (HsExp -> [HsExp] -> HsExp
apply HsExp
fromStringE
                                               [ String -> HsExp
str_ String
messageName ]))
                        []

hasDefaultInstD :: String -> HsDecl
hasDefaultInstD :: String -> HsDecl
hasDefaultInstD String
messageName =
  HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
protobufName String
"HasDefault")
      [ String -> HsType
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
    => TypeContext
    -> DotProtoIdentifier
    -> DotProtoIdentifier
    -> [DotProtoMessagePart]
    -> m [HsDecl]
dotProtoMessageD :: 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 :: [([HsName], HsBangType)] -> HsDecl
mkDataDecl [([HsName], HsBangType)]
flds =
          String -> [HsConDecl] -> [HsQName] -> HsDecl
dataDecl_ String
messageName
            [ HsName -> [([HsName], HsBangType)] -> HsConDecl
recDecl_ (String -> HsName
HsIdent String
messageName) [([HsName], HsBangType)]
flds ]
            [HsQName]
defaultMessageDeriving

    let getName :: DotProtoMessagePart -> [DotProtoIdentifier]
getName = \case
          DotProtoMessageField DotProtoField
fld     -> [DotProtoField -> DotProtoIdentifier
dotProtoFieldName DotProtoField
fld]
          DotProtoMessageOneOf DotProtoIdentifier
ident [DotProtoField]
_ -> [DotProtoIdentifier
ident]
          DotProtoMessagePart
_                            -> []

    (m [HsDecl] -> m [HsDecl]) -> [m [HsDecl]] -> m [HsDecl]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM m [HsDecl] -> m [HsDecl]
forall a. a -> a
id
      [ [m HsDecl] -> m [HsDecl]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
          [ [([HsName], HsBangType)] -> HsDecl
mkDataDecl ([([HsName], HsBangType)] -> HsDecl)
-> m [([HsName], HsBangType)] -> m HsDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DotProtoMessagePart -> m [([HsName], HsBangType)])
-> [DotProtoMessagePart] -> m [([HsName], HsBangType)]
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], HsBangType)]
messagePartFieldD String
messageName) [DotProtoMessagePart]
messageParts
          , HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> HsDecl
namedInstD String
messageName)
          , HsDecl -> m HsDecl
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 =>
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 =>
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 =>
TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
fromJSONPBMessageInstD TypeContext
ctxt' DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent [DotProtoMessagePart]
messageParts

            -- Generate Aeson instances in terms of JSONPB instances
          , HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> HsDecl
toJSONInstDecl String
messageName)
          , HsDecl -> m HsDecl
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
          , String -> Maybe [HsName] -> [String] -> m HsDecl
forall (m :: * -> *).
MonadError CompileError m =>
String -> Maybe [HsName] -> [String] -> m HsDecl
toSchemaInstanceDeclaration String
messageName Maybe [HsName]
forall a. Maybe a
Nothing
              ([String] -> m HsDecl) -> m [String] -> m HsDecl
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (DotProtoMessagePart -> m [String])
-> [DotProtoMessagePart] -> m [String]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM ((DotProtoIdentifier -> m String)
-> [DotProtoIdentifier] -> m [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName ([DotProtoIdentifier] -> m [String])
-> (DotProtoMessagePart -> [DotProtoIdentifier])
-> DotProtoMessagePart
-> m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotProtoMessagePart -> [DotProtoIdentifier]
getName) [DotProtoMessagePart]
messageParts
#endif

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

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

      , GettingM
  [HsDecl]
  [DotProtoMessagePart]
  (DotProtoIdentifier, [DotProtoField])
-> ((DotProtoIdentifier, [DotProtoField]) -> m [HsDecl])
-> [DotProtoMessagePart]
-> m [HsDecl]
forall (m :: * -> *) r s a.
(Applicative m, Monoid r) =>
GettingM r s a -> (a -> m r) -> s -> m r
foldMapOfM ((DotProtoMessagePart
 -> Compose m (Const [HsDecl]) DotProtoMessagePart)
-> [DotProtoMessagePart]
-> Compose m (Const [HsDecl]) [DotProtoMessagePart]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((DotProtoMessagePart
  -> Compose m (Const [HsDecl]) DotProtoMessagePart)
 -> [DotProtoMessagePart]
 -> Compose m (Const [HsDecl]) [DotProtoMessagePart])
-> (((DotProtoIdentifier, [DotProtoField])
     -> Compose
          m (Const [HsDecl]) (DotProtoIdentifier, [DotProtoField]))
    -> DotProtoMessagePart
    -> Compose m (Const [HsDecl]) DotProtoMessagePart)
-> ((DotProtoIdentifier, [DotProtoField])
    -> Compose
         m (Const [HsDecl]) (DotProtoIdentifier, [DotProtoField]))
-> [DotProtoMessagePart]
-> Compose m (Const [HsDecl]) [DotProtoMessagePart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DotProtoIdentifier, [DotProtoField])
 -> Compose
      m (Const [HsDecl]) (DotProtoIdentifier, [DotProtoField]))
-> DotProtoMessagePart
-> Compose m (Const [HsDecl]) 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], HsBangType)]
messagePartFieldD String
messageName (DotProtoMessageField DotProtoField{String
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldComment :: DotProtoField -> String
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
dotProtoFieldComment :: String
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldType :: DotProtoType
dotProtoFieldNumber :: FieldNumber
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
..}) = 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
      HsType
fullTy <- TypeContext -> DotProtoType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoType -> m HsType
dptToHsType TypeContext
ctxt' DotProtoType
dotProtoFieldType
      [([HsName], HsBangType)] -> m [([HsName], HsBangType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ ([String -> HsName
HsIdent String
fullName], HsType -> HsBangType
HsUnBangedTy HsType
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 :: HsType
fullTy = HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (String -> HsQName
haskellName String
"Maybe")) (HsType -> HsType) -> (String -> HsType) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsType
type_ (String -> HsType) -> String -> HsType
forall a b. (a -> b) -> a -> b
$ String
qualTyName
      [([HsName], HsBangType)] -> m [([HsName], HsBangType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ ([String -> HsName
HsIdent String
fullName], HsType -> HsBangType
HsUnBangedTy HsType
fullTy) ]

    messagePartFieldD String
_ DotProtoMessagePart
_ = [([HsName], HsBangType)] -> m [([HsName], HsBangType)]
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 =>
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
_ = [HsDecl] -> m [HsDecl]
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

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

#ifdef SWAGGER
      HsDecl
toSchemaInstance <- String -> Maybe [HsName] -> [String] -> m HsDecl
forall (m :: * -> *).
MonadError CompileError m =>
String -> Maybe [HsName] -> [String] -> m HsDecl
toSchemaInstanceDeclaration String
fullName ([HsName] -> Maybe [HsName]
forall a. a -> Maybe a
Just [HsName]
idents)
                            ([String] -> m HsDecl) -> m [String] -> m HsDecl
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (DotProtoField -> m String) -> [DotProtoField] -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName (DotProtoIdentifier -> m String)
-> (DotProtoField -> DotProtoIdentifier)
-> DotProtoField
-> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotProtoField -> DotProtoIdentifier
dotProtoFieldName) [DotProtoField]
fields
#endif

      [HsDecl] -> m [HsDecl]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ String -> [HsConDecl] -> [HsQName] -> HsDecl
dataDecl_ String
fullName [HsConDecl]
cons [HsQName]
defaultMessageDeriving
           , String -> HsDecl
namedInstD String
fullName
#ifdef SWAGGER
           , HsDecl
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 :: String
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldType :: DotProtoType
dotProtoFieldNumber :: FieldNumber
dotProtoFieldComment :: DotProtoField -> String
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
..} = do
       HsType
consTy <- case DotProtoType
dotProtoFieldType of
            Prim msg :: DotProtoPrimType
msg@(Named DotProtoIdentifier
msgName)
              | TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt' DotProtoIdentifier
msgName
                -> TypeContext -> DotProtoPrimType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType TypeContext
ctxt' DotProtoPrimType
msg
            DotProtoType
_   -> TypeContext -> DotProtoType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoType -> m HsType
dptToHsType 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 = String -> HsName
HsIdent String
consName
       (HsConDecl, HsName) -> m (HsConDecl, HsName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsName -> [HsBangType] -> HsConDecl
conDecl_ HsName
ident [HsType -> HsBangType
HsUnBangedTy HsType
consTy], HsName
ident)

    oneOfCons String
_ DotProtoField
DotProtoEmptyField = String -> m (HsConDecl, HsName)
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError String
"field type : empty field"

-- *** Generate Protobuf 'Message' instances

messageInstD
    :: forall m
     . MonadError CompileError m
    => TypeContext
    -> DotProtoIdentifier
    -> DotProtoIdentifier
    -> [DotProtoMessagePart]
    -> m HsDecl
messageInstD :: 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

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

     let encodeMessageDecl :: HsMatch
encodeMessageDecl = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"encodeMessage")
                                    [HsPat
HsPWildCard, HsQName -> [HsPatField] -> HsPat
HsPRec (String -> HsQName
unqual_ String
msgName) [HsPatField]
punnedFieldsP]
                                    (HsExp -> HsRhs
HsUnGuardedRhs HsExp
encodeMessageE) []

         encodeMessageE :: HsExp
encodeMessageE = HsExp -> [HsExp] -> HsExp
apply HsExp
mconcatE [[HsExp] -> HsExp
HsList [HsExp]
encodedFields]

         punnedFieldsP :: [HsPatField]
punnedFieldsP = (QualifiedField -> HsPatField) -> [QualifiedField] -> [HsPatField]
forall a b. (a -> b) -> [a] -> [b]
map (String -> HsPatField
fp (String -> HsPatField)
-> (QualifiedField -> String) -> QualifiedField -> HsPatField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> String
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 -> HsPatField
fp String
nm = HsQName -> HsPat -> HsPatField
HsPFieldPat (String -> HsQName
unqual_ String
nm) (HsName -> HsPat
HsPVar (String -> HsName
HsIdent String
nm))


     let decodeMessageDecl :: HsMatch
decodeMessageDecl = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"decodeMessage") [ HsPat
HsPWildCard ]
                                    (HsExp -> HsRhs
HsUnGuardedRhs HsExp
decodeMessageE) []

         decodeMessageE :: HsExp
decodeMessageE = (HsExp -> HsExp -> HsExp) -> HsExp -> [HsExp] -> HsExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\HsExp
f -> HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
f HsQOp
apOp)
                                (HsExp -> [HsExp] -> HsExp
apply HsExp
pureE [ String -> HsExp
uvar_ String
msgName ])
                                [HsExp]
decodedFields

     let dotProtoDecl :: HsMatch
dotProtoDecl = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"dotProto") [HsPat
HsPWildCard]
                               (HsExp -> HsRhs
HsUnGuardedRhs HsExp
dotProtoE) []

         dotProtoE :: HsExp
dotProtoE = [HsExp] -> HsExp
HsList ([HsExp] -> HsExp) -> [HsExp] -> HsExp
forall a b. (a -> b) -> a -> b
$ do
           DotProtoMessageField DotProtoField{String
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldComment :: String
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldType :: DotProtoType
dotProtoFieldNumber :: FieldNumber
dotProtoFieldComment :: DotProtoField -> String
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
..} <- [DotProtoMessagePart]
messageParts
           HsExp -> [HsExp]
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
HsList ((DotProtoOption -> HsExp) -> [DotProtoOption] -> [HsExp]
forall a b. (a -> b) -> [a] -> [b]
map DotProtoOption -> HsExp
optionE [DotProtoOption]
dotProtoFieldOptions)
                        , String -> HsExp
str_ String
dotProtoFieldComment
                        ]


     HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsDecl -> m HsDecl) -> HsDecl -> m HsDecl
forall a b. (a -> b) -> a -> b
$ HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
protobufName String
"Message")
                      [ String -> HsType
type_ String
msgName ]
                      [ [HsMatch] -> HsDecl
HsFunBind [ HsMatch
encodeMessageDecl ]
                      , [HsMatch] -> HsDecl
HsFunBind [ HsMatch
decodeMessageDecl ]
                      , [HsMatch] -> HsDecl
HsFunBind [ HsMatch
dotProtoDecl ]
                      ]
  where
    encodeMessageField :: QualifiedField -> m HsExp
    encodeMessageField :: QualifiedField -> m HsExp
encodeMessageField QualifiedField{FieldName
recordFieldName :: FieldName
recordFieldName :: QualifiedField -> FieldName
recordFieldName, FieldInfo
fieldInfo :: QualifiedField -> FieldInfo
fieldInfo :: FieldInfo
fieldInfo} =
      let recordFieldName' :: HsExp
recordFieldName' = String -> HsExp
uvar_ (FieldName -> String
coerce FieldName
recordFieldName) in
      case FieldInfo
fieldInfo of
        FieldNormal FieldName
_fieldName FieldNumber
fieldNum DotProtoType
dpType [DotProtoOption]
options -> do
            HsExp
fieldE <- TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
wrapE TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType HsExp
recordFieldName'
            HsExp -> m HsExp
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
fieldE ]

        FieldOneOf OneofField{[OneofSubfield]
subfields :: OneofField -> [OneofSubfield]
subfields :: [OneofSubfield]
subfields} -> do
            [HsAlt]
alts <- (OneofSubfield -> m HsAlt) -> [OneofSubfield] -> m [HsAlt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM OneofSubfield -> m HsAlt
forall (m :: * -> *).
MonadError CompileError m =>
OneofSubfield -> m HsAlt
mkAlt [OneofSubfield]
subfields
            HsExp -> m HsExp
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
HsCase HsExp
recordFieldName'
                    [ HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ (HsQName -> [HsPat] -> HsPat
HsPApp (String -> HsQName
haskellName String
"Nothing") [])
                           (HsExp -> HsGuardedAlts
HsUnGuardedAlt HsExp
memptyE)
                           []
                    , HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ (HsQName -> [HsPat] -> HsPat
HsPApp (String -> HsQName
haskellName String
"Just") [String -> HsPat
patVar String
"x"])
                           (HsExp -> HsGuardedAlts
HsUnGuardedAlt (HsExp -> [HsAlt] -> HsExp
HsCase (String -> HsExp
uvar_ String
"x") [HsAlt]
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 HsAlt
mkAlt (OneofSubfield FieldNumber
fieldNum String
conName FieldName
_ DotProtoType
dpType [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 :: HsExp -> HsExp
wrapJust = HsExp -> HsExp
HsParen (HsExp -> HsExp) -> (HsExp -> HsExp) -> HsExp -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"Just"))

              HsExp
xE <- (if Bool
isMaybe then m HsExp -> m HsExp
forall a. a -> a
id else (HsExp -> HsExp) -> m HsExp -> m HsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsExp -> HsExp
forceEmitE)
                     (m HsExp -> m HsExp) -> (HsExp -> m HsExp) -> HsExp -> m HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
wrapE TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType
                     (HsExp -> m HsExp) -> (HsExp -> HsExp) -> HsExp -> m HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isMaybe then HsExp -> HsExp
wrapJust else HsExp -> HsExp
forall a. a -> a
id)
                     (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ String -> HsExp
uvar_ String
"y"

              HsAlt -> m HsAlt
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsAlt -> m HsAlt) -> HsAlt -> m HsAlt
forall a b. (a -> b) -> a -> b
$ HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ (HsQName -> [HsPat] -> HsPat
HsPApp (String -> HsQName
unqual_ String
conName) [String -> HsPat
patVar String
"y"])
                          (HsExp -> HsGuardedAlts
HsUnGuardedAlt (HsExp -> [HsExp] -> HsExp
apply HsExp
encodeMessageFieldE [FieldNumber -> HsExp
fieldNumberE FieldNumber
fieldNum, HsExp
xE]))
                          []


    decodeMessageField :: QualifiedField -> m HsExp
    decodeMessageField :: QualifiedField -> m HsExp
decodeMessageField QualifiedField{FieldInfo
fieldInfo :: FieldInfo
fieldInfo :: QualifiedField -> FieldInfo
fieldInfo} =
      case FieldInfo
fieldInfo of
        FieldNormal FieldName
_fieldName FieldNumber
fieldNum DotProtoType
dpType [DotProtoOption]
options ->
            TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
unwrapE 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 OneofField{[OneofSubfield]
subfields :: [OneofSubfield]
subfields :: OneofField -> [OneofSubfield]
subfields} -> do
            [HsExp]
parsers <- (OneofSubfield -> m HsExp) -> [OneofSubfield] -> m [HsExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM OneofSubfield -> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
OneofSubfield -> m HsExp
subfieldParserE [OneofSubfield]
subfields
            HsExp -> m HsExp
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 [ HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"Nothing")
                                 , [HsExp] -> HsExp
HsList [HsExp]
parsers
                                 ]
          where
            -- create a list of (fieldNumber, Cons <$> parser)
            subfieldParserE :: OneofSubfield -> m HsExp
subfieldParserE (OneofSubfield FieldNumber
fieldNumber String
consName FieldName
_ DotProtoType
dpType [DotProtoOption]
options) = do
              let fE :: HsExp
fE | Prim (Named DotProtoIdentifier
tyName) <- DotProtoType
dpType, TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
tyName
                     = HsExp -> HsExp
HsParen (HsExp -> HsExp -> HsExp
HsApp HsExp
fmapE (String -> HsExp
uvar_ String
consName))
                     | Bool
otherwise
                     = HsExp -> HsExp
HsParen (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"Just"))
                                           HsQOp
composeOp
                                           (String -> HsExp
uvar_ String
consName))

              HsExp
alts <- TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
unwrapE TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType HsExp
decodeMessageFieldE

              HsExp -> m HsExp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$ [HsExp] -> HsExp
HsTuple
                   [ FieldNumber -> HsExp
fieldNumberE FieldNumber
fieldNumber
                   , HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (HsExp -> [HsExp] -> HsExp
apply HsExp
pureE [ HsExp
fE ]) HsQOp
apOp HsExp
alts
                   ]


-- *** Generate ToJSONPB/FromJSONPB instances

toJSONPBMessageInstD
    :: MonadError CompileError m
    => TypeContext
    -> DotProtoIdentifier
    -> DotProtoIdentifier
    -> [DotProtoMessagePart]
    -> m HsDecl
toJSONPBMessageInstD :: 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 -> HsExp
applyE String
nm String
oneofNm =
          HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
nm))
                [ [HsExp] -> HsExp
HsList ((FieldName -> FieldNumber -> HsExp)
-> (OneofField -> HsExp) -> QualifiedField -> HsExp
forall a.
(FieldName -> FieldNumber -> a)
-> (OneofField -> a) -> QualifiedField -> a
foldQF FieldName -> FieldNumber -> HsExp
forall a. Coercible a String => a -> FieldNumber -> HsExp
defPairE (String -> OneofField -> HsExp
oneofCaseE String
oneofNm) (QualifiedField -> HsExp) -> [QualifiedField] -> [HsExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QualifiedField]
qualFields) ]

    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 -> HsMatch
matchE String
nm String
appNm String
oneofAppNm =
          HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_
            (String -> HsName
HsIdent String
nm)
            [ HsQName -> [HsPat] -> HsPat
HsPApp (String -> HsQName
unqual_ String
msgName)
                     (String -> HsPat
patVar (String -> HsPat)
-> (QualifiedField -> String) -> QualifiedField -> HsPat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedField -> String
patBinder (QualifiedField -> HsPat) -> [QualifiedField] -> [HsPat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QualifiedField]
qualFields) ]
            (HsExp -> HsRhs
HsUnGuardedRhs (String -> String -> HsExp
applyE String
appNm String
oneofAppNm))
            []

    HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsDecl -> m HsDecl) -> HsDecl -> m HsDecl
forall a b. (a -> b) -> a -> b
$ HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
jsonpbName String
"ToJSONPB")
                     [ String -> HsType
type_ String
msgName ]
                     [ [HsMatch] -> HsDecl
HsFunBind [String -> String -> String -> HsMatch
matchE String
"toJSONPB"     String
"object" String
"objectOrNull"]
                     , [HsMatch] -> HsDecl
HsFunBind [String -> String -> String -> HsMatch
matchE String
"toEncodingPB" String
"pairs"  String
"pairsOrNull" ]
                     ]

  where
    -- E.g.
    -- "another" .= f2 -- always succeeds (produces default value on missing field)
    defPairE :: a -> FieldNumber -> HsExp
defPairE a
fldName FieldNumber
fldNum =
      HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (String -> HsExp
str_ (a -> String
coerce a
fldName))
                 HsQOp
toJSONPBOp
                 (String -> HsExp
uvar_ (FieldNumber -> String
fieldBinder FieldNumber
fldNum))

    -- E.g.
    -- HsJSONPB.pair "name" f4 -- fails on missing field
    pairE :: a -> String -> HsExp
pairE a
fldNm String
varNm =
      HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"pair"))
            [ String -> HsExp
str_ (a -> String
coerce a
fldNm) , String -> HsExp
uvar_ String
varNm]

    -- 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 -> HsExp
oneofCaseE String
retJsonCtor (OneofField String
typeName [OneofSubfield]
subfields) =
        HsExp -> HsExp
HsParen
          (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$ [HsDecl] -> HsExp -> HsExp
HsLet [ [HsMatch] -> HsDecl
HsFunBind [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
caseName) [] (HsExp -> HsRhs
HsUnGuardedRhs HsExp
caseExpr) [] ] ]
          (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$ SrcLoc -> [HsPat] -> HsExp -> HsExp
HsLambda SrcLoc
defaultSrcLoc [String -> HsPat
patVar String
optsStr] (HsExp -> HsExp -> HsExp -> HsExp
HsIf HsExp
dontInline HsExp
noInline HsExp
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 Index String
0) Char -> Char
toUpper String
typeName
        caseBnd :: HsExp
caseBnd = String -> HsExp
uvar_ String
caseName

        dontInline :: HsExp
dontInline = HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"optEmitNamedOneof")) HsExp
opts

        noInline :: HsExp
noInline = HsExp -> HsExp -> HsExp
HsApp (HsExp -> HsExp
HsParen (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (String -> HsExp
str_ String
typeName)
                                              HsQOp
toJSONPBOp
                                              (HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
retJsonCtor))
                                                     [ [HsExp] -> HsExp
HsList [HsExp
caseBnd], HsExp
opts ])))
                         HsExp
opts

        yesInline :: HsExp
yesInline = HsExp -> HsExp -> HsExp
HsApp HsExp
caseBnd HsExp
opts


        -- E.g.
        -- case f4_or_f9 of
        --   Just (SomethingPickOneName f4)
        --     -> HsJSONPB.pair "name" f4
        --   Just (SomethingPickOneSomeid f9)
        --     -> HsJSONPB.pair "someid" f9
        --   Nothing
        --     -> mempty
        caseExpr :: HsExp
caseExpr = HsExp -> HsExp
HsParen (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$
            HsExp -> [HsAlt] -> HsExp
HsCase HsExp
disjunctName ([HsAlt]
altEs [HsAlt] -> [HsAlt] -> [HsAlt]
forall a. Semigroup a => a -> a -> a
<> [HsAlt
fallthroughE])
          where
            disjunctName :: HsExp
disjunctName = String -> HsExp
uvar_ ([OneofSubfield] -> String
oneofSubDisjunctBinder [OneofSubfield]
subfields)
            altEs :: [HsAlt]
altEs = do
              sub :: OneofSubfield
sub@(OneofSubfield FieldNumber
_ String
conName FieldName
pbFldNm DotProtoType
_ [DotProtoOption]
_) <- [OneofSubfield]
subfields
              let patVarNm :: String
patVarNm = OneofSubfield -> String
oneofSubBinder OneofSubfield
sub
              HsAlt -> [HsAlt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsAlt -> [HsAlt]) -> HsAlt -> [HsAlt]
forall a b. (a -> b) -> a -> b
$ HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ (HsQName -> [HsPat] -> HsPat
HsPApp (String -> HsQName
haskellName String
"Just")
                                  [ HsPat -> HsPat
HsPParen
                                    (HsQName -> [HsPat] -> HsPat
HsPApp (String -> HsQName
unqual_ String
conName) [String -> HsPat
patVar String
patVarNm])
                                  ]
                          )
                          (HsExp -> HsGuardedAlts
HsUnGuardedAlt (FieldName -> String -> HsExp
forall a. Coercible a String => a -> String -> HsExp
pairE FieldName
pbFldNm String
patVarNm))
                          []
            fallthroughE :: HsAlt
fallthroughE =
              HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ (HsQName -> [HsPat] -> HsPat
HsPApp (String -> HsQName
haskellName String
"Nothing") [])
                   (HsExp -> HsGuardedAlts
HsUnGuardedAlt HsExp
memptyE)
                   []

fromJSONPBMessageInstD
    :: MonadError CompileError m
    => TypeContext
    -> DotProtoIdentifier
    -> DotProtoIdentifier
    -> [DotProtoMessagePart]
    -> m HsDecl
fromJSONPBMessageInstD :: 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

    let parseJSONPBE :: HsExp
parseJSONPBE =
          HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"withObject"))
                [ String -> HsExp
str_ String
msgName
                , HsExp -> HsExp
HsParen (SrcLoc -> [HsPat] -> HsExp -> HsExp
HsLambda SrcLoc
defaultSrcLoc [HsPat
lambdaPVar] HsExp
fieldAps)
                ]
          where
            fieldAps :: HsExp
fieldAps = (HsExp -> HsExp -> HsExp) -> HsExp -> [HsExp] -> HsExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\HsExp
f -> HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
f HsQOp
apOp)
                             (HsExp -> [HsExp] -> HsExp
apply HsExp
pureE [ String -> HsExp
uvar_ String
msgName ])
                             ((FieldName -> FieldNumber -> HsExp)
-> (OneofField -> HsExp) -> QualifiedField -> HsExp
forall a.
(FieldName -> FieldNumber -> a)
-> (OneofField -> a) -> QualifiedField -> a
foldQF FieldName -> FieldNumber -> HsExp
forall a p. Coercible a String => a -> p -> HsExp
normalParserE OneofField -> HsExp
oneofParserE (QualifiedField -> HsExp) -> [QualifiedField] -> [HsExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QualifiedField]
qualFields)

    let parseJSONPBDecl :: HsMatch
parseJSONPBDecl =
          HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"parseJSONPB") [] (HsExp -> HsRhs
HsUnGuardedRhs HsExp
parseJSONPBE) []

    HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
jsonpbName String
"FromJSONPB")
                   [ String -> HsType
type_ String
msgName ]
                   [ [HsMatch] -> HsDecl
HsFunBind [ HsMatch
parseJSONPBDecl ] ])
  where
    lambdaPVar :: HsPat
lambdaPVar = String -> HsPat
patVar String
"obj"
    lambdaVar :: HsExp
lambdaVar  = String -> HsExp
uvar_ String
"obj"

    -- 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 -> HsExp
oneofParserE (OneofField String
oneofType [OneofSubfield]
fields) =
        HsExp -> HsExp
HsParen (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$
          [HsDecl] -> HsExp -> HsExp
HsLet [ [HsMatch] -> HsDecl
HsFunBind [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
letBndStr) [String -> HsPat
patVar String
letArgStr ]
                                     (HsExp -> HsRhs
HsUnGuardedRhs HsExp
tryParseDisjunctsE) []
                            ]
                ]
                (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
parseWrapped HsQOp
altOp HsExp
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 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
HsParen (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$
          HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (HsExp -> HsExp
HsParen (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
lambdaVar HsQOp
parseJSONPBOp HsExp
oneofTyLit))
                     HsQOp
bindOp
                     (HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"withObject")) [ HsExp
oneofTyLit , HsExp
letBndName ])

        parseUnwrapped :: HsExp
parseUnwrapped = HsExp -> HsExp
HsParen (HsExp -> HsExp -> HsExp
HsApp HsExp
letBndName HsExp
lambdaVar)

        -- parseSomethingNameOrId parseObj =
        --   Hs.msum
        --     [ (Just . SomethingPickOneName) <$> (HsJSONPB.parseField parseObj "name")
        --     , (Just . SomethingPickOneSomeid) <$> (HsJSONPB.parseField parseObj "someid")
        --     , pure Nothing
        --     ]
        tryParseDisjunctsE :: HsExp
tryParseDisjunctsE =
            HsExp -> HsExp -> HsExp
HsApp HsExp
msumE ([HsExp] -> HsExp
HsList ((OneofSubfield -> HsExp) -> [OneofSubfield] -> [HsExp]
forall a b. (a -> b) -> [a] -> [b]
map OneofSubfield -> HsExp
subParserE [OneofSubfield]
fields [HsExp] -> [HsExp] -> [HsExp]
forall a. Semigroup a => a -> a -> a
<> [HsExp]
fallThruE))
          where
            fallThruE :: [HsExp]
fallThruE
              = [ HsExp -> HsExp -> HsExp
HsApp HsExp
pureE (HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"Nothing")) ]
            subParserE :: OneofSubfield -> HsExp
subParserE OneofSubfield{String
subfieldConsName :: OneofSubfield -> String
subfieldConsName :: String
subfieldConsName, FieldName
subfieldName :: OneofSubfield -> FieldName
subfieldName :: FieldName
subfieldName}
              = HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp
                  (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"Just"))
                              HsQOp
composeOp
                              (String -> HsExp
uvar_ String
subfieldConsName))
                  HsQOp
fmapOp
                  (HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"parseField"))
                         [ HsExp
letArgName
                         , String -> HsExp
str_ (FieldName -> String
coerce FieldName
subfieldName)])

    -- E.g. obj .: "someid"
    normalParserE :: a -> p -> HsExp
normalParserE a
fldNm p
_ =
      HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
lambdaVar
                 HsQOp
parseJSONPBOp
                 (String -> HsExp
str_(a -> String
coerce a
fldNm))

-- *** 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 =
  HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
jsonpbName String
"ToJSON")
            [ String -> HsType
type_ String
typeName ]
            [ [HsMatch] -> HsDecl
HsFunBind [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"toJSON") []
                                 (HsExp -> HsRhs
HsUnGuardedRhs (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"toAesonValue"))) []
                        ]
            , [HsMatch] -> HsDecl
HsFunBind [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"toEncoding") []
                                 (HsExp -> HsRhs
HsUnGuardedRhs (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"toAesonEncoding"))) []
                        ]
            ]

fromJSONInstDecl :: String -> HsDecl
fromJSONInstDecl :: String -> HsDecl
fromJSONInstDecl String
typeName =
  HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
jsonpbName String
"FromJSON")
            [ String -> HsType
type_ String
typeName ]
            [ [HsMatch] -> HsDecl
HsFunBind [HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"parseJSON") []
                                (HsExp -> HsRhs
HsUnGuardedRhs (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"parseJSONPB"))) []
                        ]
            ]


-- *** Generate `ToSchema` instance

toSchemaInstanceDeclaration
    :: MonadError CompileError m
    => String
    -- ^ Name of the message type to create an instance for
    -> Maybe [HsName]
    -- ^ Oneof constructors
    -> [String]
    -- ^ Field names
    -> m HsDecl
toSchemaInstanceDeclaration :: String -> Maybe [HsName] -> [String] -> m HsDecl
toSchemaInstanceDeclaration String
messageName Maybe [HsName]
maybeConstructors [String]
fieldNames = do
  [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)
mapM (String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedFieldName String
messageName) [String]
fieldNames

  let messageConstructor :: HsExp
messageConstructor = HsQName -> HsExp
HsCon (HsName -> HsQName
UnQual (String -> HsName
HsIdent String
messageName))

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

#ifdef SWAGGER
      -- { _paramSchemaType = HsJSONPB.SwaggerObject
      -- }
  let paramSchemaUpdates :: [HsFieldUpdate]
paramSchemaUpdates =
        [ HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
_paramSchemaType HsExp
_paramSchemaTypeExpression
        ]
        where
          _paramSchemaType :: HsQName
_paramSchemaType = String -> HsQName
jsonpbName String
"_paramSchemaType"

#if MIN_VERSION_swagger2(2,4,0)
          _paramSchemaTypeExpression :: HsExp
_paramSchemaTypeExpression = HsExp -> HsExp -> HsExp
HsApp HsExp
justC (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"SwaggerObject"))
#else
          _paramSchemaTypeExpression = HsVar (jsonpbName "SwaggerObject")
#endif
#else
  let paramSchemaUpdates = []
#endif

  let _schemaParamSchemaExpression :: HsExp
_schemaParamSchemaExpression = HsExp -> [HsFieldUpdate] -> HsExp
HsRecUpdate HsExp
memptyE [HsFieldUpdate]
paramSchemaUpdates

      -- [ ("fieldName0", qualifiedFieldName0)
      -- , ("fieldName1", qualifiedFieldName1)
      -- ...
      -- ]
  let properties :: HsExp
properties = [HsExp] -> HsExp
HsList ([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
        HsExp -> [HsExp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsExp] -> HsExp
HsTuple [ String -> HsExp
str_  String
fieldName, String -> HsExp
uvar_ String
qualifiedFieldName ])

  let _schemaPropertiesExpression :: HsExp
_schemaPropertiesExpression =
        HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"insOrdFromList")) HsExp
properties

      -- { _schemaParamSchema = ...
      -- , _schemaProperties  = ...
      -- , ...
      -- }
  let schemaUpdates :: [HsFieldUpdate]
schemaUpdates = [HsFieldUpdate]
normalUpdates [HsFieldUpdate] -> [HsFieldUpdate] -> [HsFieldUpdate]
forall a. [a] -> [a] -> [a]
++ [HsFieldUpdate]
extraUpdates
        where
          normalUpdates :: [HsFieldUpdate]
normalUpdates =
            [ HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
_schemaParamSchema HsExp
_schemaParamSchemaExpression
            , HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
_schemaProperties  HsExp
_schemaPropertiesExpression
            ]

          extraUpdates :: [HsFieldUpdate]
extraUpdates =
            case Maybe [HsName]
maybeConstructors of
                Just [HsName]
_ ->
                  [ HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
_schemaMinProperties HsExp
justOne
                  , HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
_schemaMaxProperties HsExp
justOne
                  ]
                Maybe [HsName]
Nothing ->
                  []

          _schemaParamSchema :: HsQName
_schemaParamSchema    = String -> HsQName
jsonpbName String
"_schemaParamSchema"
          _schemaProperties :: HsQName
_schemaProperties     = String -> HsQName
jsonpbName String
"_schemaProperties"
          _schemaMinProperties :: HsQName
_schemaMinProperties  = String -> HsQName
jsonpbName String
"_schemaMinProperties"
          _schemaMaxProperties :: HsQName
_schemaMaxProperties  = String -> HsQName
jsonpbName String
"_schemaMaxProperties"

          justOne :: HsExp
justOne = HsExp -> HsExp -> HsExp
HsApp HsExp
justC (HsLiteral -> HsExp
HsLit (Integer -> HsLiteral
HsInt Integer
1))

  let _namedSchemaSchemaExpression :: HsExp
_namedSchemaSchemaExpression = HsExp -> [HsFieldUpdate] -> HsExp
HsRecUpdate HsExp
memptyE [HsFieldUpdate]
schemaUpdates

      -- { _namedSchemaName   = ...
      -- , _namedSchemaSchema = ...
      -- }
  let namedSchemaUpdates :: [HsFieldUpdate]
namedSchemaUpdates =
        [ HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
_namedSchemaName   HsExp
_namedSchemaNameExpression
        , HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
_namedSchemaSchema HsExp
_namedSchemaSchemaExpression
        ]
        where
          _namedSchemaName :: HsQName
_namedSchemaName   = String -> HsQName
jsonpbName String
"_namedSchemaName"
          _namedSchemaSchema :: HsQName
_namedSchemaSchema = String -> HsQName
jsonpbName String
"_namedSchemaSchema"

  let namedSchema :: HsExp
namedSchema = HsQName -> [HsFieldUpdate] -> HsExp
HsRecConstr (String -> HsQName
jsonpbName String
"NamedSchema") [HsFieldUpdate]
namedSchemaUpdates

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

  let toArgument :: String -> HsExp
toArgument String
fieldName = HsExp -> HsExp -> HsExp
HsApp HsExp
asProxy HsExp
declare
        where
          declare :: HsExp
declare = String -> HsExp
uvar_ (String -> String
toDeclareName String
fieldName)

          asProxy :: HsExp
asProxy = HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName 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 :: HsExp
expressionForMessage =
          [HsStmt] -> HsExp
HsDo ([HsStmt]
bindingStatements [HsStmt] -> [HsStmt] -> [HsStmt]
forall a. [a] -> [a] -> [a]
++ [HsStmt]
inferenceStatement [HsStmt] -> [HsStmt] -> [HsStmt]
forall a. [a] -> [a] -> [a]
++ [ HsStmt
returnStatement ])
        where
          bindingStatements :: [HsStmt]
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 = String -> HsName
HsIdent (String -> String
toDeclareName String
fieldName)

            let stmt0 :: HsStmt
stmt0 = [HsDecl] -> HsStmt
HsLetStmt [ [HsMatch] -> HsDecl
HsFunBind
                                    [ SrcLoc -> HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
HsMatch SrcLoc
defaultSrcLoc HsName
declareIdentifier []
                                               (HsExp -> HsRhs
HsUnGuardedRhs (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"declareSchemaRef"))) []
                                    ]
                                  ]

            let stmt1 :: HsStmt
stmt1 = SrcLoc -> HsPat -> HsExp -> HsStmt
HsGenerator SrcLoc
defaultSrcLoc (HsName -> HsPat
HsPVar (String -> HsName
HsIdent String
qualifiedFieldName))
                                      (HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (HsName -> HsQName
UnQual HsName
declareIdentifier))
                                             (HsQName -> HsExp
HsCon (String -> HsQName
proxyName String
"Proxy")))
            [ HsStmt
stmt0, HsStmt
stmt1]


          inferenceStatement :: [HsStmt]
inferenceStatement =
              if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
fieldNames then [] else [ [HsDecl] -> HsStmt
HsLetStmt [ HsDecl
patternBind ] ]
            where
              arguments :: [HsExp]
arguments = (String -> HsExp) -> [String] -> [HsExp]
forall a b. (a -> b) -> [a] -> [b]
map String -> HsExp
toArgument [String]
fieldNames

              patternBind :: HsDecl
patternBind = SrcLoc -> HsPat -> HsRhs -> [HsDecl] -> HsDecl
HsPatBind SrcLoc
defaultSrcLoc HsPat
HsPWildCard
                                        (HsExp -> HsRhs
HsUnGuardedRhs (HsExp -> [HsExp] -> HsExp
applicativeApply HsExp
messageConstructor [HsExp]
arguments)) []

          returnStatement :: HsStmt
returnStatement = HsExp -> HsStmt
HsQualifier (HsExp -> HsExp -> HsExp
HsApp HsExp
returnE (HsExp -> HsExp
HsParen HsExp
namedSchema))

      -- 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 :: [HsName] -> HsExp
expressionForOneOf [HsName]
constructors =
          [HsStmt] -> HsExp
HsDo ([HsStmt]
bindingStatements [HsStmt] -> [HsStmt] -> [HsStmt]
forall a. [a] -> [a] -> [a]
++ [ HsStmt
returnStatement ])
        where
          bindingStatements :: [HsStmt]
bindingStatements = do
            (String
fieldName, String
qualifiedFieldName, HsName
constructor)
                <- [String] -> [String] -> [HsName] -> [(String, String, HsName)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [String]
fieldNames [String]
qualifiedFieldNames [HsName]
constructors

            let declareIdentifier :: HsName
declareIdentifier = String -> HsName
HsIdent (String -> String
toDeclareName String
fieldName)

            let stmt0 :: HsStmt
stmt0 = [HsDecl] -> HsStmt
HsLetStmt [ [HsMatch] -> HsDecl
HsFunBind
                                      [ SrcLoc -> HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
HsMatch SrcLoc
defaultSrcLoc HsName
declareIdentifier []
                                                 (HsExp -> HsRhs
HsUnGuardedRhs (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"declareSchemaRef"))) []
                                      ]
                                  ]
            let stmt1 :: HsStmt
stmt1 = SrcLoc -> HsPat -> HsExp -> HsStmt
HsGenerator SrcLoc
defaultSrcLoc (HsName -> HsPat
HsPVar (String -> HsName
HsIdent String
qualifiedFieldName))
                                      (HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (HsName -> HsQName
UnQual HsName
declareIdentifier))
                                             (HsQName -> HsExp
HsCon (String -> HsQName
proxyName String
"Proxy")))
            let inferenceStatement :: [HsStmt]
inferenceStatement =
                    if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
fieldNames then [] else [ [HsDecl] -> HsStmt
HsLetStmt [ HsDecl
patternBind ] ]
                  where
                    arguments :: [HsExp]
arguments = [ String -> HsExp
toArgument String
fieldName ]

                    patternBind :: HsDecl
patternBind = SrcLoc -> HsPat -> HsRhs -> [HsDecl] -> HsDecl
HsPatBind SrcLoc
defaultSrcLoc HsPat
HsPWildCard
                                              (HsExp -> HsRhs
HsUnGuardedRhs (HsExp -> [HsExp] -> HsExp
applicativeApply (HsQName -> HsExp
HsCon (HsName -> HsQName
UnQual HsName
constructor)) [HsExp]
arguments)) []

            [HsStmt
stmt0, HsStmt
stmt1] [HsStmt] -> [HsStmt] -> [HsStmt]
forall a. [a] -> [a] -> [a]
++ [HsStmt]
inferenceStatement


          returnStatement :: HsStmt
returnStatement = HsExp -> HsStmt
HsQualifier (HsExp -> HsExp -> HsExp
HsApp HsExp
returnE (HsExp -> HsExp
HsParen HsExp
namedSchema))

  let instanceDeclaration :: HsDecl
instanceDeclaration =
          HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ HsQName
className [ HsType
classArgument ] [ HsDecl
classDeclaration ]
        where
          className :: HsQName
className = String -> HsQName
jsonpbName String
"ToSchema"

          classArgument :: HsType
classArgument = HsQName -> HsType
HsTyCon (HsName -> HsQName
UnQual (String -> HsName
HsIdent String
messageName))

          classDeclaration :: HsDecl
classDeclaration = [HsMatch] -> HsDecl
HsFunBind [ HsMatch
match ]
            where
              match :: HsMatch
match = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ HsName
matchName [ HsPat
HsPWildCard ] HsRhs
rightHandSide []
                where
                  expression :: HsExp
expression = case Maybe [HsName]
maybeConstructors of
                      Maybe [HsName]
Nothing           -> HsExp
expressionForMessage
                      Just [HsName]
constructors -> [HsName] -> HsExp
expressionForOneOf [HsName]
constructors

                  rightHandSide :: HsRhs
rightHandSide = HsExp -> HsRhs
HsUnGuardedRhs HsExp
expression

                  matchName :: HsName
matchName = String -> HsName
HsIdent String
"declareNamedSchema"

  HsDecl -> m HsDecl
forall (m :: * -> *) a. Monad m => a -> m a
return HsDecl
instanceDeclaration


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

dotProtoEnumD
    :: MonadError CompileError m
    => DotProtoIdentifier
    -> DotProtoIdentifier
    -> [DotProtoEnumPart]
    -> m [HsDecl]
dotProtoEnumD :: 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 ]

  case [(DotProtoEnumValue, DotProtoIdentifier)]
enumeratorDecls of
    [] -> CompileError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m ()) -> CompileError -> m ()
forall a b. (a -> b) -> a -> b
$ String -> CompileError
EmptyEnumeration String
enumName
    (DotProtoEnumValue
i, DotProtoIdentifier
conIdent) : [(DotProtoEnumValue, DotProtoIdentifier)]
_
      | DotProtoEnumValue
i DotProtoEnumValue -> DotProtoEnumValue -> Bool
forall a. Eq a => a -> a -> Bool
== DotProtoEnumValue
0 -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise -> CompileError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m ()) -> CompileError -> m ()
forall a b. (a -> b) -> a -> b
$ String -> DotProtoIdentifier -> DotProtoEnumValue -> CompileError
NonzeroFirstEnumeration String
enumName DotProtoIdentifier
conIdent DotProtoEnumValue
i

  [(DotProtoEnumValue, String)]
enumCons <- ([(DotProtoEnumValue, String)] -> [(DotProtoEnumValue, String)])
-> m [(DotProtoEnumValue, String)]
-> m [(DotProtoEnumValue, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((DotProtoEnumValue, String)
 -> (DotProtoEnumValue, String) -> Ordering)
-> [(DotProtoEnumValue, String)] -> [(DotProtoEnumValue, String)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
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)) (m [(DotProtoEnumValue, String)]
 -> m [(DotProtoEnumValue, String)])
-> m [(DotProtoEnumValue, String)]
-> m [(DotProtoEnumValue, String)]
forall a b. (a -> b) -> a -> b
$
    ((DotProtoEnumValue, DotProtoIdentifier)
 -> m (DotProtoEnumValue, String))
-> [(DotProtoEnumValue, DotProtoIdentifier)]
-> m [(DotProtoEnumValue, String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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)
traverse
                ((String -> String) -> m String -> m String
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))
             [(DotProtoEnumValue, DotProtoIdentifier)]
enumeratorDecls

  let enumConNames :: [String]
enumConNames = ((DotProtoEnumValue, String) -> String)
-> [(DotProtoEnumValue, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DotProtoEnumValue, String) -> String
forall a b. (a, b) -> b
snd [(DotProtoEnumValue, String)]
enumCons

      minBoundD :: [HsMatch]
minBoundD =
          [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"minBound")
                   []
                   (HsExp -> HsRhs
HsUnGuardedRhs (String -> HsExp
uvar_ ([String] -> String
forall a. [a] -> a
head [String]
enumConNames)))
                   []
          ]

      maxBoundD :: [HsMatch]
maxBoundD =
          [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"maxBound")
                   []
                   (HsExp -> HsRhs
HsUnGuardedRhs (String -> HsExp
uvar_ ([String] -> String
forall a. [a] -> a
last [String]
enumConNames)))
                   []
          ]

      compareD :: [HsMatch]
compareD =
          [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"compare")
                   [ String -> HsPat
patVar String
"x", String -> HsPat
patVar String
"y" ]
                   (HsExp -> HsRhs
HsUnGuardedRhs
                       (HsExp -> HsExp -> HsExp
HsApp
                           (HsExp -> HsExp -> HsExp
HsApp
                               (HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"compare"))
                               (HsExp -> HsExp
HsParen
                                   (HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar(String -> HsQName
protobufName String
"fromProtoEnum"))
                                          (String -> HsExp
uvar_ String
"x")
                                   )
                               )
                           )
                           (HsExp -> HsExp
HsParen
                               (HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"fromProtoEnum"))
                                      (String -> HsExp
uvar_ String
"y")
                               )
                           )
                       )
                   )
                   []
          ]

      fromProtoEnumD :: [HsMatch]
fromProtoEnumD =
          [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"fromProtoEnum") [ HsQName -> [HsPat] -> HsPat
HsPApp (String -> HsQName
unqual_ String
conName) [] ]
                   (HsExp -> HsRhs
HsUnGuardedRhs (DotProtoEnumValue -> HsExp
forall a. Integral a => a -> HsExp
intE DotProtoEnumValue
conIdx))
                   []
          | (DotProtoEnumValue
conIdx, String
conName) <- [(DotProtoEnumValue, String)]
enumCons
          ]

      toProtoEnumMayD :: [HsMatch]
toProtoEnumMayD =
          [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"toProtoEnumMay")
                   [ DotProtoEnumValue -> HsPat
forall a. Integral a => a -> HsPat
intP DotProtoEnumValue
conIdx ]
                   (HsExp -> HsRhs
HsUnGuardedRhs (HsExp -> HsExp -> HsExp
HsApp HsExp
justC (String -> HsExp
uvar_ String
conName)))
                   []
          | (DotProtoEnumValue
conIdx, String
conName) <- [(DotProtoEnumValue, String)]
enumCons ] [HsMatch] -> [HsMatch] -> [HsMatch]
forall a. [a] -> [a] -> [a]
++
          [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"toProtoEnumMay")
                   [ HsPat
HsPWildCard ]
                   (HsExp -> HsRhs
HsUnGuardedRhs HsExp
nothingC)
                   []
          ]

      parseJSONPBDecls :: [HsMatch]
      parseJSONPBDecls :: [HsMatch]
parseJSONPBDecls = (String -> [HsMatch] -> [HsMatch])
-> [HsMatch] -> [String] -> [HsMatch]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (HsMatch -> [HsMatch] -> [HsMatch])
-> (String -> HsMatch) -> String -> [HsMatch] -> [HsMatch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsMatch
matchConName) [HsMatch
mismatch] [String]
enumConNames
        where
          matchConName :: String -> HsMatch
matchConName String
conName = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"parseJSONPB") [String -> HsPat
pat String
conName]
                                        (HsExp -> HsRhs
HsUnGuardedRhs
                                           (HsExp -> HsExp -> HsExp
HsApp HsExp
pureE (String -> HsExp
uvar_ String
conName)))
                                        []

          pat :: String -> HsPat
pat String
nm = HsQName -> [HsPat] -> HsPat
HsPApp (String -> HsQName
jsonpbName String
"String") [ HsLiteral -> HsPat
HsPLit (String -> HsLiteral
HsString (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 (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 :: HsMatch
mismatch = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"parseJSONPB") [String -> HsPat
patVar String
"v"]
                            (HsExp -> HsRhs
HsUnGuardedRhs
                                  (HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"typeMismatch"))
                                    [ String -> HsExp
str_ String
enumName, String -> HsExp
uvar_ String
"v" ]))
                            []


      toJSONPBDecl :: HsMatch
toJSONPBDecl =
        HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"toJSONPB") [ String -> HsPat
patVar String
"x", HsPat
HsPWildCard ]
          (HsExp -> HsRhs
HsUnGuardedRhs
             (HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"enumFieldString"))
                    (String -> HsExp
uvar_ String
"x")))
          []

      toEncodingPBDecl :: HsMatch
toEncodingPBDecl =
        HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
"toEncodingPB") [ String -> HsPat
patVar String
"x", HsPat
HsPWildCard ]
          (HsExp -> HsRhs
HsUnGuardedRhs
             (HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (String -> HsQName
jsonpbName String
"enumFieldEncoding"))
                    (String -> HsExp
uvar_ String
"x")))
          []

  [HsDecl] -> m [HsDecl]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ String -> [HsConDecl] -> [HsQName] -> HsDecl
dataDecl_ String
enumName
                   [ HsName -> [HsBangType] -> HsConDecl
conDecl_ (String -> HsName
HsIdent String
con) [] | String
con <- [String]
enumConNames ]
                   [HsQName]
defaultEnumDeriving
       , String -> HsDecl
namedInstD String
enumName
       , String -> HsDecl
hasDefaultInstD String
enumName
       , HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
haskellName String
"Bounded") [ String -> HsType
type_ String
enumName ]
                   [ [HsMatch] -> HsDecl
HsFunBind [HsMatch]
minBoundD
                   , [HsMatch] -> HsDecl
HsFunBind [HsMatch]
maxBoundD
                   ]
       , HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
haskellName String
"Ord") [ String -> HsType
type_ String
enumName ]
                   [ [HsMatch] -> HsDecl
HsFunBind [HsMatch]
compareD ]
       , HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
protobufName String
"ProtoEnum") [ String -> HsType
type_ String
enumName ]
                   [ [HsMatch] -> HsDecl
HsFunBind [HsMatch]
toProtoEnumMayD
                   , [HsMatch] -> HsDecl
HsFunBind [HsMatch]
fromProtoEnumD
                   ]
       , HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
jsonpbName String
"ToJSONPB") [ String -> HsType
type_ String
enumName ]
                   [ [HsMatch] -> HsDecl
HsFunBind [HsMatch
toJSONPBDecl]
                   , [HsMatch] -> HsDecl
HsFunBind [HsMatch
toEncodingPBDecl]
                   ]
       , HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
jsonpbName String
"FromJSONPB") [ String -> HsType
type_ String
enumName ]
                   [ [HsMatch] -> HsDecl
HsFunBind [HsMatch]
parseJSONPBDecls ]
       -- 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.
       , HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (String -> HsQName
protobufName String
"Finite") [ String -> HsType
type_ String
enumName ] []
       ]

-- ** Generate code for dot proto services

dotProtoServiceD
    :: MonadError CompileError m
    => DotProtoIdentifier
    -> TypeContext
    -> DotProtoIdentifier
    -> [DotProtoServicePart]
    -> m [HsDecl]
dotProtoServiceD :: DotProtoIdentifier
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
dotProtoServiceD DotProtoIdentifier
pkgIdent 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
packageName <- DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentQualName DotProtoIdentifier
pkgIdent

     let endpointPrefix :: String
endpointPrefix = 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
"/"

     let serviceFieldD :: DotProtoServicePart
-> m [(String, String, Streaming, Streaming, HsBangType)]
serviceFieldD (DotProtoServiceRPCMethod RPCMethod{[DotProtoOption]
Streaming
DotProtoIdentifier
rpcMethodOptions :: RPCMethod -> [DotProtoOption]
rpcMethodResponseStreaming :: RPCMethod -> Streaming
rpcMethodResponseType :: RPCMethod -> DotProtoIdentifier
rpcMethodRequestStreaming :: RPCMethod -> Streaming
rpcMethodRequestType :: RPCMethod -> DotProtoIdentifier
rpcMethodName :: RPCMethod -> DotProtoIdentifier
rpcMethodOptions :: [DotProtoOption]
rpcMethodResponseStreaming :: Streaming
rpcMethodResponseType :: DotProtoIdentifier
rpcMethodRequestStreaming :: Streaming
rpcMethodRequestType :: DotProtoIdentifier
rpcMethodName :: DotProtoIdentifier
..}) = do
           String
fullName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedFieldName 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 (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

           HsType
requestTy  <- TypeContext -> DotProtoPrimType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType TypeContext
ctxt (DotProtoIdentifier -> DotProtoPrimType
Named DotProtoIdentifier
rpcMethodRequestType)

           HsType
responseTy <- TypeContext -> DotProtoPrimType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType TypeContext
ctxt (DotProtoIdentifier -> DotProtoPrimType
Named DotProtoIdentifier
rpcMethodResponseType)

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

           [(String, String, Streaming, Streaming, HsBangType)]
-> m [(String, String, Streaming, Streaming, HsBangType)]
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
                  , HsType -> HsBangType
HsUnBangedTy (HsType -> HsBangType) -> HsType -> HsBangType
forall a b. (a -> b) -> a -> b
$
                    HsType -> HsType -> HsType
HsTyFun (HsType -> [HsType] -> HsType
tyApp (HsName -> HsType
HsTyVar (String -> HsName
HsIdent String
"request"))
                                   [HsType
streamingType, HsType
requestTy, HsType
responseTy])
                            (HsType -> [HsType] -> HsType
tyApp HsType
ioT
                                   [HsType -> [HsType] -> HsType
tyApp (HsName -> HsType
HsTyVar (String -> HsName
HsIdent String
"response"))
                                          [HsType
streamingType, HsType
responseTy]
                                   ]
                            )
                  )
                ]

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

     [(String, String, Streaming, Streaming, HsBangType)]
fieldsD <- (DotProtoServicePart
 -> m [(String, String, Streaming, Streaming, HsBangType)])
-> [DotProtoServicePart]
-> m [(String, String, Streaming, Streaming, HsBangType)]
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, HsBangType)]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoServicePart
-> m [(String, String, Streaming, Streaming, HsBangType)]
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], HsBangType)] -> HsConDecl
recDecl_ (String -> HsName
HsIdent String
serviceName)
                            [ ([String -> HsName
HsIdent String
hsName], HsBangType
ty) | (String
_, String
hsName, Streaming
_, Streaming
_, HsBangType
ty) <- [(String, String, Streaming, Streaming, HsBangType)]
fieldsD ]

     let serverT :: HsType
serverT = HsType -> [HsType] -> HsType
tyApp (HsQName -> HsType
HsTyCon (String -> HsQName
unqual_ String
serviceName))
                         [ HsType
serverRequestT, HsType
serverResponseT ]

     let serviceServerTypeD :: HsDecl
serviceServerTypeD =
            SrcLoc -> [HsName] -> HsQualType -> HsDecl
HsTypeSig SrcLoc
defaultSrcLoc [ String -> HsName
HsIdent String
serverFuncName ]
                        (HsContext -> HsType -> HsQualType
HsQualType [] (HsType -> HsType -> HsType
HsTyFun HsType
serverT (HsType -> HsType -> HsType
HsTyFun HsType
serviceOptionsC HsType
ioActionT)))

     let serviceServerD :: HsDecl
serviceServerD = [HsMatch] -> HsDecl
HsFunBind [HsMatch
serverFuncD]
           where
             serverFuncD :: HsMatch
serverFuncD =
               HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
serverFuncName)
                      [ HsQName -> [HsPatField] -> HsPat
HsPRec (String -> HsQName
unqual_ String
serviceName)
                               [ HsQName -> HsPat -> HsPatField
HsPFieldPat (String -> HsQName
unqual_ String
methodName) (HsName -> HsPat
HsPVar (String -> HsName
HsIdent String
methodName))
                               | (String
_, String
methodName, Streaming
_, Streaming
_, HsBangType
_) <- [(String, String, Streaming, Streaming, HsBangType)]
fieldsD
                               ]
                      , HsQName -> [HsPat] -> HsPat
HsPApp (String -> HsQName
unqual_ 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"
                               ]
                      ]
                      (HsExp -> HsRhs
HsUnGuardedRhs (HsExp -> [HsExp] -> HsExp
apply HsExp
serverLoopE [ HsExp
serverOptsE ]))
                      []

             handlerE :: HsExp -> HsExp -> String -> String -> HsExp
handlerE HsExp
handlerC HsExp
adapterE String
methodName String
hsName =
                 HsExp -> [HsExp] -> HsExp
apply HsExp
handlerC [ HsExp -> [HsExp] -> HsExp
apply HsExp
methodNameC [ String -> HsExp
str_ String
methodName ]
                                , HsExp -> [HsExp] -> HsExp
apply HsExp
adapterE [ String -> HsExp
uvar_ String
hsName ]
                                ]

             update :: String -> String -> HsFieldUpdate
update String
u String
v = HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate (String -> HsQName
unqual_ String
u) (String -> HsExp
uvar_ String
v)

             serverOptsE :: HsExp
serverOptsE = HsExp -> [HsFieldUpdate] -> HsExp
HsRecUpdate HsExp
defaultOptionsE
                 [ HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate (String -> HsQName
grpcName String
"optNormalHandlers") (HsExp -> HsFieldUpdate) -> HsExp -> HsFieldUpdate
forall a b. (a -> b) -> a -> b
$
                       [HsExp] -> HsExp
HsList [ HsExp -> HsExp -> String -> String -> HsExp
handlerE HsExp
unaryHandlerC HsExp
convertServerHandlerE String
endpointName String
hsName
                              | (String
endpointName, String
hsName, Streaming
NonStreaming, Streaming
NonStreaming, HsBangType
_) <- [(String, String, Streaming, Streaming, HsBangType)]
fieldsD
                              ]

                 , HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate (String -> HsQName
grpcName String
"optClientStreamHandlers") (HsExp -> HsFieldUpdate) -> HsExp -> HsFieldUpdate
forall a b. (a -> b) -> a -> b
$
                       [HsExp] -> HsExp
HsList [ HsExp -> HsExp -> String -> String -> HsExp
handlerE HsExp
clientStreamHandlerC HsExp
convertServerReaderHandlerE String
endpointName String
hsName
                              | (String
endpointName, String
hsName, Streaming
Streaming, Streaming
NonStreaming, HsBangType
_) <- [(String, String, Streaming, Streaming, HsBangType)]
fieldsD
                              ]


                 , HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate (String -> HsQName
grpcName String
"optServerStreamHandlers") (HsExp -> HsFieldUpdate) -> HsExp -> HsFieldUpdate
forall a b. (a -> b) -> a -> b
$
                       [HsExp] -> HsExp
HsList [ HsExp -> HsExp -> String -> String -> HsExp
handlerE HsExp
serverStreamHandlerC HsExp
convertServerWriterHandlerE String
endpointName String
hsName
                              | (String
endpointName, String
hsName, Streaming
NonStreaming, Streaming
Streaming, HsBangType
_) <- [(String, String, Streaming, Streaming, HsBangType)]
fieldsD
                              ]


                 , HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate (String -> HsQName
grpcName String
"optBiDiStreamHandlers") (HsExp -> HsFieldUpdate) -> HsExp -> HsFieldUpdate
forall a b. (a -> b) -> a -> b
$
                       [HsExp] -> HsExp
HsList [ HsExp -> HsExp -> String -> String -> HsExp
handlerE HsExp
biDiStreamHandlerC HsExp
convertServerRWHandlerE String
endpointName String
hsName
                              | (String
endpointName, String
hsName, Streaming
Streaming, Streaming
Streaming, HsBangType
_) <- [(String, String, Streaming, Streaming, HsBangType)]
fieldsD
                              ]

                 , String -> String -> HsFieldUpdate
update String
"optServerHost" String
"serverHost"
                 , String -> String -> HsFieldUpdate
update String
"optServerPort" String
"serverPort"
                 , String -> String -> HsFieldUpdate
update String
"optUseCompression" String
"useCompression"
                 , String -> String -> HsFieldUpdate
update String
"optUserAgentPrefix" String
"userAgentPrefix"
                 , String -> String -> HsFieldUpdate
update String
"optUserAgentSuffix" String
"userAgentSuffix"
                 , String -> String -> HsFieldUpdate
update String
"optInitialMetadata" String
"initialMetadata"
                 , String -> String -> HsFieldUpdate
update String
"optSSLConfig" String
"sslConfig"
                 , String -> String -> HsFieldUpdate
update String
"optLogger" String
"logger"
                 , String -> String -> HsFieldUpdate
update String
"optMaxReceiveMessageLength" String
"serverMaxReceiveMessageLength"
                 ]

     let clientT :: HsType
clientT = HsType -> [HsType] -> HsType
tyApp (HsQName -> HsType
HsTyCon (String -> HsQName
unqual_ String
serviceName)) [ HsType
clientRequestT, HsType
clientResultT ]

     let serviceClientTypeD :: HsDecl
serviceClientTypeD =
             SrcLoc -> [HsName] -> HsQualType -> HsDecl
HsTypeSig SrcLoc
defaultSrcLoc [ String -> HsName
HsIdent String
clientFuncName ]
                       (HsContext -> HsType -> HsQualType
HsQualType [] (HsType -> HsType -> HsType
HsTyFun HsType
grpcClientT (HsType -> HsType -> HsType
HsTyApp HsType
ioT HsType
clientT)))

     let serviceClientD :: HsDecl
serviceClientD = [HsMatch] -> HsDecl
HsFunBind [ HsMatch
clientFuncD ]
            where
              clientFuncD :: HsMatch
clientFuncD = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (String -> HsName
HsIdent String
clientFuncName)
                                   [ HsName -> HsPat
HsPVar (String -> HsName
HsIdent String
"client") ]
                                   ( HsExp -> HsRhs
HsUnGuardedRhs HsExp
clientRecE ) []

              clientRecE :: HsExp
clientRecE = (HsExp -> HsExp -> HsExp) -> HsExp -> [HsExp] -> HsExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\HsExp
f -> HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
f HsQOp
apOp)
                                 (HsExp -> [HsExp] -> HsExp
apply HsExp
pureE [ String -> HsExp
uvar_ String
serviceName ])
                                 [ HsExp -> HsExp
HsParen (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
clientRequestE' HsQOp
apOp (String -> HsExp
registerClientMethodE String
endpointName)
                                 | (String
endpointName, String
_, Streaming
_, Streaming
_, HsBangType
_) <- [(String, String, Streaming, Streaming, HsBangType)]
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 ]
                                            ]

     [HsDecl] -> m [HsDecl]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ SrcLoc
-> HsContext
-> HsName
-> [HsName]
-> [HsConDecl]
-> [HsQName]
-> HsDecl
HsDataDecl SrcLoc
defaultSrcLoc  [] (String -> HsName
HsIdent String
serviceName)
                [ String -> HsName
HsIdent String
"request", String -> HsName
HsIdent String
"response" ]
                [ HsConDecl
conDecl ] [HsQName]
defaultServiceDeriving

          , HsDecl
serviceServerTypeD
          , HsDecl
serviceServerD

          , HsDecl
serviceClientTypeD
          , HsDecl
serviceClientD
          ]

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

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

dotProtoFieldC, primC, optionalC, repeatedC, nestedRepeatedC, namedC, mapC,
  fieldNumberC, singleC, dotsC, pathC, nestedC, anonymousC, dotProtoOptionC,
  identifierC, stringLitC, intLitC, floatLitC, boolLitC, trueC, falseC,
  unaryHandlerC, clientStreamHandlerC, serverStreamHandlerC, biDiStreamHandlerC,
  methodNameC, nothingC, justC, forceEmitC, mconcatE, encodeMessageFieldE,
  fromStringE, decodeMessageFieldE, pureE, returnE, memptyE, msumE, atE, oneofE,
  fmapE, defaultOptionsE, serverLoopE, convertServerHandlerE,
  convertServerReaderHandlerE, convertServerWriterHandlerE,
  convertServerRWHandlerE, clientRegisterMethodE, clientRequestE :: HsExp

dotProtoFieldC :: HsExp
dotProtoFieldC       = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"DotProtoField")
primC :: HsExp
primC                = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Prim")
optionalC :: HsExp
optionalC            = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Optional")
repeatedC :: HsExp
repeatedC            = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Repeated")
nestedRepeatedC :: HsExp
nestedRepeatedC      = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"NestedRepeated")
namedC :: HsExp
namedC               = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Named")
mapC :: HsExp
mapC                 = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Map")
fieldNumberC :: HsExp
fieldNumberC         = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"FieldNumber")
singleC :: HsExp
singleC              = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Single")
pathC :: HsExp
pathC                = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Path")
dotsC :: HsExp
dotsC                = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Dots")
nestedC :: HsExp
nestedC              = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Nested")
anonymousC :: HsExp
anonymousC           = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Anonymous")
dotProtoOptionC :: HsExp
dotProtoOptionC      = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"DotProtoOption")
identifierC :: HsExp
identifierC          = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"Identifier")
stringLitC :: HsExp
stringLitC           = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"StringLit")
intLitC :: HsExp
intLitC              = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"IntLit")
floatLitC :: HsExp
floatLitC            = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"FloatLit")
boolLitC :: HsExp
boolLitC             = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"BoolLit")
forceEmitC :: HsExp
forceEmitC           = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"ForceEmit")
encodeMessageFieldE :: HsExp
encodeMessageFieldE  = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"encodeMessageField")
decodeMessageFieldE :: HsExp
decodeMessageFieldE  = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"decodeMessageField")
atE :: HsExp
atE                  = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"at")
oneofE :: HsExp
oneofE               = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"oneof")

trueC :: HsExp
trueC                       = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"True")
falseC :: HsExp
falseC                      = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"False")
nothingC :: HsExp
nothingC                    = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"Nothing")
justC :: HsExp
justC                       = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"Just")
mconcatE :: HsExp
mconcatE                    = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"mconcat")
fromStringE :: HsExp
fromStringE                 = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"fromString")
pureE :: HsExp
pureE                       = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"pure")
returnE :: HsExp
returnE                     = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"return")
memptyE :: HsExp
memptyE                     = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"mempty")
msumE :: HsExp
msumE                       = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"msum")
fmapE :: HsExp
fmapE                       = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"fmap")

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

biDiStreamingC, serverStreamingC, clientStreamingC, normalC, serviceOptionsC,
  ioActionT, serverRequestT, serverResponseT, clientRequestT, clientResultT,
  ioT, grpcClientT :: HsType
biDiStreamingC :: HsType
biDiStreamingC   = HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual (String -> Module
Module String
"'HsGRPC") (String -> HsName
HsIdent String
"BiDiStreaming"))
serverStreamingC :: HsType
serverStreamingC = HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual (String -> Module
Module String
"'HsGRPC") (String -> HsName
HsIdent String
"ServerStreaming"))
clientStreamingC :: HsType
clientStreamingC = HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual (String -> Module
Module String
"'HsGRPC") (String -> HsName
HsIdent String
"ClientStreaming"))
normalC :: HsType
normalC          = HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual (String -> Module
Module String
"'HsGRPC") (String -> HsName
HsIdent String
"Normal"))
serviceOptionsC :: HsType
serviceOptionsC  = HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual (String -> Module
Module String
"HsGRPC") (String -> HsName
HsIdent String
"ServiceOptions"))
serverRequestT :: HsType
serverRequestT   = HsQName -> HsType
HsTyCon (String -> HsQName
grpcName String
"ServerRequest")
serverResponseT :: HsType
serverResponseT  = HsQName -> HsType
HsTyCon (String -> HsQName
grpcName String
"ServerResponse")
clientRequestT :: HsType
clientRequestT   = HsQName -> HsType
HsTyCon (String -> HsQName
grpcName String
"ClientRequest")
clientResultT :: HsType
clientResultT    = HsQName -> HsType
HsTyCon (String -> HsQName
grpcName String
"ClientResult")
grpcClientT :: HsType
grpcClientT      = HsQName -> HsType
HsTyCon (String -> HsQName
grpcName String
"Client")
ioActionT :: HsType
ioActionT        = HsType -> [HsType] -> HsType
tyApp HsType
ioT [ [HsType] -> HsType
HsTyTuple [] ]
ioT :: HsType
ioT              = HsQName -> HsType
HsTyCon (String -> HsQName
haskellName String
"IO")

apOp :: HsQOp
apOp :: HsQOp
apOp  = HsQName -> HsQOp
HsQVarOp (HsName -> HsQName
UnQual (String -> HsName
HsSymbol String
"<*>"))

fmapOp :: HsQOp
fmapOp :: HsQOp
fmapOp  = HsQName -> HsQOp
HsQVarOp (HsName -> HsQName
UnQual (String -> HsName
HsSymbol String
"<$>"))

composeOp :: HsQOp
composeOp :: HsQOp
composeOp = HsQName -> HsQOp
HsQVarOp (Module -> HsName -> HsQName
Qual Module
haskellNS (String -> HsName
HsSymbol String
"."))

bindOp :: HsQOp
bindOp :: HsQOp
bindOp = HsQName -> HsQOp
HsQVarOp (Module -> HsName -> HsQName
Qual Module
haskellNS (String -> HsName
HsSymbol String
">>="))

altOp :: HsQOp
altOp :: HsQOp
altOp = HsQName -> HsQOp
HsQVarOp (HsName -> HsQName
UnQual (String -> HsName
HsSymbol String
"<|>"))

toJSONPBOp :: HsQOp
toJSONPBOp :: HsQOp
toJSONPBOp = HsQName -> HsQOp
HsQVarOp (HsName -> HsQName
UnQual (String -> HsName
HsSymbol String
".="))

parseJSONPBOp :: HsQOp
parseJSONPBOp :: HsQOp
parseJSONPBOp = HsQName -> HsQOp
HsQVarOp (HsName -> HsQName
UnQual (String -> HsName
HsSymbol String
".:"))

neConsOp :: HsQOp
neConsOp :: HsQOp
neConsOp = HsQName -> HsQOp
HsQVarOp (Module -> HsName -> HsQName
Qual Module
haskellNS (String -> HsName
HsSymbol String
":|"))

intE :: Integral a => a -> HsExp
intE :: a -> HsExp
intE a
x = (if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then HsExp -> HsExp
HsParen else HsExp -> HsExp
forall a. a -> a
id) (HsExp -> HsExp) -> (a -> HsExp) -> a -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsLiteral -> HsExp
HsLit (HsLiteral -> HsExp) -> (a -> HsLiteral) -> a -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> HsLiteral
HsInt (Integer -> HsLiteral) -> (a -> Integer) -> a -> HsLiteral
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> HsExp) -> a -> HsExp
forall a b. (a -> b) -> a -> b
$ a
x

intP :: Integral a => a -> HsPat
intP :: a -> HsPat
intP a
x = (if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then HsPat -> HsPat
HsPParen else HsPat -> HsPat
forall a. a -> a
id) (HsPat -> HsPat) -> (a -> HsPat) -> a -> HsPat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsLiteral -> HsPat
HsPLit (HsLiteral -> HsPat) -> (a -> HsLiteral) -> a -> HsPat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> HsLiteral
HsInt (Integer -> HsLiteral) -> (a -> Integer) -> a -> HsLiteral
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> HsPat) -> a -> HsPat
forall a b. (a -> b) -> a -> b
$ a
x

-- ** Expressions for protobuf-wire types

forceEmitE :: HsExp -> HsExp
forceEmitE :: HsExp -> HsExp
forceEmitE = HsExp -> HsExp
HsParen (HsExp -> HsExp) -> (HsExp -> HsExp) -> HsExp -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExp -> HsExp -> HsExp
HsApp HsExp
forceEmitC

fieldNumberE :: FieldNumber -> HsExp
fieldNumberE :: FieldNumber -> HsExp
fieldNumberE = HsExp -> HsExp
HsParen (HsExp -> HsExp) -> (FieldNumber -> HsExp) -> FieldNumber -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExp -> HsExp -> HsExp
HsApp HsExp
fieldNumberC (HsExp -> HsExp) -> (FieldNumber -> HsExp) -> FieldNumber -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> HsExp
forall a. Integral a => a -> HsExp
intE (Word64 -> HsExp)
-> (FieldNumber -> Word64) -> FieldNumber -> HsExp
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
HsParen (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (String -> HsExp
str_ String
n) HsQOp
neConsOp ([HsExp] -> HsExp
HsList ((String -> HsExp) -> [String] -> [HsExp]
forall a b. (a -> b) -> [a] -> [b]
map String -> HsExp
str_ [String]
ns))) ] ]
dpIdentE (Qualified DotProtoIdentifier
a DotProtoIdentifier
b)  = HsExp -> [HsExp] -> HsExp
apply HsExp
nestedC [ 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     [ HsLiteral -> HsExp
HsLit (Integer -> HsLiteral
HsInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)) ]
dpValueE (FloatLit Double
f)    = HsExp -> [HsExp] -> HsExp
apply HsExp
floatLitC   [ HsLiteral -> HsExp
HsLit (Rational -> HsLiteral
HsFrac (Double -> Rational
forall a. Real a => a -> Rational
toRational 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 -> HsExp
wrap = HsQName -> HsExp
HsVar (HsQName -> HsExp) -> (String -> HsQName) -> String -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
protobufName in
    case DotProtoPrimType
ty of
        Named DotProtoIdentifier
n  -> HsExp -> [HsExp] -> HsExp
apply HsExp
namedC [ DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
n ]
        DotProtoPrimType
Int32    -> String -> HsExp
wrap String
"Int32"
        DotProtoPrimType
Int64    -> String -> HsExp
wrap String
"Int64"
        DotProtoPrimType
SInt32   -> String -> HsExp
wrap String
"SInt32"
        DotProtoPrimType
SInt64   -> String -> HsExp
wrap String
"SInt64"
        DotProtoPrimType
UInt32   -> String -> HsExp
wrap String
"UInt32"
        DotProtoPrimType
UInt64   -> String -> HsExp
wrap String
"UInt64"
        DotProtoPrimType
Fixed32  -> String -> HsExp
wrap String
"Fixed32"
        DotProtoPrimType
Fixed64  -> String -> HsExp
wrap String
"Fixed64"
        DotProtoPrimType
SFixed32 -> String -> HsExp
wrap String
"SFixed32"
        DotProtoPrimType
SFixed64 -> String -> HsExp
wrap String
"SFixed64"
        DotProtoPrimType
String   -> String -> HsExp
wrap String
"String"
        DotProtoPrimType
Bytes    -> String -> HsExp
wrap String
"Bytes"
        DotProtoPrimType
Bool     -> String -> HsExp
wrap String
"Bool"
        DotProtoPrimType
Float    -> String -> HsExp
wrap String
"Float"
        DotProtoPrimType
Double   -> String -> HsExp
wrap String
"Double"

defaultImports :: Bool -> [HsImportDecl]
defaultImports :: Bool -> [HsImportDecl]
defaultImports Bool
usesGrpc =
    [ Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Prelude")               (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.Class")    (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufNS (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
#ifdef DHALL
    , importDecl_ (m "Proto3.Suite.DhallPB")  & qualified (m hsDhallPB) & everything
#endif
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.DotProto") (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufNS (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.JSONPB")   (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
jsonpbNS   (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.JSONPB")   (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec]) -> HsImportDecl
forall a. (Bool -> Maybe Module -> a) -> a
unqualified          (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting  [String -> HsImportSpec
sString
".=", String -> HsImportSpec
sString
".:"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Suite.Types")    (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufNS (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Proto3.Wire")           (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
protobufNS (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Control.Applicative")   (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Control.Applicative")   (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec]) -> HsImportDecl
forall a. (Bool -> Maybe Module -> a) -> a
unqualified          (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting  [String -> HsImportSpec
sString
"<*>", String -> HsImportSpec
sString
"<|>", String -> HsImportSpec
sString
"<$>"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Control.DeepSeq")       (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Control.Monad")         (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.ByteString")       (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Coerce")           (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Int")              (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting  [String -> HsImportSpec
iString
"Int16", String -> HsImportSpec
iString
"Int32", String -> HsImportSpec
iString
"Int64"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.List.NonEmpty")    (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting  [HsName -> HsImportSpec
HsIThingAll (String -> HsName
HsIdent String
"NonEmpty")]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Map")              (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting  [String -> HsImportSpec
iString
"Map", String -> HsImportSpec
iString
"mapKeysMonotonic"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Proxy")            (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
proxyNS    (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.String")           (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting  [String -> HsImportSpec
iString
"fromString"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Text.Lazy")        (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting  [String -> HsImportSpec
iString
"Text"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Vector")           (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting  [String -> HsImportSpec
iString
"Vector"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Data.Word")             (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting  [String -> HsImportSpec
iString
"Word16", String -> HsImportSpec
iString
"Word32", String -> HsImportSpec
iString
"Word64"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"GHC.Enum")              (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"GHC.Generics")          (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Unsafe.Coerce")         (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
qualified Module
haskellNS  (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    ]
    [HsImportDecl] -> [HsImportDecl] -> [HsImportDecl]
forall a. Semigroup a => a -> a -> a
<>
    (if Bool -> Bool
not Bool
usesGrpc then [] else
    [ Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Network.GRPC.HighLevel.Generated")           (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
alias Module
grpcNS (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Network.GRPC.HighLevel.Client")              (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
alias Module
grpcNS (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a. (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Network.GRPC.HighLevel.Server")              (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
alias Module
grpcNS (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
hiding    [String -> HsImportSpec
iString
"serverLoop"]
    , Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (String -> Module
m String
"Network.GRPC.HighLevel.Server.Unregistered") (Bool
 -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Bool
     -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
    -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& Module
-> (Bool
    -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
forall a. Module -> (Bool -> Maybe Module -> a) -> a
alias Module
grpcNS (Maybe (Bool, [HsImportSpec]) -> HsImportDecl)
-> ((Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl)
-> HsImportDecl
forall a b. a -> (a -> b) -> b
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting [String -> HsImportSpec
iString
"serverLoop"]
    ])
  where
    m :: String -> Module
m = String -> Module
Module
    i :: String -> HsImportSpec
i = HsName -> HsImportSpec
HsIVar (HsName -> HsImportSpec)
-> (String -> HsName) -> String -> HsImportSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsName
HsIdent
    s :: String -> HsImportSpec
s = HsName -> HsImportSpec
HsIVar (HsName -> HsImportSpec)
-> (String -> HsName) -> String -> HsImportSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsName
HsSymbol

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

    -- staged constructors for importDecl
    qualified :: Module -> (Bool -> Maybe Module -> a)  -> a
    qualified :: 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 :: (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 :: 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 :: [HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting [HsImportSpec]
is Maybe (Bool, [HsImportSpec]) -> a
f = Maybe (Bool, [HsImportSpec]) -> a
f ((Bool, [HsImportSpec]) -> Maybe (Bool, [HsImportSpec])
forall a. a -> Maybe a
Just (Bool
False, [HsImportSpec]
is))

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

    everything :: (Maybe (Bool, [HsImportSpec]) -> a) -> a
    everything :: (Maybe (Bool, [HsImportSpec]) -> a) -> a
everything Maybe (Bool, [HsImportSpec]) -> a
f = Maybe (Bool, [HsImportSpec]) -> a
f Maybe (Bool, [HsImportSpec])
forall a. Maybe a
Nothing

haskellNS :: Module
haskellNS :: Module
haskellNS = String -> Module
Module String
"Hs"

defaultMessageDeriving :: [HsQName]
defaultMessageDeriving :: [HsQName]
defaultMessageDeriving = (String -> HsQName) -> [String] -> [HsQName]
forall a b. (a -> b) -> [a] -> [b]
map String -> HsQName
haskellName [ String
"Show", String
"Eq", String
"Ord", String
"Generic", String
"NFData" ]

defaultEnumDeriving :: [HsQName]
defaultEnumDeriving :: [HsQName]
defaultEnumDeriving = (String -> HsQName) -> [String] -> [HsQName]
forall a b. (a -> b) -> [a] -> [b]
map String -> HsQName
haskellName [ String
"Show", String
"Eq", String
"Generic", String
"NFData" ]

defaultServiceDeriving :: [HsQName]
defaultServiceDeriving :: [HsQName]
defaultServiceDeriving = (String -> HsQName) -> [String] -> [HsQName]
forall a b. (a -> b) -> [a] -> [b]
map String -> HsQName
haskellName [ String
"Generic" ]

--------------------------------------------------------------------------------
--
-- * Wrappers around haskell-src-exts constructors
--

apply :: HsExp -> [HsExp] -> HsExp
apply :: HsExp -> [HsExp] -> HsExp
apply HsExp
f = HsExp -> HsExp
HsParen (HsExp -> HsExp) -> ([HsExp] -> HsExp) -> [HsExp] -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsExp -> HsExp -> HsExp) -> HsExp -> [HsExp] -> HsExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsExp -> HsExp -> HsExp
HsApp HsExp
f

applicativeApply :: HsExp -> [HsExp] -> HsExp
applicativeApply :: HsExp -> [HsExp] -> HsExp
applicativeApply HsExp
f = (HsExp -> HsExp -> HsExp) -> HsExp -> [HsExp] -> HsExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsExp -> HsExp -> HsExp
snoc HsExp
nil
  where
    nil :: HsExp
nil = HsExp -> HsExp -> HsExp
HsApp HsExp
pureE HsExp
f

    snoc :: HsExp -> HsExp -> HsExp
snoc HsExp
g HsExp
x = HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
g HsQOp
apOp HsExp
x

tyApp :: HsType -> [HsType] -> HsType
tyApp :: HsType -> [HsType] -> HsType
tyApp = (HsType -> HsType -> HsType) -> HsType -> [HsType] -> HsType
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsType -> HsType -> HsType
HsTyApp

module_ :: Module -> Maybe [HsExportSpec] -> [HsImportDecl] -> [HsDecl] -> HsModule
module_ :: Module
-> Maybe [HsExportSpec] -> [HsImportDecl] -> [HsDecl] -> HsModule
module_ = SrcLoc
-> Module
-> Maybe [HsExportSpec]
-> [HsImportDecl]
-> [HsDecl]
-> HsModule
HsModule SrcLoc
defaultSrcLoc

importDecl_ :: Module -> Bool -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl
importDecl_ :: Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ = SrcLoc
-> Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
HsImportDecl SrcLoc
defaultSrcLoc

dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl
dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl
dataDecl_ String
messageName [constructor :: HsConDecl
constructor@(HsRecDecl SrcLoc
_ HsName
_ [([HsName], HsBangType)
_])] =
  SrcLoc
-> HsContext
-> HsName
-> [HsName]
-> HsConDecl
-> [HsQName]
-> HsDecl
HsNewTypeDecl SrcLoc
defaultSrcLoc [] (String -> HsName
HsIdent String
messageName) [] HsConDecl
constructor
dataDecl_ String
messageName [HsConDecl]
constructors =
  SrcLoc
-> HsContext
-> HsName
-> [HsName]
-> [HsConDecl]
-> [HsQName]
-> HsDecl
HsDataDecl SrcLoc
defaultSrcLoc [] (String -> HsName
HsIdent String
messageName) [] [HsConDecl]
constructors

recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl
recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl
recDecl_ = SrcLoc -> HsName -> [([HsName], HsBangType)] -> HsConDecl
HsRecDecl SrcLoc
defaultSrcLoc

conDecl_ :: HsName -> [HsBangType] -> HsConDecl
conDecl_ :: HsName -> [HsBangType] -> HsConDecl
conDecl_ = SrcLoc -> HsName -> [HsBangType] -> HsConDecl
HsConDecl SrcLoc
defaultSrcLoc

instDecl_ :: HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ :: HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ = SrcLoc -> HsContext -> HsQName -> [HsType] -> [HsDecl] -> HsDecl
HsInstDecl SrcLoc
defaultSrcLoc []

match_ :: HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ :: HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ = SrcLoc -> HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
HsMatch SrcLoc
defaultSrcLoc

unqual_ :: String -> HsQName
unqual_ :: String -> HsQName
unqual_ = HsName -> HsQName
UnQual (HsName -> HsQName) -> (String -> HsName) -> String -> HsQName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsName
HsIdent

uvar_ :: String -> HsExp
uvar_ :: String -> HsExp
uvar_ = HsQName -> HsExp
HsVar (HsQName -> HsExp) -> (String -> HsQName) -> String -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
unqual_

protobufType_, primType_, protobufWrapperType_ :: String -> HsType
protobufType_ :: String -> HsType
protobufType_ = HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (String -> HsQName) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
protobufName
primType_ :: String -> HsType
primType_ = HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (String -> HsQName) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
haskellName
protobufWrapperType_ :: String -> HsType
protobufWrapperType_ = HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (String -> HsQName) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
protobufWrapperName

type_ :: String -> HsType
type_ :: String -> HsType
type_ = HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (String -> HsQName) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
unqual_

patVar :: String -> HsPat
patVar :: String -> HsPat
patVar =  HsName -> HsPat
HsPVar (HsName -> HsPat) -> (String -> HsName) -> String -> HsPat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsName
HsIdent

alt_ :: HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ :: HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ = SrcLoc -> HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
HsAlt SrcLoc
defaultSrcLoc

str_ :: String -> HsExp
str_ :: String -> HsExp
str_ = HsLiteral -> HsExp
HsLit (HsLiteral -> HsExp) -> (String -> HsLiteral) -> String -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLiteral
HsString

-- | For some reason, haskell-src-exts needs this 'SrcLoc' parameter
--   for some data constructors. Its value does not affect
--   pretty-printed output
defaultSrcLoc :: SrcLoc
defaultSrcLoc :: SrcLoc
defaultSrcLoc = String -> Int -> Int -> SrcLoc
SrcLoc String
"<generated>" Int
0 Int
0

__nowarn_unused :: a
__nowarn_unused :: a
__nowarn_unused = OneofSubfield -> DotProtoType
subfieldType (OneofSubfield -> DotProtoType)
-> (OneofSubfield -> [DotProtoOption]) -> Any
forall a. HasCallStack => a
`undefined` OneofSubfield -> [DotProtoOption]
subfieldOptions Any -> (OneofField -> String) -> a
forall a. HasCallStack => a
`undefined` OneofField -> String
oneofType