-- | This module provides misc internal helpers and utilities

{-# LANGUAGE CPP               #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# 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                 (find, intercalate)
import qualified Data.List.NonEmpty        as NE
import qualified Data.Map                  as M
import           Data.Maybe                (fromMaybe)
import           Data.Semigroup            (Semigroup(..))
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, MonadIO,
                                            Text)
import           Turtle.Format             ((%))
import qualified Turtle.Format             as F

-------------------------------------------------------------------------------
--
-- * Utilities
--

#if !(MIN_VERSION_mtl(2,2,2))
liftEither :: MonadError e m => Either e a -> m a
liftEither = either throwError pure
#endif

-- | Like 'foldMap', but with an effectful projection.
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

-- | Like 'Control.Lens.Getter.Getting', but allows for retrieving the 'r'
-- element in some Applicative context 'm'.
type GettingM r s a = forall m. Applicative m => (a -> Compose m (Const r) a) -> s -> Compose m (Const r) s

-- | Given an effectful projection from 'a' into a monoid 'r', retrieve the sum
-- of all 'a' values in an 's' structure as targetted by the 'GettingM' optic.
-- Note that the Monoid constraint on 'r' is implicit via 'Const', but we
-- note it in the type for clarity.
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

-- $setup
-- >>> :set -XOverloadedStrings

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)

--------------------------------------------------------------------------------
--
-- * Reading files
--

-- | toModulePath takes an include-relative path to a .proto file and produces a
-- "module path" which is used during code generation.
--
-- Note that, with the exception of the '.proto' portion of the input filepath,
-- this function interprets '.' in the filename components as if they were
-- additional slashes (assuming that the '.' is not the first character, which
-- is merely ignored). So e.g. "google/protobuf/timestamp.proto" and
-- "google.protobuf.timestamp.proto" map to the same module path.
--
-- >>> toModulePath "/absolute/path/fails.proto"
-- Left "expected include-relative path"
--
-- >>> toModulePath "relative/path/to/file_without_proto_suffix_fails"
-- Left "expected .proto suffix"
--
-- >>> toModulePath "relative/path/to/file_without_proto_suffix_fails.txt"
-- Left "expected .proto suffix"
--
-- >>> toModulePath "../foo.proto"
-- Left "expected include-relative path, but the path started with ../"
--
-- >>> toModulePath "foo..proto"
-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"
--
-- >>> toModulePath "foo/bar/baz..proto"
-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"
--
-- >>> toModulePath "foo.bar../baz.proto"
-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"
--
-- >>> toModulePath "google/protobuf/timestamp.proto"
-- Right (Path {components = "Google" :| ["Protobuf","Timestamp"]})
--
-- >>> toModulePath "a/b/c/google.protobuf.timestamp.proto"
-- Right (Path {components = "A" :| ["B","C","Google","Protobuf","Timestamp"]})
--
-- >>> toModulePath "foo/FiLeName_underscore.and.then.some.dots.proto"
-- Right (Path {components = "Foo" :| ["FiLeName_underscore","And","Then","Some","Dots"]})
--
-- >>> toModulePath "foo/bar/././baz/../boggle.proto"
-- Right (Path {components = "Foo" :| ["Bar","Boggle"]})
--
-- >>> toModulePath "./foo.proto"
-- Right (Path {components = "Foo" :| []})
--
-- NB: We ignore preceding single '.' characters
-- >>> toModulePath ".foo.proto"
-- Right (Path {components = "Foo" :| []})
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 -- Remove a potential preceding empty component which
                              -- arose from a preceding '.' in the input path, which we
                              -- want to ignore. E.g. ".foo.proto" => ["","Foo"].
             ([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 searchPaths toplevel inc@ attempts to import include-relative
-- @inc@ after locating it somewhere in the @searchPaths@; @toplevel@ is simply
-- the path of toplevel .proto being processed so we can report it in an error
-- message. This function terminates the program if it cannot find the file to
-- import or if it cannot construct a valid module path from it.
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))

-- | Attempts to locate the first (if any) filename that exists on the given
-- search paths, and constructs the "module path" from the given
-- include-relative filename (2nd parameter). Terminates the program with an
-- error if the given pathname is not relative.
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)

-- * Pretty Error Messages

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 context
--

-- | A mapping from .proto type identifiers to their type information
type TypeContext = M.Map DotProtoIdentifier DotProtoTypeInfo

-- | Information about messages and enumerations
data DotProtoTypeInfo = DotProtoTypeInfo
  { DotProtoTypeInfo -> DotProtoPackageSpec
dotProtoTypeInfoPackage    :: DotProtoPackageSpec
     -- ^ The package this type is defined in
  , DotProtoTypeInfo -> DotProtoIdentifier
dotProtoTypeInfoParent     :: DotProtoIdentifier
    -- ^ The message this type is nested under, or 'Anonymous' if it's top-level
  , DotProtoTypeInfo -> TypeContext
dotProtoTypeChildContext   :: TypeContext
    -- ^ The context that should be used for declarations within the
    --   scope of this type
  , DotProtoTypeInfo -> DotProtoKind
dotProtoTypeInfoKind       :: DotProtoKind
    -- ^ Whether this type is an enumeration or message
  , DotProtoTypeInfo -> Path
dotProtoTypeInfoModulePath :: Path
    -- ^ The include-relative module path used when importing this module
  } 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 })

-- | Whether a definition is an enumeration or a message
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)

-- ** Generating type contexts from ASTs

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)

isPacked :: [DotProtoOption] -> Bool
isPacked :: [DotProtoOption] -> Bool
isPacked [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
"packed") [DotProtoOption]
opts of
        Just (DotProtoOption DotProtoIdentifier
_ (BoolLit Bool
x)) -> Bool
x
        Maybe DotProtoOption
_ -> Bool
False

isUnpacked :: [DotProtoOption] -> Bool
isUnpacked :: [DotProtoOption] -> Bool
isUnpacked [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
"packed") [DotProtoOption]
opts of
        Just (DotProtoOption DotProtoIdentifier
_ (BoolLit Bool
x)) -> Bool -> Bool
not Bool
x
        Maybe DotProtoOption
_ -> Bool
False

-- | Returns 'True' if the given primitive type is packable. The 'TypeContext'
-- is used to distinguish Named enums and messages, only the former of which are
-- packable.
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

--------------------------------------------------------------------------------
--
-- * Name resolution
--

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)))

camelCased :: String -> String
camelCased :: ShowS
camelCased String
s = do
  (Maybe Char
prev, Maybe Char
cur) <- [Maybe Char] -> [Maybe Char] -> [(Maybe Char, Maybe Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Maybe Char
forall a. Maybe a
NothingMaybe Char -> [Maybe Char] -> [Maybe Char]
forall a. a -> [a] -> [a]
:(Char -> Maybe Char) -> String -> [Maybe Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Maybe Char
forall a. a -> Maybe a
Just String
s) ((Char -> Maybe Char) -> String -> [Maybe Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Maybe Char
forall a. a -> Maybe a
Just String
s [Maybe Char] -> [Maybe Char] -> [Maybe Char]
forall a. [a] -> [a] -> [a]
++ [Maybe Char
forall a. Maybe a
Nothing])
  case (Maybe Char
prev, Maybe Char
cur) of
    (Just Char
'_', Just Char
x)
      | Char -> Bool
isAlpha Char
x        -> Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Char
toUpper Char
x)
    (Just Char
'_', Maybe Char
Nothing)  -> Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'_'
    (Just Char
'_', Just Char
'_') -> Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'_'
    (Maybe Char
_, Just Char
'_')        -> String
forall (f :: * -> *) a. Alternative f => f a
empty
    (Maybe Char
_, Just Char
x)          -> Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
x
    (Maybe Char
_, Maybe Char
_)               -> String
forall (f :: * -> *) a. Alternative f => f a
empty

typeLikeName :: MonadError CompileError m => String -> m String
typeLikeName :: String -> m String
typeLikeName ident :: String
ident@(Char
c:String
cs)
  | Char -> Bool
isUpper Char
c = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShowS
camelCased String
ident)
  | Char -> Bool
isLower Char
c = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShowS
camelCased (Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs))
  | Char
'_'  Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShowS
camelCased (Char
'X'Char -> ShowS
forall a. a -> [a] -> [a]
:String
ident))
typeLikeName String
ident = String -> m String
forall (m :: * -> *) a. MonadError CompileError m => String -> m a
invalidTypeNameError String
ident

fieldLikeName :: String -> String
fieldLikeName :: ShowS
fieldLikeName ident :: String
ident@(Char
c:String
_)
  | Char -> Bool
isUpper Char
c = let (String
prefix, String
suffix) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper String
ident
                in (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
fieldLikeName String
ident = String
ident

prefixedEnumFieldName :: String -> String -> String
prefixedEnumFieldName :: String -> ShowS
prefixedEnumFieldName String
enumName String
fieldName = String
enumName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fieldName

prefixedConName :: MonadError CompileError m => String -> String -> m String
prefixedConName :: String -> String -> m String
prefixedConName String
msgName String
conName = (String
msgName String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName String
conName

-- TODO: This should be ~:: MessageName -> FieldName -> ...; same elsewhere, the
-- String types are a bit of a hassle.
prefixedFieldName :: MonadError CompileError m => String -> String -> m String
prefixedFieldName :: String -> String -> m String
prefixedFieldName String
msgName String
fieldName = (ShowS
fieldLikeName String
msgName String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
typeLikeName String
fieldName

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"

-- | Given a 'DotProtoIdentifier' for the parent type and the unqualified name
-- of this type, generate the corresponding Haskell name
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

--------------------------------------------------------------------------------
--
-- ** Codegen bookkeeping helpers
--

-- | Bookeeping for qualified fields
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

-- | Bookkeeping for fields
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

-- | Bookkeeping for oneof fields
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

-- | Bookkeeping for oneof subfields
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 []

-- | Project qualified fields, given a projection function per field type.
foldQF :: (FieldName -> FieldNumber -> a) -- ^ projection for normal fields
       -> (OneofField -> a)               -- ^ projection for oneof fields
       -> 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

--------------------------------------------------------------------------------
--
-- * Errors
--

data CompileError
  = CircularImport          FilePath
  | CompileParseError       ParseError
  | InternalError           String
  | InvalidPackageName      DotProtoIdentifier
  | InvalidMethodName       DotProtoIdentifier
  | 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