-- | This module provides misc internal helpers and utilities

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# 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.IO.Class
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, sort)
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 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 hiding (absolute, collapse)
import qualified Turtle.Compat as Turtle (absolute, collapse)
import           Turtle                    (ExitCode (..), FilePath, 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 :: forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m, Monoid b, Semigroup b) =>
(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 :: forall (m :: * -> *) r s a.
(Applicative m, Monoid r) =>
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 a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Const r s -> r
forall {k} a (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} {k2} (f :: k1 -> *) (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 a b. (a -> b) -> m a -> m b
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 :: forall (m :: * -> *) k2 k1 a.
(Monad m, Ord k2) =>
(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 a b. (a -> b) -> m a -> m b
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((a, k2) -> (k2, a)) -> m (a, k2) -> m (k2, a)
forall a b. (a -> b) -> m a -> m b
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (a, a) -> f (a, 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 :: forall (m :: * -> *) a. MonadIO m => 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)

-- | The proposition that some third value comes strictly after
-- the first argument but strictly before the second argument.
nonconsecutive :: (Enum a, Ord a) => a -> a -> Bool
nonconsecutive :: forall a. (Enum a, Ord a) => a -> a -> Bool
nonconsecutive a
x a
y = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y Bool -> Bool -> Bool
&& a -> a
forall a. Enum a => a -> a
succ a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y
  -- The check that @x < y@ avoids the potential for arithmetic overflow in @succ x@.
{-# INLINABLE nonconsecutive #-}  -- To allow specialization to particular type class instances.

-- | This function yields 'Just' of the union of its arguments if that union
-- can be expressed as a single interval, and otherwise yields 'Nothing'.
joinIntervals :: (Enum a, Ord a) => (a, a) -> (a, a) -> Maybe (a, a)
joinIntervals :: forall a. (Enum a, Ord a) => (a, a) -> (a, a) -> Maybe (a, a)
joinIntervals (a
a, a
b) (a
c, a
d)
  | a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
a = (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
c, a
d)  -- (a, b) is empty; we can just drop it
  | a
d a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
c = (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
a, a
b)  -- (c, d) is empty; we can just drop it
  | a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
c = if
      | a -> a -> Bool
forall a. (Enum a, Ord a) => a -> a -> Bool
nonconsecutive a
b a
c -> Maybe (a, a)
forall a. Maybe a
Nothing   -- (a, b), then something strictly between, then (c, d)
      | Bool
otherwise -> (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
a, a -> a -> a
forall a. Ord a => a -> a -> a
max a
b a
d)  -- no value lies strictly between b and c
  | Bool
otherwise = if
      | a -> a -> Bool
forall a. (Enum a, Ord a) => a -> a -> Bool
nonconsecutive a
d a
a -> Maybe (a, a)
forall a. Maybe a
Nothing   -- (c, d), then something strictly between, then (a, b)
      | Bool
otherwise -> (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
c, a -> a -> a
forall a. Ord a => a -> a -> a
max a
b a
d)  -- no value lies strictly between d and a
{-# INLINABLE joinIntervals #-}  -- To allow specialization to particular type class instances.

-- | Finds the unique shortest list of intervals having the same
-- set union as the given list and nondecreasing low endpoints.
--
-- The result also satisfies the definition of /normal/ given below.
--
-- Each interval is specified by pairing its low and high endpoints,
-- which are included in the interval, except when the first component
-- of the pair exceeds the second, in which case the interval is empty.
--
-- = Supporting Theory
--
-- == Definition of /normal/
--
-- Call a list of intervals /normal/ when it excludes empty intervals
-- and for any two consecutive intervals /[a .. b]/ and /[c .. d]/,
-- there exists an /x/ such that /b < x < c/.
--
-- We claim that, among those interval lists having any given union,
-- normality is equivalent to having minimal length and nondecreasing
-- low endpoints.
--
-- == Normal implies minimal length
--
-- To see why, first consider any normal interval list /N/.  Clearly its
-- low endpoints are nondecreasing--and in fact are strictly increasing
-- with gaps inbetween.  Therefore any interval intersecting at least two
-- intervals of /N/ necessarily includes at least one point in such a gap,
-- and that point is outside the union of /N/.  Hence every interval list
-- with the same union as /N/ consists of (possibly empty) subintervals of
-- intervals listed by /N/.  Hence /N/ has minimal length among such lists.
--
-- == Minimal length implies normal
--
-- To establish the converse, consider any interval list /N/ having
-- nondecreasing endpoints and minimal length.  Deleting empty intervals
-- from /N/ would only decrease its length, so /N/ must not include any.
-- Next note that if /[a .. b]/ and /[c .. d]/ are consecutive intervals
-- within /N/, then either there exists an /x/ such that /b < x < c/, or
-- else we may shorten /N/ without changing its union by replacing both
-- /[a .. b]/ and /[c .. d]/ by the single interval /[a .. max b d]/,
-- which would contradict the minimality of the length of /N/.  Thus
-- /N/ fulfills all the requirements of being a normal interval list.
--
-- == Existence
--
-- Having proved the desired equivalence, we turn to the question of
-- the existence of the shortest interval list having the same union
-- as any given interval list and nondecreasing low endpoints.
--
-- Consider the set /S/ of interval lists having the same union as
-- the given interval list and nondecreasing low endpoints.  Note
-- that by performing a stable sort on the given interval list we
-- immediately find that /S/ is nonempty.  Being nonempty, it must
-- contain at least one element of minimal length.
--
-- == Uniqueness
--
-- But could there be two different interval lists of minimal length
-- for their common union, both with nondecreasing low endpoints?
--
-- We claim the answer is no, and proceed by induction on that shared
-- minimal length.  The base case is trivial: if both lists are empty,
-- then they cannot differ.
--
-- For the induction step, suppose that there are two interval lists
-- that share the same positive minimal length among those that
-- have nondecreasing low endpoints and a given same union.
-- Call them /L/ and /N/.  We will prove that /L = N/.
--
-- Let /(a, b) = head L/ and /(e, f) = head N/.
--
-- If /a < e/ then /a/ is in /union L/ but not in /union N/,
-- contradicting our assumpion that /union L = union N/.  Likewise
-- we may exclude /e < a/, leaving /a = e/ and /(a, f) = head N/.
--
-- Next suppose that /b < f/.  If /tail L == []/ then clearly /f/
-- is outside of /union L/ and yet inside of /union N/, which is
-- once again beyond our scenario.  Let /(c, d) = head (tail L)/.
-- By the equivalence we established earlier, /L/ is normal and
-- hence there exists an /x/ such that /b < x < c/.  If /x <= f/,
-- then /x/ is in /[a .. f]/ and yet outside of /union L/, once
-- again contradicting our hypotheses.  Otherwise /f < x < c/, and
-- hence /f/ is outside of /union L/, a similar contradiction.
-- Therefore our supposition that /b < f/ must be impossible,
-- and we can likewise exclude /f < b/.  Hence /b = f/.
--
-- Having establishing both /a = e/ and /b = f/, we conclude that
-- /head L = head N/.  It follows that /tail L/ and /tail N/ have
-- the same union as each other.  Both tails must be minimal in
-- length, because otherwise there would also be a way to shorten
-- /L/ or /N/ in a union-preserving way.  Invoking our induction
-- hypothesis we find that /tail L = tail N/; therefore /L = N/.
--
-- = Conclusions
--
-- In conclusion, the desired behavior of this function is well defined
-- by the first paragraph in this comment block, and the second paragraph
-- (once combined with a requirement to preserve the union) provides
-- an equivalent definition.
--
-- To check that the implementation actually fulfills these requirements,
-- note that it filters out empty intervals, sorts those that remain,
-- and then merges intervals until the resulting list becomes normal.
--
-- There are also unit tests checking that the result is
-- normal and has the same union as the given list.
normalizeIntervals :: (Enum a, Ord a) => [(a, a)] -> [(a, a)]
normalizeIntervals :: forall a. (Enum a, Ord a) => [(a, a)] -> [(a, a)]
normalizeIntervals = [(a, a)] -> [(a, a)]
forall a. (Enum a, Ord a) => [(a, a)] -> [(a, a)]
mergeIntervals ([(a, a)] -> [(a, a)])
-> ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter \(a
x, a
y) -> a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y
{-# INLINABLE normalizeIntervals #-}  -- To allow specialization to particular type class instances.

-- | Returns a sorted list that contains all intervals from the minimal set of
-- intervals to represent the given list of intervals.
--
-- "Merges" overlapping intervals in a list of intervals. Think disjunctive
-- normal form.
mergeIntervals :: forall a . (Enum a, Ord a) => [(a, a)] -> [(a, a)]
mergeIntervals :: forall a. (Enum a, Ord a) => [(a, a)] -> [(a, a)]
mergeIntervals = ((a, a) -> [(a, a)] -> [(a, a)])
-> [(a, a)] -> [(a, a)] -> [(a, a)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> [(a, a)] -> [(a, a)]
step [] ([(a, a)] -> [(a, a)])
-> ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, a)] -> [(a, a)]
forall a. Ord a => [a] -> [a]
sort
  where
    step :: (a, a) -> [(a, a)] -> [(a, a)]
    step :: (a, a) -> [(a, a)] -> [(a, a)]
step (a, a)
x [] = [(a, a)
x]
    step (a, a)
x ((a, a)
y : [(a, a)]
ys) = case (a, a) -> (a, a) -> Maybe (a, a)
forall a. (Enum a, Ord a) => (a, a) -> (a, a) -> Maybe (a, a)
joinIntervals (a, a)
x (a, a)
y of
      Maybe (a, a)
Nothing -> (a, a)
x (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: (a, a)
y (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [(a, a)]
ys
        -- In this case @x@ and @y@ could not be merged, and therefore there is
        -- some value strictly inbetween the end of @x@ and the start of @y@.
        -- Compare this property to the definition of /normal/ (above).
      Just (a, a)
xy -> (a, a) -> [(a, a)] -> [(a, a)]
step (a, a)
xy [(a, a)]
ys
        -- Recursion is necessary here because @x@ may end later than did @y@,
        -- possibly making @xy@ mergable with some prefix of @ys@, unlike @y@.
        -- By merging @x@ and @y@ into @xy@ we have shortened the overall
        -- length of the list, and therefore this recursion must terminate.
{-# INLINABLE mergeIntervals #-}  -- To allow specialization to particular type class instances.

--------------------------------------------------------------------------------
--
-- * 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"]})
--
#if MIN_VERSION_turtle(1,6,0)
-- >>> toModulePath "foo/bar/././baz/../boggle.proto"
-- Left "path contained unexpected .. after canonicalization, please use form x.y.z.proto"
#else
-- >>> toModulePath "foo/bar/././baz/../boggle.proto"
-- Right (Path {components = "Foo" :| ["Bar","Boggle"]})
#endif
--
-- >>> 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 :: [Char] -> Either [Char] Path
toModulePath fp0 :: [Char]
fp0@([Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
fp0 (Maybe [Char] -> [Char])
-> ([Char] -> Maybe [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> Maybe [Char]
Turtle.stripPrefix [Char]
"./" -> [Char]
fp)
  | [Char] -> Bool
Turtle.absolute [Char]
fp
    = [Char] -> Either [Char] Path
forall a b. a -> Either a b
Left [Char]
"expected include-relative path"
  | [Char] -> Maybe [Char]
Turtle.extension [Char]
fp Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"proto"
    = [Char] -> Either [Char] Path
forall a b. a -> Either a b
Left [Char]
"expected .proto suffix"
  | Bool
otherwise
    = case [Char] -> [Char] -> Maybe [Char]
Turtle.stripPrefix [Char]
"../" [Char]
fp of
        Just{}  -> [Char] -> Either [Char] Path
forall a b. a -> Either a b
Left [Char]
"expected include-relative path, but the path started with ../"
        Maybe [Char]
Nothing
          | Text -> Text -> Bool
T.isInfixOf Text
".." (Text -> Bool) -> ([Char] -> Text) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format Text ([Char] -> Text) -> [Char] -> Text
forall r. Format Text r -> r
Turtle.format Format Text ([Char] -> Text)
forall r. Format r ([Char] -> r)
F.fp ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
Turtle.collapse ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
fp
            -> [Char] -> Either [Char] Path
forall a b. a -> Either a b
Left [Char]
"path contained unexpected .. after canonicalization, please use form x.y.z.proto"
          | Bool
otherwise
            -> Either [Char] Path
-> (NonEmpty [Char] -> Either [Char] Path)
-> Maybe (NonEmpty [Char])
-> Either [Char] Path
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] Path
forall a b. a -> Either a b
Left [Char]
"empty path after canonicalization") (Path -> Either [Char] Path
forall a b. b -> Either a b
Right (Path -> Either [Char] Path)
-> (NonEmpty [Char] -> Path)
-> NonEmpty [Char]
-> Either [Char] Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [Char] -> Path
Path)
             (Maybe (NonEmpty [Char]) -> Either [Char] Path)
-> ([Char] -> Maybe (NonEmpty [Char]))
-> [Char]
-> Either [Char] Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> Maybe (NonEmpty [Char])
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
             ([[Char]] -> Maybe (NonEmpty [Char]))
-> ([Char] -> [[Char]]) -> [Char] -> Maybe (NonEmpty [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile [Char] -> Bool
forall a. [a] -> 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"].
             ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
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
Traversal' Text Char
_head Char -> Char
toUpper)
             ([Text] -> [[Char]]) -> ([Char] -> [Text]) -> [Char] -> [[Char]]
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 (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
".")
             ([Text] -> [Text]) -> ([Char] -> [Text]) -> [Char] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split Char -> Bool
isPathSeparator
             (Text -> [Text]) -> ([Char] -> Text) -> [Char] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format Text ([Char] -> Text) -> [Char] -> Text
forall r. Format Text r -> r
Turtle.format Format Text ([Char] -> Text)
forall r. Format r ([Char] -> r)
F.fp
             ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
Turtle.collapse
             ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
Turtle.dropExtension
             ([Char] -> Either [Char] Path) -> [Char] -> Either [Char] Path
forall a b. (a -> b) -> a -> b
$ [Char]
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 :: forall (m :: * -> *).
(MonadIO m, MonadError CompileError m) =>
[[Char]] -> [Char] -> [Char] -> m DotProto
importProto [[Char]]
paths [Char]
toplevelProto [Char]
protoFP =
  [[Char]] -> [Char] -> m FindProtoResult
forall (m :: * -> *).
MonadIO m =>
[[Char]] -> [Char] -> m FindProtoResult
findProto [[Char]]
paths [Char]
protoFP m FindProtoResult -> (FindProtoResult -> m DotProto) -> m DotProto
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left [Char]
e
      -> Text -> m DotProto
forall (m :: * -> *) a. MonadIO m => Text -> m a
dieLines ([Char] -> [Char] -> Text
badModulePathErrorMsg [Char]
protoFP [Char]
e)
    Right Maybe (Path, [Char])
Nothing
      | [Char]
toplevelProto [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
protoFP
        -> Text -> m DotProto
forall (m :: * -> *) a. MonadIO m => Text -> m a
dieLines ([[Char]] -> [Char] -> Text
toplevelNotFoundErrorMsg [[Char]]
paths [Char]
toplevelProto)
      | Bool
otherwise
        -> Text -> m DotProto
forall (m :: * -> *) a. MonadIO m => Text -> m a
dieLines ([[Char]] -> [Char] -> [Char] -> Text
importNotFoundErrorMsg [[Char]]
paths [Char]
toplevelProto [Char]
protoFP)
    Right (Just (Path
mp, [Char]
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 a b c. (a -> b) -> Either a c -> Either b c
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 -> [Char] -> m (Either ParseError DotProto)
forall (m :: * -> *).
MonadIO m =>
Path -> [Char] -> m (Either ParseError DotProto)
parseProtoFile Path
mp [Char]
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 :: forall (m :: * -> *).
MonadIO m =>
[[Char]] -> [Char] -> m FindProtoResult
findProto [[Char]]
searchPaths [Char]
protoFP
  | [Char] -> Bool
Turtle.absolute [Char]
protoFP = Text -> m FindProtoResult
forall (m :: * -> *) a. MonadIO m => Text -> m a
dieLines Text
absolutePathErrorMsg
  | Bool
otherwise = Either [Char] Path
-> (Path -> m (Maybe (Path, [Char]))) -> m FindProtoResult
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Char] -> Either [Char] Path
toModulePath [Char]
protoFP) ((Path -> m (Maybe (Path, [Char]))) -> m FindProtoResult)
-> (Path -> m (Maybe (Path, [Char]))) -> m FindProtoResult
forall a b. (a -> b) -> a -> b
$ \Path
mp ->
                  (Shell (Path, [Char])
 -> Fold (Path, [Char]) (Maybe (Path, [Char]))
 -> m (Maybe (Path, [Char])))
-> Fold (Path, [Char]) (Maybe (Path, [Char]))
-> Shell (Path, [Char])
-> m (Maybe (Path, [Char]))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Shell (Path, [Char])
-> Fold (Path, [Char]) (Maybe (Path, [Char]))
-> m (Maybe (Path, [Char]))
forall (io :: * -> *) a b.
MonadIO io =>
Shell a -> Fold a b -> io b
Turtle.fold Fold (Path, [Char]) (Maybe (Path, [Char]))
forall a. Fold a (Maybe a)
FL.head (Shell (Path, [Char]) -> m (Maybe (Path, [Char])))
-> Shell (Path, [Char]) -> m (Maybe (Path, [Char]))
forall a b. (a -> b) -> a -> b
$ do
                     [Char]
sp <- [[Char]] -> Shell [Char]
forall (f :: * -> *) a. Foldable f => f a -> Shell a
Turtle.select [[Char]]
searchPaths
                     let fp :: [Char]
fp = [Char]
sp [Char] -> [Char] -> [Char]
</> [Char]
protoFP
                     Bool
True <- [Char] -> Shell Bool
forall (io :: * -> *). MonadIO io => [Char] -> io Bool
Turtle.testfile [Char]
fp
                     (Path, [Char]) -> Shell (Path, [Char])
forall a. a -> Shell a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path
mp, [Char]
fp)

-- * Pretty Error Messages

badModulePathErrorMsg :: FilePath -> String -> T.Text
badModulePathErrorMsg :: [Char] -> [Char] -> Text
badModulePathErrorMsg (Format Text ([Char] -> Text) -> [Char] -> Text
forall r. Format Text r -> r
Turtle.format Format Text ([Char] -> Text)
forall r. Format r ([Char] -> r)
F.fp -> Text
fp) ([Char] -> 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 :: [[Char]] -> [Char] -> [Char] -> Text
importNotFoundErrorMsg [[Char]]
paths [Char]
toplevelProto [Char]
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 ([Char] -> Text) -> [Char] -> Text
forall r. Format Text r -> r
Turtle.format (Format ([Char] -> Text) ([Char] -> Text)
"  "Format ([Char] -> Text) ([Char] -> Text)
-> Format Text ([Char] -> Text) -> Format Text ([Char] -> Text)
forall b c a. Format b c -> Format a b -> Format a c
%Format Text ([Char] -> Text)
forall r. Format r ([Char] -> r)
F.fp) ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> [Char]
</> [Char]
protoFP) ([Char] -> Text) -> [[Char]] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
paths)
    toplevelProtoText :: Text
toplevelProtoText = Format Text ([Char] -> Text) -> [Char] -> Text
forall r. Format Text r -> r
Turtle.format Format Text ([Char] -> Text)
forall r. Format r ([Char] -> r)
F.fp [Char]
toplevelProto
    protoFPText :: Text
protoFPText = Format Text ([Char] -> Text) -> [Char] -> Text
forall r. Format Text r -> r
Turtle.format Format Text ([Char] -> Text)
forall r. Format r ([Char] -> r)
F.fp [Char]
protoFP

toplevelNotFoundErrorMsg :: [FilePath] -> FilePath -> T.Text
toplevelNotFoundErrorMsg :: [[Char]] -> [Char] -> Text
toplevelNotFoundErrorMsg [[Char]]
searchPaths [Char]
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 ([Char] -> Text) -> [Char] -> Text
forall r. Format Text r -> r
Turtle.format (Format ([Char] -> Text) ([Char] -> Text)
"  "Format ([Char] -> Text) ([Char] -> Text)
-> Format Text ([Char] -> Text) -> Format Text ([Char] -> Text)
forall b c a. Format b c -> Format a b -> Format a c
%Format Text ([Char] -> Text)
forall r. Format r ([Char] -> r)
F.fp) ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> [Char]
</> [Char]
toplevelProto) ([Char] -> Text) -> [[Char]] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
searchPaths)
    toplevelProtoText :: Text
toplevelProtoText = Format Text ([Char] -> Text) -> [Char] -> Text
forall r. Format Text r -> r
Turtle.format Format Text ([Char] -> Text)
forall r. Format r ([Char] -> r)
F.fp [Char]
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 -> [Char] -> [Char]
[DotProtoTypeInfo] -> [Char] -> [Char]
DotProtoTypeInfo -> [Char]
(Int -> DotProtoTypeInfo -> [Char] -> [Char])
-> (DotProtoTypeInfo -> [Char])
-> ([DotProtoTypeInfo] -> [Char] -> [Char])
-> Show DotProtoTypeInfo
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> DotProtoTypeInfo -> [Char] -> [Char]
showsPrec :: Int -> DotProtoTypeInfo -> [Char] -> [Char]
$cshow :: DotProtoTypeInfo -> [Char]
show :: DotProtoTypeInfo -> [Char]
$cshowList :: [DotProtoTypeInfo] -> [Char] -> [Char]
showList :: [DotProtoTypeInfo] -> [Char] -> [Char]
Show

tiParent :: Lens' DotProtoTypeInfo DotProtoIdentifier
tiParent :: Lens' DotProtoTypeInfo DotProtoIdentifier
tiParent = (DotProtoTypeInfo -> DotProtoIdentifier)
-> (DotProtoTypeInfo -> DotProtoIdentifier -> DotProtoTypeInfo)
-> Lens' DotProtoTypeInfo 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 = p })

-- | Whether a definition is an enumeration or a message
data DotProtoKind = DotProtoKindEnum
                  | DotProtoKindMessage
                  deriving (Int -> DotProtoKind -> [Char] -> [Char]
[DotProtoKind] -> [Char] -> [Char]
DotProtoKind -> [Char]
(Int -> DotProtoKind -> [Char] -> [Char])
-> (DotProtoKind -> [Char])
-> ([DotProtoKind] -> [Char] -> [Char])
-> Show DotProtoKind
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> DotProtoKind -> [Char] -> [Char]
showsPrec :: Int -> DotProtoKind -> [Char] -> [Char]
$cshow :: DotProtoKind -> [Char]
show :: DotProtoKind -> [Char]
$cshowList :: [DotProtoKind] -> [Char] -> [Char]
showList :: [DotProtoKind] -> [Char] -> [Char]
Show, DotProtoKind -> DotProtoKind -> Bool
(DotProtoKind -> DotProtoKind -> Bool)
-> (DotProtoKind -> DotProtoKind -> Bool) -> Eq DotProtoKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DotProtoKind -> DotProtoKind -> Bool
== :: DotProtoKind -> DotProtoKind -> Bool
$c/= :: DotProtoKind -> DotProtoKind -> Bool
/= :: 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
$ccompare :: DotProtoKind -> DotProtoKind -> Ordering
compare :: DotProtoKind -> DotProtoKind -> Ordering
$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
>= :: DotProtoKind -> DotProtoKind -> Bool
$cmax :: DotProtoKind -> DotProtoKind -> DotProtoKind
max :: DotProtoKind -> DotProtoKind -> DotProtoKind
$cmin :: DotProtoKind -> DotProtoKind -> DotProtoKind
min :: DotProtoKind -> DotProtoKind -> 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
$csucc :: DotProtoKind -> DotProtoKind
succ :: DotProtoKind -> DotProtoKind
$cpred :: DotProtoKind -> DotProtoKind
pred :: DotProtoKind -> DotProtoKind
$ctoEnum :: Int -> DotProtoKind
toEnum :: Int -> DotProtoKind
$cfromEnum :: DotProtoKind -> Int
fromEnum :: DotProtoKind -> Int
$cenumFrom :: DotProtoKind -> [DotProtoKind]
enumFrom :: DotProtoKind -> [DotProtoKind]
$cenumFromThen :: DotProtoKind -> DotProtoKind -> [DotProtoKind]
enumFromThen :: DotProtoKind -> DotProtoKind -> [DotProtoKind]
$cenumFromTo :: DotProtoKind -> DotProtoKind -> [DotProtoKind]
enumFromTo :: DotProtoKind -> DotProtoKind -> [DotProtoKind]
$cenumFromThenTo :: DotProtoKind -> DotProtoKind -> DotProtoKind -> [DotProtoKind]
enumFromThenTo :: DotProtoKind -> DotProtoKind -> DotProtoKind -> [DotProtoKind]
Enum, DotProtoKind
DotProtoKind -> DotProtoKind -> Bounded DotProtoKind
forall a. a -> a -> Bounded a
$cminBound :: DotProtoKind
minBound :: DotProtoKind
$cmaxBound :: DotProtoKind
maxBound :: DotProtoKind
Bounded)

-- ** Generating type contexts from ASTs

dotProtoTypeContext :: MonadError CompileError m => DotProto -> m TypeContext
dotProtoTypeContext :: forall (m :: * -> *).
MonadError CompileError m =>
DotProto -> m TypeContext
dotProtoTypeContext DotProto{[DotProtoDefinition]
[DotProtoOption]
[DotProtoImport]
DotProtoMeta
DotProtoPackageSpec
protoImports :: [DotProtoImport]
protoOptions :: [DotProtoOption]
protoPackage :: DotProtoPackageSpec
protoDefinitions :: [DotProtoDefinition]
protoMeta :: DotProtoMeta
protoMeta :: DotProto -> DotProtoMeta
protoDefinitions :: DotProto -> [DotProtoDefinition]
protoPackage :: DotProto -> DotProtoPackageSpec
protoOptions :: DotProto -> [DotProtoOption]
protoImports :: DotProto -> [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 :: forall (m :: * -> *).
MonadError CompileError m =>
Path -> DotProtoDefinition -> m TypeContext
definitionTypeContext Path
modulePath (DotProtoMessage [Char]
_ DotProtoIdentifier
msgIdent [DotProtoMessagePart]
parts) = do
  let updateParent :: DotProtoTypeInfo -> m DotProtoTypeInfo
updateParent = (DotProtoIdentifier -> m DotProtoIdentifier)
-> DotProtoTypeInfo -> m DotProtoTypeInfo
Lens' DotProtoTypeInfo 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> Map DotProtoIdentifier a -> f (Map DotProtoIdentifier 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 { 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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeContext -> m TypeContext) -> TypeContext -> m TypeContext
forall a b. (a -> b) -> a -> b
$ 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 [Char]
_ DotProtoIdentifier
enumIdent [DotProtoEnumPart]
_) = do
  let tyInfo :: DotProtoTypeInfo
tyInfo = 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 a. a -> m a
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 a. a -> m a
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 :: [Char] -> [DotProtoOption] -> Maybe Bool
boolOption [Char]
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
== [Char] -> DotProtoIdentifier
Single [Char]
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
. [Char] -> [DotProtoOption] -> Maybe Bool
boolOption [Char]
"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
. [Char] -> [DotProtoOption] -> Maybe Bool
boolOption [Char]
"packed"

-- | 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 :: forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
i1 DotProtoIdentifier
i2 = case (DotProtoIdentifier
i1, DotProtoIdentifier
i2) of
  (Qualified{}  ,  DotProtoIdentifier
_           ) -> [Char] -> m DotProtoIdentifier
forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
internalError [Char]
"concatDotProtoIdentifier: Qualified"
  (DotProtoIdentifier
_            , Qualified{}  ) -> [Char] -> m DotProtoIdentifier
forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
internalError [Char]
"concatDotProtoIdentifier Qualified"
  (DotProtoIdentifier
Anonymous    , DotProtoIdentifier
Anonymous    ) -> DotProtoIdentifier -> m DotProtoIdentifier
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DotProtoIdentifier
Anonymous
  (DotProtoIdentifier
Anonymous    , DotProtoIdentifier
b            ) -> DotProtoIdentifier -> m DotProtoIdentifier
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DotProtoIdentifier
b
  (DotProtoIdentifier
a            , DotProtoIdentifier
Anonymous    ) -> DotProtoIdentifier -> m DotProtoIdentifier
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DotProtoIdentifier
a
  (Single [Char]
a     , DotProtoIdentifier
b            ) -> DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier (Path -> DotProtoIdentifier
Dots (NonEmpty [Char] -> Path
Path ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
a))) DotProtoIdentifier
b
  (DotProtoIdentifier
a            , Single [Char]
b     ) -> DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m DotProtoIdentifier
concatDotProtoIdentifier DotProtoIdentifier
a (Path -> DotProtoIdentifier
Dots (NonEmpty [Char] -> Path
Path ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
b)))
  (Dots (Path NonEmpty [Char]
a), Dots (Path NonEmpty [Char]
b)) -> DotProtoIdentifier -> m DotProtoIdentifier
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path -> DotProtoIdentifier
Dots (NonEmpty [Char] -> Path
Path (NonEmpty [Char]
a NonEmpty [Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
b)))

-- | @'toPascalCase' xs'@ sends a snake-case string @xs@ to a pascal-cased string. Trailing underscores are not dropped
-- from the input string and exactly double underscores are replaced by a single underscore.
toPascalCase :: String -> String
toPascalCase :: [Char] -> [Char]
toPascalCase [Char]
xs = (Either [Char] [Char] -> [Char])
-> [Either [Char] [Char]] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Either [Char] [Char] -> [Char]
forall {a}. (Eq a, IsString a) => Either [Char] a -> [Char]
go ((Char -> Bool) -> [Char] -> [Either [Char] [Char]]
forall a. (a -> Bool) -> [a] -> [Either [a] [a]]
segmentBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') [Char]
xs)
  where
    go :: Either [Char] a -> [Char]
go (Left [Char]
seg) = [Char] -> [Char]
toUpperFirst [Char]
seg
    go (Right a
seg)
      | a
seg a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"__" = [Char]
"_"
      | Bool
otherwise = [Char]
""

-- | @'toCamelCase' xs@ sends a snake-case string @xs@ to a camel-cased string.
toCamelCase :: String -> String
toCamelCase :: [Char] -> [Char]
toCamelCase [Char]
xs =
  case [Char] -> [Char]
toPascalCase [Char]
xs of
    [Char]
"" -> [Char]
""
    Char
x : [Char]
xs' -> Char -> Char
toLower Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs'

-- | Uppercases the first character of a string.
--
-- ==== __Examples__
--
-- >>> toUpperFirst "abc"
-- "Abc"
--
-- >>> toUpperFirst ""
-- ""
toUpperFirst :: String -> String
toUpperFirst :: [Char] -> [Char]
toUpperFirst [Char]
"" = [Char]
""
toUpperFirst (Char
x : [Char]
xs) = Char -> Char
toUpper Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs

-- | @'segmentBy' p xs@  partitions @xs@ into segments of @'Either' [a] [a]@
-- with:
--
-- * 'Right' sublists containing elements satisfying @p@, otherwise;
--
-- * 'Left' sublists containing elements that do not satisfy @p@
--
-- ==== __Examples__
--
-- >>> segmentBy (\c -> c == '_') "abc_123_xyz"
-- [Left "abc",Right "_",Left "123",Right "_",Left "xyz"]
segmentBy :: (a -> Bool) -> [a] -> [Either [a] [a]]
segmentBy :: forall a. (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' p xs@ yields @'Right' (xs', suf)@ if @suf@ is the longest suffix satisfying @p@ and @xs'@ is the rest
-- of the rest, otherwise the string is given back as @'Left' xs@ signifying @xs@ had no suffix satisfying @p@.
suffixBy :: forall a. (a -> Bool) -> [a] -> Either [a] ([a], [a])
suffixBy :: forall a. (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 a b. (a -> b -> b) -> b -> [a] -> b
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 a. [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 a. a -> Either [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' xs@ produces either the pascal-cased version of the string @xs@ if it begins with an alphabetical
-- character or underscore - which is replaced with 'X'. A 'CompileError' is emitted if the starting character is
-- non-alphabetic or if @xs == ""@.
typeLikeName :: MonadError CompileError m => String -> m String
typeLikeName :: forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> m [Char]
typeLikeName [Char]
"" = [Char] -> m [Char]
forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
invalidTypeNameError [Char]
"<empty name>"
typeLikeName s :: [Char]
s@(Char
x : [Char]
xs)
  | Char -> Bool
isAlpha Char
x = [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ case (Char -> Bool) -> [Char] -> Either [Char] ([Char], [Char])
forall a. (a -> Bool) -> [a] -> Either [a] ([a], [a])
suffixBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') [Char]
s of
      Left [Char]
xs' -> [Char] -> [Char]
invalidToCamelCase ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
toPascalCase [Char]
xs'
      Right ([Char]
xs', [Char]
suf) -> [Char] -> [Char]
invalidToCamelCase ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
toPascalCase [Char]
xs' [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
suf
  | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' = [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ case (Char -> Bool) -> [Char] -> Either [Char] ([Char], [Char])
forall a. (a -> Bool) -> [a] -> Either [a] ([a], [a])
suffixBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') [Char]
xs of
      Left [Char]
xs' -> [Char] -> [Char]
invalidToCamelCase ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Char
'X' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
toPascalCase [Char]
xs'
      Right ([Char]
xs', [Char]
suf) -> [Char] -> [Char]
invalidToCamelCase ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Char
'X' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: ([Char] -> [Char]
toPascalCase [Char]
xs' [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
suf)
  | Bool
otherwise = [Char] -> m [Char]
forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
invalidTypeNameError [Char]
s
  where
    -- Transforms special characters that are not valid as a part of a Haskell name to CamelCase.
    -- For instance “foo-bar---baz” will become “FooBarBaz”.
    -- This function presumes that the first character of the initial value satisfies "isAlpha".
    -- This must be checked outside of this function.
    invalidToCamelCase :: [Char] -> [Char]
invalidToCamelCase [Char]
a =
      case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isValidNameChar [Char]
a of
        ([Char]
"", [Char]
"") -> [Char]
""
        ([Char]
"", [Char]
cs) -> [Char] -> [Char]
invalidToCamelCase ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
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) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
cs
        (Char
b : [Char]
bs, [Char]
cs) -> Char -> Char
toUpper Char
b Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
bs [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
invalidToCamelCase [Char]
cs

    -- Only valid as a secondary character.
    -- First character of a Haskell name can only be "isAlpha".
    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' field@ is the casing transformation used to produce record selectors from message fields. If
-- @field@ is prefixed by a span of uppercase characters then that prefix will be lowercased while the remaining string
-- is left unchanged.
fieldLikeName :: String -> String
fieldLikeName :: [Char] -> [Char]
fieldLikeName [Char]
"" = [Char]
""
fieldLikeName (Char
x : [Char]
xs)
  | Char -> Bool
isUpper Char
x = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
suffix
  | Bool
otherwise = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs
  where ([Char]
prefix, [Char]
suffix) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUpper (Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs)

prefixedEnumFieldName :: String -> String -> String
prefixedEnumFieldName :: [Char] -> [Char] -> [Char]
prefixedEnumFieldName [Char]
enumName [Char]
enumItem = [Char]
enumName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
enumItem

prefixedConName :: MonadError CompileError m => String -> String -> m String
prefixedConName :: forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> [Char] -> m [Char]
prefixedConName [Char]
msgName [Char]
conName = do
  [Char]
constructor <- [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> m [Char]
typeLikeName [Char]
conName
  [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
msgName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
constructor)

-- | @'prefixedMethodName' service method@ produces a Haskell record selector name for the service method @method@ by
-- joining the names @service@, @method@ under concatenation on a camel-casing transformation.
prefixedMethodName :: MonadError CompileError m => String -> String -> m String
prefixedMethodName :: forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> [Char] -> m [Char]
prefixedMethodName [Char]
_ [Char]
"" = [Char] -> m [Char]
forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
invalidTypeNameError [Char]
"<empty name>"
prefixedMethodName [Char]
serviceName (Char
x : [Char]
xs)
  | Char -> Bool
isLower Char
x = [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [Char]
fieldLikeName [Char]
serviceName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
fieldLikeName (Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs))
  | Bool
otherwise = do
      [Char]
method <- [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> m [Char]
typeLikeName (Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs)
      [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [Char]
fieldLikeName [Char]
serviceName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
method)

-- | @'prefixedFieldName' prefix field@ constructs a Haskell record selector name by prepending @prefix@ in camel-case
-- to the message field/service method name @field@.
prefixedFieldName :: MonadError CompileError m => String -> String -> m String
prefixedFieldName :: forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> [Char] -> m [Char]
prefixedFieldName [Char]
msgName [Char]
fieldName = do
  [Char]
field <- [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> m [Char]
typeLikeName [Char]
fieldName
  [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [Char]
fieldLikeName [Char]
msgName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
field)

dpIdentUnqualName :: MonadError CompileError m => DotProtoIdentifier -> m String
dpIdentUnqualName :: forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m [Char]
dpIdentUnqualName (Single [Char]
name)       = [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
name
dpIdentUnqualName (Dots (Path NonEmpty [Char]
names)) = [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty [Char] -> [Char]
forall a. NonEmpty a -> a
NE.last NonEmpty [Char]
names)
dpIdentUnqualName (Qualified DotProtoIdentifier
_ DotProtoIdentifier
next)  = DotProtoIdentifier -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m [Char]
dpIdentUnqualName DotProtoIdentifier
next
dpIdentUnqualName DotProtoIdentifier
Anonymous           = [Char] -> m [Char]
forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
internalError [Char]
"dpIdentUnqualName: Anonymous"

dpIdentQualName :: MonadError CompileError m => DotProtoIdentifier -> m String
dpIdentQualName :: forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m [Char]
dpIdentQualName (Single [Char]
name)       = [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
name
dpIdentQualName (Dots (Path NonEmpty [Char]
names)) = [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." (NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
names))
dpIdentQualName (Qualified DotProtoIdentifier
_ DotProtoIdentifier
_)     = [Char] -> m [Char]
forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
internalError [Char]
"dpIdentQualName: Qualified"
dpIdentQualName DotProtoIdentifier
Anonymous           = [Char] -> m [Char]
forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
internalError [Char]
"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 :: forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> [Char] -> m [Char]
nestedTypeName DotProtoIdentifier
Anonymous             [Char]
nm = [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> m [Char]
typeLikeName [Char]
nm
nestedTypeName (Single [Char]
parent)       [Char]
nm = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"_" ([[Char]] -> [Char]) -> m [[Char]] -> m [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> m [Char]) -> [[Char]] -> m [[Char]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> m [Char]
typeLikeName [[Char]
parent, [Char]
nm]
nestedTypeName (Dots (Path NonEmpty [Char]
parents)) [Char]
nm = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"_" ([[Char]] -> [Char])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
nm]) ([[Char]] -> [Char]) -> m [[Char]] -> m [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> m [Char]) -> [[Char]] -> m [[Char]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> m [Char]
typeLikeName (NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
parents)
nestedTypeName (Qualified {})        [Char]
_  = [Char] -> m [Char]
forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
internalError [Char]
"nestedTypeName: Qualified"

qualifiedMessageName :: MonadError CompileError m => DotProtoIdentifier -> DotProtoIdentifier -> m String
qualifiedMessageName :: forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> DotProtoIdentifier -> m [Char]
qualifiedMessageName DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent = DotProtoIdentifier -> [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> [Char] -> m [Char]
nestedTypeName DotProtoIdentifier
parentIdent ([Char] -> m [Char]) -> m [Char] -> m [Char]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m [Char]
dpIdentUnqualName DotProtoIdentifier
msgIdent

qualifiedMessageTypeName :: MonadError CompileError m =>
                            TypeContext ->
                            DotProtoIdentifier ->
                            DotProtoIdentifier ->
                            m String
qualifiedMessageTypeName :: forall (m :: * -> *).
MonadError CompileError m =>
TypeContext -> DotProtoIdentifier -> DotProtoIdentifier -> m [Char]
qualifiedMessageTypeName TypeContext
ctxt DotProtoIdentifier
parentIdent DotProtoIdentifier
msgIdent = do
  [[Char]]
xs <- DotProtoIdentifier -> [[Char]] -> m [[Char]]
forall {f :: * -> *}.
MonadError CompileError f =>
DotProtoIdentifier -> [[Char]] -> f [[Char]]
parents DotProtoIdentifier
parentIdent []
  case [[Char]]
xs of
    [] -> DotProtoIdentifier -> [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> [Char] -> m [Char]
nestedTypeName DotProtoIdentifier
parentIdent ([Char] -> m [Char]) -> m [Char] -> m [Char]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m [Char]
dpIdentUnqualName DotProtoIdentifier
msgIdent
    [Char]
x : [[Char]]
xs' -> DotProtoIdentifier -> [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> [Char] -> m [Char]
nestedTypeName (Path -> DotProtoIdentifier
Dots (Path -> DotProtoIdentifier)
-> (NonEmpty [Char] -> Path)
-> NonEmpty [Char]
-> DotProtoIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [Char] -> Path
Path (NonEmpty [Char] -> DotProtoIdentifier)
-> NonEmpty [Char] -> DotProtoIdentifier
forall a b. (a -> b) -> a -> b
$ [Char]
x [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
NE.:| [[Char]]
xs') ([Char] -> m [Char]) -> m [Char] -> m [Char]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DotProtoIdentifier -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m [Char]
dpIdentUnqualName DotProtoIdentifier
msgIdent
  where
    parents :: DotProtoIdentifier -> [[Char]] -> f [[Char]]
parents par :: DotProtoIdentifier
par@(Single [Char]
x) [[Char]]
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 -> [[Char]] -> f [[Char]]
parents DotProtoIdentifier
parentIdent' ([[Char]] -> f [[Char]]) -> [[Char]] -> f [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char]
x [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
xs
        Maybe DotProtoTypeInfo
Nothing ->
          [[Char]] -> f [[Char]]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> f [[Char]]) -> [[Char]] -> f [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char]
x [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
xs
    parents DotProtoIdentifier
Anonymous [[Char]]
xs =
      [[Char]] -> f [[Char]]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]]
xs
    parents DotProtoIdentifier
par [[Char]]
_ =
      [Char] -> f [[Char]]
forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
internalError ([Char] -> f [[Char]]) -> [Char] -> f [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char]
"qualifiedMessageTypeName: wrong parent " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> DotProtoIdentifier -> [Char]
forall a. Show a => a -> [Char]
show DotProtoIdentifier
par

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

-- | Bookeeping for qualified fields
data QualifiedField = QualifiedField
  { QualifiedField -> FieldName
recordFieldName   :: FieldName
  , QualifiedField -> FieldInfo
fieldInfo         :: FieldInfo
  } deriving Int -> QualifiedField -> [Char] -> [Char]
[QualifiedField] -> [Char] -> [Char]
QualifiedField -> [Char]
(Int -> QualifiedField -> [Char] -> [Char])
-> (QualifiedField -> [Char])
-> ([QualifiedField] -> [Char] -> [Char])
-> Show QualifiedField
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> QualifiedField -> [Char] -> [Char]
showsPrec :: Int -> QualifiedField -> [Char] -> [Char]
$cshow :: QualifiedField -> [Char]
show :: QualifiedField -> [Char]
$cshowList :: [QualifiedField] -> [Char] -> [Char]
showList :: [QualifiedField] -> [Char] -> [Char]
Show

-- | Bookkeeping for fields
data FieldInfo
  = FieldOneOf FieldName OneofField
  | FieldNormal FieldName FieldNumber DotProtoType [DotProtoOption]
  deriving Int -> FieldInfo -> [Char] -> [Char]
[FieldInfo] -> [Char] -> [Char]
FieldInfo -> [Char]
(Int -> FieldInfo -> [Char] -> [Char])
-> (FieldInfo -> [Char])
-> ([FieldInfo] -> [Char] -> [Char])
-> Show FieldInfo
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> FieldInfo -> [Char] -> [Char]
showsPrec :: Int -> FieldInfo -> [Char] -> [Char]
$cshow :: FieldInfo -> [Char]
show :: FieldInfo -> [Char]
$cshowList :: [FieldInfo] -> [Char] -> [Char]
showList :: [FieldInfo] -> [Char] -> [Char]
Show

-- | Bookkeeping for oneof fields
data OneofField = OneofField
  { OneofField -> [Char]
oneofType :: String
  , OneofField -> [OneofSubfield]
subfields :: [OneofSubfield]
  } deriving Int -> OneofField -> [Char] -> [Char]
[OneofField] -> [Char] -> [Char]
OneofField -> [Char]
(Int -> OneofField -> [Char] -> [Char])
-> (OneofField -> [Char])
-> ([OneofField] -> [Char] -> [Char])
-> Show OneofField
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> OneofField -> [Char] -> [Char]
showsPrec :: Int -> OneofField -> [Char] -> [Char]
$cshow :: OneofField -> [Char]
show :: OneofField -> [Char]
$cshowList :: [OneofField] -> [Char] -> [Char]
showList :: [OneofField] -> [Char] -> [Char]
Show

-- | Bookkeeping for oneof subfields
data OneofSubfield = OneofSubfield
  { OneofSubfield -> FieldNumber
subfieldNumber       :: FieldNumber
  , OneofSubfield -> [Char]
subfieldConsName     :: String
  , OneofSubfield -> FieldName
subfieldName         :: FieldName
  , OneofSubfield -> DotProtoType
subfieldType         :: DotProtoType
  , OneofSubfield -> [DotProtoOption]
subfieldOptions      :: [DotProtoOption]
  } deriving Int -> OneofSubfield -> [Char] -> [Char]
[OneofSubfield] -> [Char] -> [Char]
OneofSubfield -> [Char]
(Int -> OneofSubfield -> [Char] -> [Char])
-> (OneofSubfield -> [Char])
-> ([OneofSubfield] -> [Char] -> [Char])
-> Show OneofSubfield
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> OneofSubfield -> [Char] -> [Char]
showsPrec :: Int -> OneofSubfield -> [Char] -> [Char]
$cshow :: OneofSubfield -> [Char]
show :: OneofSubfield -> [Char]
$cshowList :: [OneofSubfield] -> [Char] -> [Char]
showList :: [OneofSubfield] -> [Char] -> [Char]
Show

getQualifiedFields :: MonadError CompileError m
                   => String -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields :: forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> [DotProtoMessagePart] -> m [QualifiedField]
getQualifiedFields [Char]
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{[Char]
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldNumber :: FieldNumber
dotProtoFieldType :: DotProtoType
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldComment :: [Char]
dotProtoFieldComment :: DotProtoField -> [Char]
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
..} -> do
    [Char]
fieldName <- DotProtoIdentifier -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m [Char]
dpIdentUnqualName DotProtoIdentifier
dotProtoFieldName
    [Char]
qualName <- [Char] -> [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> [Char] -> m [Char]
prefixedFieldName [Char]
msgName [Char]
fieldName
    [QualifiedField] -> m [QualifiedField]
forall a. a -> m a
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 { recordFieldName :: FieldName
recordFieldName = [Char] -> FieldName
forall a b. Coercible a b => a -> b
coerce [Char]
qualName
                                  , fieldInfo :: FieldInfo
fieldInfo = FieldName
-> FieldNumber -> DotProtoType -> [DotProtoOption] -> FieldInfo
FieldNormal ([Char] -> FieldName
forall a b. Coercible a b => a -> b
coerce [Char]
fieldName)
                                                            FieldNumber
dotProtoFieldNumber
                                                            DotProtoType
dotProtoFieldType
                                                            [DotProtoOption]
dotProtoFieldOptions
                                  }

  DotProtoMessageOneOf DotProtoIdentifier
_ [] ->
    CompileError -> m [QualifiedField]
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> CompileError
InternalError [Char]
"getQualifiedFields: encountered oneof with no oneof fields")

  DotProtoMessageOneOf DotProtoIdentifier
oneofIdent [DotProtoField]
fields -> do
    [Char]
ident <- DotProtoIdentifier -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m [Char]
dpIdentUnqualName DotProtoIdentifier
oneofIdent
    [Char]
oneofName <- [Char] -> [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> [Char] -> m [Char]
prefixedFieldName [Char]
msgName [Char]
ident
    [Char]
oneofTypeName <- [Char] -> [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> [Char] -> m [Char]
prefixedConName [Char]
msgName [Char]
ident

    let mkSubfield :: DotProtoField -> m [OneofSubfield]
mkSubfield DotProtoField{[Char]
[DotProtoOption]
FieldNumber
DotProtoType
DotProtoIdentifier
dotProtoFieldComment :: DotProtoField -> [Char]
dotProtoFieldOptions :: DotProtoField -> [DotProtoOption]
dotProtoFieldName :: DotProtoField -> DotProtoIdentifier
dotProtoFieldType :: DotProtoField -> DotProtoType
dotProtoFieldNumber :: DotProtoField -> FieldNumber
dotProtoFieldNumber :: FieldNumber
dotProtoFieldType :: DotProtoType
dotProtoFieldName :: DotProtoIdentifier
dotProtoFieldOptions :: [DotProtoOption]
dotProtoFieldComment :: [Char]
..} = do
            [Char]
s <- DotProtoIdentifier -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
DotProtoIdentifier -> m [Char]
dpIdentUnqualName DotProtoIdentifier
dotProtoFieldName
            [Char]
c <- [Char] -> [Char] -> m [Char]
forall (m :: * -> *).
MonadError CompileError m =>
[Char] -> [Char] -> m [Char]
prefixedConName [Char]
oneofTypeName [Char]
s
            [OneofSubfield] -> m [OneofSubfield]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ OneofSubfield
                     { subfieldNumber :: FieldNumber
subfieldNumber       = FieldNumber
dotProtoFieldNumber
                     , subfieldConsName :: [Char]
subfieldConsName     = [Char]
c
                     , subfieldName :: FieldName
subfieldName         = [Char] -> FieldName
forall a b. Coercible a b => a -> b
coerce [Char]
s
                     , subfieldType :: DotProtoType
subfieldType         = DotProtoType
dotProtoFieldType
                     , subfieldOptions :: [DotProtoOption]
subfieldOptions      = [DotProtoOption]
dotProtoFieldOptions
                     }
                 ]

    [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 a. a -> m a
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
                     { recordFieldName :: FieldName
recordFieldName = [Char] -> FieldName
forall a b. Coercible a b => a -> b
coerce [Char]
oneofName
                     , fieldInfo :: FieldInfo
fieldInfo = FieldName -> OneofField -> FieldInfo
FieldOneOf ([Char] -> FieldName
forall a b. Coercible a b => a -> b
coerce [Char]
ident) ([Char] -> [OneofSubfield] -> OneofField
OneofField [Char]
ident [OneofSubfield]
fieldElems)
                     }
  DotProtoMessagePart
_ -> [QualifiedField] -> m [QualifiedField]
forall a. a -> m a
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 :: forall a.
(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 FieldName
_ OneofField
fld))               = OneofField -> a
g OneofField
fld

fieldBinder :: FieldNumber -> String
fieldBinder :: FieldNumber -> [Char]
fieldBinder = ([Char]
"f" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char])
-> (FieldNumber -> [Char]) -> FieldNumber -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNumber -> [Char]
forall a. Show a => a -> [Char]
show

oneofSubBinder :: OneofSubfield -> String
oneofSubBinder :: OneofSubfield -> [Char]
oneofSubBinder = FieldNumber -> [Char]
fieldBinder (FieldNumber -> [Char])
-> (OneofSubfield -> FieldNumber) -> OneofSubfield -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneofSubfield -> FieldNumber
subfieldNumber

oneofSubDisjunctBinder :: [OneofSubfield] -> String
oneofSubDisjunctBinder :: [OneofSubfield] -> [Char]
oneofSubDisjunctBinder = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"_or_" ([[Char]] -> [Char])
-> ([OneofSubfield] -> [[Char]]) -> [OneofSubfield] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OneofSubfield -> [Char]) -> [OneofSubfield] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OneofSubfield -> [Char]
oneofSubBinder

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

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
  | RedefinedFields (Histogram FieldName) (Histogram FieldNumber)
      -- ^ At least one field/oneof name and or field number was
      -- used more than once within the same message definition,
      -- which violates the protobuf specification.  The histograms
      -- mention only the repeated names and numbers, not the ones
      -- used only once.
  deriving (Int -> CompileError -> [Char] -> [Char]
[CompileError] -> [Char] -> [Char]
CompileError -> [Char]
(Int -> CompileError -> [Char] -> [Char])
-> (CompileError -> [Char])
-> ([CompileError] -> [Char] -> [Char])
-> Show CompileError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> CompileError -> [Char] -> [Char]
showsPrec :: Int -> CompileError -> [Char] -> [Char]
$cshow :: CompileError -> [Char]
show :: CompileError -> [Char]
$cshowList :: [CompileError] -> [Char] -> [Char]
showList :: [CompileError] -> [Char] -> [Char]
Show, CompileError -> CompileError -> Bool
(CompileError -> CompileError -> Bool)
-> (CompileError -> CompileError -> Bool) -> Eq CompileError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompileError -> CompileError -> Bool
== :: CompileError -> CompileError -> Bool
$c/= :: CompileError -> CompileError -> Bool
/= :: CompileError -> CompileError -> Bool
Eq)


internalError :: MonadError CompileError m => String -> m a
internalError :: forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
internalError = CompileError -> m a
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m a) -> ([Char] -> CompileError) -> [Char] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> CompileError
InternalError

invalidTypeNameError :: MonadError CompileError m => String -> m a
invalidTypeNameError :: forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
invalidTypeNameError = CompileError -> m a
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m a) -> ([Char] -> CompileError) -> [Char] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> CompileError
InvalidTypeName

_unimplementedError :: MonadError CompileError m => String -> m a
_unimplementedError :: forall (m :: * -> *) a. MonadError CompileError m => [Char] -> m a
_unimplementedError = CompileError -> m a
forall a. CompileError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> m a) -> ([Char] -> CompileError) -> [Char] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> CompileError
Unimplemented

invalidMethodNameError :: MonadError CompileError m => DotProtoIdentifier -> m a
invalidMethodNameError :: forall (m :: * -> *) a.
MonadError CompileError m =>
DotProtoIdentifier -> m a
invalidMethodNameError = CompileError -> m a
forall a. 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 :: forall (m :: * -> *) a.
MonadError CompileError m =>
DotProtoIdentifier -> m a
noSuchTypeError = CompileError -> m a
forall a. 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


newtype Histogram a = Histogram (M.Map a Int)
  deriving stock (Histogram a -> Histogram a -> Bool
(Histogram a -> Histogram a -> Bool)
-> (Histogram a -> Histogram a -> Bool) -> Eq (Histogram a)
forall a. Eq a => Histogram a -> Histogram a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Histogram a -> Histogram a -> Bool
== :: Histogram a -> Histogram a -> Bool
$c/= :: forall a. Eq a => Histogram a -> Histogram a -> Bool
/= :: Histogram a -> Histogram a -> Bool
Eq, Eq (Histogram a)
Eq (Histogram a) =>
(Histogram a -> Histogram a -> Ordering)
-> (Histogram a -> Histogram a -> Bool)
-> (Histogram a -> Histogram a -> Bool)
-> (Histogram a -> Histogram a -> Bool)
-> (Histogram a -> Histogram a -> Bool)
-> (Histogram a -> Histogram a -> Histogram a)
-> (Histogram a -> Histogram a -> Histogram a)
-> Ord (Histogram a)
Histogram a -> Histogram a -> Bool
Histogram a -> Histogram a -> Ordering
Histogram a -> Histogram a -> Histogram a
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
forall a. Ord a => Eq (Histogram a)
forall a. Ord a => Histogram a -> Histogram a -> Bool
forall a. Ord a => Histogram a -> Histogram a -> Ordering
forall a. Ord a => Histogram a -> Histogram a -> Histogram a
$ccompare :: forall a. Ord a => Histogram a -> Histogram a -> Ordering
compare :: Histogram a -> Histogram a -> Ordering
$c< :: forall a. Ord a => Histogram a -> Histogram a -> Bool
< :: Histogram a -> Histogram a -> Bool
$c<= :: forall a. Ord a => Histogram a -> Histogram a -> Bool
<= :: Histogram a -> Histogram a -> Bool
$c> :: forall a. Ord a => Histogram a -> Histogram a -> Bool
> :: Histogram a -> Histogram a -> Bool
$c>= :: forall a. Ord a => Histogram a -> Histogram a -> Bool
>= :: Histogram a -> Histogram a -> Bool
$cmax :: forall a. Ord a => Histogram a -> Histogram a -> Histogram a
max :: Histogram a -> Histogram a -> Histogram a
$cmin :: forall a. Ord a => Histogram a -> Histogram a -> Histogram a
min :: Histogram a -> Histogram a -> Histogram a
Ord, Int -> Histogram a -> [Char] -> [Char]
[Histogram a] -> [Char] -> [Char]
Histogram a -> [Char]
(Int -> Histogram a -> [Char] -> [Char])
-> (Histogram a -> [Char])
-> ([Histogram a] -> [Char] -> [Char])
-> Show (Histogram a)
forall a. Show a => Int -> Histogram a -> [Char] -> [Char]
forall a. Show a => [Histogram a] -> [Char] -> [Char]
forall a. Show a => Histogram a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Histogram a -> [Char] -> [Char]
showsPrec :: Int -> Histogram a -> [Char] -> [Char]
$cshow :: forall a. Show a => Histogram a -> [Char]
show :: Histogram a -> [Char]
$cshowList :: forall a. Show a => [Histogram a] -> [Char] -> [Char]
showList :: [Histogram a] -> [Char] -> [Char]
Show)

instance Ord a => Semigroup (Histogram a)
  where
    Histogram Map a Int
x <> :: Histogram a -> Histogram a -> Histogram a
<> Histogram Map a Int
y = Map a Int -> Histogram a
forall a. Map a Int -> Histogram a
Histogram ((Int -> Int -> Int) -> Map a Int -> Map a Int -> Map a Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Map a Int
x Map a Int
y)

instance Ord a => Monoid (Histogram a)
  where
    mempty :: Histogram a
mempty = Map a Int -> Histogram a
forall a. Map a Int -> Histogram a
Histogram Map a Int
forall k a. Map k a
M.empty

oneOccurrence :: a -> Histogram a
oneOccurrence :: forall a. a -> Histogram a
oneOccurrence a
k = Map a Int -> Histogram a
forall a. Map a Int -> Histogram a
Histogram (a -> Int -> Map a Int
forall k a. k -> a -> Map k a
M.singleton a
k Int
1)

mulipleOccurrencesOnly :: Histogram a -> Histogram a
mulipleOccurrencesOnly :: forall a. Histogram a -> Histogram a
mulipleOccurrencesOnly (Histogram Map a Int
m) = Map a Int -> Histogram a
forall a. Map a Int -> Histogram a
Histogram ((Int -> Bool) -> Map a Int -> Map a Int
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<) Map a Int
m)