{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# 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 #-}
module Proto3.Suite.DotProto.Generate
( CompileError(..)
, StringType(..)
, RecordStyle (..)
, parseStringType
, TypeContext
, CompileArgs(..)
, compileDotProtoFile
, compileDotProtoFileOrDie
, renameProtoFile
, hsModuleForDotProto
, renderHsModuleForDotProto
, readDotProtoWithContext
) where
import Control.Applicative
import Control.Lens ((&), ix, over, has, filtered)
import Control.Monad.Except (MonadError(..), runExceptT)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Char
import Data.Coerce
import Data.Either (partitionEithers)
import Data.List (find, intercalate, nub, sort, sortBy, stripPrefix)
import qualified Data.List.NonEmpty as NE
import Data.List.Split (splitOn)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Ord (comparing)
import qualified Data.Set as S
import Data.String (fromString)
import qualified Data.Text as T
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 qualified Proto3.Suite.DotProto.Generate.LargeRecord as LargeRecord
import qualified Proto3.Suite.DotProto.Generate.Record as RegularRecord
import Proto3.Suite.DotProto.Generate.Syntax
import Proto3.Suite.DotProto.Internal
import Proto3.Wire.Types (FieldNumber (..))
import Text.Parsec (Parsec, alphaNum, eof, parse, satisfy, try)
import qualified Text.Parsec as Parsec
import qualified Turtle hiding (encodeString)
import qualified Turtle.Compat as Turtle (encodeString)
import Turtle (FilePath, (</>), (<.>))
data CompileArgs = CompileArgs
{ CompileArgs -> [FilePath]
includeDir :: [FilePath]
, :: [FilePath]
, CompileArgs -> FilePath
inputProto :: FilePath
, CompileArgs -> FilePath
outputDir :: FilePath
, CompileArgs -> StringType
stringType :: StringType
, CompileArgs -> RecordStyle
recordStyle :: RecordStyle
}
data StringType = StringType String String
data RecordStyle = RegularRecords | LargeRecords
deriving stock (RecordStyle -> RecordStyle -> Bool
(RecordStyle -> RecordStyle -> Bool)
-> (RecordStyle -> RecordStyle -> Bool) -> Eq RecordStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RecordStyle -> RecordStyle -> Bool
$c/= :: RecordStyle -> RecordStyle -> Bool
== :: RecordStyle -> RecordStyle -> Bool
$c== :: RecordStyle -> RecordStyle -> Bool
Eq, Int -> RecordStyle -> ShowS
[RecordStyle] -> ShowS
RecordStyle -> FilePath
(Int -> RecordStyle -> ShowS)
-> (RecordStyle -> FilePath)
-> ([RecordStyle] -> ShowS)
-> Show RecordStyle
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RecordStyle] -> ShowS
$cshowList :: [RecordStyle] -> ShowS
show :: RecordStyle -> FilePath
$cshow :: RecordStyle -> FilePath
showsPrec :: Int -> RecordStyle -> ShowS
$cshowsPrec :: Int -> RecordStyle -> ShowS
Show, ReadPrec [RecordStyle]
ReadPrec RecordStyle
Int -> ReadS RecordStyle
ReadS [RecordStyle]
(Int -> ReadS RecordStyle)
-> ReadS [RecordStyle]
-> ReadPrec RecordStyle
-> ReadPrec [RecordStyle]
-> Read RecordStyle
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RecordStyle]
$creadListPrec :: ReadPrec [RecordStyle]
readPrec :: ReadPrec RecordStyle
$creadPrec :: ReadPrec RecordStyle
readList :: ReadS [RecordStyle]
$creadList :: ReadS [RecordStyle]
readsPrec :: Int -> ReadS RecordStyle
$creadsPrec :: Int -> ReadS RecordStyle
Read)
parseStringType :: String -> Either String StringType
parseStringType :: FilePath -> Either FilePath StringType
parseStringType FilePath
str = case FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn FilePath
"." FilePath
str of
xs :: [FilePath]
xs@(FilePath
_ : FilePath
_ : [FilePath]
_) -> StringType -> Either FilePath StringType
forall a b. b -> Either a b
Right (StringType -> Either FilePath StringType)
-> StringType -> Either FilePath StringType
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> StringType
StringType (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"." ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
forall a. [a] -> [a]
init [FilePath]
xs) ([FilePath] -> FilePath
forall a. [a] -> a
last [FilePath]
xs)
[FilePath]
_ -> FilePath -> Either FilePath StringType
forall a b. a -> Either a b
Left FilePath
"must be in the form Module.Type"
compileDotProtoFile :: CompileArgs -> IO (Either CompileError ())
compileDotProtoFile :: CompileArgs -> IO (Either CompileError ())
compileDotProtoFile CompileArgs{FilePath
[FilePath]
RecordStyle
StringType
recordStyle :: RecordStyle
stringType :: StringType
outputDir :: FilePath
inputProto :: FilePath
extraInstanceFiles :: [FilePath]
includeDir :: [FilePath]
recordStyle :: CompileArgs -> RecordStyle
stringType :: CompileArgs -> StringType
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 FilePath
modulePathPieces <- (FilePath -> ExceptT CompileError IO FilePath)
-> NonEmpty FilePath -> ExceptT CompileError IO (NonEmpty FilePath)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> ExceptT CompileError IO FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> m FilePath
renameProtoFile (DotProto -> NonEmpty FilePath
toModuleComponents DotProto
dotProto)
let relativePath :: FilePath
relativePath = (FilePath -> ShowS) -> FilePath -> [FilePath] -> FilePath
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FilePath -> ShowS
combine FilePath
forall a. Monoid a => a
mempty (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
forall a. IsString a => FilePath -> a
fromString ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FilePath
modulePathPieces) FilePath -> ShowS
<.> FilePath
"hs"
combine :: FilePath -> ShowS
combine FilePath
p1 FilePath
p2 | FilePath
p2 FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
forall a. Monoid a => a
mempty = FilePath
p1
combine FilePath
p1 FilePath
p2 = FilePath
p1 FilePath -> ShowS
</> FilePath
p2
let modulePath :: FilePath
modulePath = FilePath
outputDir FilePath -> ShowS
</> FilePath
relativePath
FilePath -> ExceptT CompileError IO ()
forall (io :: * -> *). MonadIO io => FilePath -> io ()
Turtle.mktree (ShowS
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
FilePath
haskellModule <- StringType
-> RecordStyle
-> ([HsImportDecl], [HsDecl])
-> DotProto
-> TypeContext
-> ExceptT CompileError IO FilePath
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> RecordStyle
-> ([HsImportDecl], [HsDecl])
-> DotProto
-> TypeContext
-> m FilePath
renderHsModuleForDotProto StringType
stringType RecordStyle
recordStyle ([HsImportDecl], [HsDecl])
extraInstances DotProto
dotProto TypeContext
importTypeContext
IO () -> ExceptT CompileError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> FilePath -> IO ()
writeFile (ShowS
Turtle.encodeString FilePath
modulePath) FilePath
haskellModule)
where
toModuleComponents :: DotProto -> NonEmpty String
toModuleComponents :: DotProto -> NonEmpty FilePath
toModuleComponents = Path -> NonEmpty FilePath
components (Path -> NonEmpty FilePath)
-> (DotProto -> Path) -> DotProto -> NonEmpty FilePath
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
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
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 ()
renameProtoFile :: MonadError CompileError m => String -> m String
renameProtoFile :: FilePath -> m FilePath
renameProtoFile FilePath
filename =
case Parsec FilePath () (FilePath, [(FilePath, FilePath)], FilePath)
-> FilePath
-> FilePath
-> Either ParseError (FilePath, [(FilePath, FilePath)], FilePath)
forall s t a.
Stream s Identity t =>
Parsec s () a -> FilePath -> s -> Either ParseError a
parse Parsec FilePath () (FilePath, [(FilePath, FilePath)], FilePath)
parser FilePath
"" FilePath
filename of
Left {} -> CompileError -> m FilePath
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FilePath -> CompileError
InvalidModuleName FilePath
filename)
Right (FilePath
nm, [(FilePath, FilePath)]
ps, FilePath
sn) -> FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShowS
toUpperFirst FilePath
nm FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)] -> FilePath
rename [(FilePath, FilePath)]
ps FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
sn)
where
rename :: [(String, String)] -> String
rename :: [(FilePath, FilePath)] -> FilePath
rename = ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> FilePath
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> FilePath)
-> ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)]
-> FilePath
forall a b. (a -> b) -> a -> b
$ \(FilePath
us, FilePath
nm) ->
Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
us FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
toUpperFirst FilePath
nm
parser :: Parsec String () (String, [(String, String)], String)
parser :: Parsec FilePath () (FilePath, [(FilePath, FilePath)], FilePath)
parser = do
FilePath
nm <- Parsec FilePath () FilePath
pName
[(FilePath, FilePath)]
ps <- ParsecT FilePath () Identity (FilePath, FilePath)
-> ParsecT FilePath () Identity [(FilePath, FilePath)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
Parsec.many (ParsecT FilePath () Identity (FilePath, FilePath)
-> ParsecT FilePath () Identity (FilePath, FilePath)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT FilePath () Identity (FilePath, FilePath)
pNamePart)
FilePath
sn <- ParsecT FilePath () Identity Char -> Parsec FilePath () FilePath
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
Parsec.many ((Char -> Bool) -> ParsecT FilePath () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'))
(FilePath, [(FilePath, FilePath)], FilePath)
-> Parsec FilePath () (FilePath, [(FilePath, FilePath)], FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
nm, [(FilePath, FilePath)]
ps, FilePath
sn) Parsec FilePath () (FilePath, [(FilePath, FilePath)], FilePath)
-> ParsecT FilePath () Identity ()
-> Parsec FilePath () (FilePath, [(FilePath, FilePath)], FilePath)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT FilePath () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
pNamePart :: Parsec String () (String, String)
pNamePart :: ParsecT FilePath () Identity (FilePath, FilePath)
pNamePart = (FilePath -> FilePath -> (FilePath, FilePath))
-> Parsec FilePath () FilePath
-> Parsec FilePath () FilePath
-> ParsecT FilePath () Identity (FilePath, FilePath)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (ParsecT FilePath () Identity Char -> Parsec FilePath () FilePath
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
Parsec.many1 ((Char -> Bool) -> ParsecT FilePath () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'))) Parsec FilePath () FilePath
pName
pName :: Parsec String () String
pName :: Parsec FilePath () FilePath
pName = (Char -> ShowS)
-> ParsecT FilePath () Identity Char
-> Parsec FilePath () FilePath
-> Parsec FilePath () FilePath
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) ((Char -> Bool) -> ParsecT FilePath () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isAlpha) (ParsecT FilePath () Identity Char -> Parsec FilePath () FilePath
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
Parsec.many ParsecT FilePath () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum)
renderHsModuleForDotProto
:: MonadError CompileError m
=> StringType
-> RecordStyle
-> ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String
renderHsModuleForDotProto :: StringType
-> RecordStyle
-> ([HsImportDecl], [HsDecl])
-> DotProto
-> TypeContext
-> m FilePath
renderHsModuleForDotProto StringType
stringType RecordStyle
recordStyle ([HsImportDecl], [HsDecl])
extraInstanceFiles DotProto
dotProto TypeContext
importCtxt = do
HsModule
haskellModule <- StringType
-> RecordStyle
-> ([HsImportDecl], [HsDecl])
-> DotProto
-> TypeContext
-> m HsModule
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> RecordStyle
-> ([HsImportDecl], [HsDecl])
-> DotProto
-> TypeContext
-> m HsModule
hsModuleForDotProto StringType
stringType RecordStyle
recordStyle ([HsImportDecl], [HsDecl])
extraInstanceFiles DotProto
dotProto TypeContext
importCtxt
let languagePragmas :: Text
languagePragmas = [Text] -> Text
textUnlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
extn -> Text
"{-# LANGUAGE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
extn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [Text]
extensions
ghcOptionPragmas :: Text
ghcOptionPragmas = [Text] -> Text
textUnlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
opt -> Text
"{-# OPTIONS_GHC " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
opt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [Text]
options
extensions :: [T.Text]
extensions :: [Text]
extensions =
[ Text
"DataKinds"
, Text
"DeriveAnyClass"
, Text
"DeriveGeneric"
, Text
"GADTs"
, Text
"OverloadedStrings"
, Text
"TypeApplications"
] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
case RecordStyle
recordStyle of
RecordStyle
RegularRecords -> []
RecordStyle
LargeRecords -> [ Text
"ConstraintKinds"
, Text
"FlexibleInstances"
, Text
"MultiParamTypeClasses"
, Text
"ScopedTypeVariables"
, Text
"TypeFamilies"
, Text
"UndecidableInstances"
]
options :: [T.Text]
options :: [Text]
options = [ Text
"-fno-warn-unused-imports"
, Text
"-fno-warn-name-shadowing"
, Text
"-fno-warn-unused-matches"
, Text
"-fno-warn-missing-export-lists"
] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
case RecordStyle
recordStyle of
RecordStyle
RegularRecords -> []
RecordStyle
LargeRecords -> [ Text
"-fplugin=Data.Record.Plugin" ]
mkLRAnnotation :: HsDecl -> Maybe T.Text
mkLRAnnotation :: HsDecl -> Maybe Text
mkLRAnnotation (HsDataDecl SrcLoc
_ HsContext
_ (HsIdent FilePath
recName) [HsName]
_ [HsRecDecl SrcLoc
_ HsName
_ (([HsName], HsBangType)
_fld1:([HsName], HsBangType)
_fld2:[([HsName], HsBangType)]
_)] [HsQName]
_) =
Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"{-# ANN type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
recName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" largeRecord #-}")
mkLRAnnotation HsDecl
_ = Maybe Text
forall a. Maybe a
Nothing
lrAnnotations :: T.Text
lrAnnotations :: Text
lrAnnotations =
case (RecordStyle
recordStyle, HsModule
haskellModule) of
(RecordStyle
RegularRecords, HsModule
_) -> Text
""
(RecordStyle
LargeRecords, HsModule SrcLoc
_ Module
_ Maybe [HsExportSpec]
_ [HsImportDecl]
_ [HsDecl]
moduleDecls) ->
[Text] -> Text
textUnlines ((HsDecl -> Maybe Text) -> [HsDecl] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HsDecl -> Maybe Text
mkLRAnnotation [HsDecl]
moduleDecls)
moduleContent :: T.Text
moduleContent :: Text
moduleContent = FilePath -> Text
T.pack (HsModule -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint HsModule
haskellModule)
textUnlines :: [T.Text] -> T.Text
textUnlines :: [Text] -> Text
textUnlines = Text -> [Text] -> Text
T.intercalate Text
"\n"
FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ [Neat.text|
$languagePragmas
$ghcOptionPragmas
-- | Generated by Haskell protocol buffer compiler. DO NOT EDIT!
$moduleContent
$lrAnnotations
|]
hsModuleForDotProto
:: MonadError CompileError m
=> StringType
-> RecordStyle
-> ([HsImportDecl], [HsDecl])
-> DotProto
-> TypeContext
-> m HsModule
hsModuleForDotProto :: StringType
-> RecordStyle
-> ([HsImportDecl], [HsDecl])
-> DotProto
-> TypeContext
-> m HsModule
hsModuleForDotProto
StringType
stringType
RecordStyle
recordStyle
([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
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]
(FilePath, 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])
-> (((FilePath, DotProtoIdentifier, [DotProtoServicePart])
-> Const Any (FilePath, DotProtoIdentifier, [DotProtoServicePart]))
-> DotProtoDefinition -> Const Any DotProtoDefinition)
-> Getting
Any
[DotProtoDefinition]
(FilePath, DotProtoIdentifier, [DotProtoServicePart])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((FilePath, DotProtoIdentifier, [DotProtoServicePart])
-> Const Any (FilePath, DotProtoIdentifier, [DotProtoServicePart]))
-> DotProtoDefinition -> Const Any DotProtoDefinition
Prism'
DotProtoDefinition
(FilePath, DotProtoIdentifier, [DotProtoServicePart])
_DotProtoService) [DotProtoDefinition]
protoDefinitions
let importDeclarations :: [HsImportDecl]
importDeclarations = [[HsImportDecl]] -> [HsImportDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ RecordStyle -> ImportCustomisation -> [HsImportDecl]
defaultImports RecordStyle
recordStyle
ImportCustomisation :: StringType -> Bool -> ImportCustomisation
ImportCustomisation
{ icUsesGrpc :: Bool
icUsesGrpc = Bool
hasService
, icStringType :: StringType
icStringType = StringType
stringType
}
, [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 =
StringType
-> RecordStyle
-> DotProtoPackageSpec
-> TypeContext
-> DotProtoDefinition
-> m [HsDecl]
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> RecordStyle
-> DotProtoPackageSpec
-> TypeContext
-> DotProtoDefinition
-> m [HsDecl]
dotProtoDefinitionD StringType
stringType RecordStyle
recordStyle DotProtoPackageSpec
protoPackage (TypeContext
typeContext TypeContext -> TypeContext -> TypeContext
forall a. Semigroup a => a -> a -> a
<> TypeContext
importTypeContext)
let extraInstances' :: [HsDecl]
extraInstances' = Module -> [HsDecl] -> [HsDecl]
instancesForModule Module
moduleName [HsDecl]
extraInstances
[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])
FilePath
extraInstanceFile = do
FilePath
contents <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO FilePath
readFile (ShowS
Turtle.encodeString FilePath
extraInstanceFile))
case FilePath -> ParseResult HsModule
parseModule FilePath
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)
ParseFailed SrcLoc
srcLoc FilePath
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 = FilePath -> Text
T.pack FilePath
err
let message :: Text
message = [Neat.text|
Error: Failed to parse instance file
${srcLocText}: ${errText}
|]
FilePath -> m ([HsImportDecl], [HsDecl])
forall (m :: * -> *) a.
MonadError CompileError m =>
FilePath -> m a
internalError (Text -> FilePath
T.unpack Text
message)
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
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
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
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
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
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
readDotProtoWithContext
:: (MonadError CompileError m, MonadIO m)
=> [FilePath]
-> FilePath
-> m (DotProto, TypeContext)
readDotProtoWithContext :: [FilePath] -> FilePath -> m (DotProto, TypeContext)
readDotProtoWithContext [] FilePath
toplevelProto = do
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)
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
let importPkgSpec :: DotProtoPackageSpec
importPkgSpec = DotProto -> DotProtoPackageSpec
protoPackage DotProto
import_
let fixImportTyInfo :: DotProtoTypeInfo -> DotProtoTypeInfo
fixImportTyInfo DotProtoTypeInfo
tyInfo =
DotProtoTypeInfo
tyInfo { dotProtoTypeInfoPackage :: DotProtoPackageSpec
dotProtoTypeInfoPackage = DotProtoPackageSpec
importPkgSpec
, 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_
let prefixWithPackageName :: DotProtoIdentifier -> m DotProtoIdentifier
prefixWithPackageName =
case DotProtoPackageSpec
importPkgSpec of
DotProtoPackageSpec DotProtoIdentifier
packageName -> DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
packageName
DotProtoPackageSpec
DotProtoNoPackage -> DotProtoIdentifier -> m DotProtoIdentifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure
TypeContext
qualifiedTypeContext <- (DotProtoIdentifier -> m DotProtoIdentifier)
-> TypeContext -> m TypeContext
forall (m :: * -> *) k2 k1 a.
(Monad m, Ord k2) =>
(k1 -> m k2) -> Map k1 a -> m (Map k2 a)
mapKeysM DotProtoIdentifier -> m DotProtoIdentifier
prefixWithPackageName TypeContext
importTypeContext
let isPublic :: DotProtoImport -> Bool
isPublic (DotProtoImport DotProtoImportQualifier
q 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
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 ([Module] -> [Module])
-> ([Module] -> [Module]) -> [Module] -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> Module
Module FilePath
"Google.Protobuf.Wrappers" Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/=))
(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
msgTypeFromDpTypeInfo :: MonadError CompileError m
=> TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo :: TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo TypeContext
ctxt 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
FilePath
identName <- TypeContext
-> DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext
-> DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
qualifiedMessageTypeName TypeContext
ctxt 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 (FilePath -> HsName
HsIdent FilePath
identName))
modulePathModName :: MonadError CompileError m => Path -> m Module
modulePathModName :: Path -> m Module
modulePathModName (Path NonEmpty FilePath
comps) = FilePath -> Module
Module (FilePath -> Module)
-> ([FilePath] -> FilePath) -> [FilePath] -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"." ([FilePath] -> Module) -> m [FilePath] -> m Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> m FilePath) -> [FilePath] -> m [FilePath]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> m FilePath
typeLikeName (NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FilePath
comps)
_pkgIdentModName :: MonadError CompileError m => DotProtoIdentifier -> m Module
_pkgIdentModName :: DotProtoIdentifier -> m Module
_pkgIdentModName (Single FilePath
s) = FilePath -> Module
Module (FilePath -> Module) -> m FilePath -> m Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> m FilePath
typeLikeName FilePath
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)
#ifdef DHALL
hsDhallPB :: String
hsDhallPB = "HsDhallPb"
dhallPBName :: String -> HsQName
dhallPBName name = Qual (Module hsDhallPB) (HsIdent name)
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
data FieldContext = WithinMessage | WithinOneOf
deriving (FieldContext -> FieldContext -> Bool
(FieldContext -> FieldContext -> Bool)
-> (FieldContext -> FieldContext -> Bool) -> Eq FieldContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldContext -> FieldContext -> Bool
$c/= :: FieldContext -> FieldContext -> Bool
== :: FieldContext -> FieldContext -> Bool
$c== :: FieldContext -> FieldContext -> Bool
Eq, Int -> FieldContext -> ShowS
[FieldContext] -> ShowS
FieldContext -> FilePath
(Int -> FieldContext -> ShowS)
-> (FieldContext -> FilePath)
-> ([FieldContext] -> ShowS)
-> Show FieldContext
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FieldContext] -> ShowS
$cshowList :: [FieldContext] -> ShowS
show :: FieldContext -> FilePath
$cshow :: FieldContext -> FilePath
showsPrec :: Int -> FieldContext -> ShowS
$cshowsPrec :: Int -> FieldContext -> ShowS
Show)
typeApp :: HsType -> HsExp
typeApp :: HsType -> HsExp
typeApp HsType
ty = FilePath -> HsExp
uvar_ (FilePath
"@("FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ HsType -> FilePath
pp HsType
ty FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
")")
where
pp :: HsType -> FilePath
pp = Style -> PPHsMode -> HsType -> FilePath
forall a. Pretty a => Style -> PPHsMode -> a -> FilePath
prettyPrintStyleMode Style
style{mode :: Mode
mode=Mode
OneLineMode} PPHsMode
defaultMode
coerceE :: Bool -> Bool -> HsType -> HsType -> Maybe HsExp
coerceE :: Bool -> Bool -> HsType -> HsType -> Maybe HsExp
coerceE Bool
_ 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
overTyCon 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
coerceF :: HsExp
coerceF | Bool
unsafe = HsQName -> HsExp
HsVar (FilePath -> HsQName
name FilePath
"unsafeCoerce")
| Bool
otherwise = HsQName -> HsExp
HsVar (FilePath -> HsQName
name FilePath
"coerce")
name :: FilePath -> HsQName
name | Bool
overTyCon = FilePath -> HsQName
protobufName (FilePath -> HsQName) -> ShowS -> FilePath -> HsQName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"Over")
| Bool
otherwise = FilePath -> HsQName
haskellName
wrapFunE :: MonadError CompileError m => Bool -> FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> m (Maybe HsExp)
wrapFunE :: Bool
-> FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
wrapFunE Bool
overTyCon FieldContext
fc StringType
stringType TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt =
Bool -> Bool -> HsType -> HsType -> Maybe HsExp
coerceE Bool
overTyCon (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
<$> FieldContext
-> StringType -> TypeContext -> DotProtoType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType -> TypeContext -> DotProtoType -> m HsType
dptToHsType FieldContext
fc StringType
stringType 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
<*> FieldContext
-> StringType
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m HsType
dptToHsTypeWrapped FieldContext
fc StringType
stringType [DotProtoOption]
opts TypeContext
ctxt DotProtoType
dpt
wrapE :: MonadError CompileError m => FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
wrapE :: FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
wrapE FieldContext
fc StringType
stringType TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt HsExp
e =
HsExp -> Maybe HsExp -> HsExp
maybeModify HsExp
e (Maybe HsExp -> HsExp) -> m (Maybe HsExp) -> m HsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
forall (m :: * -> *).
MonadError CompileError m =>
Bool
-> FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
wrapFunE Bool
False FieldContext
fc StringType
stringType TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt
unwrapFunE :: MonadError CompileError m => Bool -> FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> m (Maybe HsExp)
unwrapFunE :: Bool
-> FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
unwrapFunE Bool
overTyCon FieldContext
fc StringType
stringType TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt =
Bool -> Bool -> HsType -> HsType -> Maybe HsExp
coerceE Bool
overTyCon (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
<$> FieldContext
-> StringType
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m HsType
dptToHsTypeWrapped FieldContext
fc StringType
stringType [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
<*> FieldContext
-> StringType -> TypeContext -> DotProtoType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType -> TypeContext -> DotProtoType -> m HsType
dptToHsType FieldContext
fc StringType
stringType TypeContext
ctxt DotProtoType
dpt
unwrapE :: MonadError CompileError m => FieldContext -> StringType -> TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp
unwrapE :: FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
unwrapE FieldContext
fc StringType
stringType TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt HsExp
e = do
HsExp -> Maybe HsExp -> HsExp
maybeModify HsExp
e (Maybe HsExp -> HsExp) -> m (Maybe HsExp) -> m HsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
forall (m :: * -> *).
MonadError CompileError m =>
Bool
-> FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
unwrapFunE Bool
True FieldContext
fc StringType
stringType TypeContext
ctxt [DotProtoOption]
opts DotProtoType
dpt
dptToHsType :: MonadError CompileError m => FieldContext -> StringType -> TypeContext -> DotProtoType -> m HsType
dptToHsType :: FieldContext
-> StringType -> TypeContext -> DotProtoType -> m HsType
dptToHsType FieldContext
fc = (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 (FieldContext -> TypeContext -> DotProtoType -> HsType -> HsType
dptToHsContType FieldContext
fc) ((TypeContext -> DotProtoPrimType -> m HsType)
-> TypeContext -> DotProtoType -> m HsType)
-> (StringType -> TypeContext -> DotProtoPrimType -> m HsType)
-> StringType
-> TypeContext
-> DotProtoType
-> m HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringType -> TypeContext -> DotProtoPrimType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
StringType -> TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType
dptToHsTypeWrapped
:: MonadError CompileError m
=> FieldContext
-> StringType
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m HsType
dptToHsTypeWrapped :: FieldContext
-> StringType
-> [DotProtoOption]
-> TypeContext
-> DotProtoType
-> m HsType
dptToHsTypeWrapped FieldContext
fc StringType
stringType [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
(\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 (FieldContext -> TypeContext -> DotProtoType -> HsType -> HsType
dptToHsContType FieldContext
fc TypeContext
ctxt DotProtoType
ty) (HsType -> HsType) -> HsType -> HsType
forall a. a -> a
id (FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> Maybe (HsType -> HsType)
dptToHsWrappedContType FieldContext
fc TypeContext
ctxt [DotProtoOption]
opts DotProtoType
ty))
(StringType -> TypeContext -> DotProtoPrimType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
StringType -> TypeContext -> DotProtoPrimType -> m HsType
dpptToHsTypeWrapped StringType
stringType)
dpptToHsTypeWrapped
:: MonadError CompileError m
=> StringType
-> TypeContext
-> DotProtoPrimType
-> m HsType
dpptToHsTypeWrapped :: StringType -> TypeContext -> DotProtoPrimType -> m HsType
dpptToHsTypeWrapped (StringType FilePath
_ FilePath
stringType) 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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ HsType -> HsType
protobufSignedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"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
$ HsType -> HsType
protobufSignedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ HsType -> HsType
protobufFixedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"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
$ HsType -> HsType
protobufFixedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"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
$ HsType -> HsType
protobufSignedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ HsType -> HsType
protobufFixedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"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
$ HsType -> HsType
protobufSignedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ HsType -> HsType
protobufFixedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
protobufStringType_ FilePath
stringType
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
$ FilePath -> HsType
protobufBytesType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"Double"
Named (Dots (Path (FilePath
"google" :| [FilePath
"protobuf", FilePath
x])))
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ HsType -> HsType
protobufWrappedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"Int32"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ HsType -> HsType
protobufWrappedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"Int64"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ HsType -> HsType
protobufWrappedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"Word32"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ HsType -> HsType
protobufWrappedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"Word64"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ HsType -> HsType
protobufWrappedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
protobufStringType_ FilePath
stringType
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ HsType -> HsType
protobufWrappedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
protobufBytesType_ FilePath
"ByteString"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ HsType -> HsType
protobufWrappedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"Bool"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ HsType -> HsType
protobufWrappedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"Float"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ HsType -> HsType
protobufWrappedType_ (HsType -> HsType) -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"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 (FilePath -> HsType
protobufType_ FilePath
"Enumerated") (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo TypeContext
ctxt DotProtoTypeInfo
ty DotProtoIdentifier
msgName
Just DotProtoTypeInfo
ty -> TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo TypeContext
ctxt 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
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)
| 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
$ FilePath -> CompileError
InvalidMapKeyType (Doc -> FilePath
forall a. Show a => a -> FilePath
show (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ DotProtoPrimType -> Doc
forall a. Pretty a => a -> Doc
pPrint DotProtoPrimType
k)
dptToHsWrappedContType :: FieldContext -> TypeContext -> [DotProtoOption] -> DotProtoType -> Maybe (HsType -> HsType)
dptToHsWrappedContType :: FieldContext
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> Maybe (HsType -> HsType)
dptToHsWrappedContType FieldContext
fc TypeContext
ctxt [DotProtoOption]
opts = \case
Prim (Named DotProtoIdentifier
tyName)
| FieldContext
WithinMessage <- FieldContext
fc, 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 (FilePath -> HsType
protobufType_ FilePath
"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 (FilePath -> HsType
protobufType_ FilePath
"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 (FilePath -> HsType
protobufType_ FilePath
"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 (FilePath -> HsType
protobufType_ FilePath
"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 (FilePath -> HsType
protobufType_ FilePath
"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 (FilePath -> HsType
protobufType_ FilePath
"UnpackedVec")
DotProtoType
_ -> Maybe (HsType -> HsType)
forall a. Maybe a
Nothing
dptToHsContType :: FieldContext -> TypeContext -> DotProtoType -> HsType -> HsType
dptToHsContType :: FieldContext -> TypeContext -> DotProtoType -> HsType -> HsType
dptToHsContType FieldContext
fc TypeContext
ctxt = \case
Prim (Named DotProtoIdentifier
tyName) | FieldContext
WithinMessage <- FieldContext
fc, 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
$ FilePath -> HsType
primType_ FilePath
"Maybe"
Repeated DotProtoPrimType
_ -> HsType -> HsType -> HsType
HsTyApp (HsType -> HsType -> HsType) -> HsType -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"Vector"
NestedRepeated DotProtoPrimType
_ -> HsType -> HsType -> HsType
HsTyApp (HsType -> HsType -> HsType) -> HsType -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"Vector"
Map DotProtoPrimType
_ DotProtoPrimType
_ -> HsType -> HsType -> HsType
HsTyApp (HsType -> HsType -> HsType) -> HsType -> HsType -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath -> HsType
primType_ FilePath
"Map"
DotProtoType
_ -> HsType -> HsType
forall a. a -> a
id
dpptToHsType :: MonadError CompileError m
=> StringType
-> TypeContext
-> DotProtoPrimType
-> m HsType
dpptToHsType :: StringType -> TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType (StringType FilePath
_ FilePath
stringType) 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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
stringType
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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"Double"
Named (Dots (Path (FilePath
"google" :| [FilePath
"protobuf", FilePath
x])))
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"Int32"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"Int64"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"Word32"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"Word64"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ FilePath -> HsType
primType_ FilePath
stringType
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"ByteString"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"Bool"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"Float"
| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"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
$ FilePath -> HsType
primType_ FilePath
"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 (FilePath -> HsType
protobufType_ FilePath
"Enumerated") (HsType -> HsType) -> m HsType -> m HsType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo TypeContext
ctxt DotProtoTypeInfo
ty DotProtoIdentifier
msgName
Just DotProtoTypeInfo
ty -> TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
msgTypeFromDpTypeInfo TypeContext
ctxt 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])
dotProtoDefinitionD :: MonadError CompileError m
=> StringType
-> RecordStyle
-> DotProtoPackageSpec
-> TypeContext
-> DotProtoDefinition
-> m [HsDecl]
dotProtoDefinitionD :: StringType
-> RecordStyle
-> DotProtoPackageSpec
-> TypeContext
-> DotProtoDefinition
-> m [HsDecl]
dotProtoDefinitionD StringType
stringType RecordStyle
recordStyle DotProtoPackageSpec
pkgSpec TypeContext
ctxt = \case
DotProtoMessage FilePath
_ DotProtoIdentifier
messageName [DotProtoMessagePart]
messageParts ->
StringType
-> RecordStyle
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> RecordStyle
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
dotProtoMessageD StringType
stringType RecordStyle
recordStyle TypeContext
ctxt DotProtoIdentifier
Anonymous DotProtoIdentifier
messageName [DotProtoMessagePart]
messageParts
DotProtoEnum FilePath
_ 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 FilePath
_ DotProtoIdentifier
serviceName [DotProtoServicePart]
serviceParts ->
StringType
-> DotProtoPackageSpec
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> DotProtoPackageSpec
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
dotProtoServiceD StringType
stringType DotProtoPackageSpec
pkgSpec TypeContext
ctxt DotProtoIdentifier
serviceName [DotProtoServicePart]
serviceParts
namedInstD :: String -> HsDecl
namedInstD :: FilePath -> HsDecl
namedInstD FilePath
messageName =
HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
protobufName FilePath
"Named")
[ FilePath -> HsType
type_ FilePath
messageName ]
[ [HsMatch] -> HsDecl
HsFunBind [HsMatch
nameOfDecl] ]
where
nameOfDecl :: HsMatch
nameOfDecl = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"nameOf") [HsPat
HsPWildCard]
(HsExp -> HsRhs
HsUnGuardedRhs (HsExp -> [HsExp] -> HsExp
apply HsExp
fromStringE
[ FilePath -> HsExp
str_ FilePath
messageName ]))
[]
hasDefaultInstD :: String -> HsDecl
hasDefaultInstD :: FilePath -> HsDecl
hasDefaultInstD FilePath
messageName =
HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
protobufName FilePath
"HasDefault")
[ FilePath -> HsType
type_ FilePath
messageName ]
[ ]
dotProtoMessageD
:: forall m
. MonadError CompileError m
=> StringType
-> RecordStyle
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
dotProtoMessageD :: StringType
-> RecordStyle
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
dotProtoMessageD StringType
stringType RecordStyle
recordStyle TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent [DotProtoMessagePart]
messageParts = do
FilePath
messageName <- DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent
let mkDataDecl :: [([HsName], HsBangType)] -> HsDecl
mkDataDecl [([HsName], HsBangType)]
flds =
FilePath -> [HsConDecl] -> [HsQName] -> HsDecl
dataDecl_ FilePath
messageName
[ HsName -> [([HsName], HsBangType)] -> HsConDecl
recDecl_ (FilePath -> HsName
HsIdent FilePath
messageName) [([HsName], HsBangType)]
flds ]
[HsQName]
defaultMessageDeriving
#ifdef SWAGGER
let getName :: DotProtoMessagePart
-> m [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
getName = \case
DotProtoMessageField DotProtoField
fld -> ((Maybe ([DotProtoOption], DotProtoType), FilePath)
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
forall a. a -> [a] -> [a]
: []) ((Maybe ([DotProtoOption], DotProtoType), FilePath)
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)])
-> m (Maybe ([DotProtoOption], DotProtoType), FilePath)
-> m [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoField
-> m (Maybe ([DotProtoOption], DotProtoType), FilePath)
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoField
-> m (Maybe ([DotProtoOption], DotProtoType), FilePath)
getFieldNameForSchemaInstanceDeclaration DotProtoField
fld
DotProtoMessageOneOf DotProtoIdentifier
ident [DotProtoField]
_ -> ((Maybe ([DotProtoOption], DotProtoType), FilePath)
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
forall a. a -> [a] -> [a]
: []) ((Maybe ([DotProtoOption], DotProtoType), FilePath)
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)])
-> (FilePath -> (Maybe ([DotProtoOption], DotProtoType), FilePath))
-> FilePath
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ([DotProtoOption], DotProtoType)
forall a. Maybe a
Nothing, ) (FilePath -> [(Maybe ([DotProtoOption], DotProtoType), FilePath)])
-> m FilePath
-> m [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
dpIdentUnqualName DotProtoIdentifier
ident
DotProtoMessagePart
_ -> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> m [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
#endif
HsDecl
messageDataDecl <- [([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 (FilePath -> DotProtoMessagePart -> m [([HsName], HsBangType)]
messagePartFieldD FilePath
messageName) [DotProtoMessagePart]
messageParts
(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
[ HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsDecl
messageDataDecl
, HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsDecl -> FilePath -> HsDecl
nfDataInstD HsDecl
messageDataDecl FilePath
messageName)
, HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> HsDecl
namedInstD FilePath
messageName)
, HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> HsDecl
hasDefaultInstD FilePath
messageName)
, StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
messageInstD StringType
stringType TypeContext
ctxt' DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent [DotProtoMessagePart]
messageParts
, StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
toJSONPBMessageInstD StringType
stringType TypeContext
ctxt' DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent [DotProtoMessagePart]
messageParts
, StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
fromJSONPBMessageInstD StringType
stringType TypeContext
ctxt' DotProtoIdentifier
parentIdent DotProtoIdentifier
messageIdent [DotProtoMessagePart]
messageParts
, HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> HsDecl
toJSONInstDecl FilePath
messageName)
, HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> HsDecl
fromJSONInstDecl FilePath
messageName)
#ifdef SWAGGER
, StringType
-> TypeContext
-> FilePath
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> m HsDecl
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> TypeContext
-> FilePath
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> m HsDecl
toSchemaInstanceDeclaration StringType
stringType TypeContext
ctxt' FilePath
messageName Maybe [HsName]
forall a. Maybe a
Nothing
([(Maybe ([DotProtoOption], DotProtoType), FilePath)] -> m HsDecl)
-> m [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> m HsDecl
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (DotProtoMessagePart
-> m [(Maybe ([DotProtoOption], DotProtoType), FilePath)])
-> [DotProtoMessagePart]
-> m [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM DotProtoMessagePart
-> m [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
getName [DotProtoMessagePart]
messageParts
#endif
#ifdef DHALL
, pure (dhallInterpretInstDecl messageName)
, pure (dhallInjectInstDecl messageName)
#endif
]
, 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
$ FilePath -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl]
nestedOneOfDecls FilePath
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
nfDataInstD :: HsDecl -> FilePath -> HsDecl
nfDataInstD = case RecordStyle
recordStyle of
RecordStyle
RegularRecords -> HsDecl -> FilePath -> HsDecl
RegularRecord.nfDataInstD
RecordStyle
LargeRecords -> HsDecl -> FilePath -> HsDecl
LargeRecord.nfDataInstD
messagePartFieldD :: String -> DotProtoMessagePart -> m [([HsName], HsBangType)]
messagePartFieldD :: FilePath -> DotProtoMessagePart -> m [([HsName], HsBangType)]
messagePartFieldD FilePath
messageName (DotProtoMessageField DotProtoField{FilePath
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldComment :: DotProtoField -> FilePath
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
dotProtoFieldComment :: FilePath
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldType :: DotProtoType
dotProtoFieldNumber :: FieldNumber
..}) = do
FilePath
fullName <- FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> FilePath -> m FilePath
prefixedFieldName FilePath
messageName (FilePath -> m FilePath) -> m FilePath -> m FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
dpIdentUnqualName DotProtoIdentifier
dotProtoFieldName
HsType
fullTy <- FieldContext
-> StringType -> TypeContext -> DotProtoType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType -> TypeContext -> DotProtoType -> m HsType
dptToHsType FieldContext
WithinMessage StringType
stringType TypeContext
ctxt' DotProtoType
dotProtoFieldType
[([HsName], HsBangType)] -> m [([HsName], HsBangType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ ([FilePath -> HsName
HsIdent FilePath
fullName], HsType -> HsBangType
HsUnBangedTy HsType
fullTy ) ]
messagePartFieldD FilePath
messageName (DotProtoMessageOneOf DotProtoIdentifier
fieldName [DotProtoField]
_) = do
FilePath
fullName <- FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> FilePath -> m FilePath
prefixedFieldName FilePath
messageName (FilePath -> m FilePath) -> m FilePath -> m FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
dpIdentUnqualName DotProtoIdentifier
fieldName
FilePath
qualTyName <- FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> FilePath -> m FilePath
prefixedConName FilePath
messageName (FilePath -> m FilePath) -> m FilePath -> m FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
dpIdentUnqualName DotProtoIdentifier
fieldName
let fullTy :: HsType
fullTy = HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (FilePath -> HsQName
haskellName FilePath
"Maybe")) (HsType -> HsType) -> (FilePath -> HsType) -> FilePath -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> HsType
type_ (FilePath -> HsType) -> FilePath -> HsType
forall a b. (a -> b) -> a -> b
$ FilePath
qualTyName
[([HsName], HsBangType)] -> m [([HsName], HsBangType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ ([FilePath -> HsName
HsIdent FilePath
fullName], HsType -> HsBangType
HsUnBangedTy HsType
fullTy) ]
messagePartFieldD FilePath
_ 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 FilePath
_ 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
StringType
-> RecordStyle
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> RecordStyle
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m [HsDecl]
dotProtoMessageD StringType
stringType RecordStyle
recordStyle TypeContext
ctxt' DotProtoIdentifier
parentIdent' DotProtoIdentifier
subMsgName [DotProtoMessagePart]
subMessageDef
nestedDecls (DotProtoEnum FilePath
_ 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 :: FilePath -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl]
nestedOneOfDecls FilePath
messageName DotProtoIdentifier
identifier [DotProtoField]
fields = do
FilePath
fullName <- FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> FilePath -> m FilePath
prefixedConName FilePath
messageName (FilePath -> m FilePath) -> m FilePath -> m FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
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 (FilePath -> DotProtoField -> m (HsConDecl, HsName)
oneOfCons FilePath
fullName) [DotProtoField]
fields)
#ifdef SWAGGER
HsDecl
toSchemaInstance <- StringType
-> TypeContext
-> FilePath
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> m HsDecl
forall (m :: * -> *).
MonadError CompileError m =>
StringType
-> TypeContext
-> FilePath
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> m HsDecl
toSchemaInstanceDeclaration StringType
stringType TypeContext
ctxt' FilePath
fullName ([HsName] -> Maybe [HsName]
forall a. a -> Maybe a
Just [HsName]
idents)
([(Maybe ([DotProtoOption], DotProtoType), FilePath)] -> m HsDecl)
-> m [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> m HsDecl
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (DotProtoField
-> m (Maybe ([DotProtoOption], DotProtoType), FilePath))
-> [DotProtoField]
-> m [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DotProtoField
-> m (Maybe ([DotProtoOption], DotProtoType), FilePath)
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoField
-> m (Maybe ([DotProtoOption], DotProtoType), FilePath)
getFieldNameForSchemaInstanceDeclaration [DotProtoField]
fields
#endif
let nestedDecl :: HsDecl
nestedDecl = FilePath -> [HsConDecl] -> [HsQName] -> HsDecl
dataDecl_ FilePath
fullName [HsConDecl]
cons [HsQName]
defaultMessageDeriving
[HsDecl] -> m [HsDecl]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ HsDecl
nestedDecl
, HsDecl -> FilePath -> HsDecl
nfDataInstD HsDecl
nestedDecl FilePath
fullName
, FilePath -> HsDecl
namedInstD FilePath
fullName
#ifdef SWAGGER
, HsDecl
toSchemaInstance
#endif
#ifdef DHALL
, dhallInterpretInstDecl fullName
, dhallInjectInstDecl fullName
#endif
]
oneOfCons :: String -> DotProtoField -> m (HsConDecl, HsName)
oneOfCons :: FilePath -> DotProtoField -> m (HsConDecl, HsName)
oneOfCons FilePath
fullName DotProtoField{FilePath
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldComment :: FilePath
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldType :: DotProtoType
dotProtoFieldNumber :: FieldNumber
dotProtoFieldComment :: DotProtoField -> FilePath
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
..} = do
HsType
consTy <- FieldContext
-> StringType -> TypeContext -> DotProtoType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType -> TypeContext -> DotProtoType -> m HsType
dptToHsType FieldContext
WithinOneOf StringType
stringType TypeContext
ctxt' DotProtoType
dotProtoFieldType
FilePath
consName <- FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> FilePath -> m FilePath
prefixedConName FilePath
fullName (FilePath -> m FilePath) -> m FilePath -> m FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
dpIdentUnqualName DotProtoIdentifier
dotProtoFieldName
let ident :: HsName
ident = FilePath -> HsName
HsIdent FilePath
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 FilePath
_ DotProtoField
DotProtoEmptyField = FilePath -> m (HsConDecl, HsName)
forall (m :: * -> *) a.
MonadError CompileError m =>
FilePath -> m a
internalError FilePath
"field type : empty field"
messageInstD
:: forall m
. MonadError CompileError m
=> StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
messageInstD :: StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
messageInstD StringType
stringType TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent [DotProtoMessagePart]
messageParts = do
FilePath
msgName <- DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent
[QualifiedField]
qualifiedFields <- FilePath -> [DotProtoMessagePart] -> m [QualifiedField]
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields FilePath
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_ (FilePath -> HsName
HsIdent FilePath
"encodeMessage")
[HsPat
HsPWildCard, HsQName -> [HsPatField] -> HsPat
HsPRec (FilePath -> HsQName
unqual_ FilePath
msgName) [HsPatField]
punnedFieldsP]
(HsExp -> HsRhs
HsUnGuardedRhs HsExp
encodeMessageE) []
encodeMessageE :: HsExp
encodeMessageE = case [HsExp]
encodedFields of
[] -> HsExp
memptyE
(HsExp
field : [HsExp]
fields) -> (HsExp -> HsExp -> HsExp) -> HsExp -> [HsExp] -> HsExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsExp -> HsExp -> HsExp
op (HsExp -> HsExp
paren HsExp
field) [HsExp]
fields
where op :: HsExp -> HsExp -> HsExp
op HsExp
fs HsExp
f = HsExp -> [HsExp] -> HsExp
apply (HsExp -> [HsExp] -> HsExp
apply HsExp
mappendE [HsExp
fs]) [HsExp -> HsExp
paren HsExp
f]
punnedFieldsP :: [HsPatField]
punnedFieldsP = (QualifiedField -> HsPatField) -> [QualifiedField] -> [HsPatField]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> HsPatField
fp (FilePath -> HsPatField)
-> (QualifiedField -> FilePath) -> QualifiedField -> HsPatField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> FilePath
coerce (FieldName -> FilePath)
-> (QualifiedField -> FieldName) -> QualifiedField -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedField -> FieldName
recordFieldName) [QualifiedField]
qualifiedFields
where fp :: FilePath -> HsPatField
fp FilePath
nm = HsQName -> HsPat -> HsPatField
HsPFieldPat (FilePath -> HsQName
unqual_ FilePath
nm) (HsName -> HsPat
HsPVar (FilePath -> HsName
HsIdent FilePath
nm))
let decodeMessageDecl :: HsMatch
decodeMessageDecl = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"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 [ FilePath -> HsExp
uvar_ FilePath
msgName ])
[HsExp]
decodedFields
let dotProtoDecl :: HsMatch
dotProtoDecl = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"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{FilePath
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldComment :: FilePath
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldType :: DotProtoType
dotProtoFieldNumber :: FieldNumber
dotProtoFieldComment :: DotProtoField -> FilePath
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
..} <- [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)
, FilePath -> HsExp
str_ FilePath
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_ (FilePath -> HsQName
protobufName FilePath
"Message")
[ FilePath -> HsType
type_ FilePath
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' = FilePath -> HsExp
uvar_ (FieldName -> FilePath
coerce FieldName
recordFieldName) in
case FieldInfo
fieldInfo of
FieldNormal FieldName
_fieldName FieldNumber
fieldNum DotProtoType
dpType [DotProtoOption]
options -> do
HsExp
fieldE <- FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
wrapE FieldContext
WithinMessage StringType
stringType 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 (FilePath -> HsQName
haskellName FilePath
"Nothing") [])
(HsExp -> HsGuardedAlts
HsUnGuardedAlt HsExp
memptyE)
[]
, HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ (HsQName -> [HsPat] -> HsPat
HsPApp (FilePath -> HsQName
haskellName FilePath
"Just") [FilePath -> HsPat
patVar FilePath
"x"])
(HsExp -> HsGuardedAlts
HsUnGuardedAlt (HsExp -> [HsAlt] -> HsExp
HsCase (FilePath -> HsExp
uvar_ FilePath
"x") [HsAlt]
alts))
[]
]
where
mkAlt :: OneofSubfield -> m HsAlt
mkAlt (OneofSubfield FieldNumber
fieldNum FilePath
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 (FilePath -> HsQName
haskellName FilePath
"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
. FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
wrapE FieldContext
WithinMessage StringType
stringType 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
$ FilePath -> HsExp
uvar_ FilePath
"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 (FilePath -> HsQName
unqual_ FilePath
conName) [FilePath -> HsPat
patVar FilePath
"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 ->
FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
unwrapE FieldContext
WithinMessage StringType
stringType 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 (FilePath -> HsQName
haskellName FilePath
"Nothing")
, [HsExp] -> HsExp
HsList [HsExp]
parsers
]
where
subfieldParserE :: OneofSubfield -> m HsExp
subfieldParserE (OneofSubfield FieldNumber
fieldNumber FilePath
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 (FilePath -> HsExp
uvar_ FilePath
consName))
| Bool
otherwise
= HsExp -> HsExp
HsParen (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (HsQName -> HsExp
HsVar (FilePath -> HsQName
haskellName FilePath
"Just"))
HsQOp
composeOp
(FilePath -> HsExp
uvar_ FilePath
consName))
HsExp
alts <- FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
unwrapE FieldContext
WithinMessage StringType
stringType 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
]
toJSONPBMessageInstD
:: forall m
. MonadError CompileError m
=> StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
toJSONPBMessageInstD :: StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
toJSONPBMessageInstD StringType
stringType TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent [DotProtoMessagePart]
messageParts = do
FilePath
msgName <- DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent
[QualifiedField]
qualFields <- FilePath -> [DotProtoMessagePart] -> m [QualifiedField]
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields FilePath
msgName [DotProtoMessagePart]
messageParts
let applyE :: FilePath -> FilePath -> m HsExp
applyE FilePath
nm FilePath
oneofNm = do
[HsExp]
fs <- (QualifiedField -> m HsExp) -> [QualifiedField] -> m [HsExp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (FilePath -> QualifiedField -> m HsExp
encodeMessageField FilePath
oneofNm) [QualifiedField]
qualFields
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 (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
nm)) [[HsExp] -> HsExp
HsList [HsExp]
fs]
let patBinder :: QualifiedField -> FilePath
patBinder = (FieldName -> FieldNumber -> FilePath)
-> (OneofField -> FilePath) -> QualifiedField -> FilePath
forall a.
(FieldName -> FieldNumber -> a)
-> (OneofField -> a) -> QualifiedField -> a
foldQF ((FieldNumber -> FilePath) -> FieldName -> FieldNumber -> FilePath
forall a b. a -> b -> a
const FieldNumber -> FilePath
fieldBinder) ([OneofSubfield] -> FilePath
oneofSubDisjunctBinder ([OneofSubfield] -> FilePath)
-> (OneofField -> [OneofSubfield]) -> OneofField -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneofField -> [OneofSubfield]
subfields)
let matchE :: FilePath -> FilePath -> FilePath -> m HsMatch
matchE FilePath
nm FilePath
appNm FilePath
oneofAppNm = do
HsExp
rhs <- FilePath -> FilePath -> m HsExp
applyE FilePath
appNm FilePath
oneofAppNm
HsMatch -> m HsMatch
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsMatch -> m HsMatch) -> HsMatch -> m HsMatch
forall a b. (a -> b) -> a -> b
$ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_
(FilePath -> HsName
HsIdent FilePath
nm)
[ HsQName -> [HsPat] -> HsPat
HsPApp (FilePath -> HsQName
unqual_ FilePath
msgName)
(FilePath -> HsPat
patVar (FilePath -> HsPat)
-> (QualifiedField -> FilePath) -> QualifiedField -> HsPat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedField -> FilePath
patBinder (QualifiedField -> HsPat) -> [QualifiedField] -> [HsPat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QualifiedField]
qualFields) ]
(HsExp -> HsRhs
HsUnGuardedRhs HsExp
rhs)
[]
HsMatch
toJSONPB <- FilePath -> FilePath -> FilePath -> m HsMatch
matchE FilePath
"toJSONPB" FilePath
"object" FilePath
"objectOrNull"
HsMatch
toEncoding <- FilePath -> FilePath -> FilePath -> m HsMatch
matchE FilePath
"toEncodingPB" FilePath
"pairs" FilePath
"pairsOrNull"
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_ (FilePath -> HsQName
jsonpbName FilePath
"ToJSONPB")
[ FilePath -> HsType
type_ FilePath
msgName ]
[ [HsMatch] -> HsDecl
HsFunBind [HsMatch
toJSONPB]
, [HsMatch] -> HsDecl
HsFunBind [HsMatch
toEncoding]
]
where
encodeMessageField :: String -> QualifiedField -> m HsExp
encodeMessageField :: FilePath -> QualifiedField -> m HsExp
encodeMessageField FilePath
oneofNm (QualifiedField FieldName
_ FieldInfo
fieldInfo) =
case FieldInfo
fieldInfo of
FieldNormal FieldName
fldName FieldNumber
fldNum DotProtoType
dpType [DotProtoOption]
options ->
FieldName
-> FieldNumber -> DotProtoType -> [DotProtoOption] -> m HsExp
forall (m :: * -> *) a.
(MonadError CompileError m, Coercible a FilePath) =>
a -> FieldNumber -> DotProtoType -> [DotProtoOption] -> m HsExp
defPairE FieldName
fldName FieldNumber
fldNum DotProtoType
dpType [DotProtoOption]
options
FieldOneOf OneofField
oo ->
FilePath -> OneofField -> m HsExp
oneofCaseE FilePath
oneofNm OneofField
oo
defPairE :: a -> FieldNumber -> DotProtoType -> [DotProtoOption] -> m HsExp
defPairE a
fldName FieldNumber
fldNum DotProtoType
dpType [DotProtoOption]
options = do
HsExp
w <- FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
wrapE FieldContext
WithinMessage StringType
stringType TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType (FilePath -> HsExp
uvar_ (FieldNumber -> FilePath
fieldBinder FieldNumber
fldNum))
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 -> HsQOp -> HsExp -> HsExp
HsInfixApp (FilePath -> HsExp
str_ (a -> FilePath
coerce a
fldName)) HsQOp
toJSONPBOp HsExp
w
oneOfPairE :: a -> FilePath -> [DotProtoOption] -> DotProtoType -> m HsExp
oneOfPairE a
fldNm FilePath
varNm [DotProtoOption]
options DotProtoType
dpType = do
HsExp
w <- FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
wrapE FieldContext
WithinOneOf StringType
stringType TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType (FilePath -> HsExp
uvar_ FilePath
varNm)
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 (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"pair")) [FilePath -> HsExp
str_ (a -> FilePath
coerce a
fldNm), HsExp
w]
oneofCaseE :: String -> OneofField -> m HsExp
oneofCaseE :: FilePath -> OneofField -> m HsExp
oneofCaseE FilePath
retJsonCtor (OneofField FilePath
typeName [OneofSubfield]
subfields) = do
[HsAlt]
altEs <- (OneofSubfield -> m HsAlt) -> [OneofSubfield] -> m [HsAlt]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse OneofSubfield -> m HsAlt
forall (m :: * -> *).
MonadError CompileError m =>
OneofSubfield -> m HsAlt
altE [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
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_ (FilePath -> HsName
HsIdent FilePath
caseName) [] (HsExp -> HsRhs
HsUnGuardedRhs ([HsAlt] -> HsExp
caseExpr [HsAlt]
altEs)) [] ] ]
(HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$ SrcLoc -> [HsPat] -> HsExp -> HsExp
HsLambda SrcLoc
defaultSrcLoc [FilePath -> HsPat
patVar FilePath
optsStr] (HsExp -> HsExp -> HsExp -> HsExp
HsIf HsExp
dontInline HsExp
noInline HsExp
yesInline)
where
optsStr :: FilePath
optsStr = FilePath
"options"
opts :: HsExp
opts = FilePath -> HsExp
uvar_ FilePath
optsStr
caseName :: FilePath
caseName = FilePath
"encode" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ASetter FilePath FilePath Char Char -> (Char -> Char) -> ShowS
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Index FilePath -> Traversal' FilePath (IxValue FilePath)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index FilePath
0) Char -> Char
toUpper FilePath
typeName
caseBnd :: HsExp
caseBnd = FilePath -> HsExp
uvar_ FilePath
caseName
dontInline :: HsExp
dontInline = HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"optEmitNamedOneof")) HsExp
opts
noInline :: HsExp
noInline = HsExp -> HsExp -> HsExp
HsApp (HsExp -> HsExp
HsParen (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (FilePath -> HsExp
str_ FilePath
typeName)
HsQOp
toJSONPBOp
(HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
retJsonCtor))
[ [HsExp] -> HsExp
HsList [HsExp
caseBnd], HsExp
opts ])))
HsExp
opts
yesInline :: HsExp
yesInline = HsExp -> HsExp -> HsExp
HsApp HsExp
caseBnd HsExp
opts
altE :: OneofSubfield -> m HsAlt
altE sub :: OneofSubfield
sub@(OneofSubfield FieldNumber
_ FilePath
conName FieldName
pbFldNm DotProtoType
dpType [DotProtoOption]
options) = do
let patVarNm :: FilePath
patVarNm = OneofSubfield -> FilePath
oneofSubBinder OneofSubfield
sub
HsExp
p <- FieldName
-> FilePath -> [DotProtoOption] -> DotProtoType -> m HsExp
forall (m :: * -> *) a.
(MonadError CompileError m, Coercible a FilePath) =>
a -> FilePath -> [DotProtoOption] -> DotProtoType -> m HsExp
oneOfPairE FieldName
pbFldNm FilePath
patVarNm [DotProtoOption]
options DotProtoType
dpType
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 (FilePath -> HsQName
haskellName FilePath
"Just")
[ HsPat -> HsPat
HsPParen
(HsQName -> [HsPat] -> HsPat
HsPApp (FilePath -> HsQName
unqual_ FilePath
conName) [FilePath -> HsPat
patVar FilePath
patVarNm])
]
)
(HsExp -> HsGuardedAlts
HsUnGuardedAlt HsExp
p)
[]
caseExpr :: [HsAlt] -> HsExp
caseExpr [HsAlt]
altEs = 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 = FilePath -> HsExp
uvar_ ([OneofSubfield] -> FilePath
oneofSubDisjunctBinder [OneofSubfield]
subfields)
fallthroughE :: HsAlt
fallthroughE =
HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ (HsQName -> [HsPat] -> HsPat
HsPApp (FilePath -> HsQName
haskellName FilePath
"Nothing") [])
(HsExp -> HsGuardedAlts
HsUnGuardedAlt HsExp
memptyE)
[]
fromJSONPBMessageInstD
:: forall m
. MonadError CompileError m
=> StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
fromJSONPBMessageInstD :: StringType
-> TypeContext
-> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoMessagePart]
-> m HsDecl
fromJSONPBMessageInstD StringType
stringType TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent [DotProtoMessagePart]
messageParts = do
FilePath
msgName <- DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent
[QualifiedField]
qualFields <- FilePath -> [DotProtoMessagePart] -> m [QualifiedField]
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields FilePath
msgName [DotProtoMessagePart]
messageParts
[HsExp]
fieldParsers <- (QualifiedField -> m HsExp) -> [QualifiedField] -> m [HsExp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse QualifiedField -> m HsExp
parseField [QualifiedField]
qualFields
let parseJSONPBE :: HsExp
parseJSONPBE =
HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"withObject"))
[ FilePath -> HsExp
str_ FilePath
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 [ FilePath -> HsExp
uvar_ FilePath
msgName ])
[HsExp]
fieldParsers
let parseJSONPBDecl :: HsMatch
parseJSONPBDecl =
HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"parseJSONPB") [] (HsExp -> HsRhs
HsUnGuardedRhs HsExp
parseJSONPBE) []
HsDecl -> m HsDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
jsonpbName FilePath
"FromJSONPB")
[ FilePath -> HsType
type_ FilePath
msgName ]
[ [HsMatch] -> HsDecl
HsFunBind [ HsMatch
parseJSONPBDecl ] ])
where
lambdaPVar :: HsPat
lambdaPVar = FilePath -> HsPat
patVar FilePath
"obj"
lambdaVar :: HsExp
lambdaVar = FilePath -> HsExp
uvar_ FilePath
"obj"
parseField :: QualifiedField -> m HsExp
parseField (QualifiedField FieldName
_ (FieldNormal FieldName
fldName FieldNumber
_ DotProtoType
dpType [DotProtoOption]
options)) =
FieldName -> DotProtoType -> [DotProtoOption] -> m HsExp
normalParserE FieldName
fldName DotProtoType
dpType [DotProtoOption]
options
parseField (QualifiedField FieldName
_ (FieldOneOf OneofField
fld)) =
OneofField -> m HsExp
oneofParserE OneofField
fld
oneofParserE :: OneofField -> m HsExp
oneofParserE :: OneofField -> m HsExp
oneofParserE (OneofField FilePath
oneofType [OneofSubfield]
fields) = do
HsExp
ds <- m HsExp
tryParseDisjunctsE
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
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_ (FilePath -> HsName
HsIdent FilePath
letBndStr) [FilePath -> HsPat
patVar FilePath
letArgStr ]
(HsExp -> HsRhs
HsUnGuardedRhs HsExp
ds) []
]
]
(HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
parseWrapped HsQOp
altOp HsExp
parseUnwrapped)
where
oneofTyLit :: HsExp
oneofTyLit = FilePath -> HsExp
str_ FilePath
oneofType
letBndStr :: FilePath
letBndStr = FilePath
"parse" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ASetter FilePath FilePath Char Char -> (Char -> Char) -> ShowS
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Index FilePath -> Traversal' FilePath (IxValue FilePath)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index FilePath
0) Char -> Char
toUpper FilePath
oneofType
letBndName :: HsExp
letBndName = FilePath -> HsExp
uvar_ FilePath
letBndStr
letArgStr :: FilePath
letArgStr = FilePath
"parseObj"
letArgName :: HsExp
letArgName = FilePath -> HsExp
uvar_ FilePath
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 (FilePath -> HsQName
jsonpbName FilePath
"withObject")) [ HsExp
oneofTyLit , HsExp
letBndName ])
parseUnwrapped :: HsExp
parseUnwrapped = HsExp -> HsExp
HsParen (HsExp -> HsExp -> HsExp
HsApp HsExp
letBndName HsExp
lambdaVar)
tryParseDisjunctsE :: m HsExp
tryParseDisjunctsE = do
[HsExp]
fs <- (OneofSubfield -> m HsExp) -> [OneofSubfield] -> m [HsExp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse OneofSubfield -> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
OneofSubfield -> m HsExp
subParserE [OneofSubfield]
fields
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
HsApp HsExp
msumE ([HsExp] -> HsExp
HsList ([HsExp]
fs [HsExp] -> [HsExp] -> [HsExp]
forall a. Semigroup a => a -> a -> a
<> [HsExp]
fallThruE))
fallThruE :: [HsExp]
fallThruE = [ HsExp -> HsExp -> HsExp
HsApp HsExp
pureE (HsQName -> HsExp
HsVar (FilePath -> HsQName
haskellName FilePath
"Nothing")) ]
subParserE :: OneofSubfield -> m HsExp
subParserE OneofSubfield{FilePath
subfieldConsName :: OneofSubfield -> FilePath
subfieldConsName :: FilePath
subfieldConsName, FieldName
subfieldName :: OneofSubfield -> FieldName
subfieldName :: FieldName
subfieldName,
DotProtoType
subfieldType :: OneofSubfield -> DotProtoType
subfieldType :: DotProtoType
subfieldType, [DotProtoOption]
subfieldOptions :: OneofSubfield -> [DotProtoOption]
subfieldOptions :: [DotProtoOption]
subfieldOptions} = do
Maybe HsExp
maybeCoercion <-
Bool
-> FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
forall (m :: * -> *).
MonadError CompileError m =>
Bool
-> FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> m (Maybe HsExp)
unwrapFunE Bool
False FieldContext
WithinOneOf StringType
stringType TypeContext
ctxt [DotProtoOption]
subfieldOptions DotProtoType
subfieldType
let inject :: HsExp
inject = (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (HsQName -> HsExp
HsVar (FilePath -> HsQName
haskellName FilePath
"Just"))
HsQOp
composeOp
(FilePath -> HsExp
uvar_ FilePath
subfieldConsName))
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 -> HsQOp -> HsExp -> HsExp
HsInfixApp
(HsExp -> (HsExp -> HsExp) -> Maybe HsExp -> HsExp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HsExp
inject (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
inject HsQOp
composeOp) Maybe HsExp
maybeCoercion)
HsQOp
fmapOp
(HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"parseField"))
[ HsExp
letArgName
, FilePath -> HsExp
str_ (FieldName -> FilePath
coerce FieldName
subfieldName)])
normalParserE :: FieldName -> DotProtoType -> [DotProtoOption] -> m HsExp
normalParserE :: FieldName -> DotProtoType -> [DotProtoOption] -> m HsExp
normalParserE FieldName
fldName DotProtoType
dpType [DotProtoOption]
options =
FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
unwrapE FieldContext
WithinMessage StringType
stringType TypeContext
ctxt [DotProtoOption]
options DotProtoType
dpType (HsExp -> m HsExp) -> HsExp -> m HsExp
forall a b. (a -> b) -> a -> b
$
HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
lambdaVar
HsQOp
parseJSONPBOp
(FilePath -> HsExp
str_(FieldName -> FilePath
coerce FieldName
fldName))
toJSONInstDecl :: String -> HsDecl
toJSONInstDecl :: FilePath -> HsDecl
toJSONInstDecl FilePath
typeName =
HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
jsonpbName FilePath
"ToJSON")
[ FilePath -> HsType
type_ FilePath
typeName ]
[ [HsMatch] -> HsDecl
HsFunBind [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"toJSON") []
(HsExp -> HsRhs
HsUnGuardedRhs (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"toAesonValue"))) []
]
, [HsMatch] -> HsDecl
HsFunBind [ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"toEncoding") []
(HsExp -> HsRhs
HsUnGuardedRhs (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"toAesonEncoding"))) []
]
]
fromJSONInstDecl :: String -> HsDecl
fromJSONInstDecl :: FilePath -> HsDecl
fromJSONInstDecl FilePath
typeName =
HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
jsonpbName FilePath
"FromJSON")
[ FilePath -> HsType
type_ FilePath
typeName ]
[ [HsMatch] -> HsDecl
HsFunBind [HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"parseJSON") []
(HsExp -> HsRhs
HsUnGuardedRhs (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"parseJSONPB"))) []
]
]
getFieldNameForSchemaInstanceDeclaration
:: MonadError CompileError m
=> DotProtoField
-> m (Maybe ([DotProtoOption], DotProtoType), String)
getFieldNameForSchemaInstanceDeclaration :: DotProtoField
-> m (Maybe ([DotProtoOption], DotProtoType), FilePath)
getFieldNameForSchemaInstanceDeclaration DotProtoField
fld = do
FilePath
unqual <- DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
dpIdentUnqualName (DotProtoField -> DotProtoIdentifier
dotProtoFieldName DotProtoField
fld)
let optsType :: ([DotProtoOption], DotProtoType)
optsType = (DotProtoField -> [DotProtoOption]
dotProtoFieldOptions DotProtoField
fld, DotProtoField -> DotProtoType
dotProtoFieldType DotProtoField
fld)
(Maybe ([DotProtoOption], DotProtoType), FilePath)
-> m (Maybe ([DotProtoOption], DotProtoType), FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([DotProtoOption], DotProtoType)
-> Maybe ([DotProtoOption], DotProtoType)
forall a. a -> Maybe a
Just ([DotProtoOption], DotProtoType)
optsType, FilePath
unqual)
toSchemaInstanceDeclaration
:: MonadError CompileError m
=> StringType
-> TypeContext
-> String
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), String)]
-> m HsDecl
toSchemaInstanceDeclaration :: StringType
-> TypeContext
-> FilePath
-> Maybe [HsName]
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> m HsDecl
toSchemaInstanceDeclaration StringType
stringType TypeContext
ctxt FilePath
messageName Maybe [HsName]
maybeConstructors [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
fieldNamesEtc = do
let fieldNames :: [FilePath]
fieldNames = ((Maybe ([DotProtoOption], DotProtoType), FilePath) -> FilePath)
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe ([DotProtoOption], DotProtoType), FilePath) -> FilePath
forall a b. (a, b) -> b
snd [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
fieldNamesEtc
[FilePath]
qualifiedFieldNames <- (FilePath -> m FilePath) -> [FilePath] -> m [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> FilePath -> m FilePath
prefixedFieldName FilePath
messageName) [FilePath]
fieldNames
let messageConstructor :: HsExp
messageConstructor = HsQName -> HsExp
HsCon (HsName -> HsQName
UnQual (FilePath -> HsName
HsIdent FilePath
messageName))
let _namedSchemaNameExpression :: HsExp
_namedSchemaNameExpression = HsExp -> HsExp -> HsExp
HsApp HsExp
justC (FilePath -> HsExp
str_ FilePath
messageName)
#ifdef SWAGGER
let paramSchemaUpdates :: [HsFieldUpdate]
paramSchemaUpdates =
[ HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
_paramSchemaType HsExp
_paramSchemaTypeExpression
]
where
_paramSchemaType :: HsQName
_paramSchemaType = FilePath -> HsQName
jsonpbName FilePath
"_paramSchemaType"
#if MIN_VERSION_swagger2(2,4,0)
_paramSchemaTypeExpression :: HsExp
_paramSchemaTypeExpression = HsExp -> HsExp -> HsExp
HsApp HsExp
justC (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"SwaggerObject"))
#else
_paramSchemaTypeExpression = HsVar (jsonpbName "SwaggerObject")
#endif
#else
let paramSchemaUpdates = []
#endif
let _schemaParamSchemaExpression :: HsExp
_schemaParamSchemaExpression = HsExp -> [HsFieldUpdate] -> HsExp
HsRecUpdate HsExp
memptyE [HsFieldUpdate]
paramSchemaUpdates
let properties :: HsExp
properties = [HsExp] -> HsExp
HsList ([HsExp] -> HsExp) -> [HsExp] -> HsExp
forall a b. (a -> b) -> a -> b
$ do
(FilePath
fieldName, FilePath
qualifiedFieldName) <- [FilePath] -> [FilePath] -> [(FilePath, FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
fieldNames [FilePath]
qualifiedFieldNames
HsExp -> [HsExp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsExp] -> HsExp
HsTuple [ FilePath -> HsExp
str_ FilePath
fieldName, FilePath -> HsExp
uvar_ FilePath
qualifiedFieldName ])
let _schemaPropertiesExpression :: HsExp
_schemaPropertiesExpression =
HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"insOrdFromList")) HsExp
properties
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 = FilePath -> HsQName
jsonpbName FilePath
"_schemaParamSchema"
_schemaProperties :: HsQName
_schemaProperties = FilePath -> HsQName
jsonpbName FilePath
"_schemaProperties"
_schemaMinProperties :: HsQName
_schemaMinProperties = FilePath -> HsQName
jsonpbName FilePath
"_schemaMinProperties"
_schemaMaxProperties :: HsQName
_schemaMaxProperties = FilePath -> HsQName
jsonpbName FilePath
"_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
let namedSchemaUpdates :: [HsFieldUpdate]
namedSchemaUpdates =
[ HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
_namedSchemaName HsExp
_namedSchemaNameExpression
, HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate HsQName
_namedSchemaSchema HsExp
_namedSchemaSchemaExpression
]
where
_namedSchemaName :: HsQName
_namedSchemaName = FilePath -> HsQName
jsonpbName FilePath
"_namedSchemaName"
_namedSchemaSchema :: HsQName
_namedSchemaSchema = FilePath -> HsQName
jsonpbName FilePath
"_namedSchemaSchema"
let namedSchema :: HsExp
namedSchema = HsQName -> [HsFieldUpdate] -> HsExp
HsRecConstr (FilePath -> HsQName
jsonpbName FilePath
"NamedSchema") [HsFieldUpdate]
namedSchemaUpdates
let toDeclareName :: ShowS
toDeclareName FilePath
fieldName = FilePath
"declare_" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
fieldName
let toArgument :: FieldContext
-> (Maybe ([DotProtoOption], DotProtoType), FilePath) -> f HsExp
toArgument FieldContext
fc (Maybe ([DotProtoOption], DotProtoType)
maybeOptsType, FilePath
fieldName) =
(HsExp -> f HsExp)
-> (([DotProtoOption], DotProtoType) -> HsExp -> f HsExp)
-> Maybe ([DotProtoOption], DotProtoType)
-> HsExp
-> f HsExp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HsExp -> f HsExp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([DotProtoOption] -> DotProtoType -> HsExp -> f HsExp)
-> ([DotProtoOption], DotProtoType) -> HsExp -> f HsExp
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> f HsExp
forall (m :: * -> *).
MonadError CompileError m =>
FieldContext
-> StringType
-> TypeContext
-> [DotProtoOption]
-> DotProtoType
-> HsExp
-> m HsExp
unwrapE FieldContext
fc StringType
stringType TypeContext
ctxt)) Maybe ([DotProtoOption], DotProtoType)
maybeOptsType (HsExp -> f HsExp) -> HsExp -> f HsExp
forall a b. (a -> b) -> a -> b
$
HsExp -> HsExp -> HsExp
HsApp HsExp
asProxy HsExp
declare
where
declare :: HsExp
declare = FilePath -> HsExp
uvar_ (ShowS
toDeclareName FilePath
fieldName)
asProxy :: HsExp
asProxy = HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"asProxy")
let expressionForMessage :: m HsExp
expressionForMessage = do
let bindingStatements :: [HsStmt]
bindingStatements = do
(FilePath
fieldName, FilePath
qualifiedFieldName) <- [FilePath] -> [FilePath] -> [(FilePath, FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
fieldNames [FilePath]
qualifiedFieldNames
let declareIdentifier :: HsName
declareIdentifier = FilePath -> HsName
HsIdent (ShowS
toDeclareName FilePath
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 (FilePath -> HsQName
jsonpbName FilePath
"declareSchemaRef"))) []
]
]
let stmt1 :: HsStmt
stmt1 = SrcLoc -> HsPat -> HsExp -> HsStmt
HsGenerator SrcLoc
defaultSrcLoc (HsName -> HsPat
HsPVar (FilePath -> HsName
HsIdent FilePath
qualifiedFieldName))
(HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (HsName -> HsQName
UnQual HsName
declareIdentifier))
(HsQName -> HsExp
HsCon (FilePath -> HsQName
proxyName FilePath
"Proxy")))
[ HsStmt
stmt0, HsStmt
stmt1]
[HsStmt]
inferenceStatement <- do
[HsExp]
arguments <- ((Maybe ([DotProtoOption], DotProtoType), FilePath) -> m HsExp)
-> [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> m [HsExp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (FieldContext
-> (Maybe ([DotProtoOption], DotProtoType), FilePath) -> m HsExp
forall (f :: * -> *).
MonadError CompileError f =>
FieldContext
-> (Maybe ([DotProtoOption], DotProtoType), FilePath) -> f HsExp
toArgument FieldContext
WithinMessage) [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
fieldNamesEtc
let patternBind :: HsDecl
patternBind = SrcLoc -> HsPat -> HsRhs -> [HsDecl] -> HsDecl
HsPatBind SrcLoc
defaultSrcLoc HsPat
HsPWildCard
(HsExp -> HsRhs
HsUnGuardedRhs (HsExp -> [HsExp] -> HsExp
applicativeApply HsExp
messageConstructor [HsExp]
arguments)) []
[HsStmt] -> m [HsStmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HsStmt] -> m [HsStmt]) -> [HsStmt] -> m [HsStmt]
forall a b. (a -> b) -> a -> b
$ if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
fieldNames then [] else [ [HsDecl] -> HsStmt
HsLetStmt [ HsDecl
patternBind ] ]
let returnStatement :: HsStmt
returnStatement = HsExp -> HsStmt
HsQualifier (HsExp -> HsExp -> HsExp
HsApp HsExp
returnE (HsExp -> HsExp
HsParen HsExp
namedSchema))
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
$ [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 ])
let expressionForOneOf :: [HsName] -> m HsExp
expressionForOneOf [HsName]
constructors = do
let bindingStatement :: ((Maybe ([DotProtoOption], DotProtoType), FilePath), FilePath,
HsName)
-> m [HsStmt]
bindingStatement ((Maybe ([DotProtoOption], DotProtoType), FilePath)
fieldNameEtc, FilePath
qualifiedFieldName, HsName
constructor) = do
let declareIdentifier :: HsName
declareIdentifier = FilePath -> HsName
HsIdent (ShowS
toDeclareName ((Maybe ([DotProtoOption], DotProtoType), FilePath) -> FilePath
forall a b. (a, b) -> b
snd (Maybe ([DotProtoOption], DotProtoType), FilePath)
fieldNameEtc))
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 (FilePath -> HsQName
jsonpbName FilePath
"declareSchemaRef"))) []
]
]
let stmt1 :: HsStmt
stmt1 = SrcLoc -> HsPat -> HsExp -> HsStmt
HsGenerator SrcLoc
defaultSrcLoc (HsName -> HsPat
HsPVar (FilePath -> HsName
HsIdent FilePath
qualifiedFieldName))
(HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (HsName -> HsQName
UnQual HsName
declareIdentifier))
(HsQName -> HsExp
HsCon (FilePath -> HsQName
proxyName FilePath
"Proxy")))
[HsStmt]
inferenceStatement <- do
HsExp
argument <- FieldContext
-> (Maybe ([DotProtoOption], DotProtoType), FilePath) -> m HsExp
forall (f :: * -> *).
MonadError CompileError f =>
FieldContext
-> (Maybe ([DotProtoOption], DotProtoType), FilePath) -> f HsExp
toArgument FieldContext
WithinOneOf (Maybe ([DotProtoOption], DotProtoType), FilePath)
fieldNameEtc
let 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
argument ])) []
[HsStmt] -> m [HsStmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HsStmt] -> m [HsStmt]) -> [HsStmt] -> m [HsStmt]
forall a b. (a -> b) -> a -> b
$ if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
fieldNames then [] else [ [HsDecl] -> HsStmt
HsLetStmt [ HsDecl
patternBind ] ]
[HsStmt] -> m [HsStmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HsStmt] -> m [HsStmt]) -> [HsStmt] -> m [HsStmt]
forall a b. (a -> b) -> a -> b
$ [HsStmt
stmt0, HsStmt
stmt1] [HsStmt] -> [HsStmt] -> [HsStmt]
forall a. [a] -> [a] -> [a]
++ [HsStmt]
inferenceStatement
[HsStmt]
bindingStatements <- (((Maybe ([DotProtoOption], DotProtoType), FilePath), FilePath,
HsName)
-> m [HsStmt])
-> [((Maybe ([DotProtoOption], DotProtoType), FilePath), FilePath,
HsName)]
-> m [HsStmt]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM ((Maybe ([DotProtoOption], DotProtoType), FilePath), FilePath,
HsName)
-> m [HsStmt]
forall (m :: * -> *).
MonadError CompileError m =>
((Maybe ([DotProtoOption], DotProtoType), FilePath), FilePath,
HsName)
-> m [HsStmt]
bindingStatement ([((Maybe ([DotProtoOption], DotProtoType), FilePath), FilePath,
HsName)]
-> m [HsStmt])
-> [((Maybe ([DotProtoOption], DotProtoType), FilePath), FilePath,
HsName)]
-> m [HsStmt]
forall a b. (a -> b) -> a -> b
$
[(Maybe ([DotProtoOption], DotProtoType), FilePath)]
-> [FilePath]
-> [HsName]
-> [((Maybe ([DotProtoOption], DotProtoType), FilePath), FilePath,
HsName)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [(Maybe ([DotProtoOption], DotProtoType), FilePath)]
fieldNamesEtc [FilePath]
qualifiedFieldNames [HsName]
constructors
let returnStatement :: HsStmt
returnStatement = HsExp -> HsStmt
HsQualifier (HsExp -> HsExp -> HsExp
HsApp HsExp
returnE (HsExp -> HsExp
HsParen HsExp
namedSchema))
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
$ [HsStmt] -> HsExp
HsDo ([HsStmt]
bindingStatements [HsStmt] -> [HsStmt] -> [HsStmt]
forall a. [a] -> [a] -> [a]
++ [ HsStmt
returnStatement ])
HsExp
expression <- case Maybe [HsName]
maybeConstructors of
Maybe [HsName]
Nothing -> m HsExp
expressionForMessage
Just [HsName]
constructors -> [HsName] -> m HsExp
forall (m :: * -> *).
MonadError CompileError m =>
[HsName] -> m HsExp
expressionForOneOf [HsName]
constructors
let instanceDeclaration :: HsDecl
instanceDeclaration =
HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ HsQName
className [ HsType
classArgument ] [ HsDecl
classDeclaration ]
where
className :: HsQName
className = FilePath -> HsQName
jsonpbName FilePath
"ToSchema"
classArgument :: HsType
classArgument = HsQName -> HsType
HsTyCon (HsName -> HsQName
UnQual (FilePath -> HsName
HsIdent FilePath
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
rightHandSide :: HsRhs
rightHandSide = HsExp -> HsRhs
HsUnGuardedRhs HsExp
expression
matchName :: HsName
matchName = FilePath -> HsName
HsIdent FilePath
"declareNamedSchema"
HsDecl -> m HsDecl
forall (m :: * -> *) a. Monad m => a -> m a
return HsDecl
instanceDeclaration
dotProtoEnumD
:: MonadError CompileError m
=> DotProtoIdentifier
-> DotProtoIdentifier
-> [DotProtoEnumPart]
-> m [HsDecl]
dotProtoEnumD :: DotProtoIdentifier
-> DotProtoIdentifier -> [DotProtoEnumPart] -> m [HsDecl]
dotProtoEnumD DotProtoIdentifier
parentIdent DotProtoIdentifier
enumIdent [DotProtoEnumPart]
enumParts = do
FilePath
enumName <- DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m FilePath
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
$ FilePath -> CompileError
EmptyEnumeration FilePath
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
$ FilePath -> DotProtoIdentifier -> DotProtoEnumValue -> CompileError
NonzeroFirstEnumeration FilePath
enumName DotProtoIdentifier
conIdent DotProtoEnumValue
i
[(DotProtoEnumValue, FilePath)]
enumCons <- ((DotProtoEnumValue, FilePath)
-> (DotProtoEnumValue, FilePath) -> Ordering)
-> [(DotProtoEnumValue, FilePath)]
-> [(DotProtoEnumValue, FilePath)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((DotProtoEnumValue, FilePath) -> DotProtoEnumValue)
-> (DotProtoEnumValue, FilePath)
-> (DotProtoEnumValue, FilePath)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (DotProtoEnumValue, FilePath) -> DotProtoEnumValue
forall a b. (a, b) -> a
fst) ([(DotProtoEnumValue, FilePath)]
-> [(DotProtoEnumValue, FilePath)])
-> m [(DotProtoEnumValue, FilePath)]
-> m [(DotProtoEnumValue, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((DotProtoEnumValue, DotProtoIdentifier)
-> m (DotProtoEnumValue, FilePath))
-> [(DotProtoEnumValue, DotProtoIdentifier)]
-> m [(DotProtoEnumValue, FilePath)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((DotProtoIdentifier -> m FilePath)
-> (DotProtoEnumValue, DotProtoIdentifier)
-> m (DotProtoEnumValue, FilePath)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ShowS -> m FilePath -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> ShowS
prefixedEnumFieldName FilePath
enumName) (m FilePath -> m FilePath)
-> (DotProtoIdentifier -> m FilePath)
-> DotProtoIdentifier
-> m FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
dpIdentUnqualName)) [(DotProtoEnumValue, DotProtoIdentifier)]
enumeratorDecls
let enumConNames :: [FilePath]
enumConNames = ((DotProtoEnumValue, FilePath) -> FilePath)
-> [(DotProtoEnumValue, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (DotProtoEnumValue, FilePath) -> FilePath
forall a b. (a, b) -> b
snd [(DotProtoEnumValue, FilePath)]
enumCons
minBoundD :: [HsMatch]
minBoundD =
[ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"minBound")
[]
(HsExp -> HsRhs
HsUnGuardedRhs (FilePath -> HsExp
uvar_ ([FilePath] -> FilePath
forall a. [a] -> a
head [FilePath]
enumConNames)))
[]
]
maxBoundD :: [HsMatch]
maxBoundD =
[ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"maxBound")
[]
(HsExp -> HsRhs
HsUnGuardedRhs (FilePath -> HsExp
uvar_ ([FilePath] -> FilePath
forall a. [a] -> a
last [FilePath]
enumConNames)))
[]
]
compareD :: [HsMatch]
compareD =
[ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"compare")
[ FilePath -> HsPat
patVar FilePath
"x", FilePath -> HsPat
patVar FilePath
"y" ]
(HsExp -> HsRhs
HsUnGuardedRhs
(HsExp -> HsExp -> HsExp
HsApp
(HsExp -> HsExp -> HsExp
HsApp
(HsQName -> HsExp
HsVar (FilePath -> HsQName
haskellName FilePath
"compare"))
(HsExp -> HsExp
HsParen
(HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar(FilePath -> HsQName
protobufName FilePath
"fromProtoEnum"))
(FilePath -> HsExp
uvar_ FilePath
"x")
)
)
)
(HsExp -> HsExp
HsParen
(HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (FilePath -> HsQName
protobufName FilePath
"fromProtoEnum"))
(FilePath -> HsExp
uvar_ FilePath
"y")
)
)
)
)
[]
]
fromProtoEnumD :: [HsMatch]
fromProtoEnumD =
[ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"fromProtoEnum") [ HsQName -> [HsPat] -> HsPat
HsPApp (FilePath -> HsQName
unqual_ FilePath
conName) [] ]
(HsExp -> HsRhs
HsUnGuardedRhs (DotProtoEnumValue -> HsExp
forall a. Integral a => a -> HsExp
intE DotProtoEnumValue
conIdx))
[]
| (DotProtoEnumValue
conIdx, FilePath
conName) <- [(DotProtoEnumValue, FilePath)]
enumCons
]
toProtoEnumMayD :: [HsMatch]
toProtoEnumMayD =
[ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"toProtoEnumMay")
[ DotProtoEnumValue -> HsPat
forall a. Integral a => a -> HsPat
intP DotProtoEnumValue
conIdx ]
(HsExp -> HsRhs
HsUnGuardedRhs (HsExp -> HsExp -> HsExp
HsApp HsExp
justC (FilePath -> HsExp
uvar_ FilePath
conName)))
[]
| (DotProtoEnumValue
conIdx, FilePath
conName) <- [(DotProtoEnumValue, FilePath)]
enumCons ] [HsMatch] -> [HsMatch] -> [HsMatch]
forall a. [a] -> [a] -> [a]
++
[ HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"toProtoEnumMay")
[ HsPat
HsPWildCard ]
(HsExp -> HsRhs
HsUnGuardedRhs HsExp
nothingC)
[]
]
parseJSONPBDecls :: [HsMatch]
parseJSONPBDecls :: [HsMatch]
parseJSONPBDecls = (FilePath -> [HsMatch] -> [HsMatch])
-> [HsMatch] -> [FilePath] -> [HsMatch]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (HsMatch -> [HsMatch] -> [HsMatch])
-> (FilePath -> HsMatch) -> FilePath -> [HsMatch] -> [HsMatch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> HsMatch
matchConName) [HsMatch
mismatch] [FilePath]
enumConNames
where
matchConName :: FilePath -> HsMatch
matchConName FilePath
conName = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"parseJSONPB") [FilePath -> HsPat
pat FilePath
conName]
(HsExp -> HsRhs
HsUnGuardedRhs
(HsExp -> HsExp -> HsExp
HsApp HsExp
pureE (FilePath -> HsExp
uvar_ FilePath
conName)))
[]
pat :: FilePath -> HsPat
pat FilePath
nm = HsQName -> [HsPat] -> HsPat
HsPApp (FilePath -> HsQName
jsonpbName FilePath
"String") [ HsLiteral -> HsPat
HsPLit (FilePath -> HsLiteral
HsString (ShowS
tryStripEnumName FilePath
nm)) ]
tryStripEnumName :: ShowS
tryStripEnumName = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Maybe FilePath -> FilePath)
-> (FilePath -> Maybe FilePath) -> ShowS
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
enumName
mismatch :: HsMatch
mismatch = HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"parseJSONPB") [FilePath -> HsPat
patVar FilePath
"v"]
(HsExp -> HsRhs
HsUnGuardedRhs
(HsExp -> [HsExp] -> HsExp
apply (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"typeMismatch"))
[ FilePath -> HsExp
str_ FilePath
enumName, FilePath -> HsExp
uvar_ FilePath
"v" ]))
[]
toJSONPBDecl :: HsMatch
toJSONPBDecl =
HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"toJSONPB") [ FilePath -> HsPat
patVar FilePath
"x", HsPat
HsPWildCard ]
(HsExp -> HsRhs
HsUnGuardedRhs
(HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"enumFieldString"))
(FilePath -> HsExp
uvar_ FilePath
"x")))
[]
toEncodingPBDecl :: HsMatch
toEncodingPBDecl =
HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ (FilePath -> HsName
HsIdent FilePath
"toEncodingPB") [ FilePath -> HsPat
patVar FilePath
"x", HsPat
HsPWildCard ]
(HsExp -> HsRhs
HsUnGuardedRhs
(HsExp -> HsExp -> HsExp
HsApp (HsQName -> HsExp
HsVar (FilePath -> HsQName
jsonpbName FilePath
"enumFieldEncoding"))
(FilePath -> HsExp
uvar_ FilePath
"x")))
[]
[HsDecl] -> m [HsDecl]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ FilePath -> [HsConDecl] -> [HsQName] -> HsDecl
dataDecl_ FilePath
enumName
[ HsName -> [HsBangType] -> HsConDecl
conDecl_ (FilePath -> HsName
HsIdent FilePath
con) [] | FilePath
con <- [FilePath]
enumConNames ]
[HsQName]
defaultEnumDeriving
, FilePath -> HsDecl
namedInstD FilePath
enumName
, FilePath -> HsDecl
hasDefaultInstD FilePath
enumName
, HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
haskellName FilePath
"Bounded") [ FilePath -> HsType
type_ FilePath
enumName ]
[ [HsMatch] -> HsDecl
HsFunBind [HsMatch]
minBoundD
, [HsMatch] -> HsDecl
HsFunBind [HsMatch]
maxBoundD
]
, HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
haskellName FilePath
"Ord") [ FilePath -> HsType
type_ FilePath
enumName ]
[ [HsMatch] -> HsDecl
HsFunBind [HsMatch]
compareD ]
, HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
protobufName FilePath
"ProtoEnum") [ FilePath -> HsType
type_ FilePath
enumName ]
[ [HsMatch] -> HsDecl
HsFunBind [HsMatch]
toProtoEnumMayD
, [HsMatch] -> HsDecl
HsFunBind [HsMatch]
fromProtoEnumD
]
, HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
jsonpbName FilePath
"ToJSONPB") [ FilePath -> HsType
type_ FilePath
enumName ]
[ [HsMatch] -> HsDecl
HsFunBind [HsMatch
toJSONPBDecl]
, [HsMatch] -> HsDecl
HsFunBind [HsMatch
toEncodingPBDecl]
]
, HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
jsonpbName FilePath
"FromJSONPB") [ FilePath -> HsType
type_ FilePath
enumName ]
[ [HsMatch] -> HsDecl
HsFunBind [HsMatch]
parseJSONPBDecls ]
, FilePath -> HsDecl
toJSONInstDecl FilePath
enumName
, FilePath -> HsDecl
fromJSONInstDecl FilePath
enumName
#ifdef DHALL
, dhallInterpretInstDecl enumName
, dhallInjectInstDecl enumName
#endif
, HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ (FilePath -> HsQName
protobufName FilePath
"Finite") [ FilePath -> HsType
type_ FilePath
enumName ] []
]
dotProtoServiceD
:: MonadError CompileError m
=> StringType
-> DotProtoPackageSpec
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
dotProtoServiceD :: StringType
-> DotProtoPackageSpec
-> TypeContext
-> DotProtoIdentifier
-> [DotProtoServicePart]
-> m [HsDecl]
dotProtoServiceD StringType
stringType DotProtoPackageSpec
pkgSpec TypeContext
ctxt DotProtoIdentifier
serviceIdent [DotProtoServicePart]
service = do
FilePath
serviceName <- FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> m FilePath
typeLikeName (FilePath -> m FilePath) -> m FilePath -> m FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
dpIdentUnqualName DotProtoIdentifier
serviceIdent
FilePath
endpointPrefix <-
case DotProtoPackageSpec
pkgSpec of
DotProtoPackageSpec DotProtoIdentifier
pkgIdent -> do
FilePath
packageName <- DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
dpIdentQualName DotProtoIdentifier
pkgIdent
FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"/" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
packageName FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"." FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
serviceName FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"/"
DotProtoPackageSpec
DotProtoNoPackage -> FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"/" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
serviceName FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"/"
let serviceFieldD :: DotProtoServicePart
-> m [(FilePath, FilePath, 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
FilePath
fullName <- FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> FilePath -> m FilePath
prefixedMethodName FilePath
serviceName (FilePath -> m FilePath) -> m FilePath -> m FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m FilePath
dpIdentUnqualName DotProtoIdentifier
rpcMethodName
FilePath
methodName <- case DotProtoIdentifier
rpcMethodName of
Single FilePath
nm -> FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
nm
DotProtoIdentifier
_ -> DotProtoIdentifier -> m FilePath
forall (m :: * -> *) a.
MonadError CompileError m =>
DotProtoIdentifier -> m a
invalidMethodNameError DotProtoIdentifier
rpcMethodName
HsType
requestTy <- StringType -> TypeContext -> DotProtoPrimType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
StringType -> TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType StringType
stringType TypeContext
ctxt (DotProtoIdentifier -> DotProtoPrimType
Named DotProtoIdentifier
rpcMethodRequestType)
HsType
responseTy <- StringType -> TypeContext -> DotProtoPrimType -> m HsType
forall (m :: * -> *).
MonadError CompileError m =>
StringType -> TypeContext -> DotProtoPrimType -> m HsType
dpptToHsType StringType
stringType 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
[(FilePath, FilePath, Streaming, Streaming, HsBangType)]
-> m [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ ( FilePath
endpointPrefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
methodName
, FilePath
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 (FilePath -> HsName
HsIdent FilePath
"request"))
[HsType
streamingType, HsType
requestTy, HsType
responseTy])
(HsType -> [HsType] -> HsType
tyApp HsType
ioT
[HsType -> [HsType] -> HsType
tyApp (HsName -> HsType
HsTyVar (FilePath -> HsName
HsIdent FilePath
"response"))
[HsType
streamingType, HsType
responseTy]
]
)
)
]
serviceFieldD DotProtoServicePart
_ = [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
-> m [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
[(FilePath, FilePath, Streaming, Streaming, HsBangType)]
fieldsD <- (DotProtoServicePart
-> m [(FilePath, FilePath, Streaming, Streaming, HsBangType)])
-> [DotProtoServicePart]
-> m [(FilePath, FilePath, 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 [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoServicePart
-> m [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
serviceFieldD [DotProtoServicePart]
service
FilePath
serverFuncName <- FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> FilePath -> m FilePath
prefixedFieldName FilePath
serviceName FilePath
"server"
FilePath
clientFuncName <- FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadError CompileError m =>
FilePath -> FilePath -> m FilePath
prefixedFieldName FilePath
serviceName FilePath
"client"
let conDecl :: HsConDecl
conDecl = HsName -> [([HsName], HsBangType)] -> HsConDecl
recDecl_ (FilePath -> HsName
HsIdent FilePath
serviceName)
[ ([FilePath -> HsName
HsIdent FilePath
hsName], HsBangType
ty) | (FilePath
_, FilePath
hsName, Streaming
_, Streaming
_, HsBangType
ty) <- [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
fieldsD ]
let serverT :: HsType
serverT = HsType -> [HsType] -> HsType
tyApp (HsQName -> HsType
HsTyCon (FilePath -> HsQName
unqual_ FilePath
serviceName))
[ HsType
serverRequestT, HsType
serverResponseT ]
let serviceServerTypeD :: HsDecl
serviceServerTypeD =
SrcLoc -> [HsName] -> HsQualType -> HsDecl
HsTypeSig SrcLoc
defaultSrcLoc [ FilePath -> HsName
HsIdent FilePath
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_ (FilePath -> HsName
HsIdent FilePath
serverFuncName)
[ HsQName -> [HsPatField] -> HsPat
HsPRec (FilePath -> HsQName
unqual_ FilePath
serviceName)
[ HsQName -> HsPat -> HsPatField
HsPFieldPat (FilePath -> HsQName
unqual_ FilePath
methodName) (HsName -> HsPat
HsPVar (FilePath -> HsName
HsIdent FilePath
methodName))
| (FilePath
_, FilePath
methodName, Streaming
_, Streaming
_, HsBangType
_) <- [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
fieldsD
]
, HsQName -> [HsPat] -> HsPat
HsPApp (FilePath -> HsQName
unqual_ FilePath
"ServiceOptions")
[ FilePath -> HsPat
patVar FilePath
"serverHost"
, FilePath -> HsPat
patVar FilePath
"serverPort"
, FilePath -> HsPat
patVar FilePath
"useCompression"
, FilePath -> HsPat
patVar FilePath
"userAgentPrefix"
, FilePath -> HsPat
patVar FilePath
"userAgentSuffix"
, FilePath -> HsPat
patVar FilePath
"initialMetadata"
, FilePath -> HsPat
patVar FilePath
"sslConfig"
, FilePath -> HsPat
patVar FilePath
"logger"
, FilePath -> HsPat
patVar FilePath
"serverMaxReceiveMessageLength"
, FilePath -> HsPat
patVar FilePath
"serverMaxMetadataSize"
]
]
(HsExp -> HsRhs
HsUnGuardedRhs (HsExp -> [HsExp] -> HsExp
apply HsExp
serverLoopE [ HsExp
serverOptsE ]))
[]
handlerE :: HsExp -> HsExp -> FilePath -> FilePath -> HsExp
handlerE HsExp
handlerC HsExp
adapterE FilePath
methodName FilePath
hsName =
HsExp -> [HsExp] -> HsExp
apply HsExp
handlerC [ HsExp -> [HsExp] -> HsExp
apply HsExp
methodNameC [ FilePath -> HsExp
str_ FilePath
methodName ]
, HsExp -> [HsExp] -> HsExp
apply HsExp
adapterE [ FilePath -> HsExp
uvar_ FilePath
hsName ]
]
update :: FilePath -> FilePath -> HsFieldUpdate
update FilePath
u FilePath
v = HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate (FilePath -> HsQName
unqual_ FilePath
u) (FilePath -> HsExp
uvar_ FilePath
v)
serverOptsE :: HsExp
serverOptsE = HsExp -> [HsFieldUpdate] -> HsExp
HsRecUpdate HsExp
defaultOptionsE
[ HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate (FilePath -> HsQName
grpcName FilePath
"optNormalHandlers") (HsExp -> HsFieldUpdate) -> HsExp -> HsFieldUpdate
forall a b. (a -> b) -> a -> b
$
[HsExp] -> HsExp
HsList [ HsExp -> HsExp -> FilePath -> FilePath -> HsExp
handlerE HsExp
unaryHandlerC HsExp
convertServerHandlerE FilePath
endpointName FilePath
hsName
| (FilePath
endpointName, FilePath
hsName, Streaming
NonStreaming, Streaming
NonStreaming, HsBangType
_) <- [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
fieldsD
]
, HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate (FilePath -> HsQName
grpcName FilePath
"optClientStreamHandlers") (HsExp -> HsFieldUpdate) -> HsExp -> HsFieldUpdate
forall a b. (a -> b) -> a -> b
$
[HsExp] -> HsExp
HsList [ HsExp -> HsExp -> FilePath -> FilePath -> HsExp
handlerE HsExp
clientStreamHandlerC HsExp
convertServerReaderHandlerE FilePath
endpointName FilePath
hsName
| (FilePath
endpointName, FilePath
hsName, Streaming
Streaming, Streaming
NonStreaming, HsBangType
_) <- [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
fieldsD
]
, HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate (FilePath -> HsQName
grpcName FilePath
"optServerStreamHandlers") (HsExp -> HsFieldUpdate) -> HsExp -> HsFieldUpdate
forall a b. (a -> b) -> a -> b
$
[HsExp] -> HsExp
HsList [ HsExp -> HsExp -> FilePath -> FilePath -> HsExp
handlerE HsExp
serverStreamHandlerC HsExp
convertServerWriterHandlerE FilePath
endpointName FilePath
hsName
| (FilePath
endpointName, FilePath
hsName, Streaming
NonStreaming, Streaming
Streaming, HsBangType
_) <- [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
fieldsD
]
, HsQName -> HsExp -> HsFieldUpdate
HsFieldUpdate (FilePath -> HsQName
grpcName FilePath
"optBiDiStreamHandlers") (HsExp -> HsFieldUpdate) -> HsExp -> HsFieldUpdate
forall a b. (a -> b) -> a -> b
$
[HsExp] -> HsExp
HsList [ HsExp -> HsExp -> FilePath -> FilePath -> HsExp
handlerE HsExp
biDiStreamHandlerC HsExp
convertServerRWHandlerE FilePath
endpointName FilePath
hsName
| (FilePath
endpointName, FilePath
hsName, Streaming
Streaming, Streaming
Streaming, HsBangType
_) <- [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
fieldsD
]
, FilePath -> FilePath -> HsFieldUpdate
update FilePath
"optServerHost" FilePath
"serverHost"
, FilePath -> FilePath -> HsFieldUpdate
update FilePath
"optServerPort" FilePath
"serverPort"
, FilePath -> FilePath -> HsFieldUpdate
update FilePath
"optUseCompression" FilePath
"useCompression"
, FilePath -> FilePath -> HsFieldUpdate
update FilePath
"optUserAgentPrefix" FilePath
"userAgentPrefix"
, FilePath -> FilePath -> HsFieldUpdate
update FilePath
"optUserAgentSuffix" FilePath
"userAgentSuffix"
, FilePath -> FilePath -> HsFieldUpdate
update FilePath
"optInitialMetadata" FilePath
"initialMetadata"
, FilePath -> FilePath -> HsFieldUpdate
update FilePath
"optSSLConfig" FilePath
"sslConfig"
, FilePath -> FilePath -> HsFieldUpdate
update FilePath
"optLogger" FilePath
"logger"
, FilePath -> FilePath -> HsFieldUpdate
update FilePath
"optMaxReceiveMessageLength" FilePath
"serverMaxReceiveMessageLength"
, FilePath -> FilePath -> HsFieldUpdate
update FilePath
"optMaxMetadataSize" FilePath
"serverMaxMetadataSize"
]
let clientT :: HsType
clientT = HsType -> [HsType] -> HsType
tyApp (HsQName -> HsType
HsTyCon (FilePath -> HsQName
unqual_ FilePath
serviceName)) [ HsType
clientRequestT, HsType
clientResultT ]
let serviceClientTypeD :: HsDecl
serviceClientTypeD =
SrcLoc -> [HsName] -> HsQualType -> HsDecl
HsTypeSig SrcLoc
defaultSrcLoc [ FilePath -> HsName
HsIdent FilePath
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_ (FilePath -> HsName
HsIdent FilePath
clientFuncName)
[ HsName -> HsPat
HsPVar (FilePath -> HsName
HsIdent FilePath
"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 [ FilePath -> HsExp
uvar_ FilePath
serviceName ])
[ HsExp -> HsExp
HsParen (HsExp -> HsExp) -> HsExp -> HsExp
forall a b. (a -> b) -> a -> b
$ HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
clientRequestE' HsQOp
apOp (FilePath -> HsExp
registerClientMethodE FilePath
endpointName)
| (FilePath
endpointName, FilePath
_, Streaming
_, Streaming
_, HsBangType
_) <- [(FilePath, FilePath, Streaming, Streaming, HsBangType)]
fieldsD
]
clientRequestE' :: HsExp
clientRequestE' = HsExp -> [HsExp] -> HsExp
apply HsExp
pureE [ HsExp -> [HsExp] -> HsExp
apply HsExp
clientRequestE [ FilePath -> HsExp
uvar_ FilePath
"client" ] ]
registerClientMethodE :: FilePath -> HsExp
registerClientMethodE FilePath
endpoint =
HsExp -> [HsExp] -> HsExp
apply HsExp
clientRegisterMethodE [ FilePath -> HsExp
uvar_ FilePath
"client"
, HsExp -> [HsExp] -> HsExp
apply HsExp
methodNameC [ FilePath -> HsExp
str_ FilePath
endpoint ]
]
[HsDecl] -> m [HsDecl]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ SrcLoc
-> HsContext
-> HsName
-> [HsName]
-> [HsConDecl]
-> [HsQName]
-> HsDecl
HsDataDecl SrcLoc
defaultSrcLoc [] (FilePath -> HsName
HsIdent FilePath
serviceName)
[ FilePath -> HsName
HsIdent FilePath
"request", FilePath -> HsName
HsIdent FilePath
"response" ]
[ HsConDecl
conDecl ] [HsQName]
defaultServiceDeriving
, HsDecl
serviceServerTypeD
, HsDecl
serviceServerD
, HsDecl
serviceClientTypeD
, HsDecl
serviceClientD
]
unaryHandlerC, clientStreamHandlerC, serverStreamHandlerC, biDiStreamHandlerC,
methodNameC, defaultOptionsE, serverLoopE, convertServerHandlerE,
convertServerReaderHandlerE, convertServerWriterHandlerE,
convertServerRWHandlerE, clientRegisterMethodE, clientRequestE :: HsExp
unaryHandlerC :: HsExp
unaryHandlerC = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"UnaryHandler")
clientStreamHandlerC :: HsExp
clientStreamHandlerC = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"ClientStreamHandler")
serverStreamHandlerC :: HsExp
serverStreamHandlerC = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"ServerStreamHandler")
biDiStreamHandlerC :: HsExp
biDiStreamHandlerC = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"BiDiStreamHandler")
methodNameC :: HsExp
methodNameC = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"MethodName")
defaultOptionsE :: HsExp
defaultOptionsE = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"defaultOptions")
serverLoopE :: HsExp
serverLoopE = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"serverLoop")
convertServerHandlerE :: HsExp
convertServerHandlerE = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"convertGeneratedServerHandler")
convertServerReaderHandlerE :: HsExp
convertServerReaderHandlerE = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"convertGeneratedServerReaderHandler")
convertServerWriterHandlerE :: HsExp
convertServerWriterHandlerE = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"convertGeneratedServerWriterHandler")
convertServerRWHandlerE :: HsExp
convertServerRWHandlerE = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"convertGeneratedServerRWHandler")
clientRegisterMethodE :: HsExp
clientRegisterMethodE = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"clientRegisterMethod")
clientRequestE :: HsExp
clientRequestE = HsQName -> HsExp
HsVar (FilePath -> HsQName
grpcName FilePath
"clientRequest")
biDiStreamingC, serverStreamingC, clientStreamingC, normalC, serviceOptionsC,
ioActionT, serverRequestT, serverResponseT, clientRequestT, clientResultT,
ioT, grpcClientT :: HsType
biDiStreamingC :: HsType
biDiStreamingC = HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual (FilePath -> Module
Module FilePath
"'HsGRPC") (FilePath -> HsName
HsIdent FilePath
"BiDiStreaming"))
serverStreamingC :: HsType
serverStreamingC = HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual (FilePath -> Module
Module FilePath
"'HsGRPC") (FilePath -> HsName
HsIdent FilePath
"ServerStreaming"))
clientStreamingC :: HsType
clientStreamingC = HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual (FilePath -> Module
Module FilePath
"'HsGRPC") (FilePath -> HsName
HsIdent FilePath
"ClientStreaming"))
normalC :: HsType
normalC = HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual (FilePath -> Module
Module FilePath
"'HsGRPC") (FilePath -> HsName
HsIdent FilePath
"Normal"))
serviceOptionsC :: HsType
serviceOptionsC = HsQName -> HsType
HsTyCon (Module -> HsName -> HsQName
Qual (FilePath -> Module
Module FilePath
"HsGRPC") (FilePath -> HsName
HsIdent FilePath
"ServiceOptions"))
serverRequestT :: HsType
serverRequestT = HsQName -> HsType
HsTyCon (FilePath -> HsQName
grpcName FilePath
"ServerRequest")
serverResponseT :: HsType
serverResponseT = HsQName -> HsType
HsTyCon (FilePath -> HsQName
grpcName FilePath
"ServerResponse")
clientRequestT :: HsType
clientRequestT = HsQName -> HsType
HsTyCon (FilePath -> HsQName
grpcName FilePath
"ClientRequest")
clientResultT :: HsType
clientResultT = HsQName -> HsType
HsTyCon (FilePath -> HsQName
grpcName FilePath
"ClientResult")
grpcClientT :: HsType
grpcClientT = HsQName -> HsType
HsTyCon (FilePath -> HsQName
grpcName FilePath
"Client")
ioActionT :: HsType
ioActionT = HsType -> [HsType] -> HsType
tyApp HsType
ioT [ [HsType] -> HsType
HsTyTuple [] ]
ioT :: HsType
ioT = HsQName -> HsType
HsTyCon (FilePath -> HsQName
haskellName FilePath
"IO")
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 FilePath
n) = HsExp -> [HsExp] -> HsExp
apply HsExp
singleC [ FilePath -> HsExp
str_ FilePath
n ]
dpIdentE (Dots (Path (FilePath
n NE.:| [FilePath]
ns)))
= HsExp -> [HsExp] -> HsExp
apply HsExp
dotsC [ HsExp -> [HsExp] -> HsExp
apply HsExp
pathC [ HsExp -> HsExp
HsParen (HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp (FilePath -> HsExp
str_ FilePath
n) HsQOp
neConsOp ([HsExp] -> HsExp
HsList ((FilePath -> HsExp) -> [FilePath] -> [HsExp]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> HsExp
str_ [FilePath]
ns))) ] ]
dpIdentE (Qualified DotProtoIdentifier
a DotProtoIdentifier
b) = HsExp -> [HsExp] -> HsExp
apply HsExp
qualifiedC [ DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
a, DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
b ]
dpIdentE DotProtoIdentifier
Anonymous = HsExp
anonymousC
dpValueE :: DotProtoValue -> HsExp
dpValueE :: DotProtoValue -> HsExp
dpValueE (Identifier DotProtoIdentifier
nm) = HsExp -> [HsExp] -> HsExp
apply HsExp
identifierC [ DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
nm ]
dpValueE (StringLit FilePath
s) = HsExp -> [HsExp] -> HsExp
apply HsExp
stringLitC [ FilePath -> HsExp
str_ FilePath
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 ]
dpTypeE :: DotProtoType -> HsExp
dpTypeE :: DotProtoType -> HsExp
dpTypeE (Prim DotProtoPrimType
p) = HsExp -> [HsExp] -> HsExp
apply HsExp
primC [ 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]
dpPrimTypeE :: DotProtoPrimType -> HsExp
dpPrimTypeE :: DotProtoPrimType -> HsExp
dpPrimTypeE DotProtoPrimType
ty =
let wrap :: FilePath -> HsExp
wrap = HsQName -> HsExp
HsVar (HsQName -> HsExp) -> (FilePath -> HsQName) -> FilePath -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> HsQName
protobufASTName in
case DotProtoPrimType
ty of
Named DotProtoIdentifier
n -> HsExp -> [HsExp] -> HsExp
apply HsExp
namedC [ DotProtoIdentifier -> HsExp
dpIdentE DotProtoIdentifier
n ]
DotProtoPrimType
Int32 -> FilePath -> HsExp
wrap FilePath
"Int32"
DotProtoPrimType
Int64 -> FilePath -> HsExp
wrap FilePath
"Int64"
DotProtoPrimType
SInt32 -> FilePath -> HsExp
wrap FilePath
"SInt32"
DotProtoPrimType
SInt64 -> FilePath -> HsExp
wrap FilePath
"SInt64"
DotProtoPrimType
UInt32 -> FilePath -> HsExp
wrap FilePath
"UInt32"
DotProtoPrimType
UInt64 -> FilePath -> HsExp
wrap FilePath
"UInt64"
DotProtoPrimType
Fixed32 -> FilePath -> HsExp
wrap FilePath
"Fixed32"
DotProtoPrimType
Fixed64 -> FilePath -> HsExp
wrap FilePath
"Fixed64"
DotProtoPrimType
SFixed32 -> FilePath -> HsExp
wrap FilePath
"SFixed32"
DotProtoPrimType
SFixed64 -> FilePath -> HsExp
wrap FilePath
"SFixed64"
DotProtoPrimType
String -> FilePath -> HsExp
wrap FilePath
"String"
DotProtoPrimType
Bytes -> FilePath -> HsExp
wrap FilePath
"Bytes"
DotProtoPrimType
Bool -> FilePath -> HsExp
wrap FilePath
"Bool"
DotProtoPrimType
Float -> FilePath -> HsExp
wrap FilePath
"Float"
DotProtoPrimType
Double -> FilePath -> HsExp
wrap FilePath
"Double"
data ImportCustomisation = ImportCustomisation
{ ImportCustomisation -> StringType
icStringType :: StringType
, ImportCustomisation -> Bool
icUsesGrpc :: Bool
}
defaultImports :: RecordStyle -> ImportCustomisation -> [HsImportDecl]
defaultImports :: RecordStyle -> ImportCustomisation -> [HsImportDecl]
defaultImports RecordStyle
recordStyle ImportCustomisation{ Bool
icUsesGrpc :: Bool
icUsesGrpc :: ImportCustomisation -> Bool
icUsesGrpc, icStringType :: ImportCustomisation -> StringType
icStringType = StringType FilePath
stringModule FilePath
stringType} =
[ Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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
protobufASTNS (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_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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 [FilePath -> HsImportSpec
sFilePath
".=", FilePath -> HsImportSpec
sFilePath
".:"]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"Proto3.Wire.Decode") (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
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting [FilePath -> HsImportSpec
iFilePath
"Parser", FilePath -> HsImportSpec
iFilePath
"RawField"]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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 [FilePath -> HsImportSpec
sFilePath
"<*>", FilePath -> HsImportSpec
sFilePath
"<|>", FilePath -> HsImportSpec
sFilePath
"<$>"]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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 [FilePath -> HsImportSpec
iFilePath
"Int16", FilePath -> HsImportSpec
iFilePath
"Int32", FilePath -> HsImportSpec
iFilePath
"Int64"]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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 (FilePath -> HsName
HsIdent FilePath
"NonEmpty")]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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 [FilePath -> HsImportSpec
iFilePath
"Map", FilePath -> HsImportSpec
iFilePath
"mapKeysMonotonic"]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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 [FilePath -> HsImportSpec
iFilePath
"fromString"]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
stringModule) (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 [FilePath -> HsImportSpec
i FilePath
stringType]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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 [FilePath -> HsImportSpec
iFilePath
"Vector"]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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 [FilePath -> HsImportSpec
iFilePath
"Word16", FilePath -> HsImportSpec
iFilePath
"Word32", FilePath -> HsImportSpec
iFilePath
"Word64"]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"Google.Protobuf.Wrappers.Polymorphic") (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
& [HsImportSpec]
-> (Maybe (Bool, [HsImportSpec]) -> HsImportDecl) -> HsImportDecl
forall a.
[HsImportSpec] -> (Maybe (Bool, [HsImportSpec]) -> a) -> a
selecting [HsName -> HsImportSpec
HsIThingAll (FilePath -> HsName
HsIdent FilePath
"Wrapped")]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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
icUsesGrpc then [] else
[ Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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_ (FilePath -> Module
m FilePath
"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 [FilePath -> HsImportSpec
iFilePath
"serverLoop"]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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 [FilePath -> HsImportSpec
iFilePath
"serverLoop"]
])
[HsImportDecl] -> [HsImportDecl] -> [HsImportDecl]
forall a. Semigroup a => a -> a -> a
<>
case RecordStyle
recordStyle of
RecordStyle
RegularRecords -> []
RecordStyle
LargeRecords ->
[ Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"Data.Record.Generic") (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
lrNS (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 LARGE_RECORDS
#if MIN_VERSION_large_generics(0,2,1)
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"Data.Record.Generic.NFData") (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
lrNS (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
#endif
#endif
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"Data.Record.Generic.Rep") (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
lrNS (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_ (FilePath -> Module
m FilePath
"Data.Record.Generic.Rep.Internal") (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
lrNS (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_ (FilePath -> Module
m FilePath
"Data.Record.Plugin.Runtime") (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
lrNS (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 LARGE_RECORDS
#if MIN_VERSION_large_records(0,4,0)
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"Data.Record.Plugin") (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 [FilePath -> HsImportSpec
iFilePath
"largeRecord"]
, Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ (FilePath -> Module
m FilePath
"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
& (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 [FilePath -> HsImportSpec
iFilePath
"Eq", FilePath -> HsImportSpec
iFilePath
"Int", FilePath -> HsImportSpec
iFilePath
"Ord", FilePath -> HsImportSpec
iFilePath
"Show", FilePath -> HsImportSpec
iFilePath
"error"]
#endif
#endif
]
where
m :: FilePath -> Module
m = FilePath -> Module
Module
i :: FilePath -> HsImportSpec
i = HsName -> HsImportSpec
HsIVar (HsName -> HsImportSpec)
-> (FilePath -> HsName) -> FilePath -> HsImportSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> HsName
HsIdent
s :: FilePath -> HsImportSpec
s = HsName -> HsImportSpec
HsIVar (HsName -> HsImportSpec)
-> (FilePath -> HsName) -> FilePath -> HsImportSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> HsName
HsSymbol
grpcNS :: Module
grpcNS = FilePath -> Module
m FilePath
"HsGRPC"
jsonpbNS :: Module
jsonpbNS = FilePath -> Module
m FilePath
"HsJSONPB"
lrNS :: Module
lrNS = FilePath -> Module
m FilePath
"LR"
protobufNS :: Module
protobufNS = FilePath -> Module
m FilePath
"HsProtobuf"
protobufASTNS :: Module
protobufASTNS = FilePath -> Module
m FilePath
"HsProtobufAST"
proxyNS :: Module
proxyNS = FilePath -> Module
m FilePath
"Proxy"
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
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
defaultMessageDeriving :: [HsQName]
defaultMessageDeriving :: [HsQName]
defaultMessageDeriving = (FilePath -> HsQName) -> [FilePath] -> [HsQName]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> HsQName
haskellName [ FilePath
"Show", FilePath
"Eq", FilePath
"Ord", FilePath
"Generic" ]
defaultEnumDeriving :: [HsQName]
defaultEnumDeriving :: [HsQName]
defaultEnumDeriving = (FilePath -> HsQName) -> [FilePath] -> [HsQName]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> HsQName
haskellName [ FilePath
"Show", FilePath
"Eq", FilePath
"Generic", FilePath
"NFData" ]
defaultServiceDeriving :: [HsQName]
defaultServiceDeriving :: [HsQName]
defaultServiceDeriving = (FilePath -> HsQName) -> [FilePath] -> [HsQName]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> HsQName
haskellName [ FilePath
"Generic" ]