{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Proto3.Suite.DotProto.Internal where
import Control.Applicative
import qualified Control.Foldl as FL
import Control.Lens (Lens', lens, over)
import Control.Lens.Cons (_head)
import Control.Monad
import Control.Monad.Except
import Data.Bifunctor (first)
import Data.Char
import Data.Coerce
import Data.Either
import Data.Foldable
import Data.Functor.Compose
import Data.Int (Int32)
import Data.List (intercalate)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Tuple (swap)
import Filesystem.Path.CurrentOS ((</>))
import qualified Filesystem.Path.CurrentOS as FP
import qualified NeatInterpolation as Neat
import Prelude hiding (FilePath)
import Proto3.Suite.DotProto.AST
import Proto3.Suite.DotProto.AST.Lens
import Proto3.Suite.DotProto.Parsing
import Proto3.Wire.Types (FieldNumber (..))
import System.FilePath (isPathSeparator)
import Text.Parsec (ParseError)
import qualified Turtle
import Turtle (ExitCode (..), FilePath, Text)
import Turtle.Format ((%))
import qualified Turtle.Format as F
#if !(MIN_VERSION_mtl(2,2,2))
liftEither :: MonadError e m => Either e a -> m a
liftEither = either throwError pure
#endif
foldMapM ::
(Foldable t, Monad m, Monoid b, Semigroup b) => (a -> m b) -> t a -> m b
foldMapM :: (a -> m b) -> t a -> m b
foldMapM a -> m b
f = (b -> a -> m b) -> b -> t a -> m b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\b
b a
a -> (b
b b -> b -> b
forall a. Semigroup a => a -> a -> a
<>) (b -> b) -> m b -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
a) b
forall a. Monoid a => a
mempty
type GettingM r s a = forall m. Applicative m => (a -> Compose m (Const r) a) -> s -> Compose m (Const r) s
foldMapOfM :: (Applicative m, Monoid r) => GettingM r s a -> (a -> m r) -> s -> m r
foldMapOfM :: GettingM r s a -> (a -> m r) -> s -> m r
foldMapOfM GettingM r s a
l a -> m r
f = (Const r s -> r) -> m (Const r s) -> m r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Const r s -> r
forall a k (b :: k). Const a b -> a
getConst (m (Const r s) -> m r) -> (s -> m (Const r s)) -> s -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose m (Const r) s -> m (Const r s)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose m (Const r) s -> m (Const r s))
-> (s -> Compose m (Const r) s) -> s -> m (Const r s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Compose m (Const r) a) -> s -> Compose m (Const r) s
GettingM r s a
l (m (Const r a) -> Compose m (Const r) a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (m (Const r a) -> Compose m (Const r) a)
-> (a -> m (Const r a)) -> a -> Compose m (Const r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> Const r a) -> m r -> m (Const r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Const r a
forall k a (b :: k). a -> Const a b
Const (m r -> m (Const r a)) -> (a -> m r) -> a -> m (Const r a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m r
f)
mapKeysM :: (Monad m, Ord k2) => (k1 -> m k2) -> M.Map k1 a -> m (M.Map k2 a)
mapKeysM :: (k1 -> m k2) -> Map k1 a -> m (Map k2 a)
mapKeysM k1 -> m k2
f = ([(k2, a)] -> Map k2 a) -> m [(k2, a)] -> m (Map k2 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(k2, a)] -> Map k2 a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (m [(k2, a)] -> m (Map k2 a))
-> (Map k1 a -> m [(k2, a)]) -> Map k1 a -> m (Map k2 a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k1, a) -> m (k2, a)) -> [(k1, a)] -> m [(k2, a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((a, k2) -> (k2, a)) -> m (a, k2) -> m (k2, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, k2) -> (k2, a)
forall a b. (a, b) -> (b, a)
swap (m (a, k2) -> m (k2, a))
-> ((k1, a) -> m (a, k2)) -> (k1, a) -> m (k2, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k1 -> m k2) -> (a, k1) -> m (a, k2)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse k1 -> m k2
f ((a, k1) -> m (a, k2))
-> ((k1, a) -> (a, k1)) -> (k1, a) -> m (a, k2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k1, a) -> (a, k1)
forall a b. (a, b) -> (b, a)
swap) ([(k1, a)] -> m [(k2, a)])
-> (Map k1 a -> [(k1, a)]) -> Map k1 a -> m [(k2, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k1 a -> [(k1, a)]
forall k a. Map k a -> [(k, a)]
M.assocs
dieLines :: MonadIO m => Text -> m a
dieLines :: Text -> m a
dieLines (Text -> NonEmpty Line
Turtle.textToLines -> NonEmpty Line
msg) = do
(Line -> m ()) -> NonEmpty Line -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Line -> m ()
forall (io :: * -> *). MonadIO io => Line -> io ()
Turtle.err NonEmpty Line
msg
ExitCode -> m a
forall (io :: * -> *) a. MonadIO io => ExitCode -> io a
Turtle.exit (Int -> ExitCode
ExitFailure Int
1)
toModulePath :: FilePath -> Either String Path
toModulePath :: FilePath -> Either String Path
toModulePath fp0 :: FilePath
fp0@(FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
fp0 (Maybe FilePath -> FilePath)
-> (FilePath -> Maybe FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Maybe FilePath
FP.stripPrefix FilePath
"./" -> FilePath
fp)
| FilePath -> Bool
Turtle.absolute FilePath
fp
= String -> Either String Path
forall a b. a -> Either a b
Left String
"expected include-relative path"
| FilePath -> Maybe Text
Turtle.extension FilePath
fp Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"proto"
= String -> Either String Path
forall a b. a -> Either a b
Left String
"expected .proto suffix"
| Bool
otherwise
= case FilePath -> FilePath -> Maybe FilePath
FP.stripPrefix FilePath
"../" FilePath
fp of
Just{} -> String -> Either String Path
forall a b. a -> Either a b
Left String
"expected include-relative path, but the path started with ../"
Maybe FilePath
Nothing
| Text -> Text -> Bool
T.isInfixOf Text
".." (Text -> Bool) -> (FilePath -> Text) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format Text (FilePath -> Text) -> FilePath -> Text
forall r. Format Text r -> r
Turtle.format Format Text (FilePath -> Text)
forall r. Format r (FilePath -> r)
F.fp (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FP.collapse (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath
fp
-> String -> Either String Path
forall a b. a -> Either a b
Left String
"path contained unexpected .. after canonicalization, please use form x.y.z.proto"
| Bool
otherwise
-> Either String Path
-> (NonEmpty String -> Either String Path)
-> Maybe (NonEmpty String)
-> Either String Path
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Path
forall a b. a -> Either a b
Left String
"empty path after canonicalization") (Path -> Either String Path
forall a b. b -> Either a b
Right (Path -> Either String Path)
-> (NonEmpty String -> Path)
-> NonEmpty String
-> Either String Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> Path
Path)
(Maybe (NonEmpty String) -> Either String Path)
-> (FilePath -> Maybe (NonEmpty String))
-> FilePath
-> Either String Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
([String] -> Maybe (NonEmpty String))
-> (FilePath -> [String]) -> FilePath -> Maybe (NonEmpty String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
([String] -> [String])
-> (FilePath -> [String]) -> FilePath -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Text Text Char Char -> (Char -> Char) -> Text -> Text
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Text Text Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toUpper)
([Text] -> [String])
-> (FilePath -> [Text]) -> FilePath -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> Text -> [Text]
T.splitOn Text
".")
([Text] -> [Text]) -> (FilePath -> [Text]) -> FilePath -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split Char -> Bool
isPathSeparator
(Text -> [Text]) -> (FilePath -> Text) -> FilePath -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format Text (FilePath -> Text) -> FilePath -> Text
forall r. Format Text r -> r
Turtle.format Format Text (FilePath -> Text)
forall r. Format r (FilePath -> r)
F.fp
(FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FP.collapse
(FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
Turtle.dropExtension
(FilePath -> Either String Path) -> FilePath -> Either String Path
forall a b. (a -> b) -> a -> b
$ FilePath
fp
importProto :: (MonadIO m, MonadError CompileError m)
=> [FilePath] -> FilePath -> FilePath -> m DotProto
importProto :: [FilePath] -> FilePath -> FilePath -> m DotProto
importProto [FilePath]
paths FilePath
toplevelProto FilePath
protoFP =
[FilePath] -> FilePath -> m FindProtoResult
forall (m :: * -> *).
MonadIO m =>
[FilePath] -> FilePath -> m FindProtoResult
findProto [FilePath]
paths FilePath
protoFP m FindProtoResult -> (FindProtoResult -> m DotProto) -> m DotProto
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left String
e
-> Text -> m DotProto
forall (m :: * -> *) a. MonadIO m => Text -> m a
dieLines (FilePath -> String -> Text
badModulePathErrorMsg FilePath
protoFP String
e)
Right Maybe (Path, FilePath)
Nothing
| FilePath
toplevelProto FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
protoFP
-> Text -> m DotProto
forall (m :: * -> *) a. MonadIO m => Text -> m a
dieLines ([FilePath] -> FilePath -> Text
toplevelNotFoundErrorMsg [FilePath]
paths FilePath
toplevelProto)
| Bool
otherwise
-> Text -> m DotProto
forall (m :: * -> *) a. MonadIO m => Text -> m a
dieLines ([FilePath] -> FilePath -> FilePath -> Text
importNotFoundErrorMsg [FilePath]
paths FilePath
toplevelProto FilePath
protoFP)
Right (Just (Path
mp, FilePath
fp))
-> Either CompileError DotProto -> m DotProto
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either CompileError DotProto -> m DotProto)
-> (Either ParseError DotProto -> Either CompileError DotProto)
-> Either ParseError DotProto
-> m DotProto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseError -> CompileError)
-> Either ParseError DotProto -> Either CompileError DotProto
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseError -> CompileError
CompileParseError (Either ParseError DotProto -> m DotProto)
-> m (Either ParseError DotProto) -> m DotProto
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Path -> FilePath -> m (Either ParseError DotProto)
forall (m :: * -> *).
MonadIO m =>
Path -> FilePath -> m (Either ParseError DotProto)
parseProtoFile Path
mp FilePath
fp
type FindProtoResult = Either String (Maybe (Path, FilePath))
findProto :: MonadIO m => [FilePath] -> FilePath -> m FindProtoResult
findProto :: [FilePath] -> FilePath -> m FindProtoResult
findProto [FilePath]
searchPaths FilePath
protoFP
| FilePath -> Bool
Turtle.absolute FilePath
protoFP = Text -> m FindProtoResult
forall (m :: * -> *) a. MonadIO m => Text -> m a
dieLines Text
absolutePathErrorMsg
| Bool
otherwise = Either String Path
-> (Path -> m (Maybe (Path, FilePath))) -> m FindProtoResult
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (FilePath -> Either String Path
toModulePath FilePath
protoFP) ((Path -> m (Maybe (Path, FilePath))) -> m FindProtoResult)
-> (Path -> m (Maybe (Path, FilePath))) -> m FindProtoResult
forall a b. (a -> b) -> a -> b
$ \Path
mp ->
(Shell (Path, FilePath)
-> Fold (Path, FilePath) (Maybe (Path, FilePath))
-> m (Maybe (Path, FilePath)))
-> Fold (Path, FilePath) (Maybe (Path, FilePath))
-> Shell (Path, FilePath)
-> m (Maybe (Path, FilePath))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Shell (Path, FilePath)
-> Fold (Path, FilePath) (Maybe (Path, FilePath))
-> m (Maybe (Path, FilePath))
forall (io :: * -> *) a b.
MonadIO io =>
Shell a -> Fold a b -> io b
Turtle.fold Fold (Path, FilePath) (Maybe (Path, FilePath))
forall a. Fold a (Maybe a)
FL.head (Shell (Path, FilePath) -> m (Maybe (Path, FilePath)))
-> Shell (Path, FilePath) -> m (Maybe (Path, FilePath))
forall a b. (a -> b) -> a -> b
$ do
FilePath
sp <- [FilePath] -> Shell FilePath
forall (f :: * -> *) a. Foldable f => f a -> Shell a
Turtle.select [FilePath]
searchPaths
let fp :: FilePath
fp = FilePath
sp FilePath -> FilePath -> FilePath
</> FilePath
protoFP
Bool
True <- FilePath -> Shell Bool
forall (io :: * -> *). MonadIO io => FilePath -> io Bool
Turtle.testfile FilePath
fp
(Path, FilePath) -> Shell (Path, FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path
mp, FilePath
fp)
badModulePathErrorMsg :: FilePath -> String -> T.Text
badModulePathErrorMsg :: FilePath -> String -> Text
badModulePathErrorMsg (Format Text (FilePath -> Text) -> FilePath -> Text
forall r. Format Text r -> r
Turtle.format Format Text (FilePath -> Text)
forall r. Format r (FilePath -> r)
F.fp -> Text
fp) (String -> Text
T.pack -> Text
rsn) =
[Neat.text|
Error: failed when computing the "module path" for "${fp}": ${rsn}
Please ensure that the provided path to a .proto file is specified as
relative to some --includeDir path and that it has the .proto suffix.
|]
importNotFoundErrorMsg :: [FilePath] -> FilePath -> FilePath -> T.Text
importNotFoundErrorMsg :: [FilePath] -> FilePath -> FilePath -> Text
importNotFoundErrorMsg [FilePath]
paths FilePath
toplevelProto FilePath
protoFP =
[Neat.text|
Error: while processing include statements in "${toplevelProtoText}", failed
to find the imported file "${protoFPText}", after looking in the following
locations (controlled via the --includeDir switch(es)):
$pathsText
|]
where
pathsText :: Text
pathsText = [Text] -> Text
T.unlines (Format Text (FilePath -> Text) -> FilePath -> Text
forall r. Format Text r -> r
Turtle.format (Format (FilePath -> Text) (FilePath -> Text)
" "Format (FilePath -> Text) (FilePath -> Text)
-> Format Text (FilePath -> Text) -> Format Text (FilePath -> Text)
forall b c a. Format b c -> Format a b -> Format a c
%Format Text (FilePath -> Text)
forall r. Format r (FilePath -> r)
F.fp) (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
</> FilePath
protoFP) (FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
paths)
toplevelProtoText :: Text
toplevelProtoText = Format Text (FilePath -> Text) -> FilePath -> Text
forall r. Format Text r -> r
Turtle.format Format Text (FilePath -> Text)
forall r. Format r (FilePath -> r)
F.fp FilePath
toplevelProto
protoFPText :: Text
protoFPText = Format Text (FilePath -> Text) -> FilePath -> Text
forall r. Format Text r -> r
Turtle.format Format Text (FilePath -> Text)
forall r. Format r (FilePath -> r)
F.fp FilePath
protoFP
toplevelNotFoundErrorMsg :: [FilePath] -> FilePath -> T.Text
toplevelNotFoundErrorMsg :: [FilePath] -> FilePath -> Text
toplevelNotFoundErrorMsg [FilePath]
searchPaths FilePath
toplevelProto =
[Neat.text|
Error: failed to find file "${toplevelProtoText}", after looking in
the following locations (controlled via the --includeDir switch(es)):
$searchPathsText
|]
where
searchPathsText :: Text
searchPathsText = [Text] -> Text
T.unlines (Format Text (FilePath -> Text) -> FilePath -> Text
forall r. Format Text r -> r
Turtle.format (Format (FilePath -> Text) (FilePath -> Text)
" "Format (FilePath -> Text) (FilePath -> Text)
-> Format Text (FilePath -> Text) -> Format Text (FilePath -> Text)
forall b c a. Format b c -> Format a b -> Format a c
%Format Text (FilePath -> Text)
forall r. Format r (FilePath -> r)
F.fp) (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
</> FilePath
toplevelProto) (FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
searchPaths)
toplevelProtoText :: Text
toplevelProtoText = Format Text (FilePath -> Text) -> FilePath -> Text
forall r. Format Text r -> r
Turtle.format Format Text (FilePath -> Text)
forall r. Format r (FilePath -> r)
F.fp FilePath
toplevelProto
absolutePathErrorMsg :: T.Text
absolutePathErrorMsg :: Text
absolutePathErrorMsg =
[Neat.text|
Error: Absolute paths to .proto files, whether on the command line or
in include directives, are not currently permitted; rather, all .proto
filenames must be relative to the current directory, or relative to some
search path specified via --includeDir.
This is because we currently use the include-relative name to decide
the structure of the Haskell module tree that we emit during code
generation.
|]
type TypeContext = M.Map DotProtoIdentifier DotProtoTypeInfo
data DotProtoTypeInfo = DotProtoTypeInfo
{ DotProtoTypeInfo -> DotProtoPackageSpec
dotProtoTypeInfoPackage :: DotProtoPackageSpec
, DotProtoTypeInfo -> DotProtoIdentifier
dotProtoTypeInfoParent :: DotProtoIdentifier
, DotProtoTypeInfo -> TypeContext
dotProtoTypeChildContext :: TypeContext
, DotProtoTypeInfo -> DotProtoKind
dotProtoTypeInfoKind :: DotProtoKind
, DotProtoTypeInfo -> Path
dotProtoTypeInfoModulePath :: Path
} deriving Int -> DotProtoTypeInfo -> ShowS
[DotProtoTypeInfo] -> ShowS
DotProtoTypeInfo -> String
(Int -> DotProtoTypeInfo -> ShowS)
-> (DotProtoTypeInfo -> String)
-> ([DotProtoTypeInfo] -> ShowS)
-> Show DotProtoTypeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DotProtoTypeInfo] -> ShowS
$cshowList :: [DotProtoTypeInfo] -> ShowS
show :: DotProtoTypeInfo -> String
$cshow :: DotProtoTypeInfo -> String
showsPrec :: Int -> DotProtoTypeInfo -> ShowS
$cshowsPrec :: Int -> DotProtoTypeInfo -> ShowS
Show
tiParent :: Lens' DotProtoTypeInfo DotProtoIdentifier
tiParent :: (DotProtoIdentifier -> f DotProtoIdentifier)
-> DotProtoTypeInfo -> f DotProtoTypeInfo
tiParent = (DotProtoTypeInfo -> DotProtoIdentifier)
-> (DotProtoTypeInfo -> DotProtoIdentifier -> DotProtoTypeInfo)
-> Lens
DotProtoTypeInfo
DotProtoTypeInfo
DotProtoIdentifier
DotProtoIdentifier
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DotProtoTypeInfo -> DotProtoIdentifier
dotProtoTypeInfoParent (\DotProtoTypeInfo
d DotProtoIdentifier
p -> DotProtoTypeInfo
d{ dotProtoTypeInfoParent :: DotProtoIdentifier
dotProtoTypeInfoParent = DotProtoIdentifier
p })
data DotProtoKind = DotProtoKindEnum
| DotProtoKindMessage
deriving (Int -> DotProtoKind -> ShowS
[DotProtoKind] -> ShowS
DotProtoKind -> String
(Int -> DotProtoKind -> ShowS)
-> (DotProtoKind -> String)
-> ([DotProtoKind] -> ShowS)
-> Show DotProtoKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DotProtoKind] -> ShowS
$cshowList :: [DotProtoKind] -> ShowS
show :: DotProtoKind -> String
$cshow :: DotProtoKind -> String
showsPrec :: Int -> DotProtoKind -> ShowS
$cshowsPrec :: Int -> DotProtoKind -> ShowS
Show, DotProtoKind -> DotProtoKind -> Bool
(DotProtoKind -> DotProtoKind -> Bool)
-> (DotProtoKind -> DotProtoKind -> Bool) -> Eq DotProtoKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DotProtoKind -> DotProtoKind -> Bool
$c/= :: DotProtoKind -> DotProtoKind -> Bool
== :: DotProtoKind -> DotProtoKind -> Bool
$c== :: DotProtoKind -> DotProtoKind -> Bool
Eq, Eq DotProtoKind
Eq DotProtoKind
-> (DotProtoKind -> DotProtoKind -> Ordering)
-> (DotProtoKind -> DotProtoKind -> Bool)
-> (DotProtoKind -> DotProtoKind -> Bool)
-> (DotProtoKind -> DotProtoKind -> Bool)
-> (DotProtoKind -> DotProtoKind -> Bool)
-> (DotProtoKind -> DotProtoKind -> DotProtoKind)
-> (DotProtoKind -> DotProtoKind -> DotProtoKind)
-> Ord DotProtoKind
DotProtoKind -> DotProtoKind -> Bool
DotProtoKind -> DotProtoKind -> Ordering
DotProtoKind -> DotProtoKind -> DotProtoKind
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DotProtoKind -> DotProtoKind -> DotProtoKind
$cmin :: DotProtoKind -> DotProtoKind -> DotProtoKind
max :: DotProtoKind -> DotProtoKind -> DotProtoKind
$cmax :: DotProtoKind -> DotProtoKind -> DotProtoKind
>= :: DotProtoKind -> DotProtoKind -> Bool
$c>= :: DotProtoKind -> DotProtoKind -> Bool
> :: DotProtoKind -> DotProtoKind -> Bool
$c> :: DotProtoKind -> DotProtoKind -> Bool
<= :: DotProtoKind -> DotProtoKind -> Bool
$c<= :: DotProtoKind -> DotProtoKind -> Bool
< :: DotProtoKind -> DotProtoKind -> Bool
$c< :: DotProtoKind -> DotProtoKind -> Bool
compare :: DotProtoKind -> DotProtoKind -> Ordering
$ccompare :: DotProtoKind -> DotProtoKind -> Ordering
$cp1Ord :: Eq DotProtoKind
Ord, Int -> DotProtoKind
DotProtoKind -> Int
DotProtoKind -> [DotProtoKind]
DotProtoKind -> DotProtoKind
DotProtoKind -> DotProtoKind -> [DotProtoKind]
DotProtoKind -> DotProtoKind -> DotProtoKind -> [DotProtoKind]
(DotProtoKind -> DotProtoKind)
-> (DotProtoKind -> DotProtoKind)
-> (Int -> DotProtoKind)
-> (DotProtoKind -> Int)
-> (DotProtoKind -> [DotProtoKind])
-> (DotProtoKind -> DotProtoKind -> [DotProtoKind])
-> (DotProtoKind -> DotProtoKind -> [DotProtoKind])
-> (DotProtoKind -> DotProtoKind -> DotProtoKind -> [DotProtoKind])
-> Enum DotProtoKind
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: DotProtoKind -> DotProtoKind -> DotProtoKind -> [DotProtoKind]
$cenumFromThenTo :: DotProtoKind -> DotProtoKind -> DotProtoKind -> [DotProtoKind]
enumFromTo :: DotProtoKind -> DotProtoKind -> [DotProtoKind]
$cenumFromTo :: DotProtoKind -> DotProtoKind -> [DotProtoKind]
enumFromThen :: DotProtoKind -> DotProtoKind -> [DotProtoKind]
$cenumFromThen :: DotProtoKind -> DotProtoKind -> [DotProtoKind]
enumFrom :: DotProtoKind -> [DotProtoKind]
$cenumFrom :: DotProtoKind -> [DotProtoKind]
fromEnum :: DotProtoKind -> Int
$cfromEnum :: DotProtoKind -> Int
toEnum :: Int -> DotProtoKind
$ctoEnum :: Int -> DotProtoKind
pred :: DotProtoKind -> DotProtoKind
$cpred :: DotProtoKind -> DotProtoKind
succ :: DotProtoKind -> DotProtoKind
$csucc :: DotProtoKind -> DotProtoKind
Enum, DotProtoKind
DotProtoKind -> DotProtoKind -> Bounded DotProtoKind
forall a. a -> a -> Bounded a
maxBound :: DotProtoKind
$cmaxBound :: DotProtoKind
minBound :: DotProtoKind
$cminBound :: DotProtoKind
Bounded)
dotProtoTypeContext :: MonadError CompileError m => DotProto -> m TypeContext
dotProtoTypeContext :: DotProto -> m TypeContext
dotProtoTypeContext DotProto{[DotProtoDefinition]
[DotProtoOption]
[DotProtoImport]
DotProtoMeta
DotProtoPackageSpec
protoMeta :: DotProto -> DotProtoMeta
protoDefinitions :: DotProto -> [DotProtoDefinition]
protoPackage :: DotProto -> DotProtoPackageSpec
protoOptions :: DotProto -> [DotProtoOption]
protoImports :: DotProto -> [DotProtoImport]
protoMeta :: DotProtoMeta
protoDefinitions :: [DotProtoDefinition]
protoPackage :: DotProtoPackageSpec
protoOptions :: [DotProtoOption]
protoImports :: [DotProtoImport]
..} =
(DotProtoDefinition -> m TypeContext)
-> [DotProtoDefinition] -> m TypeContext
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM (Path -> DotProtoDefinition -> m TypeContext
forall (m :: * -> *).
MonadError CompileError m =>
Path -> DotProtoDefinition -> m TypeContext
definitionTypeContext (DotProtoMeta -> Path
metaModulePath DotProtoMeta
protoMeta)) [DotProtoDefinition]
protoDefinitions
definitionTypeContext :: MonadError CompileError m
=> Path -> DotProtoDefinition -> m TypeContext
definitionTypeContext :: Path -> DotProtoDefinition -> m TypeContext
definitionTypeContext Path
modulePath (DotProtoMessage String
_ DotProtoIdentifier
msgIdent [DotProtoMessagePart]
parts) = do
let updateParent :: DotProtoTypeInfo -> m DotProtoTypeInfo
updateParent = (DotProtoIdentifier -> m DotProtoIdentifier)
-> DotProtoTypeInfo -> m DotProtoTypeInfo
Lens
DotProtoTypeInfo
DotProtoTypeInfo
DotProtoIdentifier
DotProtoIdentifier
tiParent (DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
msgIdent)
TypeContext
childTyContext <- GettingM TypeContext [DotProtoMessagePart] DotProtoDefinition
-> (DotProtoDefinition -> m TypeContext)
-> [DotProtoMessagePart]
-> m TypeContext
forall (m :: * -> *) r s a.
(Applicative m, Monoid r) =>
GettingM r s a -> (a -> m r) -> s -> m r
foldMapOfM ((DotProtoMessagePart
-> Compose m (Const TypeContext) DotProtoMessagePart)
-> [DotProtoMessagePart]
-> Compose m (Const TypeContext) [DotProtoMessagePart]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((DotProtoMessagePart
-> Compose m (Const TypeContext) DotProtoMessagePart)
-> [DotProtoMessagePart]
-> Compose m (Const TypeContext) [DotProtoMessagePart])
-> ((DotProtoDefinition
-> Compose m (Const TypeContext) DotProtoDefinition)
-> DotProtoMessagePart
-> Compose m (Const TypeContext) DotProtoMessagePart)
-> (DotProtoDefinition
-> Compose m (Const TypeContext) DotProtoDefinition)
-> [DotProtoMessagePart]
-> Compose m (Const TypeContext) [DotProtoMessagePart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DotProtoDefinition
-> Compose m (Const TypeContext) DotProtoDefinition)
-> DotProtoMessagePart
-> Compose m (Const TypeContext) DotProtoMessagePart
Prism' DotProtoMessagePart DotProtoDefinition
_DotProtoMessageDefinition)
(Path -> DotProtoDefinition -> m TypeContext
forall (m :: * -> *).
MonadError CompileError m =>
Path -> DotProtoDefinition -> m TypeContext
definitionTypeContext Path
modulePath (DotProtoDefinition -> m TypeContext)
-> (TypeContext -> m TypeContext)
-> DotProtoDefinition
-> m TypeContext
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (DotProtoTypeInfo -> m DotProtoTypeInfo)
-> TypeContext -> m TypeContext
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DotProtoTypeInfo -> m DotProtoTypeInfo
updateParent)
[DotProtoMessagePart]
parts
TypeContext
qualifiedChildTyContext <- (DotProtoIdentifier -> m DotProtoIdentifier)
-> TypeContext -> m TypeContext
forall (m :: * -> *) k2 k1 a.
(Monad m, Ord k2) =>
(k1 -> m k2) -> Map k1 a -> m (Map k2 a)
mapKeysM (DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
msgIdent) TypeContext
childTyContext
let tyInfo :: DotProtoTypeInfo
tyInfo = DotProtoTypeInfo :: DotProtoPackageSpec
-> DotProtoIdentifier
-> TypeContext
-> DotProtoKind
-> Path
-> DotProtoTypeInfo
DotProtoTypeInfo { dotProtoTypeInfoPackage :: DotProtoPackageSpec
dotProtoTypeInfoPackage = DotProtoPackageSpec
DotProtoNoPackage
, dotProtoTypeInfoParent :: DotProtoIdentifier
dotProtoTypeInfoParent = DotProtoIdentifier
Anonymous
, dotProtoTypeChildContext :: TypeContext
dotProtoTypeChildContext = TypeContext
childTyContext
, dotProtoTypeInfoKind :: DotProtoKind
dotProtoTypeInfoKind = DotProtoKind
DotProtoKindMessage
, dotProtoTypeInfoModulePath :: Path
dotProtoTypeInfoModulePath = Path
modulePath
}
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
$ DotProtoIdentifier -> DotProtoTypeInfo -> TypeContext
forall k a. k -> a -> Map k a
M.singleton DotProtoIdentifier
msgIdent DotProtoTypeInfo
tyInfo TypeContext -> TypeContext -> TypeContext
forall a. Semigroup a => a -> a -> a
<> TypeContext
qualifiedChildTyContext
definitionTypeContext Path
modulePath (DotProtoEnum String
_ DotProtoIdentifier
enumIdent [DotProtoEnumPart]
_) = do
let tyInfo :: DotProtoTypeInfo
tyInfo = DotProtoTypeInfo :: DotProtoPackageSpec
-> DotProtoIdentifier
-> TypeContext
-> DotProtoKind
-> Path
-> DotProtoTypeInfo
DotProtoTypeInfo { dotProtoTypeInfoPackage :: DotProtoPackageSpec
dotProtoTypeInfoPackage = DotProtoPackageSpec
DotProtoNoPackage
, dotProtoTypeInfoParent :: DotProtoIdentifier
dotProtoTypeInfoParent = DotProtoIdentifier
Anonymous
, dotProtoTypeChildContext :: TypeContext
dotProtoTypeChildContext = TypeContext
forall a. Monoid a => a
mempty
, dotProtoTypeInfoKind :: DotProtoKind
dotProtoTypeInfoKind = DotProtoKind
DotProtoKindEnum
, dotProtoTypeInfoModulePath :: Path
dotProtoTypeInfoModulePath = Path
modulePath
}
TypeContext -> m TypeContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DotProtoIdentifier -> DotProtoTypeInfo -> TypeContext
forall k a. k -> a -> Map k a
M.singleton DotProtoIdentifier
enumIdent DotProtoTypeInfo
tyInfo)
definitionTypeContext Path
_ DotProtoDefinition
_ = TypeContext -> m TypeContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeContext
forall a. Monoid a => a
mempty
isMessage :: TypeContext -> DotProtoIdentifier -> Bool
isMessage :: TypeContext -> DotProtoIdentifier -> Bool
isMessage TypeContext
ctxt DotProtoIdentifier
n = DotProtoKind -> Maybe DotProtoKind
forall a. a -> Maybe a
Just DotProtoKind
DotProtoKindMessage Maybe DotProtoKind -> Maybe DotProtoKind -> Bool
forall a. Eq a => a -> a -> Bool
== (DotProtoTypeInfo -> DotProtoKind
dotProtoTypeInfoKind (DotProtoTypeInfo -> DotProtoKind)
-> Maybe DotProtoTypeInfo -> Maybe DotProtoKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoIdentifier -> TypeContext -> Maybe DotProtoTypeInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup DotProtoIdentifier
n TypeContext
ctxt)
boolOption :: String -> [DotProtoOption] -> Maybe Bool
boolOption :: String -> [DotProtoOption] -> Maybe Bool
boolOption String
desired [DotProtoOption]
opts =
case (DotProtoOption -> Bool)
-> [DotProtoOption] -> Maybe DotProtoOption
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(DotProtoOption DotProtoIdentifier
name DotProtoValue
_) -> DotProtoIdentifier
name DotProtoIdentifier -> DotProtoIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== String -> DotProtoIdentifier
Single String
desired) [DotProtoOption]
opts of
Just (DotProtoOption DotProtoIdentifier
_ (BoolLit Bool
x)) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x
Maybe DotProtoOption
_ -> Maybe Bool
forall a. Maybe a
Nothing
isPacked :: [DotProtoOption] -> Bool
isPacked :: [DotProtoOption] -> Bool
isPacked = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool)
-> ([DotProtoOption] -> Maybe Bool) -> [DotProtoOption] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [DotProtoOption] -> Maybe Bool
boolOption String
"packed"
isUnpacked :: [DotProtoOption] -> Bool
isUnpacked :: [DotProtoOption] -> Bool
isUnpacked = Bool -> (Bool -> Bool) -> Maybe Bool -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Bool -> Bool
not (Maybe Bool -> Bool)
-> ([DotProtoOption] -> Maybe Bool) -> [DotProtoOption] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [DotProtoOption] -> Maybe Bool
boolOption String
"packed"
isPackable :: TypeContext -> DotProtoPrimType -> Bool
isPackable :: TypeContext -> DotProtoPrimType -> Bool
isPackable TypeContext
_ DotProtoPrimType
Bytes = Bool
False
isPackable TypeContext
_ DotProtoPrimType
String = Bool
False
isPackable TypeContext
_ DotProtoPrimType
Int32 = Bool
True
isPackable TypeContext
_ DotProtoPrimType
Int64 = Bool
True
isPackable TypeContext
_ DotProtoPrimType
SInt32 = Bool
True
isPackable TypeContext
_ DotProtoPrimType
SInt64 = Bool
True
isPackable TypeContext
_ DotProtoPrimType
UInt32 = Bool
True
isPackable TypeContext
_ DotProtoPrimType
UInt64 = Bool
True
isPackable TypeContext
_ DotProtoPrimType
Fixed32 = Bool
True
isPackable TypeContext
_ DotProtoPrimType
Fixed64 = Bool
True
isPackable TypeContext
_ DotProtoPrimType
SFixed32 = Bool
True
isPackable TypeContext
_ DotProtoPrimType
SFixed64 = Bool
True
isPackable TypeContext
_ DotProtoPrimType
Bool = Bool
True
isPackable TypeContext
_ DotProtoPrimType
Float = Bool
True
isPackable TypeContext
_ DotProtoPrimType
Double = Bool
True
isPackable TypeContext
ctxt (Named DotProtoIdentifier
tyName) =
DotProtoKind -> Maybe DotProtoKind
forall a. a -> Maybe a
Just DotProtoKind
DotProtoKindEnum Maybe DotProtoKind -> Maybe DotProtoKind -> Bool
forall a. Eq a => a -> a -> Bool
== (DotProtoTypeInfo -> DotProtoKind
dotProtoTypeInfoKind (DotProtoTypeInfo -> DotProtoKind)
-> Maybe DotProtoTypeInfo -> Maybe DotProtoKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotProtoIdentifier -> TypeContext -> Maybe DotProtoTypeInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup DotProtoIdentifier
tyName TypeContext
ctxt)
isMap :: DotProtoType -> Bool
isMap :: DotProtoType -> Bool
isMap Map{} = Bool
True
isMap DotProtoType
_ = Bool
False
concatDotProtoIdentifier ::
MonadError CompileError m =>
DotProtoIdentifier ->
DotProtoIdentifier ->
m DotProtoIdentifier
concatDotProtoIdentifier :: DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
i1 DotProtoIdentifier
i2 = case (DotProtoIdentifier
i1, DotProtoIdentifier
i2) of
(Qualified{} , DotProtoIdentifier
_ ) -> String -> m DotProtoIdentifier
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError String
"concatDotProtoIdentifier: Qualified"
(DotProtoIdentifier
_ , Qualified{} ) -> String -> m DotProtoIdentifier
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError String
"concatDotProtoIdentifier Qualified"
(DotProtoIdentifier
Anonymous , DotProtoIdentifier
Anonymous ) -> DotProtoIdentifier -> m DotProtoIdentifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure DotProtoIdentifier
Anonymous
(DotProtoIdentifier
Anonymous , DotProtoIdentifier
b ) -> DotProtoIdentifier -> m DotProtoIdentifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure DotProtoIdentifier
b
(DotProtoIdentifier
a , DotProtoIdentifier
Anonymous ) -> DotProtoIdentifier -> m DotProtoIdentifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure DotProtoIdentifier
a
(Single String
a , DotProtoIdentifier
b ) -> DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier (Path -> DotProtoIdentifier
Dots (NonEmpty String -> Path
Path (String -> NonEmpty String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
a))) DotProtoIdentifier
b
(DotProtoIdentifier
a , Single String
b ) -> DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
a (Path -> DotProtoIdentifier
Dots (NonEmpty String -> Path
Path (String -> NonEmpty String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
b)))
(Dots (Path NonEmpty String
a), Dots (Path NonEmpty String
b)) -> DotProtoIdentifier -> m DotProtoIdentifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path -> DotProtoIdentifier
Dots (NonEmpty String -> Path
Path (NonEmpty String
a NonEmpty String -> NonEmpty String -> NonEmpty String
forall a. Semigroup a => a -> a -> a
<> NonEmpty String
b)))
toPascalCase :: String -> String
toPascalCase :: ShowS
toPascalCase String
xs = (Either String String -> String)
-> [Either String String] -> String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Either String String -> String
forall a. (Eq a, IsString a) => Either String a -> String
go ((Char -> Bool) -> String -> [Either String String]
forall a. (a -> Bool) -> [a] -> [Either [a] [a]]
segmentBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') String
xs)
where
go :: Either String a -> String
go (Left String
seg) = ShowS
toUpperFirst String
seg
go (Right a
seg)
| a
seg a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"__" = String
"_"
| Bool
otherwise = String
""
toCamelCase :: String -> String
toCamelCase :: ShowS
toCamelCase String
xs =
case ShowS
toPascalCase String
xs of
String
"" -> String
""
Char
x : String
xs' -> Char -> Char
toLower Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs'
toUpperFirst :: String -> String
toUpperFirst :: ShowS
toUpperFirst String
"" = String
""
toUpperFirst (Char
x : String
xs) = Char -> Char
toUpper Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
segmentBy :: (a -> Bool) -> [a] -> [Either [a] [a]]
segmentBy :: (a -> Bool) -> [a] -> [Either [a] [a]]
segmentBy a -> Bool
p [a]
xs = case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span a -> Bool
p [a]
xs of
([], []) -> []
([a]
ys, []) -> [[a] -> Either [a] [a]
forall a b. b -> Either a b
Right [a]
ys]
([], [a]
ys) -> [a] -> Either [a] [a]
forall a b. a -> Either a b
Left [a]
seg Either [a] [a] -> [Either [a] [a]] -> [Either [a] [a]]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [Either [a] [a]]
forall a. (a -> Bool) -> [a] -> [Either [a] [a]]
segmentBy a -> Bool
p [a]
ys'
where
([a]
seg, [a]
ys') = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
p [a]
ys
([a]
xs', [a]
ys) -> [a] -> Either [a] [a]
forall a b. b -> Either a b
Right [a]
xs' Either [a] [a] -> [Either [a] [a]] -> [Either [a] [a]]
forall a. a -> [a] -> [a]
: [a] -> Either [a] [a]
forall a b. a -> Either a b
Left [a]
seg Either [a] [a] -> [Either [a] [a]] -> [Either [a] [a]]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [Either [a] [a]]
forall a. (a -> Bool) -> [a] -> [Either [a] [a]]
segmentBy a -> Bool
p [a]
ys'
where
([a]
seg, [a]
ys') = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
p [a]
ys
suffixBy :: forall a. (a -> Bool) -> [a] -> Either [a] ([a], [a])
suffixBy :: (a -> Bool) -> [a] -> Either [a] ([a], [a])
suffixBy a -> Bool
p [a]
xs' = do
([a]
pref, [a]
suf) <- (a -> Either [a] ([a], [a]) -> Either [a] ([a], [a]))
-> Either [a] ([a], [a]) -> [a] -> Either [a] ([a], [a])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> Either [a] ([a], [a]) -> Either [a] ([a], [a])
go ([a] -> Either [a] ([a], [a])
forall a b. a -> Either a b
Left []) [a]
xs'
if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
suf
then [a] -> Either [a] ([a], [a])
forall a b. a -> Either a b
Left [a]
pref
else ([a], [a]) -> Either [a] ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
pref, [a]
suf)
where
go :: a -> Either [a] ([a], [a]) -> Either [a] ([a], [a])
go :: a -> Either [a] ([a], [a]) -> Either [a] ([a], [a])
go a
x (Right ([a]
xs, [a]
suf)) = ([a], [a]) -> Either [a] ([a], [a])
forall a b. b -> Either a b
Right (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs, [a]
suf)
go a
x (Left [a]
xs)
| a -> Bool
p a
x = [a] -> Either [a] ([a], [a])
forall a b. a -> Either a b
Left (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)
| Bool
otherwise = ([a], [a]) -> Either [a] ([a], [a])
forall a b. b -> Either a b
Right ([a
x], [a]
xs)
typeLikeName :: MonadError CompileError m => String -> m String
typeLikeName :: String -> m String
typeLikeName String
"" = String -> m String
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
invalidTypeNameError String
"<empty name>"
typeLikeName s :: String
s@(Char
x : String
xs)
| Char -> Bool
isAlpha Char
x = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ case (Char -> Bool) -> String -> Either String (String, String)
forall a. (a -> Bool) -> [a] -> Either [a] ([a], [a])
suffixBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') String
s of
Left String
xs' -> ShowS
invalidToCamelCase ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
toPascalCase String
xs'
Right (String
xs', String
suf) -> ShowS
invalidToCamelCase ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
toPascalCase String
xs' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
suf
| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ case (Char -> Bool) -> String -> Either String (String, String)
forall a. (a -> Bool) -> [a] -> Either [a] ([a], [a])
suffixBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') String
xs of
Left String
xs' -> ShowS
invalidToCamelCase ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Char
'X' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
toPascalCase String
xs'
Right (String
xs', String
suf) -> ShowS
invalidToCamelCase ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Char
'X' Char -> ShowS
forall a. a -> [a] -> [a]
: (ShowS
toPascalCase String
xs' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
suf)
| Bool
otherwise = String -> m String
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
invalidTypeNameError String
s
where
invalidToCamelCase :: ShowS
invalidToCamelCase String
a =
case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isValidNameChar String
a of
(String
"", String
"") -> String
""
(String
"", String
cs) -> ShowS
invalidToCamelCase ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isValidNameChar) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
cs
(Char
b : String
bs, String
cs) -> Char -> Char
toUpper Char
b Char -> ShowS
forall a. a -> [a] -> [a]
: String
bs String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
invalidToCamelCase String
cs
isValidNameChar :: Char -> Bool
isValidNameChar Char
ch = Char -> Bool
isAlphaNum Char
ch Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
fieldLikeName :: String -> String
fieldLikeName :: ShowS
fieldLikeName String
"" = String
""
fieldLikeName (Char
x : String
xs)
| Char -> Bool
isUpper Char
x = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suffix
| Bool
otherwise = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
where (String
prefix, String
suffix) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper (Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs)
prefixedEnumFieldName :: String -> String -> String
prefixedEnumFieldName :: String -> ShowS
prefixedEnumFieldName String
enumName String
enumItem = String
enumName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
enumItem
prefixedConName :: MonadError CompileError m => String -> String -> m String
prefixedConName :: String -> String -> m String
prefixedConName String
msgName String
conName = do
String
constructor <- String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName String
conName
String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
msgName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
constructor)
prefixedMethodName :: MonadError CompileError m => String -> String -> m String
prefixedMethodName :: String -> String -> m String
prefixedMethodName String
_ String
"" = String -> m String
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
invalidTypeNameError String
"<empty name>"
prefixedMethodName String
serviceName (Char
x : String
xs)
| Char -> Bool
isLower Char
x = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (ShowS
fieldLikeName String
serviceName String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
fieldLikeName (Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs))
| Bool
otherwise = do
String
method <- String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName (Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs)
String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (ShowS
fieldLikeName String
serviceName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
method)
prefixedFieldName :: MonadError CompileError m => String -> String -> m String
prefixedFieldName :: String -> String -> m String
prefixedFieldName String
msgName String
fieldName = do
String
field <- String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName String
fieldName
String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (ShowS
fieldLikeName String
msgName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
field)
dpIdentUnqualName :: MonadError CompileError m => DotProtoIdentifier -> m String
dpIdentUnqualName :: DotProtoIdentifier -> m String
dpIdentUnqualName (Single String
name) = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
name
dpIdentUnqualName (Dots (Path NonEmpty String
names)) = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty String -> String
forall a. NonEmpty a -> a
NE.last NonEmpty String
names)
dpIdentUnqualName (Qualified DotProtoIdentifier
_ DotProtoIdentifier
next) = DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
next
dpIdentUnqualName DotProtoIdentifier
Anonymous = String -> m String
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError String
"dpIdentUnqualName: Anonymous"
dpIdentQualName :: MonadError CompileError m => DotProtoIdentifier -> m String
dpIdentQualName :: DotProtoIdentifier -> m String
dpIdentQualName (Single String
name) = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
name
dpIdentQualName (Dots (Path NonEmpty String
names)) = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
names))
dpIdentQualName (Qualified DotProtoIdentifier
_ DotProtoIdentifier
_) = String -> m String
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError String
"dpIdentQualName: Qualified"
dpIdentQualName DotProtoIdentifier
Anonymous = String -> m String
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError String
"dpIdentQualName: Anonymous"
nestedTypeName :: MonadError CompileError m => DotProtoIdentifier -> String -> m String
nestedTypeName :: DotProtoIdentifier -> String -> m String
nestedTypeName DotProtoIdentifier
Anonymous String
nm = String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName String
nm
nestedTypeName (Single String
parent) String
nm = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" ([String] -> String) -> m [String] -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m String) -> [String] -> m [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName [String
parent, String
nm]
nestedTypeName (Dots (Path NonEmpty String
parents)) String
nm = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
nm]) ([String] -> String) -> m [String] -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m String) -> [String] -> m [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
parents)
nestedTypeName (Qualified {}) String
_ = String -> m String
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError String
"nestedTypeName: Qualified"
qualifiedMessageName :: MonadError CompileError m => DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName :: DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent = DotProtoIdentifier -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> String -> m String
nestedTypeName DotProtoIdentifier
parentIdent (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
msgIdent
qualifiedMessageTypeName :: MonadError CompileError m =>
TypeContext ->
DotProtoIdentifier ->
DotProtoIdentifier ->
m String
qualifiedMessageTypeName :: TypeContext -> DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageTypeName TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent = do
[String]
xs <- DotProtoIdentifier -> [String] -> m [String]
forall (f :: * -> *).
MonadError CompileError f =>
DotProtoIdentifier -> [String] -> f [String]
parents DotProtoIdentifier
parentIdent []
case [String]
xs of
[] -> DotProtoIdentifier -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> String -> m String
nestedTypeName DotProtoIdentifier
parentIdent (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
msgIdent
String
x : [String]
xs' -> DotProtoIdentifier -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> String -> m String
nestedTypeName (Path -> DotProtoIdentifier
Dots (Path -> DotProtoIdentifier)
-> (NonEmpty String -> Path)
-> NonEmpty String
-> DotProtoIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> Path
Path (NonEmpty String -> DotProtoIdentifier)
-> NonEmpty String -> DotProtoIdentifier
forall a b. (a -> b) -> a -> b
$ String
x String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
NE.:| [String]
xs') (String -> m String) -> m String -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
msgIdent
where
parents :: DotProtoIdentifier -> [String] -> f [String]
parents par :: DotProtoIdentifier
par@(Single String
x) [String]
xs =
case DotProtoIdentifier -> TypeContext -> Maybe DotProtoTypeInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup DotProtoIdentifier
par TypeContext
ctxt of
Just (DotProtoTypeInfo { dotProtoTypeInfoParent :: DotProtoTypeInfo -> DotProtoIdentifier
dotProtoTypeInfoParent = DotProtoIdentifier
parentIdent' }) ->
DotProtoIdentifier -> [String] -> f [String]
parents DotProtoIdentifier
parentIdent' ([String] -> f [String]) -> [String] -> f [String]
forall a b. (a -> b) -> a -> b
$ String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs
Maybe DotProtoTypeInfo
Nothing ->
[String] -> f [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> f [String]) -> [String] -> f [String]
forall a b. (a -> b) -> a -> b
$ String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs
parents DotProtoIdentifier
Anonymous [String]
xs =
[String] -> f [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String]
xs
parents DotProtoIdentifier
par [String]
_ =
String -> f [String]
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
internalError (String -> f [String]) -> String -> f [String]
forall a b. (a -> b) -> a -> b
$ String
"qualifiedMessageTypeName: wrong parent " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> DotProtoIdentifier -> String
forall a. Show a => a -> String
show DotProtoIdentifier
par
data QualifiedField = QualifiedField
{ QualifiedField -> FieldName
recordFieldName :: FieldName
, QualifiedField -> FieldInfo
fieldInfo :: FieldInfo
} deriving Int -> QualifiedField -> ShowS
[QualifiedField] -> ShowS
QualifiedField -> String
(Int -> QualifiedField -> ShowS)
-> (QualifiedField -> String)
-> ([QualifiedField] -> ShowS)
-> Show QualifiedField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QualifiedField] -> ShowS
$cshowList :: [QualifiedField] -> ShowS
show :: QualifiedField -> String
$cshow :: QualifiedField -> String
showsPrec :: Int -> QualifiedField -> ShowS
$cshowsPrec :: Int -> QualifiedField -> ShowS
Show
data FieldInfo
= FieldOneOf OneofField
| FieldNormal FieldName FieldNumber DotProtoType [DotProtoOption]
deriving Int -> FieldInfo -> ShowS
[FieldInfo] -> ShowS
FieldInfo -> String
(Int -> FieldInfo -> ShowS)
-> (FieldInfo -> String)
-> ([FieldInfo] -> ShowS)
-> Show FieldInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldInfo] -> ShowS
$cshowList :: [FieldInfo] -> ShowS
show :: FieldInfo -> String
$cshow :: FieldInfo -> String
showsPrec :: Int -> FieldInfo -> ShowS
$cshowsPrec :: Int -> FieldInfo -> ShowS
Show
data OneofField = OneofField
{ OneofField -> String
oneofType :: String
, OneofField -> [OneofSubfield]
subfields :: [OneofSubfield]
} deriving Int -> OneofField -> ShowS
[OneofField] -> ShowS
OneofField -> String
(Int -> OneofField -> ShowS)
-> (OneofField -> String)
-> ([OneofField] -> ShowS)
-> Show OneofField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OneofField] -> ShowS
$cshowList :: [OneofField] -> ShowS
show :: OneofField -> String
$cshow :: OneofField -> String
showsPrec :: Int -> OneofField -> ShowS
$cshowsPrec :: Int -> OneofField -> ShowS
Show
data OneofSubfield = OneofSubfield
{ OneofSubfield -> FieldNumber
subfieldNumber :: FieldNumber
, OneofSubfield -> String
subfieldConsName :: String
, OneofSubfield -> FieldName
subfieldName :: FieldName
, OneofSubfield -> DotProtoType
subfieldType :: DotProtoType
, OneofSubfield -> [DotProtoOption]
subfieldOptions :: [DotProtoOption]
} deriving Int -> OneofSubfield -> ShowS
[OneofSubfield] -> ShowS
OneofSubfield -> String
(Int -> OneofSubfield -> ShowS)
-> (OneofSubfield -> String)
-> ([OneofSubfield] -> ShowS)
-> Show OneofSubfield
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OneofSubfield] -> ShowS
$cshowList :: [OneofSubfield] -> ShowS
show :: OneofSubfield -> String
$cshow :: OneofSubfield -> String
showsPrec :: Int -> OneofSubfield -> ShowS
$cshowsPrec :: Int -> OneofSubfield -> ShowS
Show
getQualifiedFields :: MonadError CompileError m
=> String -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields :: String -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields String
msgName [DotProtoMessagePart]
msgParts = ((DotProtoMessagePart -> m [QualifiedField])
-> [DotProtoMessagePart] -> m [QualifiedField])
-> [DotProtoMessagePart]
-> (DotProtoMessagePart -> m [QualifiedField])
-> m [QualifiedField]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DotProtoMessagePart -> m [QualifiedField])
-> [DotProtoMessagePart] -> m [QualifiedField]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM [DotProtoMessagePart]
msgParts ((DotProtoMessagePart -> m [QualifiedField]) -> m [QualifiedField])
-> (DotProtoMessagePart -> m [QualifiedField])
-> m [QualifiedField]
forall a b. (a -> b) -> a -> b
$ \case
DotProtoMessageField DotProtoField{String
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldComment :: DotProtoField -> String
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
dotProtoFieldComment :: String
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldType :: DotProtoType
dotProtoFieldNumber :: FieldNumber
..} -> do
String
fieldName <- DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
dotProtoFieldName
String
qualName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedFieldName String
msgName String
fieldName
[QualifiedField] -> m [QualifiedField]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([QualifiedField] -> m [QualifiedField])
-> (QualifiedField -> [QualifiedField])
-> QualifiedField
-> m [QualifiedField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualifiedField -> [QualifiedField] -> [QualifiedField]
forall a. a -> [a] -> [a]
:[]) (QualifiedField -> m [QualifiedField])
-> QualifiedField -> m [QualifiedField]
forall a b. (a -> b) -> a -> b
$ QualifiedField :: FieldName -> FieldInfo -> QualifiedField
QualifiedField { recordFieldName :: FieldName
recordFieldName = String -> FieldName
coerce String
qualName
, fieldInfo :: FieldInfo
fieldInfo = FieldName
-> FieldNumber -> DotProtoType -> [DotProtoOption] -> FieldInfo
FieldNormal (String -> FieldName
coerce String
fieldName)
FieldNumber
dotProtoFieldNumber
DotProtoType
dotProtoFieldType
[DotProtoOption]
dotProtoFieldOptions
}
DotProtoMessageOneOf DotProtoIdentifier
_ [] ->
CompileError -> m [QualifiedField]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> CompileError
InternalError String
"getQualifiedFields: encountered oneof with no oneof fields")
DotProtoMessageOneOf DotProtoIdentifier
oneofIdent [DotProtoField]
fields -> do
String
ident <- DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
oneofIdent
String
oneofName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedFieldName String
msgName String
ident
String
oneofTypeName <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedConName String
msgName String
ident
let mkSubfield :: DotProtoField -> m [OneofSubfield]
mkSubfield DotProtoField{String
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldComment :: String
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldType :: DotProtoType
dotProtoFieldNumber :: FieldNumber
dotProtoFieldComment :: DotProtoField -> String
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
..} = do
String
s <- DotProtoIdentifier -> m String
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m String
dpIdentUnqualName DotProtoIdentifier
dotProtoFieldName
String
c <- String -> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> String -> m String
prefixedConName String
oneofTypeName String
s
[OneofSubfield] -> m [OneofSubfield]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FieldNumber
-> String
-> FieldName
-> DotProtoType
-> [DotProtoOption]
-> OneofSubfield
OneofSubfield FieldNumber
dotProtoFieldNumber String
c (String -> FieldName
coerce String
s) DotProtoType
dotProtoFieldType [DotProtoOption]
dotProtoFieldOptions]
mkSubfield DotProtoField
DotProtoEmptyField = [OneofSubfield] -> m [OneofSubfield]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
[OneofSubfield]
fieldElems <- (DotProtoField -> m [OneofSubfield])
-> [DotProtoField] -> m [OneofSubfield]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(a -> m b) -> t a -> m b
foldMapM DotProtoField -> m [OneofSubfield]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoField -> m [OneofSubfield]
mkSubfield [DotProtoField]
fields
[QualifiedField] -> m [QualifiedField]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([QualifiedField] -> m [QualifiedField])
-> (QualifiedField -> [QualifiedField])
-> QualifiedField
-> m [QualifiedField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualifiedField -> [QualifiedField] -> [QualifiedField]
forall a. a -> [a] -> [a]
:[]) (QualifiedField -> m [QualifiedField])
-> QualifiedField -> m [QualifiedField]
forall a b. (a -> b) -> a -> b
$ QualifiedField :: FieldName -> FieldInfo -> QualifiedField
QualifiedField { recordFieldName :: FieldName
recordFieldName = String -> FieldName
coerce String
oneofName
, fieldInfo :: FieldInfo
fieldInfo = OneofField -> FieldInfo
FieldOneOf (String -> [OneofSubfield] -> OneofField
OneofField String
ident [OneofSubfield]
fieldElems)
}
DotProtoMessagePart
_ -> [QualifiedField] -> m [QualifiedField]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
foldQF :: (FieldName -> FieldNumber -> a)
-> (OneofField -> a)
-> QualifiedField
-> a
foldQF :: (FieldName -> FieldNumber -> a)
-> (OneofField -> a) -> QualifiedField -> a
foldQF FieldName -> FieldNumber -> a
f OneofField -> a
_ (QualifiedField FieldName
_ (FieldNormal FieldName
fldName FieldNumber
fldNum DotProtoType
_ [DotProtoOption]
_)) = FieldName -> FieldNumber -> a
f FieldName
fldName FieldNumber
fldNum
foldQF FieldName -> FieldNumber -> a
_ OneofField -> a
g (QualifiedField FieldName
_ (FieldOneOf OneofField
fld)) = OneofField -> a
g OneofField
fld
fieldBinder :: FieldNumber -> String
fieldBinder :: FieldNumber -> String
fieldBinder = (String
"f" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (FieldNumber -> String) -> FieldNumber -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNumber -> String
forall a. Show a => a -> String
show
oneofSubBinder :: OneofSubfield -> String
oneofSubBinder :: OneofSubfield -> String
oneofSubBinder = FieldNumber -> String
fieldBinder (FieldNumber -> String)
-> (OneofSubfield -> FieldNumber) -> OneofSubfield -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneofSubfield -> FieldNumber
subfieldNumber
oneofSubDisjunctBinder :: [OneofSubfield] -> String
oneofSubDisjunctBinder :: [OneofSubfield] -> String
oneofSubDisjunctBinder = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_or_" ([String] -> String)
-> ([OneofSubfield] -> [String]) -> [OneofSubfield] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OneofSubfield -> String) -> [OneofSubfield] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OneofSubfield -> String
oneofSubBinder
data CompileError
= CircularImport FilePath
| CompileParseError ParseError
| InternalError String
| InvalidPackageName DotProtoIdentifier
| InvalidMethodName DotProtoIdentifier
| InvalidModuleName String
| InvalidTypeName String
| InvalidMapKeyType String
| NoPackageDeclaration
| NoSuchType DotProtoIdentifier
| NonzeroFirstEnumeration String DotProtoIdentifier Int32
| EmptyEnumeration String
| Unimplemented String
deriving (Int -> CompileError -> ShowS
[CompileError] -> ShowS
CompileError -> String
(Int -> CompileError -> ShowS)
-> (CompileError -> String)
-> ([CompileError] -> ShowS)
-> Show CompileError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompileError] -> ShowS
$cshowList :: [CompileError] -> ShowS
show :: CompileError -> String
$cshow :: CompileError -> String
showsPrec :: Int -> CompileError -> ShowS
$cshowsPrec :: Int -> CompileError -> ShowS
Show, CompileError -> CompileError -> Bool
(CompileError -> CompileError -> Bool)
-> (CompileError -> CompileError -> Bool) -> Eq CompileError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompileError -> CompileError -> Bool
$c/= :: CompileError -> CompileError -> Bool
== :: CompileError -> CompileError -> Bool
$c== :: CompileError -> CompileError -> Bool
Eq)
internalError :: MonadError CompileError m => String -> m a
internalError :: String -> m a
internalError = CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m a) -> (String -> CompileError) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CompileError
InternalError
invalidTypeNameError :: MonadError CompileError m => String -> m a
invalidTypeNameError :: String -> m a
invalidTypeNameError = CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m a) -> (String -> CompileError) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CompileError
InvalidTypeName
_unimplementedError :: MonadError CompileError m => String -> m a
_unimplementedError :: String -> m a
_unimplementedError = CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m a) -> (String -> CompileError) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CompileError
Unimplemented
invalidMethodNameError :: MonadError CompileError m => DotProtoIdentifier -> m a
invalidMethodNameError :: DotProtoIdentifier -> m a
invalidMethodNameError = CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m a)
-> (DotProtoIdentifier -> CompileError)
-> DotProtoIdentifier
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotProtoIdentifier -> CompileError
InvalidMethodName
noSuchTypeError :: MonadError CompileError m => DotProtoIdentifier -> m a
noSuchTypeError :: DotProtoIdentifier -> m a
noSuchTypeError = CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m a)
-> (DotProtoIdentifier -> CompileError)
-> DotProtoIdentifier
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotProtoIdentifier -> CompileError
NoSuchType
protoPackageName :: MonadError CompileError m => DotProtoPackageSpec -> m DotProtoIdentifier
protoPackageName :: DotProtoPackageSpec -> m DotProtoIdentifier
protoPackageName (DotProtoPackageSpec DotProtoIdentifier
name) = DotProtoIdentifier -> m DotProtoIdentifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure DotProtoIdentifier
name
protoPackageName DotProtoPackageSpec
DotProtoNoPackage = CompileError -> m DotProtoIdentifier
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CompileError
NoPackageDeclaration