{-# LANGUAGE RankNTypes, FlexibleContexts, ScopedTypeVariables #-}
{-  fixing resolution.  This is a large beast of a module.  Sorry.
  updated for version 2.0.3 to match protoc's namespace resolution better
  updated for version 2.0.4 to differentiate Entity and E'Entity, this makes eName a total selector
  updated after version 2.0.5 to fix problem when package name was not specified in proto file.
    main calls either runStandalone or runPlugin which call loadProto or loadStandalone which both call loadProto'
      loadProto' uses getPackage to make packageName, loads the imports, and passes all this to makeTopLevel to get Env

        The "load" loop in loadProto' caches the imported TopLevel based on _filename_
           files can be loaded via multiple paths but this is not important
           this may interact badly with absent "package" declarations that act as part of importing package
             need these to be "polymorphic" in the packageID somehow?

        Speculate: makeTopLevel knows the parent from the imports:
           parent with explicit package could resolve "polymorphic" imports by a recursive transformation?
           parent with no explicit package could do nothing.
           root will need default explicit package name ? or special handling in loadProto' or load* ?

    Then loadProto or loadStandalone both call run' which calls makeNameMaps with the Env from loadProto'
      makeNameMaps calls makeNameMap on each top level fdp from each TopLevel in the Global Env from loadProto'
        makeNameMap calls getPackage to form packageName, and unless overridden it is also used for hParent

          makeNameMap on the imports gets called without any special knowledge of the "parent".  If
          root or some imports are still "polymorphic" then this is most annoying.

    Alternative solution: a middle step after makeTopLevel and before makeNameMaps examines and fixes all the polymorphic imports.

    The nameMap this computes is passed by run' to makeProtoInfo from MakeReflections

    The bug is being reported by main>runStandalon>loadStandalone>loadProto'>makeTopLevel>resolveFDP>fqFileDP>fqMessage>fqField>resolvePredEnv


  entityField uses resolveMGE instead of expectMGE and resolveEnv : this should allow field types to resolve just to MGE insteadof other field names.

  what about keys 'extendee' resolution to Message names only? expectM in entityField

  'makeTopLevel' is the main internal entry point in this module.
  This is called from loadProto' which has two callers:
  loadProto and loadCodeGenRequest

  makeTopLevel uses a lazy 'myFixSE' trick and so the order of execution is not immediately clear.

  The environment for name resolution comes from the global' declaration which first involves using
  resolveFDP/runRE (E'Entity).  To make things more complicated the definition of global' passes
  global' to (resolveFDP fdp).

  The resolveFDP/runRE runs all the fq* stuff (E'Entity and consumeUNO/interpretOption/resolveHere).

  Note that the only source of E'Error values of E'Entity are from 'unique' detecting name
  collisions.

  This global' environment gets fed back in as global'Param to form the SEnv for running the
  entityMsg, entityField, entityEnum, entityService functions.  These clean up the parsed descriptor
  proto structures into dependable and fully resolved ones.

  The kids operator and the unZip are used to seprate and collect all the error messages, so that
  they can be checked for and reported as a group.

  ====

  Problem? Nesting namespaces allows shadowing.  I forget if Google's protoc allows this.

  Problem? When the current file being resolves has the same package name as an imported file then
   hprotoc will find unqualified names in the local name space and the imported name space.  But if
   there is a name collision between the two then hprotoc will not detect this; the unqualified name
   will resolve to the local file and not observe the duplicate from the import.  TODO: check what
   Google's protoc does in this case.

  Solution to either of the above might be to resolve to a list of successes and check for a single
  success.  This may be too lazy.

  ====

  aggregate option types not handled: Need to take fk and bytestring from parser and:
    1) look at mVal of fk (E'Message) to understand what fields are expected (listed in mVals of this mVal).
    2) lex the bytestring
    3) parse the sequence of "name" ":" "value" by doing
      4) find "name" in the expected list from (1) (E'Field)
      5) Look at the fType of this E'Field and parse the "value", if Nothing (message/group/enum) then
         6) resolve name and look at mVal
         7) if enum then parse "value" as identifier or if message or group
            8) recursively go to (1) and either prepend lenght (message) or append stop tag (group)
      9) runPut to get the wire encoded field tag and value when Just a simple type
    10) concatentanate the results of (3) to get the wire encoding for the message value

  Handling recursive message/groups makes this more annoying.

-}

-- | This huge module handles the loading and name resolution.  The
-- loadProto command recursively gets all the imported proto files.
-- The makeNameMaps command makes the translator from proto name to
-- Haskell name.  Many possible errors in the proto data are caught
-- and reported by these operations.
--
-- hprotoc will actually resolve more unqualified imported names than Google's protoc which requires
-- more qualified names.  I do not have the obsessive nature to fix this.
module Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto,loadCodeGenRequest,makeNameMaps,getTLS,getPackageID
                                                ,Env(..),TopLevel(..),ReMap,NameMap(..),PackageID(..),LocalFP(..),CanonFP(..)) where

import qualified Text.DescriptorProtos.DescriptorProto                as D(DescriptorProto)
import qualified Text.DescriptorProtos.DescriptorProto                as D.DescriptorProto(DescriptorProto(..))
import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D(ExtensionRange(ExtensionRange))
import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.ExtensionRange(ExtensionRange(..))
import qualified Text.DescriptorProtos.EnumDescriptorProto            as D(EnumDescriptorProto(EnumDescriptorProto))
import qualified Text.DescriptorProtos.EnumDescriptorProto            as D.EnumDescriptorProto(EnumDescriptorProto(..))
import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D(EnumValueDescriptorProto)
import qualified Text.DescriptorProtos.EnumValueDescriptorProto       as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))
import qualified Text.DescriptorProtos.FieldDescriptorProto           as D(FieldDescriptorProto(FieldDescriptorProto))
import qualified Text.DescriptorProtos.FieldDescriptorProto           as D.FieldDescriptorProto(FieldDescriptorProto(..))
import           Text.DescriptorProtos.FieldDescriptorProto.Label
import qualified Text.DescriptorProtos.FieldDescriptorProto.Type      as D(Type)
import           Text.DescriptorProtos.FieldDescriptorProto.Type      as D.Type(Type(..))
import qualified Text.DescriptorProtos.FileDescriptorProto            as D(FileDescriptorProto)
import qualified Text.DescriptorProtos.FileDescriptorProto            as D.FileDescriptorProto(FileDescriptorProto(..))
import qualified Text.DescriptorProtos.MethodDescriptorProto          as D(MethodDescriptorProto)
import qualified Text.DescriptorProtos.MethodDescriptorProto          as D.MethodDescriptorProto(MethodDescriptorProto(..))
import qualified Text.DescriptorProtos.OneofDescriptorProto           as D(OneofDescriptorProto)
import qualified Text.DescriptorProtos.OneofDescriptorProto           as D.OneofDescriptorProto(OneofDescriptorProto(..))
import qualified Text.DescriptorProtos.ServiceDescriptorProto         as D(ServiceDescriptorProto)
import qualified Text.DescriptorProtos.ServiceDescriptorProto         as D.ServiceDescriptorProto(ServiceDescriptorProto(..))
import qualified Text.DescriptorProtos.UninterpretedOption            as D(UninterpretedOption)
import qualified Text.DescriptorProtos.UninterpretedOption            as D.UninterpretedOption(UninterpretedOption(..))
import qualified Text.DescriptorProtos.UninterpretedOption.NamePart   as D(NamePart(NamePart))
import qualified Text.DescriptorProtos.UninterpretedOption.NamePart   as D.NamePart(NamePart(..))
-- import qualified Text.DescriptorProtos.EnumOptions      as D(EnumOptions)
import qualified Text.DescriptorProtos.EnumOptions      as D.EnumOptions(EnumOptions(uninterpreted_option))
-- import qualified Text.DescriptorProtos.EnumValueOptions as D(EnumValueOptions)
import qualified Text.DescriptorProtos.EnumValueOptions as D.EnumValueOptions(EnumValueOptions(uninterpreted_option))
import qualified Text.DescriptorProtos.FieldOptions     as D(FieldOptions(FieldOptions))
import qualified Text.DescriptorProtos.FieldOptions     as D.FieldOptions(FieldOptions(packed,uninterpreted_option))
-- import qualified Text.DescriptorProtos.FileOptions      as D(FileOptions)
import qualified Text.DescriptorProtos.FileOptions      as D.FileOptions(FileOptions(..))
-- import qualified Text.DescriptorProtos.MessageOptions   as D(MessageOptions)
import qualified Text.DescriptorProtos.MessageOptions   as D.MessageOptions(MessageOptions(uninterpreted_option))
-- import qualified Text.DescriptorProtos.MethodOptions    as D(MethodOptions)
import qualified Text.DescriptorProtos.MethodOptions    as D.MethodOptions(MethodOptions(uninterpreted_option))
-- import qualified Text.DescriptorProtos.ServiceOptions   as D(ServiceOptions)
import qualified Text.DescriptorProtos.ServiceOptions   as D.ServiceOptions(ServiceOptions(uninterpreted_option))

import qualified Text.Google.Protobuf.Compiler.CodeGeneratorRequest as CGR

import Text.ProtocolBuffers.Header
import Text.ProtocolBuffers.Identifiers
import Text.ProtocolBuffers.Extensions
import Text.ProtocolBuffers.WireMessage
import Text.ProtocolBuffers.ProtoCompile.Instances
import Text.ProtocolBuffers.ProtoCompile.Parser

import Control.Applicative
import qualified Control.Monad.Fail as Fail
import Control.Monad.Identity
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Error
import Control.Monad.Writer
import Data.Char
import Data.Ratio
import Data.Ix(inRange)
import Data.List(foldl',stripPrefix,isPrefixOf,isSuffixOf)
import Data.Map(Map)
import Data.Maybe(mapMaybe,isNothing)
import Data.Typeable
-- import Data.Monoid()
import System.Directory(doesFileExist,canonicalizePath)
import qualified System.FilePath as Local(pathSeparator,splitDirectories,joinPath,combine,makeRelative)
import qualified System.FilePath.Posix as Canon(pathSeparator,splitDirectories,joinPath,takeBaseName)
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.ByteString.Lazy.UTF8 as U
import qualified Data.Foldable as F
import qualified Data.Sequence as Seq
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.Traversable as T

--import Debug.Trace(trace)

-- Used by err and throw
indent :: String -> String
indent :: String -> String
indent = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
str -> Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
str) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

ishow :: Show a => a -> String
ishow :: a -> String
ishow = String -> String
indent (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

errMsg :: String -> String
errMsg :: String -> String
errMsg String
s = String
"Text.ProtocolBuffers.ProtoCompile.Resolve fatal error encountered, message:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
indent String
s

err :: forall b. String -> b
err :: String -> b
err = String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> (String -> String) -> String -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
errMsg

throw :: (Error e, MonadError e m) =>  String -> m a
throw :: String -> m a
throw String
s = e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> e
forall a. Error a => String -> a
strMsg (String -> String
errMsg String
s))

annErr :: (MonadError String m) => String -> m a -> m a
annErr :: String -> m a -> m a
annErr String
s m a
act = m a -> (String -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m a
act (\String
e -> String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String
"Text.ProtocolBuffers.ProtoCompile.Resolve annErr: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
indent String
e))

getJust :: (Error e,MonadError e m, Typeable a) => String -> Maybe a -> m a
{-#  INLINE getJust #-}
getJust :: String -> Maybe a -> m a
getJust String
s ma :: Maybe a
ma@Maybe a
Nothing = String -> m a
forall e (m :: * -> *) a.
(Error e, MonadError e m) =>
String -> m a
throw (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Impossible? Expected Just of type "String -> String -> String
forall a. [a] -> [a] -> [a]
++TypeRep -> String
forall a. Show a => a -> String
show (Maybe a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Maybe a
ma)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" but got nothing:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
indent String
s
getJust String
_s (Just a
a) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

defaultPackageName :: Utf8
defaultPackageName :: Utf8
defaultPackageName = ByteString -> Utf8
Utf8 (String -> ByteString
LC.pack String
"defaultPackageName")

-- The "package" name turns out to be more complicated than I anticipated (when missing).  Instead
-- of plain UTF8 annotate this with the PackageID newtype to force me to trace the usage.  Later
-- change this to track the additional complexity.
--newtype PackageID a = PackageID { getPackageID :: a } deriving (Show)

data PackageID a = PackageID { PackageID a -> a
_getPackageID :: a }
                 | NoPackageID { PackageID a -> a
_getNoPackageID :: a }
 deriving (Int -> PackageID a -> String -> String
[PackageID a] -> String -> String
PackageID a -> String
(Int -> PackageID a -> String -> String)
-> (PackageID a -> String)
-> ([PackageID a] -> String -> String)
-> Show (PackageID a)
forall a. Show a => Int -> PackageID a -> String -> String
forall a. Show a => [PackageID a] -> String -> String
forall a. Show a => PackageID a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PackageID a] -> String -> String
$cshowList :: forall a. Show a => [PackageID a] -> String -> String
show :: PackageID a -> String
$cshow :: forall a. Show a => PackageID a -> String
showsPrec :: Int -> PackageID a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> PackageID a -> String -> String
Show)

instance Functor PackageID where
   fmap :: (a -> b) -> PackageID a -> PackageID b
fmap a -> b
f (PackageID a
a) = b -> PackageID b
forall a. a -> PackageID a
PackageID (a -> b
f a
a)
   fmap a -> b
f (NoPackageID a
a) = b -> PackageID b
forall a. a -> PackageID a
NoPackageID (a -> b
f a
a)

-- Used in MakeReflections.makeProtoInfo
getPackageID :: PackageID a -> a
getPackageID :: PackageID a -> a
getPackageID (PackageID a
a) = a
a
getPackageID (NoPackageID a
a) = a
a

-- The package field of FileDescriptorProto is set in Parser.hs.
-- 'getPackage' is the only direct user of this information in hprotoc.
-- The convertFileToPackage was developed looking at the Java output of Google's protoc.
-- In 2.0.5 this has lead to problems with the stricter import name resolution when the imported file has no package directive.
-- I need a fancier way of handling this.
getPackage :: D.FileDescriptorProto -> PackageID Utf8
getPackage :: FileDescriptorProto -> PackageID Utf8
getPackage FileDescriptorProto
fdp = case FileDescriptorProto -> Maybe Utf8
D.FileDescriptorProto.package FileDescriptorProto
fdp of
                   Just Utf8
a -> Utf8 -> PackageID Utf8
forall a. a -> PackageID a
PackageID Utf8
a
                   Maybe Utf8
Nothing -> case FileDescriptorProto -> Maybe Utf8
D.FileDescriptorProto.name FileDescriptorProto
fdp of
                                Maybe Utf8
Nothing -> Utf8 -> PackageID Utf8
forall a. a -> PackageID a
NoPackageID Utf8
defaultPackageName
                                Just Utf8
filename -> case Utf8 -> Maybe Utf8
convertFileToPackage Utf8
filename of
                                                   Maybe Utf8
Nothing -> Utf8 -> PackageID Utf8
forall a. a -> PackageID a
NoPackageID Utf8
defaultPackageName
                                                   Just Utf8
name -> Utf8 -> PackageID Utf8
forall a. a -> PackageID a
NoPackageID Utf8
name

--getPackageUtf8 :: PackageID Utf8 -> Utf8
--getPackageUtf8 (PackageID {_getPackageID=x}) = x
--getPackageUtf8 (NoPackageID {_getNoPackageID=x}) = x

-- LOSES PackageID vs NoPackageID 2012-09-19
checkPackageID :: PackageID Utf8 -> Either String (PackageID (Bool,[IName Utf8]))
checkPackageID :: PackageID Utf8 -> Either String (PackageID (Bool, [IName Utf8]))
checkPackageID (PackageID Utf8
a) = ((Bool, [IName Utf8]) -> PackageID (Bool, [IName Utf8]))
-> Either String (Bool, [IName Utf8])
-> Either String (PackageID (Bool, [IName Utf8]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, [IName Utf8]) -> PackageID (Bool, [IName Utf8])
forall a. a -> PackageID a
PackageID (Utf8 -> Either String (Bool, [IName Utf8])
checkDIUtf8 Utf8
a)
checkPackageID (NoPackageID Utf8
a) = ((Bool, [IName Utf8]) -> PackageID (Bool, [IName Utf8]))
-> Either String (Bool, [IName Utf8])
-> Either String (PackageID (Bool, [IName Utf8]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, [IName Utf8]) -> PackageID (Bool, [IName Utf8])
forall a. a -> PackageID a
NoPackageID (Utf8 -> Either String (Bool, [IName Utf8])
checkDIUtf8 Utf8
a)

-- | 'convertFileToPackage' mimics what I observe protoc --java_out do to convert the file name to a
-- class name.
convertFileToPackage :: Utf8 -> Maybe Utf8
convertFileToPackage :: Utf8 -> Maybe Utf8
convertFileToPackage Utf8
filename =
  let full :: String
full = Utf8 -> String
toString Utf8
filename
      suffix :: String
suffix = String
".proto"
      noproto :: String
noproto = if String
suffix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
full then Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
full Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
suffix) String
full else String
full
      convert :: Bool -> String -> String
      convert :: Bool -> String -> String
convert Bool
_ [] = []
      convert Bool
toUp (Char
x:String
xs) | (Char, Char) -> Char -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'a',Char
'z') Char
x = if Bool
toUp
                                                    then Char -> Char
toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
convert Bool
False String
xs
                                                    else Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
convert Bool
False String
xs
                          | (Char, Char) -> Char -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'A',Char
'Z') Char
x = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
convert Bool
False String
xs
                          | (Char, Char) -> Char -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'0',Char
'9') Char
x = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
convert Bool
True String
xs
                          | Char
'_' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
convert Bool
True String
xs
                          | Bool
otherwise = Bool -> String -> String
convert Bool
True String
xs
      converted :: String
converted = Bool -> String -> String
convert Bool
True String
noproto
      leading :: String
leading = case String
converted of
                  (Char
x:String
_) | (Char, Char) -> Char -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'0',Char
'9') Char
x -> String
"proto_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
converted
                  String
_ -> String
converted
  in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
leading then Maybe Utf8
forall a. Maybe a
Nothing else (Utf8 -> Maybe Utf8
forall a. a -> Maybe a
Just (String -> Utf8
fromString String
leading))

-- This adds a leading dot if the input is non-empty
joinDot :: [IName String] -> FIName String
joinDot :: [IName String] -> FIName String
joinDot [] = String -> FIName String
forall b. String -> b
err (String -> FIName String) -> String -> FIName String
forall a b. (a -> b) -> a -> b
$ String
"joinDot on an empty list of IName!"
joinDot (IName String
x:[IName String]
xs) = FIName String -> [IName String] -> FIName String
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend (IName String -> FIName String
forall a. Dotted a => IName a -> FIName a
promoteFI IName String
x) [IName String]
xs

checkFI :: [(FieldId,FieldId)] -> FieldId -> Bool
checkFI :: [(FieldId, FieldId)] -> FieldId -> Bool
checkFI [(FieldId, FieldId)]
ers FieldId
fid = ((FieldId, FieldId) -> Bool) -> [(FieldId, FieldId)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((FieldId, FieldId) -> FieldId -> Bool
forall a. Ix a => (a, a) -> a -> Bool
`inRange` FieldId
fid) [(FieldId, FieldId)]
ers

getExtRanges :: D.DescriptorProto -> [(FieldId,FieldId)]
getExtRanges :: DescriptorProto -> [(FieldId, FieldId)]
getExtRanges DescriptorProto
d = ((FieldId, FieldId) -> [(FieldId, FieldId)])
-> [(FieldId, FieldId)] -> [(FieldId, FieldId)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FieldId, FieldId) -> [(FieldId, FieldId)]
forall b. (Ord b, Num b) => (b, b) -> [(b, b)]
check [(FieldId, FieldId)]
unchecked
  where check :: (b, b) -> [(b, b)]
check x :: (b, b)
x@(b
lo,b
hi) | b
hi b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
lo = []
                        | b
hib -> b -> Bool
forall a. Ord a => a -> a -> Bool
<b
19000 Bool -> Bool -> Bool
|| b
19999b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<b
lo  = [(b, b)
x]
                        | Bool
otherwise = ((b, b) -> [(b, b)]) -> [(b, b)] -> [(b, b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (b, b) -> [(b, b)]
check [(b
lo,b
18999),(b
20000,b
hi)]
        unchecked :: [(FieldId, FieldId)]
unchecked = (ExtensionRange -> [(FieldId, FieldId)] -> [(FieldId, FieldId)])
-> [(FieldId, FieldId)]
-> Seq ExtensionRange
-> [(FieldId, FieldId)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) ((FieldId, FieldId)
 -> [(FieldId, FieldId)] -> [(FieldId, FieldId)])
-> (ExtensionRange -> (FieldId, FieldId))
-> ExtensionRange
-> [(FieldId, FieldId)]
-> [(FieldId, FieldId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtensionRange -> (FieldId, FieldId)
extToPair) [] (DescriptorProto -> Seq ExtensionRange
D.DescriptorProto.extension_range DescriptorProto
d)
        extToPair :: ExtensionRange -> (FieldId, FieldId)
extToPair (D.ExtensionRange
                    { start :: ExtensionRange -> Maybe Int32
D.ExtensionRange.start = Maybe Int32
start
                    , end :: ExtensionRange -> Maybe Int32
D.ExtensionRange.end = Maybe Int32
end }) =
          (FieldId -> (Int32 -> FieldId) -> Maybe Int32 -> FieldId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldId
forall a. Bounded a => a
minBound Int32 -> FieldId
FieldId Maybe Int32
start, FieldId -> (Int32 -> FieldId) -> Maybe Int32 -> FieldId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldId
forall a. Bounded a => a
maxBound (Int32 -> FieldId
FieldId (Int32 -> FieldId) -> (Int32 -> Int32) -> Int32 -> FieldId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int32
forall a. Enum a => a -> a
pred) Maybe Int32
end)

-- | By construction Env is 0 or more Local Entity namespaces followed
-- by 1 or more Global TopLevel namespaces (self and imported files).
-- Entities in first Global TopLevel namespace can refer to each other
-- and to Entities in the list of directly imported TopLevel namespaces only.
data Env = Local [IName String] EMap {- E'Message,E'Group,E'Service -} Env
         | Global TopLevel [TopLevel]
  deriving Int -> Env -> String -> String
[Env] -> String -> String
Env -> String
(Int -> Env -> String -> String)
-> (Env -> String) -> ([Env] -> String -> String) -> Show Env
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Env] -> String -> String
$cshowList :: [Env] -> String -> String
show :: Env -> String
$cshow :: Env -> String
showsPrec :: Int -> Env -> String -> String
$cshowsPrec :: Int -> Env -> String -> String
Show

-- | TopLevel corresponds to all items defined in a .proto file. This
-- includes the FileOptions since this will be consulted when
-- generating the Haskell module names, and the imported files are only
-- known through their TopLevel data.
data TopLevel = TopLevel { TopLevel -> String
top'Path :: FilePath
                         , TopLevel -> PackageID [IName String]
top'Package :: PackageID [IName String]
                         , TopLevel -> Either String FileDescriptorProto
top'FDP :: Either ErrStr D.FileDescriptorProto -- resolvedFDP'd
                         , TopLevel -> EMap
top'mVals :: EMap } deriving Int -> TopLevel -> String -> String
[TopLevel] -> String -> String
TopLevel -> String
(Int -> TopLevel -> String -> String)
-> (TopLevel -> String)
-> ([TopLevel] -> String -> String)
-> Show TopLevel
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TopLevel] -> String -> String
$cshowList :: [TopLevel] -> String -> String
show :: TopLevel -> String
$cshow :: TopLevel -> String
showsPrec :: Int -> TopLevel -> String -> String
$cshowsPrec :: Int -> TopLevel -> String -> String
Show

-- | The EMap type is a local namespace attached to an entity
--
-- The E'Error values come from using unique to resolse name collisions when building EMap
type EMap = Map (IName String) E'Entity

-- | An Entity is some concrete item in the namespace of a proto file.
-- All Entity values have a leading-dot fully-qualified with the package "eName".
-- The E'Message,Group,Service have EMap namespaces to inner Entity items.
data Entity = E'Message { Entity -> [IName String]
eName :: [IName String], Entity -> [(FieldId, FieldId)]
validExtensions :: [(FieldId,FieldId)]
                                                 , Entity -> EMap
mVals :: EMap {- E'Message,Group,Field,Key,Enum -} }

            | E'Group   { eName :: [IName String], mVals :: EMap {- E'Message,Group,Field,Key,Enum -} }

            | E'Service { eName :: [IName String], mVals :: EMap {- E'Method -} }

            | E'Key     { eName :: [IName String], Entity -> Either String Entity
eMsg :: Either ErrStr Entity         {- E'Message -}
                                                 , Entity -> FieldId
fNumber :: FieldId, Entity -> Maybe Type
fType :: Maybe D.Type
                                                 , Entity -> Maybe (Either String Entity)
mVal :: Maybe (Either ErrStr Entity) {- E'Message,Group,Enum -} }

            | E'Field   { eName :: [IName String], fNumber :: FieldId, fType :: Maybe D.Type
                                                 , mVal :: Maybe (Either ErrStr Entity) {- E'Message,Group,Enum -} }

            | E'Enum    { eName :: [IName String], Entity -> Map (IName Utf8) Int32
eVals :: Map (IName Utf8) Int32 }

            | E'Method  { eName :: [IName String], Entity -> Maybe (Either String Entity)
eMsgIn,Entity -> Maybe (Either String Entity)
eMsgOut :: Maybe (Either ErrStr Entity) {- E'Message -} }
  deriving (Int -> Entity -> String -> String
[Entity] -> String -> String
Entity -> String
(Int -> Entity -> String -> String)
-> (Entity -> String)
-> ([Entity] -> String -> String)
-> Show Entity
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Entity] -> String -> String
$cshowList :: [Entity] -> String -> String
show :: Entity -> String
$cshow :: Entity -> String
showsPrec :: Int -> Entity -> String -> String
$cshowsPrec :: Int -> Entity -> String -> String
Show)

-- This type handles entity errors by storing them rather than propagating or throwing them.
--
-- The E'Error values come from using unique to resolse name collisions when building EMap
data E'Entity = E'Ok Entity
              | E'Error String [E'Entity]
  deriving (Int -> E'Entity -> String -> String
[E'Entity] -> String -> String
E'Entity -> String
(Int -> E'Entity -> String -> String)
-> (E'Entity -> String)
-> ([E'Entity] -> String -> String)
-> Show E'Entity
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [E'Entity] -> String -> String
$cshowList :: [E'Entity] -> String -> String
show :: E'Entity -> String
$cshow :: E'Entity -> String
showsPrec :: Int -> E'Entity -> String -> String
$cshowsPrec :: Int -> E'Entity -> String -> String
Show)

newtype LocalFP = LocalFP { LocalFP -> String
unLocalFP :: FilePath } deriving (ReadPrec [LocalFP]
ReadPrec LocalFP
Int -> ReadS LocalFP
ReadS [LocalFP]
(Int -> ReadS LocalFP)
-> ReadS [LocalFP]
-> ReadPrec LocalFP
-> ReadPrec [LocalFP]
-> Read LocalFP
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LocalFP]
$creadListPrec :: ReadPrec [LocalFP]
readPrec :: ReadPrec LocalFP
$creadPrec :: ReadPrec LocalFP
readList :: ReadS [LocalFP]
$creadList :: ReadS [LocalFP]
readsPrec :: Int -> ReadS LocalFP
$creadsPrec :: Int -> ReadS LocalFP
Read,Int -> LocalFP -> String -> String
[LocalFP] -> String -> String
LocalFP -> String
(Int -> LocalFP -> String -> String)
-> (LocalFP -> String)
-> ([LocalFP] -> String -> String)
-> Show LocalFP
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LocalFP] -> String -> String
$cshowList :: [LocalFP] -> String -> String
show :: LocalFP -> String
$cshow :: LocalFP -> String
showsPrec :: Int -> LocalFP -> String -> String
$cshowsPrec :: Int -> LocalFP -> String -> String
Show,LocalFP -> LocalFP -> Bool
(LocalFP -> LocalFP -> Bool)
-> (LocalFP -> LocalFP -> Bool) -> Eq LocalFP
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LocalFP -> LocalFP -> Bool
$c/= :: LocalFP -> LocalFP -> Bool
== :: LocalFP -> LocalFP -> Bool
$c== :: LocalFP -> LocalFP -> Bool
Eq,Eq LocalFP
Eq LocalFP
-> (LocalFP -> LocalFP -> Ordering)
-> (LocalFP -> LocalFP -> Bool)
-> (LocalFP -> LocalFP -> Bool)
-> (LocalFP -> LocalFP -> Bool)
-> (LocalFP -> LocalFP -> Bool)
-> (LocalFP -> LocalFP -> LocalFP)
-> (LocalFP -> LocalFP -> LocalFP)
-> Ord LocalFP
LocalFP -> LocalFP -> Bool
LocalFP -> LocalFP -> Ordering
LocalFP -> LocalFP -> LocalFP
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LocalFP -> LocalFP -> LocalFP
$cmin :: LocalFP -> LocalFP -> LocalFP
max :: LocalFP -> LocalFP -> LocalFP
$cmax :: LocalFP -> LocalFP -> LocalFP
>= :: LocalFP -> LocalFP -> Bool
$c>= :: LocalFP -> LocalFP -> Bool
> :: LocalFP -> LocalFP -> Bool
$c> :: LocalFP -> LocalFP -> Bool
<= :: LocalFP -> LocalFP -> Bool
$c<= :: LocalFP -> LocalFP -> Bool
< :: LocalFP -> LocalFP -> Bool
$c< :: LocalFP -> LocalFP -> Bool
compare :: LocalFP -> LocalFP -> Ordering
$ccompare :: LocalFP -> LocalFP -> Ordering
$cp1Ord :: Eq LocalFP
Ord)
newtype CanonFP = CanonFP { CanonFP -> String
unCanonFP :: FilePath } deriving (ReadPrec [CanonFP]
ReadPrec CanonFP
Int -> ReadS CanonFP
ReadS [CanonFP]
(Int -> ReadS CanonFP)
-> ReadS [CanonFP]
-> ReadPrec CanonFP
-> ReadPrec [CanonFP]
-> Read CanonFP
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CanonFP]
$creadListPrec :: ReadPrec [CanonFP]
readPrec :: ReadPrec CanonFP
$creadPrec :: ReadPrec CanonFP
readList :: ReadS [CanonFP]
$creadList :: ReadS [CanonFP]
readsPrec :: Int -> ReadS CanonFP
$creadsPrec :: Int -> ReadS CanonFP
Read,Int -> CanonFP -> String -> String
[CanonFP] -> String -> String
CanonFP -> String
(Int -> CanonFP -> String -> String)
-> (CanonFP -> String)
-> ([CanonFP] -> String -> String)
-> Show CanonFP
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CanonFP] -> String -> String
$cshowList :: [CanonFP] -> String -> String
show :: CanonFP -> String
$cshow :: CanonFP -> String
showsPrec :: Int -> CanonFP -> String -> String
$cshowsPrec :: Int -> CanonFP -> String -> String
Show,CanonFP -> CanonFP -> Bool
(CanonFP -> CanonFP -> Bool)
-> (CanonFP -> CanonFP -> Bool) -> Eq CanonFP
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CanonFP -> CanonFP -> Bool
$c/= :: CanonFP -> CanonFP -> Bool
== :: CanonFP -> CanonFP -> Bool
$c== :: CanonFP -> CanonFP -> Bool
Eq,Eq CanonFP
Eq CanonFP
-> (CanonFP -> CanonFP -> Ordering)
-> (CanonFP -> CanonFP -> Bool)
-> (CanonFP -> CanonFP -> Bool)
-> (CanonFP -> CanonFP -> Bool)
-> (CanonFP -> CanonFP -> Bool)
-> (CanonFP -> CanonFP -> CanonFP)
-> (CanonFP -> CanonFP -> CanonFP)
-> Ord CanonFP
CanonFP -> CanonFP -> Bool
CanonFP -> CanonFP -> Ordering
CanonFP -> CanonFP -> CanonFP
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CanonFP -> CanonFP -> CanonFP
$cmin :: CanonFP -> CanonFP -> CanonFP
max :: CanonFP -> CanonFP -> CanonFP
$cmax :: CanonFP -> CanonFP -> CanonFP
>= :: CanonFP -> CanonFP -> Bool
$c>= :: CanonFP -> CanonFP -> Bool
> :: CanonFP -> CanonFP -> Bool
$c> :: CanonFP -> CanonFP -> Bool
<= :: CanonFP -> CanonFP -> Bool
$c<= :: CanonFP -> CanonFP -> Bool
< :: CanonFP -> CanonFP -> Bool
$c< :: CanonFP -> CanonFP -> Bool
compare :: CanonFP -> CanonFP -> Ordering
$ccompare :: CanonFP -> CanonFP -> Ordering
$cp1Ord :: Eq CanonFP
Ord)

fpLocalToCanon :: LocalFP -> CanonFP
fpLocalToCanon :: LocalFP -> CanonFP
fpLocalToCanon | Char
Canon.pathSeparator Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
Local.pathSeparator = String -> CanonFP
CanonFP (String -> CanonFP) -> (LocalFP -> String) -> LocalFP -> CanonFP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalFP -> String
unLocalFP
               | Bool
otherwise = String -> CanonFP
CanonFP (String -> CanonFP) -> (LocalFP -> String) -> LocalFP -> CanonFP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
Canon.joinPath ([String] -> String) -> (LocalFP -> [String]) -> LocalFP -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
Local.splitDirectories (String -> [String]) -> (LocalFP -> String) -> LocalFP -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalFP -> String
unLocalFP

fpCanonToLocal :: CanonFP -> LocalFP
fpCanonToLocal :: CanonFP -> LocalFP
fpCanonToLocal | Char
Canon.pathSeparator Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
Local.pathSeparator = String -> LocalFP
LocalFP (String -> LocalFP) -> (CanonFP -> String) -> CanonFP -> LocalFP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CanonFP -> String
unCanonFP
               | Bool
otherwise = String -> LocalFP
LocalFP (String -> LocalFP) -> (CanonFP -> String) -> CanonFP -> LocalFP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
Local.joinPath ([String] -> String) -> (CanonFP -> [String]) -> CanonFP -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
Canon.splitDirectories (String -> [String]) -> (CanonFP -> String) -> CanonFP -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CanonFP -> String
unCanonFP

-- Used to create optimal error messages
allowedGlobal :: Env -> [(PackageID [IName String],[IName String])]
allowedGlobal :: Env -> [(PackageID [IName String], [IName String])]
allowedGlobal (Local [IName String]
_ EMap
_ Env
env) = Env -> [(PackageID [IName String], [IName String])]
allowedGlobal Env
env
allowedGlobal (Global TopLevel
t [TopLevel]
ts) = (TopLevel -> (PackageID [IName String], [IName String]))
-> [TopLevel] -> [(PackageID [IName String], [IName String])]
forall a b. (a -> b) -> [a] -> [b]
map TopLevel -> (PackageID [IName String], [IName String])
allowedT (TopLevel
tTopLevel -> [TopLevel] -> [TopLevel]
forall a. a -> [a] -> [a]
:[TopLevel]
ts)

allowedT :: TopLevel -> (PackageID [IName String], [IName String])
allowedT :: TopLevel -> (PackageID [IName String], [IName String])
allowedT TopLevel
tl = (TopLevel -> PackageID [IName String]
top'Package TopLevel
tl,EMap -> [IName String]
forall k a. Map k a -> [k]
M.keys (TopLevel -> EMap
top'mVals TopLevel
tl))

-- Used to create optional error messages
allowedLocal :: Env -> [([IName String],[IName String])]
allowedLocal :: Env -> [([IName String], [IName String])]
allowedLocal (Global TopLevel
_t [TopLevel]
_ts) = []
allowedLocal (Local [IName String]
name EMap
vals Env
env) = ([IName String], [IName String])
allowedE ([IName String], [IName String])
-> [([IName String], [IName String])]
-> [([IName String], [IName String])]
forall a. a -> [a] -> [a]
: Env -> [([IName String], [IName String])]
allowedLocal Env
env
  where allowedE :: ([IName String], [IName String])
        allowedE :: ([IName String], [IName String])
allowedE = ([IName String]
name,EMap -> [IName String]
forall k a. Map k a -> [k]
M.keys EMap
vals)

-- Create a mapping from the "official" name to the Haskell hierarchy mangled name
type ReMap = Map (FIName Utf8) ProtoName

data NameMap = NameMap ( PackageID (FIName Utf8) -- packageName from 'getPackage' on fdp
                       , [MName String]   -- hPrefix from command line
                       , [MName String])  -- hParent from java_outer_classname, java_package, or 'getPackage'
                       ReMap
  deriving (Int -> NameMap -> String -> String
[NameMap] -> String -> String
NameMap -> String
(Int -> NameMap -> String -> String)
-> (NameMap -> String)
-> ([NameMap] -> String -> String)
-> Show NameMap
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [NameMap] -> String -> String
$cshowList :: [NameMap] -> String -> String
show :: NameMap -> String
$cshow :: NameMap -> String
showsPrec :: Int -> NameMap -> String -> String
$cshowsPrec :: Int -> NameMap -> String -> String
Show)

type RE a = ReaderT Env (Either ErrStr) a


data SEnv = SEnv { SEnv -> [IName String]
my'Parent :: [IName String]   -- top level value is derived from PackageID
                 , SEnv -> Env
my'Env :: Env }
--                 , my'Template :: ProtoName }

-- E'Service here is arbitrary
emptyEntity :: Entity
emptyEntity :: Entity
emptyEntity = [IName String] -> EMap -> Entity
E'Service [String -> IName String
forall a. a -> IName a
IName String
"emptyEntity from myFix"] EMap
forall a. Monoid a => a
mempty

emptyEnv :: Env
emptyEnv :: Env
emptyEnv = TopLevel -> [TopLevel] -> Env
Global (String
-> PackageID [IName String]
-> Either String FileDescriptorProto
-> EMap
-> TopLevel
TopLevel String
"emptyEnv from myFix" ([IName String] -> PackageID [IName String]
forall a. a -> PackageID a
PackageID [String -> IName String
forall a. a -> IName a
IName String
"emptyEnv form myFix"]) (String -> Either String FileDescriptorProto
forall a b. a -> Either a b
Left String
"emptyEnv: top'FDP does not exist") EMap
forall a. Monoid a => a
mempty) []

instance Show SEnv where
  show :: SEnv -> String
show (SEnv [IName String]
p Env
e) = String
"(SEnv "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show [IName String]
pString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" ; "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Env -> String
whereEnv Env
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" --" ; "++show (haskellPrefix t,parentModule t)++ " )"

type ErrStr = String

type SE a = ReaderT SEnv (Either ErrStr) a

runSE :: SEnv -> SE a -> Either ErrStr a
runSE :: SEnv -> SE a -> Either String a
runSE SEnv
sEnv SE a
m = SE a -> SEnv -> Either String a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT SE a
m SEnv
sEnv

fqName :: Entity -> FIName Utf8
fqName :: Entity -> FIName Utf8
fqName = FIName String -> FIName Utf8
fiFromString (FIName String -> FIName Utf8)
-> (Entity -> FIName String) -> Entity -> FIName Utf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IName String] -> FIName String
joinDot ([IName String] -> FIName String)
-> (Entity -> [IName String]) -> Entity -> FIName String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> [IName String]
eName

fiFromString :: FIName String -> FIName Utf8
fiFromString :: FIName String -> FIName Utf8
fiFromString = Utf8 -> FIName Utf8
forall a. a -> FIName a
FIName (Utf8 -> FIName Utf8)
-> (FIName String -> Utf8) -> FIName String -> FIName Utf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Utf8
fromString (String -> Utf8)
-> (FIName String -> String) -> FIName String -> Utf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FIName String -> String
forall a. FIName a -> a
fiName

iToString :: IName Utf8 -> IName String
iToString :: IName Utf8 -> IName String
iToString = String -> IName String
forall a. a -> IName a
IName (String -> IName String)
-> (IName Utf8 -> String) -> IName Utf8 -> IName String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8 -> String
toString (Utf8 -> String) -> (IName Utf8 -> Utf8) -> IName Utf8 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IName Utf8 -> Utf8
forall a. IName a -> a
iName

-- Three entities provide child namespaces: E'Message, E'Group, and E'Service
get'mVals'E :: E'Entity -> Maybe EMap
get'mVals'E :: E'Entity -> Maybe EMap
get'mVals'E (E'Ok Entity
entity) = Entity -> Maybe EMap
get'mVals Entity
entity
get'mVals'E (E'Error {}) = Maybe EMap
forall a. Maybe a
Nothing

get'mVals :: Entity -> Maybe EMap
get'mVals :: Entity -> Maybe EMap
get'mVals (E'Message {mVals :: Entity -> EMap
mVals = EMap
x}) = EMap -> Maybe EMap
forall a. a -> Maybe a
Just EMap
x
get'mVals (E'Group   {mVals :: Entity -> EMap
mVals = EMap
x}) = EMap -> Maybe EMap
forall a. a -> Maybe a
Just EMap
x
get'mVals (E'Service {mVals :: Entity -> EMap
mVals = EMap
x}) = EMap -> Maybe EMap
forall a. a -> Maybe a
Just EMap
x
get'mVals Entity
_ = Maybe EMap
forall a. Maybe a
Nothing

-- | This is a helper for resolveEnv
toGlobal :: Env -> Env
toGlobal :: Env -> Env
toGlobal (Local [IName String]
_ EMap
_ Env
env) = Env -> Env
toGlobal Env
env
toGlobal x :: Env
x@(Global {}) = Env
x

getTL :: Env -> TopLevel
getTL :: Env -> TopLevel
getTL (Local [IName String]
_ EMap
_ Env
env) = Env -> TopLevel
getTL Env
env
getTL (Global TopLevel
tl [TopLevel]
_tls) = TopLevel
tl

getTLS :: Env -> (TopLevel,[TopLevel])
getTLS :: Env -> (TopLevel, [TopLevel])
getTLS (Local [IName String]
_ EMap
_ Env
env) = Env -> (TopLevel, [TopLevel])
getTLS Env
env
getTLS (Global TopLevel
tl [TopLevel]
tls) = (TopLevel
tl, [TopLevel]
tls)

-- | This is used for resolving some UninterpretedOption names
resolveHere :: Entity -> Utf8 -> RE Entity
resolveHere :: Entity -> Utf8 -> RE Entity
resolveHere Entity
parent Utf8
nameU = do
  let rFail :: String -> RE Entity
rFail String
msg = String -> RE Entity
forall e (m :: * -> *) a.
(Error e, MonadError e m) =>
String -> m a
throw (String
"Could not lookup "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show (Utf8 -> String
toString Utf8
nameU)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
indent String
msg)
  IName String
x <- String
-> Maybe (IName String)
-> ReaderT Env (Either String) (IName String)
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust (String
"resolveHere: validI nameU failed for "String -> String -> String
forall a. [a] -> [a] -> [a]
++Utf8 -> String
forall a. Show a => a -> String
show Utf8
nameU) ((IName Utf8 -> IName String)
-> Maybe (IName Utf8) -> Maybe (IName String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IName Utf8 -> IName String
iToString (Utf8 -> Maybe (IName Utf8)
forall a. Dotted a => a -> Maybe (IName a)
validI Utf8
nameU))
  case Entity -> Maybe EMap
get'mVals Entity
parent of
    Just EMap
vals -> case IName String -> EMap -> Maybe E'Entity
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup IName String
x EMap
vals of
                   Just (E'Ok Entity
entity) -> Entity -> RE Entity
forall (m :: * -> *) a. Monad m => a -> m a
return Entity
entity
                   Just (E'Error String
s [E'Entity]
_) -> String -> RE Entity
rFail (String
"because the name resolved to an error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
indent String
s)
                   Maybe E'Entity
Nothing -> String -> RE Entity
rFail (String
"because there is no such name here:  "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show (Entity -> [IName String]
eName Entity
parent))
    Maybe EMap
Nothing -> String -> RE Entity
rFail (String
"because environment has no local names:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
ishow (Entity -> [IName String]
eName Entity
parent))

-- | 'resolvePredEnv' is the query operation for the Env namespace.  It recognizes names beginning
-- with a '.' as already being fully-qualified names. This is called from the different monads via
-- resolveEnv, resolveMGE,  and resolveM
--
-- The returned (Right _::Entity) will never be an E'Error, which results in (Left _::ErrStr) instead
resolvePredEnv :: String -> (E'Entity -> Bool) -> Utf8 -> Env -> Either ErrStr Entity
resolvePredEnv :: String -> (E'Entity -> Bool) -> Utf8 -> Env -> Either String Entity
resolvePredEnv String
userMessage E'Entity -> Bool
accept Utf8
nameU Env
envIn = do
  (Bool
isGlobal,[IName Utf8]
xs) <- Utf8 -> Either String (Bool, [IName Utf8])
checkDIUtf8 Utf8
nameU
  let mResult :: Maybe E'Entity
mResult = if Bool
isGlobal then [IName String] -> Env -> Maybe E'Entity
lookupEnv ((IName Utf8 -> IName String) -> [IName Utf8] -> [IName String]
forall a b. (a -> b) -> [a] -> [b]
map IName Utf8 -> IName String
iToString [IName Utf8]
xs) (Env -> Env
toGlobal Env
envIn)
                            else [IName String] -> Env -> Maybe E'Entity
lookupEnv ((IName Utf8 -> IName String) -> [IName Utf8] -> [IName String]
forall a b. (a -> b) -> [a] -> [b]
map IName Utf8 -> IName String
iToString [IName Utf8]
xs) Env
envIn
  case Maybe E'Entity
mResult of
    Just (E'Ok Entity
e) -> Entity -> Either String Entity
forall (m :: * -> *) a. Monad m => a -> m a
return Entity
e
    Just (E'Error String
s [E'Entity]
_es) -> String -> Either String Entity
forall e (m :: * -> *) a.
(Error e, MonadError e m) =>
String -> m a
throw String
s
    Maybe E'Entity
Nothing -> String -> Either String Entity
forall e (m :: * -> *) a.
(Error e, MonadError e m) =>
String -> m a
throw (String -> Either String Entity)
-> ([String] -> String) -> [String] -> Either String Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Either String Entity)
-> [String] -> Either String Entity
forall a b. (a -> b) -> a -> b
$ [ String
"resolvePredEnv: Could not lookup " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Utf8 -> String
forall a. Show a => a -> String
show Utf8
nameU
                                 , String
"which parses as "                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Bool, [IName Utf8]) -> String
forall a. Show a => a -> String
show (Bool
isGlobal,[IName Utf8]
xs)
                                 , String
"in environment: "                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Env -> String
whereEnv Env
envIn)
                                 , String
"looking for: "                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
userMessage
                                 , String
"allowed (local):  "                String -> String -> String
forall a. [a] -> [a] -> [a]
++ [([IName String], [IName String])] -> String
forall a. Show a => a -> String
show (Env -> [([IName String], [IName String])]
allowedLocal Env
envIn)
                                 , String
"allowed (global): "                String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(PackageID [IName String], [IName String])] -> String
forall a. Show a => a -> String
show (Env -> [(PackageID [IName String], [IName String])]
allowedGlobal Env
envIn) ]
 where
  lookupEnv :: [IName String] -> Env -> Maybe E'Entity
  lookupEnv :: [IName String] -> Env -> Maybe E'Entity
lookupEnv [IName String]
xs (Global TopLevel
tl [TopLevel]
tls) = let findThis :: TopLevel -> Maybe E'Entity
findThis = PackageID [IName String]
-> [IName String] -> TopLevel -> Maybe E'Entity
lookupTopLevel PackageID [IName String]
main [IName String]
xs
                                       where main :: PackageID [IName String]
main = TopLevel -> PackageID [IName String]
top'Package TopLevel
tl
                                 in [Maybe E'Entity] -> Maybe E'Entity
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((TopLevel -> Maybe E'Entity) -> [TopLevel] -> [Maybe E'Entity]
forall a b. (a -> b) -> [a] -> [b]
map TopLevel -> Maybe E'Entity
findThis (TopLevel
tlTopLevel -> [TopLevel] -> [TopLevel]
forall a. a -> [a] -> [a]
:[TopLevel]
tls))
  lookupEnv [IName String]
xs (Local [IName String]
_ EMap
vals Env
env) = EMap -> [IName String] -> Maybe E'Entity
filteredLookup EMap
vals [IName String]
xs Maybe E'Entity -> Maybe E'Entity -> Maybe E'Entity
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [IName String] -> Env -> Maybe E'Entity
lookupEnv [IName String]
xs Env
env

  lookupTopLevel :: PackageID [IName String] -> [IName String] -> TopLevel -> Maybe E'Entity
  lookupTopLevel :: PackageID [IName String]
-> [IName String] -> TopLevel -> Maybe E'Entity
lookupTopLevel PackageID [IName String]
main [IName String]
xs TopLevel
tl =
    (if PackageID [IName String] -> PackageID [IName String] -> Bool
forall a. Eq a => PackageID a -> PackageID a -> Bool
matchesMain PackageID [IName String]
main (TopLevel -> PackageID [IName String]
top'Package TopLevel
tl) then EMap -> [IName String] -> Maybe E'Entity
filteredLookup (TopLevel -> EMap
top'mVals TopLevel
tl) [IName String]
xs else Maybe E'Entity
forall a. Maybe a
Nothing)
    Maybe E'Entity -> Maybe E'Entity -> Maybe E'Entity
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    (PackageID [IName String] -> [IName String] -> Maybe [IName String]
forall a. Eq a => PackageID [a] -> [a] -> Maybe [a]
matchPrefix (TopLevel -> PackageID [IName String]
top'Package TopLevel
tl) [IName String]
xs Maybe [IName String]
-> ([IName String] -> Maybe E'Entity) -> Maybe E'Entity
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EMap -> [IName String] -> Maybe E'Entity
filteredLookup (TopLevel -> EMap
top'mVals TopLevel
tl))
    Maybe E'Entity -> Maybe E'Entity -> Maybe E'Entity
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    (PackageID [IName String]
-> PackageID [IName String] -> Maybe [IName String]
forall a. Eq a => PackageID [a] -> PackageID [a] -> Maybe [a]
testPrefix PackageID [IName String]
main (TopLevel -> PackageID [IName String]
top'Package TopLevel
tl) Maybe [IName String] -> Maybe E'Entity -> Maybe E'Entity
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EMap -> [IName String] -> Maybe E'Entity
filteredLookup (TopLevel -> EMap
top'mVals TopLevel
tl) [IName String]
xs)
   where matchesMain :: PackageID a -> PackageID a -> Bool
matchesMain (PackageID {_getPackageID :: forall a. PackageID a -> a
_getPackageID=a
a}) (PackageID {_getPackageID :: forall a. PackageID a -> a
_getPackageID=a
b}) = a
aa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
b
         matchesMain (NoPackageID {}) (PackageID {})   = Bool
False  -- XXX XXX XXX 2012-09-19 suspicious
         matchesMain (PackageID {})   (NoPackageID {}) = Bool
True
         matchesMain (NoPackageID {}) (NoPackageID {}) = Bool
True

         matchPrefix :: PackageID [a] -> [a] -> Maybe [a]
matchPrefix (NoPackageID {}) [a]
_ = Maybe [a]
forall a. Maybe a
Nothing
         matchPrefix (PackageID {_getPackageID :: forall a. PackageID a -> a
_getPackageID=[a]
a}) [a]
ys = [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
a [a]
ys

         testPrefix :: PackageID [a] -> PackageID [a] -> Maybe [a]
testPrefix (PackageID {_getPackageID :: forall a. PackageID a -> a
_getPackageID=[a]
child}) (PackageID {_getPackageID :: forall a. PackageID a -> a
_getPackageID=[a]
parent}) = [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
parent [a]
child
         testPrefix PackageID [a]
_ PackageID [a]
_ = Maybe [a]
forall a. Maybe a
Nothing

  filteredLookup :: EMap -> [IName String] -> Maybe E'Entity
filteredLookup EMap
valsIn [IName String]
namesIn =
    let lookupVals :: EMap -> [IName String] -> Maybe E'Entity
        lookupVals :: EMap -> [IName String] -> Maybe E'Entity
lookupVals EMap
_vals [] = Maybe E'Entity
forall a. Maybe a
Nothing
        lookupVals EMap
vals [IName String
x] = IName String -> EMap -> Maybe E'Entity
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup IName String
x EMap
vals
        lookupVals EMap
vals (IName String
x:[IName String]
xs) = do
          E'Entity
entity <- IName String -> EMap -> Maybe E'Entity
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup IName String
x EMap
vals
          case E'Entity -> Maybe EMap
get'mVals'E E'Entity
entity of
            Just EMap
vals' -> EMap -> [IName String] -> Maybe E'Entity
lookupVals EMap
vals' [IName String]
xs
            Maybe EMap
Nothing -> Maybe E'Entity
forall a. Maybe a
Nothing
        m'x :: Maybe E'Entity
m'x = EMap -> [IName String] -> Maybe E'Entity
lookupVals EMap
valsIn [IName String]
namesIn
    in case Maybe E'Entity
m'x of
         Just E'Entity
entity | E'Entity -> Bool
accept E'Entity
entity -> Maybe E'Entity
m'x
         Maybe E'Entity
_ -> Maybe E'Entity
forall a. Maybe a
Nothing

-- Used in resolveRE and getType.resolveSE.  Accepts all types and so commits to first hit, but
-- caller may reject some types later.
resolveEnv :: Utf8 -> Env -> Either ErrStr Entity
resolveEnv :: Utf8 -> Env -> Either String Entity
resolveEnv = String -> (E'Entity -> Bool) -> Utf8 -> Env -> Either String Entity
resolvePredEnv String
"Any item" (Bool -> E'Entity -> Bool
forall a b. a -> b -> a
const Bool
True)

-- resolveRE is the often used workhorse of the fq* family of functions
resolveRE :: Utf8 -> RE Entity
resolveRE :: Utf8 -> RE Entity
resolveRE Utf8
nameU = Either String Entity -> RE Entity
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String Entity -> RE Entity)
-> (Env -> Either String Entity) -> Env -> RE Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Utf8 -> Env -> Either String Entity
resolveEnv Utf8
nameU) (Env -> RE Entity) -> ReaderT Env (Either String) Env -> RE Entity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT Env (Either String) Env
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | 'getType' is used to lookup the type strings in service method records.
getType :: Show a => String -> (a -> Maybe Utf8) -> a -> SE (Maybe (Either ErrStr Entity))
getType :: String
-> (a -> Maybe Utf8) -> a -> SE (Maybe (Either String Entity))
getType String
s a -> Maybe Utf8
f a
a = do
  Utf8
typeU <- String -> Maybe Utf8 -> ReaderT SEnv (Either String) Utf8
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
s (a -> Maybe Utf8
f a
a)
  case String -> Maybe Type
parseType (Utf8 -> String
toString Utf8
typeU) of
    Just Type
_ -> Maybe (Either String Entity) -> SE (Maybe (Either String Entity))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either String Entity)
forall a. Maybe a
Nothing
    Maybe Type
Nothing -> do Either String Entity
ee <- Utf8 -> SE (Either String Entity)
resolveSE Utf8
typeU
                  Maybe (Either String Entity) -> SE (Maybe (Either String Entity))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Entity -> Maybe (Either String Entity)
forall a. a -> Maybe a
Just (Either String Entity -> Either String Entity
expectMGE Either String Entity
ee))
 where
  -- All uses of this then apply expectMGE or expectM, so provide predicate 'skip' support.
  resolveSE :: Utf8 -> SE (Either ErrStr Entity)
  resolveSE :: Utf8 -> SE (Either String Entity)
resolveSE Utf8
nameU = (Env -> Either String Entity)
-> ReaderT SEnv (Either String) Env -> SE (Either String Entity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Utf8 -> Env -> Either String Entity
resolveEnv Utf8
nameU) ((SEnv -> Env) -> ReaderT SEnv (Either String) Env
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SEnv -> Env
my'Env)

-- | 'expectMGE' is used by getType and 'entityField'
expectMGE :: Either ErrStr Entity -> Either ErrStr Entity
expectMGE :: Either String Entity -> Either String Entity
expectMGE ee :: Either String Entity
ee@(Left {}) = Either String Entity
ee
expectMGE ee :: Either String Entity
ee@(Right Entity
e) | Bool
isMGE = Either String Entity
ee
                       | Bool
otherwise = String -> Either String Entity
forall e (m :: * -> *) a.
(Error e, MonadError e m) =>
String -> m a
throw (String -> Either String Entity) -> String -> Either String Entity
forall a b. (a -> b) -> a -> b
$ String
"expectMGE: Name resolution failed to find a Message, Group, or Enum:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
ishow (Entity -> [IName String]
eName Entity
e)
  -- cannot show all of "e" because this will loop and hang the hprotoc program
  where isMGE :: Bool
isMGE = case Entity
e of E'Message {} -> Bool
True
                          E'Group {} -> Bool
True
                          E'Enum {} -> Bool
True
                          Entity
_ -> Bool
False

-- | This is a helper for resolveEnv and (Show SEnv) for error messages
whereEnv :: Env -> String
whereEnv :: Env -> String
whereEnv (Local [IName String]
name EMap
_ Env
env) = FIName String -> String
forall a. FIName a -> a
fiName ([IName String] -> FIName String
joinDot [IName String]
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show (TopLevel -> String
top'Path (TopLevel -> String) -> (Env -> TopLevel) -> Env -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> TopLevel
getTL (Env -> String) -> Env -> String
forall a b. (a -> b) -> a -> b
$ Env
env)
-- WAS whereEnv (Global tl _) = fiName (joinDot (getPackageID (top'Package tl))) ++ " in " ++ show (top'Path tl)
whereEnv (Global TopLevel
tl [TopLevel]
_) = String
formatPackageID String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (TopLevel -> String
top'Path TopLevel
tl)
  where formatPackageID :: String
formatPackageID = case TopLevel -> PackageID [IName String]
top'Package TopLevel
tl of
                            PackageID {_getPackageID :: forall a. PackageID a -> a
_getPackageID=[IName String]
x} -> FIName String -> String
forall a. FIName a -> a
fiName ([IName String] -> FIName String
joinDot [IName String]
x)
                            NoPackageID {_getNoPackageID :: forall a. PackageID a -> a
_getNoPackageID=[IName String]
y} -> [IName String] -> String
forall a. Show a => a -> String
show [IName String]
y

-- | 'partEither' separates the Left errors and Right success in the obvious way.
partEither :: [Either a b] -> ([a],[b])
partEither :: [Either a b] -> ([a], [b])
partEither [] = ([],[])
partEither (Left a
a:[Either a b]
xs) = let ~([a]
ls,[b]
rs) = [Either a b] -> ([a], [b])
forall a b. [Either a b] -> ([a], [b])
partEither [Either a b]
xs
                         in (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls,[b]
rs)
partEither (Right b
b:[Either a b]
xs) = let ~([a]
ls,[b]
rs) = [Either a b] -> ([a], [b])
forall a b. [Either a b] -> ([a], [b])
partEither [Either a b]
xs
                          in ([a]
ls,b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
rs)

-- | The 'unique' function is used with Data.Map.fromListWithKey to detect
-- name collisions and record this as E'Error entries in the map.
--
-- This constructs new E'Error values
unique :: IName String -> E'Entity -> E'Entity -> E'Entity
unique :: IName String -> E'Entity -> E'Entity -> E'Entity
unique IName String
name (E'Error String
_ [E'Entity]
a) (E'Error String
_ [E'Entity]
b) = String -> [E'Entity] -> E'Entity
E'Error (String
"Namespace collision for "String -> String -> String
forall a. [a] -> [a] -> [a]
++IName String -> String
forall a. Show a => a -> String
show IName String
name) ([E'Entity]
a[E'Entity] -> [E'Entity] -> [E'Entity]
forall a. [a] -> [a] -> [a]
++[E'Entity]
b)
unique IName String
name (E'Error String
_ [E'Entity]
a) E'Entity
b = String -> [E'Entity] -> E'Entity
E'Error (String
"Namespace collision for "String -> String -> String
forall a. [a] -> [a] -> [a]
++IName String -> String
forall a. Show a => a -> String
show IName String
name) ([E'Entity]
a[E'Entity] -> [E'Entity] -> [E'Entity]
forall a. [a] -> [a] -> [a]
++[E'Entity
b])
unique IName String
name E'Entity
a (E'Error String
_ [E'Entity]
b) = String -> [E'Entity] -> E'Entity
E'Error (String
"Namespace collision for "String -> String -> String
forall a. [a] -> [a] -> [a]
++IName String -> String
forall a. Show a => a -> String
show IName String
name) (E'Entity
aE'Entity -> [E'Entity] -> [E'Entity]
forall a. a -> [a] -> [a]
:[E'Entity]
b)
unique IName String
name E'Entity
a E'Entity
b = String -> [E'Entity] -> E'Entity
E'Error (String
"Namespace collision for "String -> String -> String
forall a. [a] -> [a] -> [a]
++IName String -> String
forall a. Show a => a -> String
show IName String
name) [E'Entity
a,E'Entity
b]

maybeM :: Monad m => (x -> m a) -> (Maybe x) -> m (Maybe a)
maybeM :: (x -> m a) -> Maybe x -> m (Maybe a)
maybeM x -> m a
f Maybe x
mx = m (Maybe a) -> (x -> m (Maybe a)) -> Maybe x -> m (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) ((a -> Maybe a) -> m a -> m (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just (m a -> m (Maybe a)) -> (x -> m a) -> x -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> m a
f) Maybe x
mx

-- ReaderT containing template stacked on WriterT of list of name translations stacked on error reporting
type MRM a = ReaderT ProtoName (WriterT [(FIName Utf8,ProtoName)] (Either ErrStr)) a

runMRM'Reader :: MRM a -> ProtoName -> WriterT [(FIName Utf8,ProtoName)] (Either ErrStr) a
runMRM'Reader :: MRM a
-> ProtoName
-> WriterT [(FIName Utf8, ProtoName)] (Either String) a
runMRM'Reader = MRM a
-> ProtoName
-> WriterT [(FIName Utf8, ProtoName)] (Either String) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

runMRM'Writer :: WriterT [(FIName Utf8,ProtoName)] (Either ErrStr) a -> Either ErrStr (a,[(FIName Utf8,ProtoName)])
runMRM'Writer :: WriterT [(FIName Utf8, ProtoName)] (Either String) a
-> Either String (a, [(FIName Utf8, ProtoName)])
runMRM'Writer = WriterT [(FIName Utf8, ProtoName)] (Either String) a
-> Either String (a, [(FIName Utf8, ProtoName)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT

mrmName :: String -> (a -> Maybe Utf8) -> a -> MRM ProtoName
mrmName :: String -> (a -> Maybe Utf8) -> a -> MRM ProtoName
mrmName String
s a -> Maybe Utf8
f a
a = do
  ProtoName
template <- MRM ProtoName
forall r (m :: * -> *). MonadReader r m => m r
ask
  IName Utf8
iSelf <- String
-> Maybe (IName Utf8)
-> ReaderT
     ProtoName
     (WriterT [(FIName Utf8, ProtoName)] (Either String))
     (IName Utf8)
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
s (Utf8 -> Maybe (IName Utf8)
forall a. Dotted a => a -> Maybe (IName a)
validI (Utf8 -> Maybe (IName Utf8)) -> Maybe Utf8 -> Maybe (IName Utf8)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> Maybe Utf8
f a
a)
  let mSelf :: MName String
mSelf = IName Utf8 -> MName String
forall a b. Mangle a b => a -> b
mangle IName Utf8
iSelf
      fqSelf :: FIName Utf8
fqSelf = FIName Utf8 -> [IName Utf8] -> FIName Utf8
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend (ProtoName -> FIName Utf8
protobufName ProtoName
template) [IName Utf8
iSelf]
      self :: ProtoName
self = ProtoName
template { protobufName :: FIName Utf8
protobufName = FIName Utf8
fqSelf
                      , baseName :: MName String
baseName = MName String
mSelf }
      template' :: ProtoName
template' = ProtoName
template { protobufName :: FIName Utf8
protobufName = FIName Utf8
fqSelf
                           , parentModule :: [MName String]
parentModule = ProtoName -> [MName String]
parentModule ProtoName
template [MName String] -> [MName String] -> [MName String]
forall a. [a] -> [a] -> [a]
++ [MName String
mSelf] }
  [(FIName Utf8, ProtoName)]
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(FIName Utf8
fqSelf,ProtoName
self)]
  ProtoName -> MRM ProtoName
forall (m :: * -> *) a. Monad m => a -> m a
return ProtoName
template'

-- | Compute the nameMap that determine how to translate from proto names to haskell names
-- The loop oever makeNameMap uses the (optional) package name
-- makeNameMaps is called from the run' routine in ProtoCompile.hs for both standalone and plugin use.
-- hPrefix and hAs are command line controlled options.
-- hPrefix is "-p MODULE --prefix=MODULE dotted Haskell MODULE name to use as a prefix (default is none); last flag used"
-- hAs is "-a FILEPATH=MODULE --as=FILEPATH=MODULE assign prefix module to imported prot file: --as descriptor.proto=Text"
-- Note that 'setAs' puts both the full path and the basename as keys into the association list
makeNameMaps :: [MName String] -> [(CanonFP,[MName String])] -> Env -> Either ErrStr NameMap
makeNameMaps :: [MName String]
-> [(CanonFP, [MName String])] -> Env -> Either String NameMap
makeNameMaps [MName String]
hPrefix [(CanonFP, [MName String])]
hAs Env
env = do
  let getPrefix :: FileDescriptorProto -> [MName String]
getPrefix FileDescriptorProto
fdp =
        case FileDescriptorProto -> Maybe Utf8
D.FileDescriptorProto.name FileDescriptorProto
fdp of
          Maybe Utf8
Nothing -> [MName String]
hPrefix -- really likely to be an error elsewhere since this ought to be a filename
          Just Utf8
n -> let path :: CanonFP
path = String -> CanonFP
CanonFP (Utf8 -> String
toString Utf8
n)
                    in case CanonFP -> [(CanonFP, [MName String])] -> Maybe [MName String]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CanonFP
path [(CanonFP, [MName String])]
hAs of
                          Just [MName String]
p -> [MName String]
p
                          Maybe [MName String]
Nothing -> case CanonFP -> [(CanonFP, [MName String])] -> Maybe [MName String]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> CanonFP
CanonFP (String -> CanonFP) -> (CanonFP -> String) -> CanonFP -> CanonFP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
Canon.takeBaseName (String -> String) -> (CanonFP -> String) -> CanonFP -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CanonFP -> String
unCanonFP (CanonFP -> CanonFP) -> CanonFP -> CanonFP
forall a b. (a -> b) -> a -> b
$ CanonFP
path) [(CanonFP, [MName String])]
hAs of
                                       Just [MName String]
p -> [MName String]
p
                                       Maybe [MName String]
Nothing -> [MName String]
hPrefix  -- this is the usual branch unless overridden on command line
  let (TopLevel
tl,[TopLevel]
tls) = Env -> (TopLevel, [TopLevel])
getTLS Env
env
  FileDescriptorProto
fdp <- TopLevel -> Either String FileDescriptorProto
top'FDP TopLevel
tl
  [FileDescriptorProto]
fdps <- (TopLevel -> Either String FileDescriptorProto)
-> [TopLevel] -> Either String [FileDescriptorProto]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TopLevel -> Either String FileDescriptorProto
top'FDP [TopLevel]
tls
  (NameMap (PackageID (FIName Utf8), [MName String], [MName String])
tuple ReMap
m) <- [MName String] -> FileDescriptorProto -> Either String NameMap
makeNameMap (FileDescriptorProto -> [MName String]
getPrefix FileDescriptorProto
fdp) FileDescriptorProto
fdp
  let f :: NameMap -> ReMap
f (NameMap (PackageID (FIName Utf8), [MName String], [MName String])
_ ReMap
x) = ReMap
x
  [ReMap]
ms <- ([NameMap] -> [ReMap])
-> Either String [NameMap] -> Either String [ReMap]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NameMap -> ReMap) -> [NameMap] -> [ReMap]
forall a b. (a -> b) -> [a] -> [b]
map NameMap -> ReMap
f) (Either String [NameMap] -> Either String [ReMap])
-> ([FileDescriptorProto] -> Either String [NameMap])
-> [FileDescriptorProto]
-> Either String [ReMap]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileDescriptorProto -> Either String NameMap)
-> [FileDescriptorProto] -> Either String [NameMap]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\FileDescriptorProto
y -> [MName String] -> FileDescriptorProto -> Either String NameMap
makeNameMap (FileDescriptorProto -> [MName String]
getPrefix FileDescriptorProto
y) FileDescriptorProto
y) ([FileDescriptorProto] -> Either String [ReMap])
-> [FileDescriptorProto] -> Either String [ReMap]
forall a b. (a -> b) -> a -> b
$ [FileDescriptorProto]
fdps
  let nameMap :: NameMap
nameMap = ((PackageID (FIName Utf8), [MName String], [MName String])
-> ReMap -> NameMap
NameMap (PackageID (FIName Utf8), [MName String], [MName String])
tuple ([ReMap] -> ReMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions (ReMap
mReMap -> [ReMap] -> [ReMap]
forall a. a -> [a] -> [a]
:[ReMap]
ms)))
  NameMap -> Either String NameMap
forall (m :: * -> *) a. Monad m => a -> m a
return NameMap
nameMap

-- | 'makeNameMap' conservatively checks its input.
makeNameMap :: [MName String] -> D.FileDescriptorProto -> Either ErrStr NameMap
makeNameMap :: [MName String] -> FileDescriptorProto -> Either String NameMap
makeNameMap [MName String]
hPrefix FileDescriptorProto
fdpIn = WriterT
  [(FIName Utf8, ProtoName)]
  (Either String)
  (PackageID (FIName Utf8), [MName String], [MName String])
-> Either String NameMap
go (FileDescriptorProto
-> WriterT
     [(FIName Utf8, ProtoName)]
     (Either String)
     (PackageID (FIName Utf8), [MName String], [MName String])
makeOne FileDescriptorProto
fdpIn) where
  go :: WriterT
  [(FIName Utf8, ProtoName)]
  (Either String)
  (PackageID (FIName Utf8), [MName String], [MName String])
-> Either String NameMap
go = (((PackageID (FIName Utf8), [MName String], [MName String]),
  [(FIName Utf8, ProtoName)])
 -> NameMap)
-> Either
     String
     ((PackageID (FIName Utf8), [MName String], [MName String]),
      [(FIName Utf8, ProtoName)])
-> Either String NameMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\((PackageID (FIName Utf8), [MName String], [MName String])
a,[(FIName Utf8, ProtoName)]
w) -> (PackageID (FIName Utf8), [MName String], [MName String])
-> ReMap -> NameMap
NameMap (PackageID (FIName Utf8), [MName String], [MName String])
a ([(FIName Utf8, ProtoName)] -> ReMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(FIName Utf8, ProtoName)]
w))) (Either
   String
   ((PackageID (FIName Utf8), [MName String], [MName String]),
    [(FIName Utf8, ProtoName)])
 -> Either String NameMap)
-> (WriterT
      [(FIName Utf8, ProtoName)]
      (Either String)
      (PackageID (FIName Utf8), [MName String], [MName String])
    -> Either
         String
         ((PackageID (FIName Utf8), [MName String], [MName String]),
          [(FIName Utf8, ProtoName)]))
-> WriterT
     [(FIName Utf8, ProtoName)]
     (Either String)
     (PackageID (FIName Utf8), [MName String], [MName String])
-> Either String NameMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT
  [(FIName Utf8, ProtoName)]
  (Either String)
  (PackageID (FIName Utf8), [MName String], [MName String])
-> Either
     String
     ((PackageID (FIName Utf8), [MName String], [MName String]),
      [(FIName Utf8, ProtoName)])
forall a.
WriterT [(FIName Utf8, ProtoName)] (Either String) a
-> Either String (a, [(FIName Utf8, ProtoName)])
runMRM'Writer

  makeOne :: FileDescriptorProto
-> WriterT
     [(FIName Utf8, ProtoName)]
     (Either String)
     (PackageID (FIName Utf8), [MName String], [MName String])
makeOne FileDescriptorProto
fdp = do
    -- Create 'template' :: ProtoName using "Text.ProtocolBuffers.Identifiers" with error for baseName
    let rawPackage :: PackageID Utf8
rawPackage = FileDescriptorProto -> PackageID Utf8
getPackage FileDescriptorProto
fdp :: PackageID Utf8
    PackageID (Bool, [IName Utf8])
_ <- Either String (PackageID (Bool, [IName Utf8]))
-> WriterT
     [(FIName Utf8, ProtoName)]
     (Either String)
     (PackageID (Bool, [IName Utf8]))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PackageID Utf8 -> Either String (PackageID (Bool, [IName Utf8]))
checkPackageID PackageID Utf8
rawPackage) -- guard-like effect
{-
    -- Previously patched way of doing this
    let packageName = case D.FileDescriptorProto.package fdp of
                        Nothing -> FIName $ fromString ""
                        Just p  -> difi $ DIName p
-}
    let packageName :: PackageID (FIName Utf8)
        packageName :: PackageID (FIName Utf8)
packageName = (Utf8 -> FIName Utf8) -> PackageID Utf8 -> PackageID (FIName Utf8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DIName Utf8 -> FIName Utf8
forall a. Dotted a => DIName a -> FIName a
difi (DIName Utf8 -> FIName Utf8)
-> (Utf8 -> DIName Utf8) -> Utf8 -> FIName Utf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8 -> DIName Utf8
forall a. a -> DIName a
DIName) PackageID Utf8
rawPackage
        fi'package'name :: FIName Utf8
fi'package'name = PackageID (FIName Utf8) -> FIName Utf8
forall a. PackageID a -> a
getPackageID PackageID (FIName Utf8)
packageName
    Utf8
rawParent <- String
-> Maybe Utf8
-> WriterT [(FIName Utf8, ProtoName)] (Either String) Utf8
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"makeNameMap.makeOne: impossible Nothing found" (Maybe Utf8
 -> WriterT [(FIName Utf8, ProtoName)] (Either String) Utf8)
-> ([Maybe Utf8] -> Maybe Utf8)
-> [Maybe Utf8]
-> WriterT [(FIName Utf8, ProtoName)] (Either String) Utf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Utf8] -> Maybe Utf8
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Utf8]
 -> WriterT [(FIName Utf8, ProtoName)] (Either String) Utf8)
-> [Maybe Utf8]
-> WriterT [(FIName Utf8, ProtoName)] (Either String) Utf8
forall a b. (a -> b) -> a -> b
$
        [ FileOptions -> Maybe Utf8
D.FileOptions.java_outer_classname (FileOptions -> Maybe Utf8) -> Maybe FileOptions -> Maybe Utf8
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FileDescriptorProto -> Maybe FileOptions
D.FileDescriptorProto.options FileDescriptorProto
fdp)
        , FileOptions -> Maybe Utf8
D.FileOptions.java_package (FileOptions -> Maybe Utf8) -> Maybe FileOptions -> Maybe Utf8
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FileDescriptorProto -> Maybe FileOptions
D.FileDescriptorProto.options FileDescriptorProto
fdp)
        , Utf8 -> Maybe Utf8
forall a. a -> Maybe a
Just (PackageID Utf8 -> Utf8
forall a. PackageID a -> a
getPackageID PackageID Utf8
rawPackage)]
    DIName Utf8
diParent <- String
-> Maybe (DIName Utf8)
-> WriterT [(FIName Utf8, ProtoName)] (Either String) (DIName Utf8)
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust (String
"makeNameMap.makeOne: invalid character in: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Utf8 -> String
forall a. Show a => a -> String
show Utf8
rawParent)
                  (Utf8 -> Maybe (DIName Utf8)
forall a. Dotted a => a -> Maybe (DIName a)
validDI Utf8
rawParent)
    let hParent :: [MName String]
hParent = (IName Utf8 -> MName String) -> [IName Utf8] -> [MName String]
forall a b. (a -> b) -> [a] -> [b]
map (IName Utf8 -> MName String
forall a b. Mangle a b => a -> b
mangle :: IName Utf8 -> MName String) ([IName Utf8] -> [MName String])
-> (DIName Utf8 -> [IName Utf8]) -> DIName Utf8 -> [MName String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DIName Utf8 -> [IName Utf8]
forall a. Dotted a => DIName a -> [IName a]
splitDI (DIName Utf8 -> [MName String]) -> DIName Utf8 -> [MName String]
forall a b. (a -> b) -> a -> b
$ DIName Utf8
diParent
        template :: ProtoName
template = FIName Utf8
-> [MName String] -> [MName String] -> MName String -> ProtoName
ProtoName FIName Utf8
fi'package'name [MName String]
hPrefix [MName String]
hParent
                     (String -> MName String
forall a. HasCallStack => String -> a
error String
"makeNameMap.makeOne.template.baseName undefined")
    ReaderT
  ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
-> ProtoName
-> WriterT [(FIName Utf8, ProtoName)] (Either String) ()
forall a.
MRM a
-> ProtoName
-> WriterT [(FIName Utf8, ProtoName)] (Either String) a
runMRM'Reader (FileDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmFile FileDescriptorProto
fdp) ProtoName
template
    (PackageID (FIName Utf8), [MName String], [MName String])
-> WriterT
     [(FIName Utf8, ProtoName)]
     (Either String)
     (PackageID (FIName Utf8), [MName String], [MName String])
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageID (FIName Utf8)
packageName,[MName String]
hPrefix,[MName String]
hParent)
  -- Traversal of the named DescriptorProto types
  fieldNotOneof :: D.DescriptorProto -> Seq D.FieldDescriptorProto
  fieldNotOneof :: DescriptorProto -> Seq FieldDescriptorProto
fieldNotOneof = (FieldDescriptorProto -> Bool)
-> Seq FieldDescriptorProto -> Seq FieldDescriptorProto
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (Maybe Int32 -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Int32 -> Bool)
-> (FieldDescriptorProto -> Maybe Int32)
-> FieldDescriptorProto
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescriptorProto -> Maybe Int32
D.FieldDescriptorProto.oneof_index) (Seq FieldDescriptorProto -> Seq FieldDescriptorProto)
-> (DescriptorProto -> Seq FieldDescriptorProto)
-> DescriptorProto
-> Seq FieldDescriptorProto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.field

  oneofFieldMap :: D.DescriptorProto -> [(D.OneofDescriptorProto,Seq D.FieldDescriptorProto)]
  oneofFieldMap :: DescriptorProto
-> [(OneofDescriptorProto, Seq FieldDescriptorProto)]
oneofFieldMap DescriptorProto
dp = [OneofDescriptorProto]
-> [Seq FieldDescriptorProto]
-> [(OneofDescriptorProto, Seq FieldDescriptorProto)]
forall a b. [a] -> [b] -> [(a, b)]
zip [OneofDescriptorProto]
odps [Seq FieldDescriptorProto]
fdpss
    where odps :: [OneofDescriptorProto]
odps = Seq OneofDescriptorProto -> [OneofDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (DescriptorProto -> Seq OneofDescriptorProto
D.DescriptorProto.oneof_decl DescriptorProto
dp)
          fdps :: Seq FieldDescriptorProto
fdps = DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.field DescriptorProto
dp
          fdpss :: [Seq FieldDescriptorProto]
fdpss = (Int32 -> Seq FieldDescriptorProto)
-> [Int32] -> [Seq FieldDescriptorProto]
forall a b. (a -> b) -> [a] -> [b]
map  (\Int32
i->(FieldDescriptorProto -> Bool)
-> Seq FieldDescriptorProto -> Seq FieldDescriptorProto
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter ((Maybe Int32 -> Maybe Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
i) (Maybe Int32 -> Bool)
-> (FieldDescriptorProto -> Maybe Int32)
-> FieldDescriptorProto
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescriptorProto -> Maybe Int32
D.FieldDescriptorProto.oneof_index) Seq FieldDescriptorProto
fdps) [Int32
0..]


  mrmFile :: D.FileDescriptorProto -> MRM ()
  mrmFile :: FileDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmFile FileDescriptorProto
fdp = do
    (DescriptorProto
 -> ReaderT
      ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ())
-> Seq DescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ DescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmMsg     (FileDescriptorProto -> Seq DescriptorProto
D.FileDescriptorProto.message_type FileDescriptorProto
fdp)
    (FieldDescriptorProto -> MRM ProtoName)
-> Seq FieldDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ FieldDescriptorProto -> MRM ProtoName
mrmField   (FileDescriptorProto -> Seq FieldDescriptorProto
D.FileDescriptorProto.extension    FileDescriptorProto
fdp)
    (EnumDescriptorProto
 -> ReaderT
      ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ())
-> Seq EnumDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ EnumDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmEnum    (FileDescriptorProto -> Seq EnumDescriptorProto
D.FileDescriptorProto.enum_type    FileDescriptorProto
fdp)
    (ServiceDescriptorProto
 -> ReaderT
      ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ())
-> Seq ServiceDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ ServiceDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmService (FileDescriptorProto -> Seq ServiceDescriptorProto
D.FileDescriptorProto.service      FileDescriptorProto
fdp)
  mrmMsg :: DescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmMsg DescriptorProto
dp = do
    ProtoName
template <- String
-> (DescriptorProto -> Maybe Utf8)
-> DescriptorProto
-> MRM ProtoName
forall a. String -> (a -> Maybe Utf8) -> a -> MRM ProtoName
mrmName String
"mrmMsg.name" DescriptorProto -> Maybe Utf8
D.DescriptorProto.name DescriptorProto
dp
    (ProtoName -> ProtoName)
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ProtoName -> ProtoName -> ProtoName
forall a b. a -> b -> a
const ProtoName
template) (ReaderT
   ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
 -> ReaderT
      ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ())
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall a b. (a -> b) -> a -> b
$ do
      (EnumDescriptorProto
 -> ReaderT
      ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ())
-> Seq EnumDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ EnumDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmEnum    (DescriptorProto -> Seq EnumDescriptorProto
D.DescriptorProto.enum_type   DescriptorProto
dp)
      (FieldDescriptorProto -> MRM ProtoName)
-> Seq FieldDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ FieldDescriptorProto -> MRM ProtoName
mrmField   (DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.extension   DescriptorProto
dp)
      (FieldDescriptorProto -> MRM ProtoName)
-> Seq FieldDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ FieldDescriptorProto -> MRM ProtoName
mrmField   (DescriptorProto -> Seq FieldDescriptorProto
fieldNotOneof                 DescriptorProto
dp)
      ((OneofDescriptorProto, Seq FieldDescriptorProto)
 -> ReaderT
      ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ())
-> [(OneofDescriptorProto, Seq FieldDescriptorProto)]
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ (OneofDescriptorProto, Seq FieldDescriptorProto)
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *).
Foldable t =>
(OneofDescriptorProto, t FieldDescriptorProto)
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmOneof   (DescriptorProto
-> [(OneofDescriptorProto, Seq FieldDescriptorProto)]
oneofFieldMap                 DescriptorProto
dp)
      (DescriptorProto
 -> ReaderT
      ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ())
-> Seq DescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ DescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmMsg     (DescriptorProto -> Seq DescriptorProto
D.DescriptorProto.nested_type DescriptorProto
dp)
  mrmField :: FieldDescriptorProto -> MRM ProtoName
mrmField FieldDescriptorProto
fdp = String
-> (FieldDescriptorProto -> Maybe Utf8)
-> FieldDescriptorProto
-> MRM ProtoName
forall a. String -> (a -> Maybe Utf8) -> a -> MRM ProtoName
mrmName String
"mrmField.name" FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.name FieldDescriptorProto
fdp
  mrmOneof :: (OneofDescriptorProto, t FieldDescriptorProto)
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmOneof (OneofDescriptorProto
odp,t FieldDescriptorProto
fdps) = do
    ProtoName
template <- String
-> (OneofDescriptorProto -> Maybe Utf8)
-> OneofDescriptorProto
-> MRM ProtoName
forall a. String -> (a -> Maybe Utf8) -> a -> MRM ProtoName
mrmName String
"mrmOneof.name" OneofDescriptorProto -> Maybe Utf8
D.OneofDescriptorProto.name OneofDescriptorProto
odp
    (ProtoName -> ProtoName)
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ProtoName -> ProtoName -> ProtoName
forall a b. a -> b -> a
const ProtoName
template) (ReaderT
   ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
 -> ReaderT
      ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ())
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall a b. (a -> b) -> a -> b
$
      (FieldDescriptorProto -> MRM ProtoName)
-> t FieldDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ FieldDescriptorProto -> MRM ProtoName
mrmField t FieldDescriptorProto
fdps
  mrmEnum :: EnumDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmEnum EnumDescriptorProto
edp = do
    ProtoName
template <- String
-> (EnumDescriptorProto -> Maybe Utf8)
-> EnumDescriptorProto
-> MRM ProtoName
forall a. String -> (a -> Maybe Utf8) -> a -> MRM ProtoName
mrmName String
"mrmEnum.name" EnumDescriptorProto -> Maybe Utf8
D.EnumDescriptorProto.name EnumDescriptorProto
edp
    (ProtoName -> ProtoName)
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ProtoName -> ProtoName -> ProtoName
forall a b. a -> b -> a
const ProtoName
template) (ReaderT
   ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
 -> ReaderT
      ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ())
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall a b. (a -> b) -> a -> b
$ (EnumValueDescriptorProto -> MRM ProtoName)
-> Seq EnumValueDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ EnumValueDescriptorProto -> MRM ProtoName
mrmEnumValue (EnumDescriptorProto -> Seq EnumValueDescriptorProto
D.EnumDescriptorProto.value EnumDescriptorProto
edp)
  mrmEnumValue :: EnumValueDescriptorProto -> MRM ProtoName
mrmEnumValue EnumValueDescriptorProto
evdp = String
-> (EnumValueDescriptorProto -> Maybe Utf8)
-> EnumValueDescriptorProto
-> MRM ProtoName
forall a. String -> (a -> Maybe Utf8) -> a -> MRM ProtoName
mrmName String
"mrmEnumValue.name" EnumValueDescriptorProto -> Maybe Utf8
D.EnumValueDescriptorProto.name EnumValueDescriptorProto
evdp
  mrmService :: ServiceDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
mrmService ServiceDescriptorProto
sdp = do
    ProtoName
template <- String
-> (ServiceDescriptorProto -> Maybe Utf8)
-> ServiceDescriptorProto
-> MRM ProtoName
forall a. String -> (a -> Maybe Utf8) -> a -> MRM ProtoName
mrmName String
"mrmService.name" ServiceDescriptorProto -> Maybe Utf8
D.ServiceDescriptorProto.name ServiceDescriptorProto
sdp
    (ProtoName -> ProtoName)
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ProtoName -> ProtoName -> ProtoName
forall a b. a -> b -> a
const ProtoName
template) (ReaderT
   ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
 -> ReaderT
      ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ())
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall a b. (a -> b) -> a -> b
$ (MethodDescriptorProto -> MRM ProtoName)
-> Seq MethodDescriptorProto
-> ReaderT
     ProtoName (WriterT [(FIName Utf8, ProtoName)] (Either String)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ MethodDescriptorProto -> MRM ProtoName
mrmMethod (ServiceDescriptorProto -> Seq MethodDescriptorProto
D.ServiceDescriptorProto.method ServiceDescriptorProto
sdp)
  mrmMethod :: MethodDescriptorProto -> MRM ProtoName
mrmMethod MethodDescriptorProto
mdp = String
-> (MethodDescriptorProto -> Maybe Utf8)
-> MethodDescriptorProto
-> MRM ProtoName
forall a. String -> (a -> Maybe Utf8) -> a -> MRM ProtoName
mrmName String
"mrmMethod.name" MethodDescriptorProto -> Maybe Utf8
D.MethodDescriptorProto.name MethodDescriptorProto
mdp

getNames :: String -> (a -> Maybe Utf8) -> a -> SE (IName String,[IName String])
getNames :: String
-> (a -> Maybe Utf8) -> a -> SE (IName String, [IName String])
getNames String
errorMessage a -> Maybe Utf8
accessor a
record = do
  [IName String]
parent <- (SEnv -> [IName String])
-> ReaderT SEnv (Either String) [IName String]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SEnv -> [IName String]
my'Parent
  IName String
iSelf <- (IName Utf8 -> IName String)
-> ReaderT SEnv (Either String) (IName Utf8)
-> ReaderT SEnv (Either String) (IName String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IName Utf8 -> IName String
iToString (ReaderT SEnv (Either String) (IName Utf8)
 -> ReaderT SEnv (Either String) (IName String))
-> ReaderT SEnv (Either String) (IName Utf8)
-> ReaderT SEnv (Either String) (IName String)
forall a b. (a -> b) -> a -> b
$ String
-> Maybe (IName Utf8) -> ReaderT SEnv (Either String) (IName Utf8)
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
errorMessage (Utf8 -> Maybe (IName Utf8)
forall a. Dotted a => a -> Maybe (IName a)
validI (Utf8 -> Maybe (IName Utf8)) -> Maybe Utf8 -> Maybe (IName Utf8)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> Maybe Utf8
accessor a
record)
  let names :: [IName String]
names = [IName String]
parent [IName String] -> [IName String] -> [IName String]
forall a. [a] -> [a] -> [a]
++ [ IName String
iSelf ]
  (IName String, [IName String]) -> SE (IName String, [IName String])
forall (m :: * -> *) a. Monad m => a -> m a
return (IName String
iSelf,[IName String]
names)

descend :: [IName String] -> Entity -> SE a -> SE a
descend :: [IName String] -> Entity -> SE a -> SE a
descend [IName String]
names Entity
entity SE a
act = (SEnv -> SEnv) -> SE a -> SE a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local SEnv -> SEnv
mutate SE a
act
  where mutate :: SEnv -> SEnv
mutate (SEnv [IName String]
_parent Env
env) = [IName String] -> Env -> SEnv
SEnv [IName String]
parent' Env
env'
          where parent' :: [IName String]
parent' = [IName String]
names -- cannot call eName ename, will cause <<loop>> with "getNames" -- XXX revisit
                env' :: Env
env' = [IName String] -> EMap -> Env -> Env
Local (Entity -> [IName String]
eName Entity
entity) (Entity -> EMap
mVals Entity
entity) Env
env

-- Run each element of (Seq x) as (f x) with same initial environment and state.
-- Then merge the output states and sort out the failures and successes.
kids :: (x -> SE (IName String,E'Entity)) -> Seq x -> SE ([ErrStr],[(IName String,E'Entity)])
kids :: (x -> SE (IName String, E'Entity))
-> Seq x -> SE ([String], [(IName String, E'Entity)])
kids x -> SE (IName String, E'Entity)
f Seq x
xs = do SEnv
sEnv <- ReaderT SEnv (Either String) SEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
               let ans :: [Either String (IName String, E'Entity)]
ans = (SE (IName String, E'Entity)
 -> Either String (IName String, E'Entity))
-> [SE (IName String, E'Entity)]
-> [Either String (IName String, E'Entity)]
forall a b. (a -> b) -> [a] -> [b]
map (SEnv
-> SE (IName String, E'Entity)
-> Either String (IName String, E'Entity)
forall a. SEnv -> SE a -> Either String a
runSE SEnv
sEnv) ([SE (IName String, E'Entity)]
 -> [Either String (IName String, E'Entity)])
-> (Seq x -> [SE (IName String, E'Entity)])
-> Seq x
-> [Either String (IName String, E'Entity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> SE (IName String, E'Entity))
-> [x] -> [SE (IName String, E'Entity)]
forall a b. (a -> b) -> [a] -> [b]
map x -> SE (IName String, E'Entity)
f ([x] -> [SE (IName String, E'Entity)])
-> (Seq x -> [x]) -> Seq x -> [SE (IName String, E'Entity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq x -> [x]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq x -> [Either String (IName String, E'Entity)])
-> Seq x -> [Either String (IName String, E'Entity)]
forall a b. (a -> b) -> a -> b
$ Seq x
xs
               ([String], [(IName String, E'Entity)])
-> SE ([String], [(IName String, E'Entity)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either String (IName String, E'Entity)]
-> ([String], [(IName String, E'Entity)])
forall a b. [Either a b] -> ([a], [b])
partEither [Either String (IName String, E'Entity)]
ans)

-- | 'makeTopLevel' takes a .proto file's FileDescriptorProto and the TopLevel values of its
-- directly imported file and constructs the TopLevel of the FileDescriptorProto in a Global
-- Environment.
--
-- This goes to some lengths to be a total function with good error messages.  Errors in building
-- the skeleton of the namespace are detected and reported instead of returning the new 'Global'
-- environment.  Collisions in the namespace are only detected when the offending name is looked up,
-- and will return an E'Error entity with a message and list of colliding Entity items.  The
-- cross-linking of Entity fields may fail and this failure is stored in the corresponding Entity.
--
-- Also caught: name collisions in Enum definitions.
--
-- The 'mdo' usage has been replace by modified forms of 'mfix' that will generate useful error
-- values instead of calling 'error' and halting 'hprotoc'.
--
-- Used from loadProto'
makeTopLevel :: D.FileDescriptorProto -> PackageID [IName String] -> [TopLevel] -> Either ErrStr Env {- Global -}
makeTopLevel :: FileDescriptorProto
-> PackageID [IName String] -> [TopLevel] -> Either String Env
makeTopLevel FileDescriptorProto
fdp PackageID [IName String]
packageName [TopLevel]
imports = do
  Utf8
filePath <- String -> Maybe Utf8 -> Either String Utf8
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"makeTopLevel.filePath" (FileDescriptorProto -> Maybe Utf8
D.FileDescriptorProto.name FileDescriptorProto
fdp)
  let -- There should be no TYPE_GROUP in the extension list here, but to be safe:
      isGroup :: IName String -> Bool
isGroup = (IName String -> [IName String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IName String]
groupNames) where
        groupNamesRaw :: [String]
groupNamesRaw = (Utf8 -> String) -> [Utf8] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Utf8 -> String
toString ([Utf8] -> [String])
-> ([FieldDescriptorProto] -> [Utf8])
-> [FieldDescriptorProto]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDescriptorProto -> Maybe Utf8)
-> [FieldDescriptorProto] -> [Utf8]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.type_name
                   ([FieldDescriptorProto] -> [Utf8])
-> ([FieldDescriptorProto] -> [FieldDescriptorProto])
-> [FieldDescriptorProto]
-> [Utf8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDescriptorProto -> Bool)
-> [FieldDescriptorProto] -> [FieldDescriptorProto]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> (Type -> Bool) -> Maybe Type -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Type
TYPE_GROUP Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe Type -> Bool)
-> (FieldDescriptorProto -> Maybe Type)
-> FieldDescriptorProto
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescriptorProto -> Maybe Type
D.FieldDescriptorProto.type')
                   ([FieldDescriptorProto] -> [String])
-> [FieldDescriptorProto] -> [String]
forall a b. (a -> b) -> a -> b
$ (Seq FieldDescriptorProto -> [FieldDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq FieldDescriptorProto -> [FieldDescriptorProto])
-> (FileDescriptorProto -> Seq FieldDescriptorProto)
-> FileDescriptorProto
-> [FieldDescriptorProto]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileDescriptorProto -> Seq FieldDescriptorProto
D.FileDescriptorProto.extension (FileDescriptorProto -> [FieldDescriptorProto])
-> FileDescriptorProto -> [FieldDescriptorProto]
forall a b. (a -> b) -> a -> b
$ FileDescriptorProto
fdp)
        groupNamesI :: [IName String]
groupNamesI = (String -> Maybe (IName String)) -> [String] -> [IName String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (IName String)
forall a. Dotted a => a -> Maybe (IName a)
validI [String]
groupNamesRaw
        groupNamesDI :: [DIName String]
groupNamesDI = (String -> Maybe (DIName String)) -> [String] -> [DIName String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (DIName String)
forall a. Dotted a => a -> Maybe (DIName a)
validDI [String]
groupNamesRaw  -- These fully qualified names from using hprotoc as a plugin for protoc
        groupNames :: [IName String]
groupNames = [IName String]
groupNamesI [IName String] -> [IName String] -> [IName String]
forall a. [a] -> [a] -> [a]
++ (DIName String -> IName String)
-> [DIName String] -> [IName String]
forall a b. (a -> b) -> [a] -> [b]
map ([IName String] -> IName String
forall a. [a] -> a
last ([IName String] -> IName String)
-> (DIName String -> [IName String])
-> DIName String
-> IName String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DIName String -> [IName String]
forall a. Dotted a => DIName a -> [IName a]
splitDI) [DIName String]
groupNamesDI
  (String
bad,Env
global) <- (String, Env)
-> (Env -> Either String (String, Env))
-> Either String (String, Env)
forall a.
(String, a)
-> (a -> Either String (String, a)) -> Either String (String, a)
myFixE (String
"makeTopLevel myFixE",Env
emptyEnv) ((Env -> Either String (String, Env))
 -> Either String (String, Env))
-> (Env -> Either String (String, Env))
-> Either String (String, Env)
forall a b. (a -> b) -> a -> b
$ \ Env
global'Param ->
    let sEnv :: SEnv
sEnv = [IName String] -> Env -> SEnv
SEnv (PackageID [IName String] -> [IName String]
get'SEnv'root'from'PackageID PackageID [IName String]
packageName) Env
global'Param
    in SEnv -> SE (String, Env) -> Either String (String, Env)
forall a. SEnv -> SE a -> Either String a
runSE SEnv
sEnv (SE (String, Env) -> Either String (String, Env))
-> SE (String, Env) -> Either String (String, Env)
forall a b. (a -> b) -> a -> b
$ do
      ([[String]]
bads,[[(IName String, E'Entity)]]
children) <- ([([String], [(IName String, E'Entity)])]
 -> ([[String]], [[(IName String, E'Entity)]]))
-> ReaderT
     SEnv (Either String) [([String], [(IName String, E'Entity)])]
-> ReaderT
     SEnv (Either String) ([[String]], [[(IName String, E'Entity)]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [([String], [(IName String, E'Entity)])]
-> ([[String]], [[(IName String, E'Entity)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (ReaderT
   SEnv (Either String) [([String], [(IName String, E'Entity)])]
 -> ReaderT
      SEnv (Either String) ([[String]], [[(IName String, E'Entity)]]))
-> ([SE ([String], [(IName String, E'Entity)])]
    -> ReaderT
         SEnv (Either String) [([String], [(IName String, E'Entity)])])
-> [SE ([String], [(IName String, E'Entity)])]
-> ReaderT
     SEnv (Either String) ([[String]], [[(IName String, E'Entity)]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SE ([String], [(IName String, E'Entity)])]
-> ReaderT
     SEnv (Either String) [([String], [(IName String, E'Entity)])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([SE ([String], [(IName String, E'Entity)])]
 -> ReaderT
      SEnv (Either String) ([[String]], [[(IName String, E'Entity)]]))
-> [SE ([String], [(IName String, E'Entity)])]
-> ReaderT
     SEnv (Either String) ([[String]], [[(IName String, E'Entity)]])
forall a b. (a -> b) -> a -> b
$
        [ (DescriptorProto -> SE (IName String, E'Entity))
-> Seq DescriptorProto -> SE ([String], [(IName String, E'Entity)])
forall x.
(x -> SE (IName String, E'Entity))
-> Seq x -> SE ([String], [(IName String, E'Entity)])
kids ((IName String -> Bool)
-> DescriptorProto -> SE (IName String, E'Entity)
entityMsg IName String -> Bool
isGroup) (FileDescriptorProto -> Seq DescriptorProto
D.FileDescriptorProto.message_type FileDescriptorProto
fdp)
        , (FieldDescriptorProto -> SE (IName String, E'Entity))
-> Seq FieldDescriptorProto
-> SE ([String], [(IName String, E'Entity)])
forall x.
(x -> SE (IName String, E'Entity))
-> Seq x -> SE ([String], [(IName String, E'Entity)])
kids (Bool -> FieldDescriptorProto -> SE (IName String, E'Entity)
entityField Bool
True)  (FileDescriptorProto -> Seq FieldDescriptorProto
D.FileDescriptorProto.extension    FileDescriptorProto
fdp)
        , (EnumDescriptorProto -> SE (IName String, E'Entity))
-> Seq EnumDescriptorProto
-> SE ([String], [(IName String, E'Entity)])
forall x.
(x -> SE (IName String, E'Entity))
-> Seq x -> SE ([String], [(IName String, E'Entity)])
kids EnumDescriptorProto -> SE (IName String, E'Entity)
entityEnum          (FileDescriptorProto -> Seq EnumDescriptorProto
D.FileDescriptorProto.enum_type    FileDescriptorProto
fdp)
        , (ServiceDescriptorProto -> SE (IName String, E'Entity))
-> Seq ServiceDescriptorProto
-> SE ([String], [(IName String, E'Entity)])
forall x.
(x -> SE (IName String, E'Entity))
-> Seq x -> SE ([String], [(IName String, E'Entity)])
kids ServiceDescriptorProto -> SE (IName String, E'Entity)
entityService       (FileDescriptorProto -> Seq ServiceDescriptorProto
D.FileDescriptorProto.service      FileDescriptorProto
fdp) ]
      let bad' :: String
bad' = [String] -> String
unlines ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
bads)
          global' :: Env
global' = TopLevel -> [TopLevel] -> Env
Global (String
-> PackageID [IName String]
-> Either String FileDescriptorProto
-> EMap
-> TopLevel
TopLevel (Utf8 -> String
toString Utf8
filePath)
                                     PackageID [IName String]
packageName
                                     (FileDescriptorProto -> Env -> Either String FileDescriptorProto
resolveFDP FileDescriptorProto
fdp Env
global')
                                     ((IName String -> E'Entity -> E'Entity -> E'Entity)
-> [(IName String, E'Entity)] -> EMap
forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWithKey IName String -> E'Entity -> E'Entity -> E'Entity
unique ([[(IName String, E'Entity)]] -> [(IName String, E'Entity)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(IName String, E'Entity)]]
children)))
                           [TopLevel]
imports
      (String, Env) -> SE (String, Env)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
bad',Env
global')
  -- Moving this outside the myFixE reduces the cases where myFixE generates an 'error' call.
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
bad)) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall e (m :: * -> *) a.
(Error e, MonadError e m) =>
String -> m a
throw (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"makeTopLevel.bad: Some children failed for "String -> String -> String
forall a. [a] -> [a] -> [a]
++Utf8 -> String
forall a. Show a => a -> String
show Utf8
filePathString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
bad
  Env -> Either String Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
global

 where resolveFDP :: D.FileDescriptorProto -> Env -> Either ErrStr D.FileDescriptorProto
       resolveFDP :: FileDescriptorProto -> Env -> Either String FileDescriptorProto
resolveFDP FileDescriptorProto
fdpIn Env
env = Env -> RE FileDescriptorProto -> Either String FileDescriptorProto
runRE Env
env (FileDescriptorProto -> RE FileDescriptorProto
fqFileDP FileDescriptorProto
fdpIn)
        where runRE :: Env -> RE D.FileDescriptorProto -> Either ErrStr D.FileDescriptorProto
              runRE :: Env -> RE FileDescriptorProto -> Either String FileDescriptorProto
runRE Env
envIn RE FileDescriptorProto
m = RE FileDescriptorProto -> Env -> Either String FileDescriptorProto
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RE FileDescriptorProto
m Env
envIn

       -- Used from makeTopLevel, from loadProto'
       get'SEnv'root'from'PackageID :: PackageID [IName String] -> [IName String]
       get'SEnv'root'from'PackageID :: PackageID [IName String] -> [IName String]
get'SEnv'root'from'PackageID = PackageID [IName String] -> [IName String]
forall a. PackageID a -> a
getPackageID -- was mPackageID before 2012-09-19
           -- where
           -- Used from get'SEnv  makeTopLevel, from loadProto'
           -- mPackageID :: Monoid a => PackageID a -> a
           -- mPackageID (PackageID {_getPackageID=x}) = x
           -- mPackageID (NoPackageID {}) = mempty


-- Copies of mFix for use the string in (Left msg) for the error message.
-- Note that the usual mfix for Either calls 'error' while this does not,
-- it uses a default value passed to myFix*.
myFixSE :: (String,a) -> (a -> SE (String,a)) -> SE (String,a)
myFixSE :: (String, a) -> (a -> SE (String, a)) -> SE (String, a)
myFixSE (String, a)
s a -> SE (String, a)
f = (SEnv -> Either String (String, a)) -> SE (String, a)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((SEnv -> Either String (String, a)) -> SE (String, a))
-> (SEnv -> Either String (String, a)) -> SE (String, a)
forall a b. (a -> b) -> a -> b
$ \SEnv
r -> (String, a)
-> (a -> Either String (String, a)) -> Either String (String, a)
forall a.
(String, a)
-> (a -> Either String (String, a)) -> Either String (String, a)
myFixE (String, a)
s (\a
a -> SE (String, a) -> SEnv -> Either String (String, a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> SE (String, a)
f a
a) SEnv
r)

-- Note that f ignores the fst argument
myFixE :: (String,a) -> (a -> Either ErrStr (String,a)) -> Either ErrStr (String,a)
myFixE :: (String, a)
-> (a -> Either String (String, a)) -> Either String (String, a)
myFixE (String, a)
s a -> Either String (String, a)
f = let a :: Either String (String, a)
a = a -> Either String (String, a)
f (Either String (String, a) -> a
unRight Either String (String, a)
a) in Either String (String, a)
a
    where unRight :: Either String (String, a) -> a
unRight (Right (String, a)
x) = (String, a) -> a
forall a b. (a, b) -> b
snd (String, a)
x
          unRight (Left String
_msg) = (String, a) -> a
forall a b. (a, b) -> b
snd (String, a)
s
--            ( "Text.ProtocolBuffers.ProtoCompile.Resolve: "++fst s ++":\n" ++ indent msg
--                               , snd s)

{- ***
All the entity* functions are used by makeTopLevel and each other.
If there is no error then these return (IName String,E'Entity) and this E'Entity is always E'Ok.
 *** -}

-- Fix this to look at groupNamesDI as well as the original list of groupNamesI.  This fixes a bug
-- in the plug-in usage because protoc will have already resolved the type_name to a fully qualified
-- name.
entityMsg :: (IName String -> Bool) -> D.DescriptorProto -> SE (IName String,E'Entity)
entityMsg :: (IName String -> Bool)
-> DescriptorProto -> SE (IName String, E'Entity)
entityMsg IName String -> Bool
isGroup DescriptorProto
dp = String
-> SE (IName String, E'Entity) -> SE (IName String, E'Entity)
forall (m :: * -> *) a. MonadError String m => String -> m a -> m a
annErr (String
"entityMsg DescriptorProto name is "String -> String -> String
forall a. [a] -> [a] -> [a]
++Maybe Utf8 -> String
forall a. Show a => a -> String
show (DescriptorProto -> Maybe Utf8
D.DescriptorProto.name DescriptorProto
dp)) (SE (IName String, E'Entity) -> SE (IName String, E'Entity))
-> SE (IName String, E'Entity) -> SE (IName String, E'Entity)
forall a b. (a -> b) -> a -> b
$ do
  (IName String
self,[IName String]
names) <- String
-> (DescriptorProto -> Maybe Utf8)
-> DescriptorProto
-> SE (IName String, [IName String])
forall a.
String
-> (a -> Maybe Utf8) -> a -> SE (IName String, [IName String])
getNames String
"entityMsg.name" DescriptorProto -> Maybe Utf8
D.DescriptorProto.name DescriptorProto
dp
  Set Int32
numbers <- ([Int32] -> Set Int32)
-> ReaderT SEnv (Either String) [Int32]
-> ReaderT SEnv (Either String) (Set Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int32] -> Set Int32
forall a. Ord a => [a] -> Set a
Set.fromList (ReaderT SEnv (Either String) [Int32]
 -> ReaderT SEnv (Either String) (Set Int32))
-> (DescriptorProto -> ReaderT SEnv (Either String) [Int32])
-> DescriptorProto
-> ReaderT SEnv (Either String) (Set Int32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDescriptorProto -> ReaderT SEnv (Either String) Int32)
-> [FieldDescriptorProto] -> ReaderT SEnv (Either String) [Int32]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Maybe Int32 -> ReaderT SEnv (Either String) Int32
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"entityMsg.field.number" (Maybe Int32 -> ReaderT SEnv (Either String) Int32)
-> (FieldDescriptorProto -> Maybe Int32)
-> FieldDescriptorProto
-> ReaderT SEnv (Either String) Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescriptorProto -> Maybe Int32
D.FieldDescriptorProto.number) ([FieldDescriptorProto] -> ReaderT SEnv (Either String) [Int32])
-> (DescriptorProto -> [FieldDescriptorProto])
-> DescriptorProto
-> ReaderT SEnv (Either String) [Int32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq FieldDescriptorProto -> [FieldDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq FieldDescriptorProto -> [FieldDescriptorProto])
-> (DescriptorProto -> Seq FieldDescriptorProto)
-> DescriptorProto
-> [FieldDescriptorProto]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.field (DescriptorProto -> ReaderT SEnv (Either String) (Set Int32))
-> DescriptorProto -> ReaderT SEnv (Either String) (Set Int32)
forall a b. (a -> b) -> a -> b
$ DescriptorProto
dp
  Bool
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set Int32 -> Int
forall a. Set a -> Int
Set.size Set Int32
numbers Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Seq FieldDescriptorProto -> Int
forall a. Seq a -> Int
Seq.length (DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.field DescriptorProto
dp)) (ReaderT SEnv (Either String) ()
 -> ReaderT SEnv (Either String) ())
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$
    String -> ReaderT SEnv (Either String) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT SEnv (Either String) ())
-> String -> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"entityMsg.field.number: There must be duplicate field numbers for "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show [IName String]
namesString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n "String -> String -> String
forall a. [a] -> [a] -> [a]
++Set Int32 -> String
forall a. Show a => a -> String
show Set Int32
numbers
  let groupNamesRaw :: [String]
groupNamesRaw = (Utf8 -> String) -> [Utf8] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Utf8 -> String
toString ([Utf8] -> [String])
-> ([FieldDescriptorProto] -> [Utf8])
-> [FieldDescriptorProto]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDescriptorProto -> Maybe Utf8)
-> [FieldDescriptorProto] -> [Utf8]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.type_name
                      ([FieldDescriptorProto] -> [Utf8])
-> ([FieldDescriptorProto] -> [FieldDescriptorProto])
-> [FieldDescriptorProto]
-> [Utf8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDescriptorProto -> Bool)
-> [FieldDescriptorProto] -> [FieldDescriptorProto]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> (Type -> Bool) -> Maybe Type -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Type
TYPE_GROUP Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe Type -> Bool)
-> (FieldDescriptorProto -> Maybe Type)
-> FieldDescriptorProto
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescriptorProto -> Maybe Type
D.FieldDescriptorProto.type')
                      ([FieldDescriptorProto] -> [String])
-> [FieldDescriptorProto] -> [String]
forall a b. (a -> b) -> a -> b
$ (Seq FieldDescriptorProto -> [FieldDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq FieldDescriptorProto -> [FieldDescriptorProto])
-> (DescriptorProto -> Seq FieldDescriptorProto)
-> DescriptorProto
-> [FieldDescriptorProto]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.field (DescriptorProto -> [FieldDescriptorProto])
-> DescriptorProto -> [FieldDescriptorProto]
forall a b. (a -> b) -> a -> b
$ DescriptorProto
dp) [FieldDescriptorProto]
-> [FieldDescriptorProto] -> [FieldDescriptorProto]
forall a. [a] -> [a] -> [a]
++ (Seq FieldDescriptorProto -> [FieldDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq FieldDescriptorProto -> [FieldDescriptorProto])
-> (DescriptorProto -> Seq FieldDescriptorProto)
-> DescriptorProto
-> [FieldDescriptorProto]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.extension (DescriptorProto -> [FieldDescriptorProto])
-> DescriptorProto -> [FieldDescriptorProto]
forall a b. (a -> b) -> a -> b
$ DescriptorProto
dp)
      groupNamesI :: [IName String]
groupNamesI = (String -> Maybe (IName String)) -> [String] -> [IName String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (IName String)
forall a. Dotted a => a -> Maybe (IName a)
validI [String]
groupNamesRaw
      groupNamesDI :: [DIName String]
groupNamesDI = (String -> Maybe (DIName String)) -> [String] -> [DIName String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (DIName String)
forall a. Dotted a => a -> Maybe (DIName a)
validDI [String]
groupNamesRaw  -- These fully qualified names from using hprotoc as a plugin for protoc
      groupNames :: [IName String]
groupNames = [IName String]
groupNamesI [IName String] -> [IName String] -> [IName String]
forall a. [a] -> [a] -> [a]
++ (DIName String -> IName String)
-> [DIName String] -> [IName String]
forall a b. (a -> b) -> [a] -> [b]
map ([IName String] -> IName String
forall a. [a] -> a
last ([IName String] -> IName String)
-> (DIName String -> [IName String])
-> DIName String
-> IName String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DIName String -> [IName String]
forall a. Dotted a => DIName a -> [IName a]
splitDI) [DIName String]
groupNamesDI
      isGroup' :: IName String -> Bool
isGroup' = (IName String -> [IName String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IName String]
groupNames)
  (String
bad,Entity
entity) <- (String, Entity)
-> (Entity -> SE (String, Entity)) -> SE (String, Entity)
forall a. (String, a) -> (a -> SE (String, a)) -> SE (String, a)
myFixSE (String
"myFixSE entityMsg",Entity
emptyEntity) ((Entity -> SE (String, Entity)) -> SE (String, Entity))
-> (Entity -> SE (String, Entity)) -> SE (String, Entity)
forall a b. (a -> b) -> a -> b
$ \ Entity
entity'Param -> [IName String]
-> Entity -> SE (String, Entity) -> SE (String, Entity)
forall a. [IName String] -> Entity -> SE a -> SE a
descend [IName String]
names Entity
entity'Param (SE (String, Entity) -> SE (String, Entity))
-> SE (String, Entity) -> SE (String, Entity)
forall a b. (a -> b) -> a -> b
$ do
    ([[String]]
bads,[[(IName String, E'Entity)]]
children) <- ([([String], [(IName String, E'Entity)])]
 -> ([[String]], [[(IName String, E'Entity)]]))
-> ReaderT
     SEnv (Either String) [([String], [(IName String, E'Entity)])]
-> ReaderT
     SEnv (Either String) ([[String]], [[(IName String, E'Entity)]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [([String], [(IName String, E'Entity)])]
-> ([[String]], [[(IName String, E'Entity)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (ReaderT
   SEnv (Either String) [([String], [(IName String, E'Entity)])]
 -> ReaderT
      SEnv (Either String) ([[String]], [[(IName String, E'Entity)]]))
-> ([SE ([String], [(IName String, E'Entity)])]
    -> ReaderT
         SEnv (Either String) [([String], [(IName String, E'Entity)])])
-> [SE ([String], [(IName String, E'Entity)])]
-> ReaderT
     SEnv (Either String) ([[String]], [[(IName String, E'Entity)]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SE ([String], [(IName String, E'Entity)])]
-> ReaderT
     SEnv (Either String) [([String], [(IName String, E'Entity)])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([SE ([String], [(IName String, E'Entity)])]
 -> ReaderT
      SEnv (Either String) ([[String]], [[(IName String, E'Entity)]]))
-> [SE ([String], [(IName String, E'Entity)])]
-> ReaderT
     SEnv (Either String) ([[String]], [[(IName String, E'Entity)]])
forall a b. (a -> b) -> a -> b
$
      [ (EnumDescriptorProto -> SE (IName String, E'Entity))
-> Seq EnumDescriptorProto
-> SE ([String], [(IName String, E'Entity)])
forall x.
(x -> SE (IName String, E'Entity))
-> Seq x -> SE ([String], [(IName String, E'Entity)])
kids EnumDescriptorProto -> SE (IName String, E'Entity)
entityEnum           (DescriptorProto -> Seq EnumDescriptorProto
D.DescriptorProto.enum_type   DescriptorProto
dp)
      , (FieldDescriptorProto -> SE (IName String, E'Entity))
-> Seq FieldDescriptorProto
-> SE ([String], [(IName String, E'Entity)])
forall x.
(x -> SE (IName String, E'Entity))
-> Seq x -> SE ([String], [(IName String, E'Entity)])
kids (Bool -> FieldDescriptorProto -> SE (IName String, E'Entity)
entityField Bool
True)   (DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.extension   DescriptorProto
dp)
      , (FieldDescriptorProto -> SE (IName String, E'Entity))
-> Seq FieldDescriptorProto
-> SE ([String], [(IName String, E'Entity)])
forall x.
(x -> SE (IName String, E'Entity))
-> Seq x -> SE ([String], [(IName String, E'Entity)])
kids (Bool -> FieldDescriptorProto -> SE (IName String, E'Entity)
entityField Bool
False)  (DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.field       DescriptorProto
dp)
      , (DescriptorProto -> SE (IName String, E'Entity))
-> Seq DescriptorProto -> SE ([String], [(IName String, E'Entity)])
forall x.
(x -> SE (IName String, E'Entity))
-> Seq x -> SE ([String], [(IName String, E'Entity)])
kids ((IName String -> Bool)
-> DescriptorProto -> SE (IName String, E'Entity)
entityMsg IName String -> Bool
isGroup') (DescriptorProto -> Seq DescriptorProto
D.DescriptorProto.nested_type DescriptorProto
dp) ]
    let bad' :: String
bad' = [String] -> String
unlines ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
bads)
        entity' :: Entity
entity' | IName String -> Bool
isGroup IName String
self = [IName String] -> EMap -> Entity
E'Group [IName String]
names ((IName String -> E'Entity -> E'Entity -> E'Entity)
-> [(IName String, E'Entity)] -> EMap
forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWithKey IName String -> E'Entity -> E'Entity -> E'Entity
unique ([[(IName String, E'Entity)]] -> [(IName String, E'Entity)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(IName String, E'Entity)]]
children))
                | Bool
otherwise = [IName String] -> [(FieldId, FieldId)] -> EMap -> Entity
E'Message [IName String]
names (DescriptorProto -> [(FieldId, FieldId)]
getExtRanges DescriptorProto
dp) ((IName String -> E'Entity -> E'Entity -> E'Entity)
-> [(IName String, E'Entity)] -> EMap
forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWithKey IName String -> E'Entity -> E'Entity -> E'Entity
unique ([[(IName String, E'Entity)]] -> [(IName String, E'Entity)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(IName String, E'Entity)]]
children))
    (String, Entity) -> SE (String, Entity)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
bad',Entity
entity')
  -- Moving this outside the myFixSE reduces the cases where myFixSE uses the error-default call.
  Bool
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
bad)) (ReaderT SEnv (Either String) ()
 -> ReaderT SEnv (Either String) ())
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$
    String -> ReaderT SEnv (Either String) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT SEnv (Either String) ())
-> String -> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"entityMsg.bad: Some children failed for "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show [IName String]
namesString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
bad
  (IName String, E'Entity) -> SE (IName String, E'Entity)
forall (m :: * -> *) a. Monad m => a -> m a
return (IName String
self,Entity -> E'Entity
E'Ok (Entity -> E'Entity) -> Entity -> E'Entity
forall a b. (a -> b) -> a -> b
$ Entity
entity)

-- Among other things, this is where ambiguous type names in the proto file are resolved into a
-- Message or a Group or an Enum.
entityField :: Bool -> D.FieldDescriptorProto -> SE (IName String,E'Entity)
entityField :: Bool -> FieldDescriptorProto -> SE (IName String, E'Entity)
entityField Bool
isKey FieldDescriptorProto
fdp = String
-> SE (IName String, E'Entity) -> SE (IName String, E'Entity)
forall (m :: * -> *) a. MonadError String m => String -> m a -> m a
annErr (String
"entityField FieldDescriptorProto name is "String -> String -> String
forall a. [a] -> [a] -> [a]
++Maybe Utf8 -> String
forall a. Show a => a -> String
show (FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.name FieldDescriptorProto
fdp)) (SE (IName String, E'Entity) -> SE (IName String, E'Entity))
-> SE (IName String, E'Entity) -> SE (IName String, E'Entity)
forall a b. (a -> b) -> a -> b
$ do
  (IName String
self,[IName String]
names) <- String
-> (FieldDescriptorProto -> Maybe Utf8)
-> FieldDescriptorProto
-> SE (IName String, [IName String])
forall a.
String
-> (a -> Maybe Utf8) -> a -> SE (IName String, [IName String])
getNames String
"entityField.name" FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.name FieldDescriptorProto
fdp
  let isKey' :: Bool
isKey' = Bool -> (Utf8 -> Bool) -> Maybe Utf8 -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Utf8 -> Bool
forall a b. a -> b -> a
const Bool
True) (FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.extendee FieldDescriptorProto
fdp)
  Bool
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isKeyBool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/=Bool
isKey') (ReaderT SEnv (Either String) ()
 -> ReaderT SEnv (Either String) ())
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$
    String -> ReaderT SEnv (Either String) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT SEnv (Either String) ())
-> String -> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"entityField: Impossible? Expected key and got field or vice-versa:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++((Bool, Bool), [IName String], FieldDescriptorProto) -> String
forall a. Show a => a -> String
ishow ((Bool
isKey,Bool
isKey'),[IName String]
names,FieldDescriptorProto
fdp)
  Int32
number <- String -> Maybe Int32 -> ReaderT SEnv (Either String) Int32
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"entityField.name" (Maybe Int32 -> ReaderT SEnv (Either String) Int32)
-> (FieldDescriptorProto -> Maybe Int32)
-> FieldDescriptorProto
-> ReaderT SEnv (Either String) Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescriptorProto -> Maybe Int32
D.FieldDescriptorProto.number (FieldDescriptorProto -> ReaderT SEnv (Either String) Int32)
-> FieldDescriptorProto -> ReaderT SEnv (Either String) Int32
forall a b. (a -> b) -> a -> b
$ FieldDescriptorProto
fdp
  let mType :: Maybe Type
mType = FieldDescriptorProto -> Maybe Type
D.FieldDescriptorProto.type' FieldDescriptorProto
fdp
  Maybe (Either String Entity)
typeName <- (Utf8 -> SE (Either String Entity))
-> Maybe Utf8 -> SE (Maybe (Either String Entity))
forall (m :: * -> *) x a.
Monad m =>
(x -> m a) -> Maybe x -> m (Maybe a)
maybeM Utf8 -> SE (Either String Entity)
resolveMGE (FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.type_name FieldDescriptorProto
fdp)
  if Bool
isKey
    then do
      Either String Entity
extendee <- Utf8 -> SE (Either String Entity)
resolveM (Utf8 -> SE (Either String Entity))
-> ReaderT SEnv (Either String) Utf8 -> SE (Either String Entity)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe Utf8 -> ReaderT SEnv (Either String) Utf8
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"entityField.extendee" (FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.extendee FieldDescriptorProto
fdp)
      (IName String, E'Entity) -> SE (IName String, E'Entity)
forall (m :: * -> *) a. Monad m => a -> m a
return (IName String
self,Entity -> E'Entity
E'Ok (Entity -> E'Entity) -> Entity -> E'Entity
forall a b. (a -> b) -> a -> b
$ [IName String]
-> Either String Entity
-> FieldId
-> Maybe Type
-> Maybe (Either String Entity)
-> Entity
E'Key [IName String]
names Either String Entity
extendee (Int32 -> FieldId
FieldId Int32
number) Maybe Type
mType Maybe (Either String Entity)
typeName)
    else
      (IName String, E'Entity) -> SE (IName String, E'Entity)
forall (m :: * -> *) a. Monad m => a -> m a
return (IName String
self,Entity -> E'Entity
E'Ok (Entity -> E'Entity) -> Entity -> E'Entity
forall a b. (a -> b) -> a -> b
$ [IName String]
-> FieldId -> Maybe Type -> Maybe (Either String Entity) -> Entity
E'Field [IName String]
names (Int32 -> FieldId
FieldId Int32
number) Maybe Type
mType Maybe (Either String Entity)
typeName)
 where
  resolveMGE :: Utf8 -> SE (Either ErrStr Entity)
  resolveMGE :: Utf8 -> SE (Either String Entity)
resolveMGE Utf8
nameU = (Env -> Either String Entity)
-> ReaderT SEnv (Either String) Env -> SE (Either String Entity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> (E'Entity -> Bool) -> Utf8 -> Env -> Either String Entity
resolvePredEnv String
"Message or Group or Enum" E'Entity -> Bool
isMGE Utf8
nameU) ((SEnv -> Env) -> ReaderT SEnv (Either String) Env
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SEnv -> Env
my'Env)
    where isMGE :: E'Entity -> Bool
isMGE (E'Ok Entity
e') = case Entity
e' of E'Message {} -> Bool
True
                                       E'Group {} -> Bool
True
                                       E'Enum {} -> Bool
True
                                       Entity
_ -> Bool
False
          isMGE (E'Error {}) = Bool
False
  -- To be used for key extendee name resolution, but not part of the official protobuf-2.1.0 update, since made official
  resolveM :: Utf8 -> SE (Either ErrStr Entity)
  resolveM :: Utf8 -> SE (Either String Entity)
resolveM Utf8
nameU = (Env -> Either String Entity)
-> ReaderT SEnv (Either String) Env -> SE (Either String Entity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> (E'Entity -> Bool) -> Utf8 -> Env -> Either String Entity
resolvePredEnv String
"Message" E'Entity -> Bool
isM Utf8
nameU) ((SEnv -> Env) -> ReaderT SEnv (Either String) Env
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SEnv -> Env
my'Env)
    where isM :: E'Entity -> Bool
isM (E'Ok Entity
e') = case Entity
e' of E'Message {} -> Bool
True
                                     Entity
_ -> Bool
False
          isM (E'Error {}) = Bool
False

entityEnum :: D.EnumDescriptorProto -> SE (IName String,E'Entity)
entityEnum :: EnumDescriptorProto -> SE (IName String, E'Entity)
entityEnum edp :: EnumDescriptorProto
edp@(D.EnumDescriptorProto {value :: EnumDescriptorProto -> Seq EnumValueDescriptorProto
D.EnumDescriptorProto.value=Seq EnumValueDescriptorProto
vs}) = do
  (IName String
self,[IName String]
names) <- String
-> (EnumDescriptorProto -> Maybe Utf8)
-> EnumDescriptorProto
-> SE (IName String, [IName String])
forall a.
String
-> (a -> Maybe Utf8) -> a -> SE (IName String, [IName String])
getNames String
"entityEnum.name" EnumDescriptorProto -> Maybe Utf8
D.EnumDescriptorProto.name EnumDescriptorProto
edp
  [Int32]
values <- (EnumValueDescriptorProto -> ReaderT SEnv (Either String) Int32)
-> [EnumValueDescriptorProto]
-> ReaderT SEnv (Either String) [Int32]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Maybe Int32 -> ReaderT SEnv (Either String) Int32
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"entityEnum.value.number" (Maybe Int32 -> ReaderT SEnv (Either String) Int32)
-> (EnumValueDescriptorProto -> Maybe Int32)
-> EnumValueDescriptorProto
-> ReaderT SEnv (Either String) Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumValueDescriptorProto -> Maybe Int32
D.EnumValueDescriptorProto.number) ([EnumValueDescriptorProto]
 -> ReaderT SEnv (Either String) [Int32])
-> (Seq EnumValueDescriptorProto -> [EnumValueDescriptorProto])
-> Seq EnumValueDescriptorProto
-> ReaderT SEnv (Either String) [Int32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq EnumValueDescriptorProto -> [EnumValueDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq EnumValueDescriptorProto
 -> ReaderT SEnv (Either String) [Int32])
-> Seq EnumValueDescriptorProto
-> ReaderT SEnv (Either String) [Int32]
forall a b. (a -> b) -> a -> b
$ Seq EnumValueDescriptorProto
vs
{- Cannot match protoc if I enable this as a fatal check here
  when (Set.size (Set.fromList values) /= Seq.length vs) $
    throwError $ "entityEnum.value.number: There must be duplicate enum values for "++show names++"\n "++show values
-}
  [Utf8]
justNames <- (EnumValueDescriptorProto -> ReaderT SEnv (Either String) Utf8)
-> [EnumValueDescriptorProto]
-> ReaderT SEnv (Either String) [Utf8]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\EnumValueDescriptorProto
v -> String -> Maybe Utf8 -> ReaderT SEnv (Either String) Utf8
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust (String
"entityEnum.value.name failed for "String -> String -> String
forall a. [a] -> [a] -> [a]
++EnumValueDescriptorProto -> String
forall a. Show a => a -> String
show EnumValueDescriptorProto
v) (EnumValueDescriptorProto -> Maybe Utf8
D.EnumValueDescriptorProto.name EnumValueDescriptorProto
v))
               ([EnumValueDescriptorProto] -> ReaderT SEnv (Either String) [Utf8])
-> (Seq EnumValueDescriptorProto -> [EnumValueDescriptorProto])
-> Seq EnumValueDescriptorProto
-> ReaderT SEnv (Either String) [Utf8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq EnumValueDescriptorProto -> [EnumValueDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq EnumValueDescriptorProto
 -> ReaderT SEnv (Either String) [Utf8])
-> Seq EnumValueDescriptorProto
-> ReaderT SEnv (Either String) [Utf8]
forall a b. (a -> b) -> a -> b
$ Seq EnumValueDescriptorProto
vs
  [IName Utf8]
valNames <- (Utf8 -> ReaderT SEnv (Either String) (IName Utf8))
-> [Utf8] -> ReaderT SEnv (Either String) [IName Utf8]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Utf8
n -> String
-> Maybe (IName Utf8) -> ReaderT SEnv (Either String) (IName Utf8)
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust (String
"validI of entityEnum.value.name failed for "String -> String -> String
forall a. [a] -> [a] -> [a]
++Utf8 -> String
forall a. Show a => a -> String
show Utf8
n) (Utf8 -> Maybe (IName Utf8)
forall a. Dotted a => a -> Maybe (IName a)
validI Utf8
n)) [Utf8]
justNames
  let mapping :: Map (IName Utf8) Int32
mapping = [(IName Utf8, Int32)] -> Map (IName Utf8) Int32
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([IName Utf8] -> [Int32] -> [(IName Utf8, Int32)]
forall a b. [a] -> [b] -> [(a, b)]
zip [IName Utf8]
valNames [Int32]
values)
  Bool
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map (IName Utf8) Int32 -> Int
forall k a. Map k a -> Int
M.size Map (IName Utf8) Int32
mapping Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Seq EnumValueDescriptorProto -> Int
forall a. Seq a -> Int
Seq.length Seq EnumValueDescriptorProto
vs) (ReaderT SEnv (Either String) ()
 -> ReaderT SEnv (Either String) ())
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$
    String -> ReaderT SEnv (Either String) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT SEnv (Either String) ())
-> String -> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"entityEnum.value.name: There must be duplicate enum names for "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show [IName String]
namesString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName Utf8] -> String
forall a. Show a => a -> String
show [IName Utf8]
valNames
  [IName String]
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall a. [IName String] -> SE a -> SE a
descend'Enum [IName String]
names (ReaderT SEnv (Either String) ()
 -> ReaderT SEnv (Either String) ())
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$ (EnumValueDescriptorProto -> ReaderT SEnv (Either String) ())
-> Seq EnumValueDescriptorProto -> ReaderT SEnv (Either String) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ EnumValueDescriptorProto -> ReaderT SEnv (Either String) ()
entityEnumValue Seq EnumValueDescriptorProto
vs
  (IName String, E'Entity) -> SE (IName String, E'Entity)
forall (m :: * -> *) a. Monad m => a -> m a
return (IName String
self,Entity -> E'Entity
E'Ok (Entity -> E'Entity) -> Entity -> E'Entity
forall a b. (a -> b) -> a -> b
$ [IName String] -> Map (IName Utf8) Int32 -> Entity
E'Enum [IName String]
names Map (IName Utf8) Int32
mapping) -- discard values

 where entityEnumValue :: D.EnumValueDescriptorProto -> SE ()
       entityEnumValue :: EnumValueDescriptorProto -> ReaderT SEnv (Either String) ()
entityEnumValue EnumValueDescriptorProto
evdp = do -- Merely use getNames to add mangled self to ReMap state
         (IName String, [IName String])
_ <- String
-> (EnumValueDescriptorProto -> Maybe Utf8)
-> EnumValueDescriptorProto
-> SE (IName String, [IName String])
forall a.
String
-> (a -> Maybe Utf8) -> a -> SE (IName String, [IName String])
getNames String
"entityEnumValue.name" EnumValueDescriptorProto -> Maybe Utf8
D.EnumValueDescriptorProto.name EnumValueDescriptorProto
evdp
         () -> ReaderT SEnv (Either String) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

       descend'Enum :: [IName String] -> SE a -> SE a
       descend'Enum :: [IName String] -> SE a -> SE a
descend'Enum [IName String]
names SE a
act = (SEnv -> SEnv) -> SE a -> SE a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local SEnv -> SEnv
mutate SE a
act
         where mutate :: SEnv -> SEnv
mutate (SEnv [IName String]
_parent Env
env) = [IName String] -> Env -> SEnv
SEnv [IName String]
names Env
env

entityService :: D.ServiceDescriptorProto -> SE (IName String,E'Entity)
entityService :: ServiceDescriptorProto -> SE (IName String, E'Entity)
entityService ServiceDescriptorProto
sdp = String
-> SE (IName String, E'Entity) -> SE (IName String, E'Entity)
forall (m :: * -> *) a. MonadError String m => String -> m a -> m a
annErr (String
"entityService ServiceDescriptorProto name is "String -> String -> String
forall a. [a] -> [a] -> [a]
++Maybe Utf8 -> String
forall a. Show a => a -> String
show (ServiceDescriptorProto -> Maybe Utf8
D.ServiceDescriptorProto.name ServiceDescriptorProto
sdp)) (SE (IName String, E'Entity) -> SE (IName String, E'Entity))
-> SE (IName String, E'Entity) -> SE (IName String, E'Entity)
forall a b. (a -> b) -> a -> b
$ do
  (IName String
self,[IName String]
names) <- String
-> (ServiceDescriptorProto -> Maybe Utf8)
-> ServiceDescriptorProto
-> SE (IName String, [IName String])
forall a.
String
-> (a -> Maybe Utf8) -> a -> SE (IName String, [IName String])
getNames String
"entityService.name" ServiceDescriptorProto -> Maybe Utf8
D.ServiceDescriptorProto.name ServiceDescriptorProto
sdp
  (String
bad,Entity
entity) <- (String, Entity)
-> (Entity -> SE (String, Entity)) -> SE (String, Entity)
forall a. (String, a) -> (a -> SE (String, a)) -> SE (String, a)
myFixSE (String
"myFixSE entityService",Entity
emptyEntity) ((Entity -> SE (String, Entity)) -> SE (String, Entity))
-> (Entity -> SE (String, Entity)) -> SE (String, Entity)
forall a b. (a -> b) -> a -> b
$ \ Entity
entity'Param ->
    [IName String]
-> Entity -> SE (String, Entity) -> SE (String, Entity)
forall a. [IName String] -> Entity -> SE a -> SE a
descend [IName String]
names Entity
entity'Param (SE (String, Entity) -> SE (String, Entity))
-> SE (String, Entity) -> SE (String, Entity)
forall a b. (a -> b) -> a -> b
$ do
      ([String]
badMethods',[(IName String, E'Entity)]
goodMethods) <- (MethodDescriptorProto -> SE (IName String, E'Entity))
-> Seq MethodDescriptorProto
-> SE ([String], [(IName String, E'Entity)])
forall x.
(x -> SE (IName String, E'Entity))
-> Seq x -> SE ([String], [(IName String, E'Entity)])
kids MethodDescriptorProto -> SE (IName String, E'Entity)
entityMethod (ServiceDescriptorProto -> Seq MethodDescriptorProto
D.ServiceDescriptorProto.method ServiceDescriptorProto
sdp)
      let bad' :: String
bad' = [String] -> String
unlines [String]
badMethods'
          entity' :: Entity
entity' = [IName String] -> EMap -> Entity
E'Service [IName String]
names ((IName String -> E'Entity -> E'Entity -> E'Entity)
-> [(IName String, E'Entity)] -> EMap
forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWithKey IName String -> E'Entity -> E'Entity -> E'Entity
unique [(IName String, E'Entity)]
goodMethods)
      (String, Entity) -> SE (String, Entity)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
bad',Entity
entity')
  -- Moving this outside the myFixSE reduces the cases where myFixSE generates an 'error' call.
  Bool
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
bad)) (ReaderT SEnv (Either String) ()
 -> ReaderT SEnv (Either String) ())
-> ReaderT SEnv (Either String) ()
-> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$
    String -> ReaderT SEnv (Either String) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT SEnv (Either String) ())
-> String -> ReaderT SEnv (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"entityService.badMethods: Some methods failed for "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show [IName String]
namesString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
bad
  (IName String, E'Entity) -> SE (IName String, E'Entity)
forall (m :: * -> *) a. Monad m => a -> m a
return (IName String
self,Entity -> E'Entity
E'Ok Entity
entity)

entityMethod :: D.MethodDescriptorProto -> SE (IName String,E'Entity)
entityMethod :: MethodDescriptorProto -> SE (IName String, E'Entity)
entityMethod MethodDescriptorProto
mdp = do
  (IName String
self,[IName String]
names) <- String
-> (MethodDescriptorProto -> Maybe Utf8)
-> MethodDescriptorProto
-> SE (IName String, [IName String])
forall a.
String
-> (a -> Maybe Utf8) -> a -> SE (IName String, [IName String])
getNames String
"entityMethod.name" MethodDescriptorProto -> Maybe Utf8
D.MethodDescriptorProto.name MethodDescriptorProto
mdp
  Maybe (Either String Entity)
inputType <- String
-> (MethodDescriptorProto -> Maybe Utf8)
-> MethodDescriptorProto
-> SE (Maybe (Either String Entity))
forall a.
Show a =>
String
-> (a -> Maybe Utf8) -> a -> SE (Maybe (Either String Entity))
getType String
"entityMethod.input_type" MethodDescriptorProto -> Maybe Utf8
D.MethodDescriptorProto.input_type MethodDescriptorProto
mdp
  Maybe (Either String Entity)
outputType <- String
-> (MethodDescriptorProto -> Maybe Utf8)
-> MethodDescriptorProto
-> SE (Maybe (Either String Entity))
forall a.
Show a =>
String
-> (a -> Maybe Utf8) -> a -> SE (Maybe (Either String Entity))
getType String
"entityMethod.output_type" MethodDescriptorProto -> Maybe Utf8
D.MethodDescriptorProto.output_type MethodDescriptorProto
mdp
  (IName String, E'Entity) -> SE (IName String, E'Entity)
forall (m :: * -> *) a. Monad m => a -> m a
return (IName String
self,Entity -> E'Entity
E'Ok (Entity -> E'Entity) -> Entity -> E'Entity
forall a b. (a -> b) -> a -> b
$ [IName String]
-> Maybe (Either String Entity)
-> Maybe (Either String Entity)
-> Entity
E'Method [IName String]
names Maybe (Either String Entity)
inputType Maybe (Either String Entity)
outputType)

{- ***

The namespace Env is used to transform the original FileDescriptorProto into a canonical
FileDescriptorProto. The goal is to match the transformation done by Google's protoc program.  This
will allow the "front end" vs "back end" of each program to cross-couple, which will at least allow
better testing of hprotoc and the new UninterpretedOption support.

The UninterpretedOption fields are converted by the resolveFDP code below.

These should be total functions with no 'error' or 'undefined' values possible.

*** -}

fqFail :: Show a => String -> a -> Entity -> RE b
fqFail :: String -> a -> Entity -> RE b
fqFail String
msg a
dp Entity
entity = do
  Env
env <- ReaderT Env (Either String) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  String -> RE b
forall e (m :: * -> *) a.
(Error e, MonadError e m) =>
String -> m a
throw (String -> RE b) -> String -> RE b
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
msg, String
"resolving: "String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
dp, String
"in environment: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Env -> String
whereEnv Env
env, String
"found: "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show (Entity -> [IName String]
eName Entity
entity) ]

fqFileDP :: D.FileDescriptorProto -> RE D.FileDescriptorProto
fqFileDP :: FileDescriptorProto -> RE FileDescriptorProto
fqFileDP FileDescriptorProto
fdp = String -> RE FileDescriptorProto -> RE FileDescriptorProto
forall (m :: * -> *) a. MonadError String m => String -> m a -> m a
annErr (String
"fqFileDP FileDescriptorProto (name,package) is "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Maybe Utf8, Maybe Utf8) -> String
forall a. Show a => a -> String
show (FileDescriptorProto -> Maybe Utf8
D.FileDescriptorProto.name FileDescriptorProto
fdp,FileDescriptorProto -> Maybe Utf8
D.FileDescriptorProto.package FileDescriptorProto
fdp)) (RE FileDescriptorProto -> RE FileDescriptorProto)
-> RE FileDescriptorProto -> RE FileDescriptorProto
forall a b. (a -> b) -> a -> b
$ do
  Seq DescriptorProto
newMessages <- (DescriptorProto -> ReaderT Env (Either String) DescriptorProto)
-> Seq DescriptorProto
-> ReaderT Env (Either String) (Seq DescriptorProto)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM DescriptorProto -> ReaderT Env (Either String) DescriptorProto
fqMessage      (FileDescriptorProto -> Seq DescriptorProto
D.FileDescriptorProto.message_type FileDescriptorProto
fdp)
  Seq EnumDescriptorProto
newEnums    <- (EnumDescriptorProto
 -> ReaderT Env (Either String) EnumDescriptorProto)
-> Seq EnumDescriptorProto
-> ReaderT Env (Either String) (Seq EnumDescriptorProto)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM EnumDescriptorProto
-> ReaderT Env (Either String) EnumDescriptorProto
fqEnum         (FileDescriptorProto -> Seq EnumDescriptorProto
D.FileDescriptorProto.enum_type    FileDescriptorProto
fdp)
  Seq ServiceDescriptorProto
newServices <- (ServiceDescriptorProto
 -> ReaderT Env (Either String) ServiceDescriptorProto)
-> Seq ServiceDescriptorProto
-> ReaderT Env (Either String) (Seq ServiceDescriptorProto)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM ServiceDescriptorProto
-> ReaderT Env (Either String) ServiceDescriptorProto
fqService      (FileDescriptorProto -> Seq ServiceDescriptorProto
D.FileDescriptorProto.service      FileDescriptorProto
fdp)
  Seq FieldDescriptorProto
newKeys     <- (FieldDescriptorProto
 -> ReaderT Env (Either String) FieldDescriptorProto)
-> Seq FieldDescriptorProto
-> ReaderT Env (Either String) (Seq FieldDescriptorProto)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (Bool
-> FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
fqField Bool
True) (FileDescriptorProto -> Seq FieldDescriptorProto
D.FileDescriptorProto.extension    FileDescriptorProto
fdp)
  FileDescriptorProto -> RE FileDescriptorProto
forall a. ConsumeUNO a => a -> RE a
consumeUNO (FileDescriptorProto -> RE FileDescriptorProto)
-> FileDescriptorProto -> RE FileDescriptorProto
forall a b. (a -> b) -> a -> b
$ FileDescriptorProto
fdp { message_type :: Seq DescriptorProto
D.FileDescriptorProto.message_type = Seq DescriptorProto
newMessages
                   , enum_type :: Seq EnumDescriptorProto
D.FileDescriptorProto.enum_type    = Seq EnumDescriptorProto
newEnums
                   , service :: Seq ServiceDescriptorProto
D.FileDescriptorProto.service      = Seq ServiceDescriptorProto
newServices
                   , extension :: Seq FieldDescriptorProto
D.FileDescriptorProto.extension    = Seq FieldDescriptorProto
newKeys }

fqMessage :: D.DescriptorProto -> RE D.DescriptorProto
fqMessage :: DescriptorProto -> ReaderT Env (Either String) DescriptorProto
fqMessage DescriptorProto
dp = String
-> ReaderT Env (Either String) DescriptorProto
-> ReaderT Env (Either String) DescriptorProto
forall (m :: * -> *) a. MonadError String m => String -> m a -> m a
annErr (String
"fqMessage DescriptorProto name is "String -> String -> String
forall a. [a] -> [a] -> [a]
++Maybe Utf8 -> String
forall a. Show a => a -> String
show (DescriptorProto -> Maybe Utf8
D.DescriptorProto.name DescriptorProto
dp)) (ReaderT Env (Either String) DescriptorProto
 -> ReaderT Env (Either String) DescriptorProto)
-> ReaderT Env (Either String) DescriptorProto
-> ReaderT Env (Either String) DescriptorProto
forall a b. (a -> b) -> a -> b
$ do
  Entity
entity <- Utf8 -> RE Entity
resolveRE (Utf8 -> RE Entity)
-> ReaderT Env (Either String) Utf8 -> RE Entity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe Utf8 -> ReaderT Env (Either String) Utf8
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"fqMessage.name" (DescriptorProto -> Maybe Utf8
D.DescriptorProto.name DescriptorProto
dp)
  ([IName String]
name,EMap
vals) <- case Entity
entity of
                   E'Message {eName :: Entity -> [IName String]
eName=[IName String]
name',mVals :: Entity -> EMap
mVals=EMap
vals'} -> ([IName String], EMap)
-> ReaderT Env (Either String) ([IName String], EMap)
forall (m :: * -> *) a. Monad m => a -> m a
return ([IName String]
name',EMap
vals')
                   E'Group {eName :: Entity -> [IName String]
eName=[IName String]
name',mVals :: Entity -> EMap
mVals=EMap
vals'} -> ([IName String], EMap)
-> ReaderT Env (Either String) ([IName String], EMap)
forall (m :: * -> *) a. Monad m => a -> m a
return ([IName String]
name',EMap
vals')
                   Entity
_ -> String
-> DescriptorProto
-> Entity
-> ReaderT Env (Either String) ([IName String], EMap)
forall a b. Show a => String -> a -> Entity -> RE b
fqFail String
"fqMessage.entity: did not resolve to an E'Message or E'Group:" DescriptorProto
dp Entity
entity
  (Env -> Env)
-> ReaderT Env (Either String) DescriptorProto
-> ReaderT Env (Either String) DescriptorProto
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Env
env -> ([IName String] -> EMap -> Env -> Env
Local [IName String]
name EMap
vals Env
env)) (ReaderT Env (Either String) DescriptorProto
 -> ReaderT Env (Either String) DescriptorProto)
-> ReaderT Env (Either String) DescriptorProto
-> ReaderT Env (Either String) DescriptorProto
forall a b. (a -> b) -> a -> b
$ do
    Seq FieldDescriptorProto
newFields   <- (FieldDescriptorProto
 -> ReaderT Env (Either String) FieldDescriptorProto)
-> Seq FieldDescriptorProto
-> ReaderT Env (Either String) (Seq FieldDescriptorProto)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (Bool
-> FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
fqField Bool
False) (DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.field       DescriptorProto
dp)
    Seq FieldDescriptorProto
newKeys     <- (FieldDescriptorProto
 -> ReaderT Env (Either String) FieldDescriptorProto)
-> Seq FieldDescriptorProto
-> ReaderT Env (Either String) (Seq FieldDescriptorProto)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (Bool
-> FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
fqField Bool
True)  (DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.extension   DescriptorProto
dp)
    Seq DescriptorProto
newMessages <- (DescriptorProto -> ReaderT Env (Either String) DescriptorProto)
-> Seq DescriptorProto
-> ReaderT Env (Either String) (Seq DescriptorProto)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM DescriptorProto -> ReaderT Env (Either String) DescriptorProto
fqMessage       (DescriptorProto -> Seq DescriptorProto
D.DescriptorProto.nested_type DescriptorProto
dp)
    Seq EnumDescriptorProto
newEnums    <- (EnumDescriptorProto
 -> ReaderT Env (Either String) EnumDescriptorProto)
-> Seq EnumDescriptorProto
-> ReaderT Env (Either String) (Seq EnumDescriptorProto)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM EnumDescriptorProto
-> ReaderT Env (Either String) EnumDescriptorProto
fqEnum          (DescriptorProto -> Seq EnumDescriptorProto
D.DescriptorProto.enum_type   DescriptorProto
dp)
    DescriptorProto -> ReaderT Env (Either String) DescriptorProto
forall a. ConsumeUNO a => a -> RE a
consumeUNO (DescriptorProto -> ReaderT Env (Either String) DescriptorProto)
-> DescriptorProto -> ReaderT Env (Either String) DescriptorProto
forall a b. (a -> b) -> a -> b
$ DescriptorProto
dp { field :: Seq FieldDescriptorProto
D.DescriptorProto.field       = Seq FieldDescriptorProto
newFields
                    , extension :: Seq FieldDescriptorProto
D.DescriptorProto.extension   = Seq FieldDescriptorProto
newKeys
                    , nested_type :: Seq DescriptorProto
D.DescriptorProto.nested_type = Seq DescriptorProto
newMessages
                    , enum_type :: Seq EnumDescriptorProto
D.DescriptorProto.enum_type   = Seq EnumDescriptorProto
newEnums }

fqService :: D.ServiceDescriptorProto -> RE D.ServiceDescriptorProto
fqService :: ServiceDescriptorProto
-> ReaderT Env (Either String) ServiceDescriptorProto
fqService ServiceDescriptorProto
sdp =  String
-> ReaderT Env (Either String) ServiceDescriptorProto
-> ReaderT Env (Either String) ServiceDescriptorProto
forall (m :: * -> *) a. MonadError String m => String -> m a -> m a
annErr (String
"fqService ServiceDescriptorProto name is "String -> String -> String
forall a. [a] -> [a] -> [a]
++Maybe Utf8 -> String
forall a. Show a => a -> String
show (ServiceDescriptorProto -> Maybe Utf8
D.ServiceDescriptorProto.name ServiceDescriptorProto
sdp)) (ReaderT Env (Either String) ServiceDescriptorProto
 -> ReaderT Env (Either String) ServiceDescriptorProto)
-> ReaderT Env (Either String) ServiceDescriptorProto
-> ReaderT Env (Either String) ServiceDescriptorProto
forall a b. (a -> b) -> a -> b
$ do
  Entity
entity <- Utf8 -> RE Entity
resolveRE (Utf8 -> RE Entity)
-> ReaderT Env (Either String) Utf8 -> RE Entity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe Utf8 -> ReaderT Env (Either String) Utf8
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"fqService.name" (ServiceDescriptorProto -> Maybe Utf8
D.ServiceDescriptorProto.name ServiceDescriptorProto
sdp)
  case Entity
entity of
    E'Service {eName :: Entity -> [IName String]
eName=[IName String]
name,mVals :: Entity -> EMap
mVals=EMap
vals} -> do
      Seq MethodDescriptorProto
newMethods <- (Env -> Env)
-> ReaderT Env (Either String) (Seq MethodDescriptorProto)
-> ReaderT Env (Either String) (Seq MethodDescriptorProto)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ([IName String] -> EMap -> Env -> Env
Local [IName String]
name EMap
vals) (ReaderT Env (Either String) (Seq MethodDescriptorProto)
 -> ReaderT Env (Either String) (Seq MethodDescriptorProto))
-> ReaderT Env (Either String) (Seq MethodDescriptorProto)
-> ReaderT Env (Either String) (Seq MethodDescriptorProto)
forall a b. (a -> b) -> a -> b
$ (MethodDescriptorProto
 -> ReaderT Env (Either String) MethodDescriptorProto)
-> Seq MethodDescriptorProto
-> ReaderT Env (Either String) (Seq MethodDescriptorProto)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
fqMethod (ServiceDescriptorProto -> Seq MethodDescriptorProto
D.ServiceDescriptorProto.method ServiceDescriptorProto
sdp)
      ServiceDescriptorProto
-> ReaderT Env (Either String) ServiceDescriptorProto
forall a. ConsumeUNO a => a -> RE a
consumeUNO (ServiceDescriptorProto
 -> ReaderT Env (Either String) ServiceDescriptorProto)
-> ServiceDescriptorProto
-> ReaderT Env (Either String) ServiceDescriptorProto
forall a b. (a -> b) -> a -> b
$ ServiceDescriptorProto
sdp { method :: Seq MethodDescriptorProto
D.ServiceDescriptorProto.method = Seq MethodDescriptorProto
newMethods }
    Entity
_ -> String
-> ServiceDescriptorProto
-> Entity
-> ReaderT Env (Either String) ServiceDescriptorProto
forall a b. Show a => String -> a -> Entity -> RE b
fqFail String
"fqService.entity: did not resolve to a service:" ServiceDescriptorProto
sdp Entity
entity

fqMethod :: D.MethodDescriptorProto -> RE D.MethodDescriptorProto
fqMethod :: MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
fqMethod MethodDescriptorProto
mdp = do
  Entity
entity <- Utf8 -> RE Entity
resolveRE (Utf8 -> RE Entity)
-> ReaderT Env (Either String) Utf8 -> RE Entity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe Utf8 -> ReaderT Env (Either String) Utf8
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"fqMethod.name" (MethodDescriptorProto -> Maybe Utf8
D.MethodDescriptorProto.name MethodDescriptorProto
mdp)
  case Entity
entity of
    E'Method {eMsgIn :: Entity -> Maybe (Either String Entity)
eMsgIn=Maybe (Either String Entity)
msgIn,eMsgOut :: Entity -> Maybe (Either String Entity)
eMsgOut=Maybe (Either String Entity)
msgOut} -> do
      MethodDescriptorProto
mdp1 <- case Maybe (Either String Entity)
msgIn of
                Maybe (Either String Entity)
Nothing -> MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return MethodDescriptorProto
mdp
                Just Either String Entity
resolveIn -> do
                  FIName Utf8
new <- (Entity -> FIName Utf8)
-> RE Entity -> ReaderT Env (Either String) (FIName Utf8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity -> FIName Utf8
fqName (Either String Entity -> RE Entity
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Either String Entity
resolveIn)
                  MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodDescriptorProto
mdp {input_type :: Maybe Utf8
D.MethodDescriptorProto.input_type = Utf8 -> Maybe Utf8
forall a. a -> Maybe a
Just (FIName Utf8 -> Utf8
forall a. FIName a -> a
fiName FIName Utf8
new)})
      MethodDescriptorProto
mdp2 <- case Maybe (Either String Entity)
msgOut of
                Maybe (Either String Entity)
Nothing -> MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return MethodDescriptorProto
mdp1
                Just Either String Entity
resolveIn -> do
                  FIName Utf8
new <- (Entity -> FIName Utf8)
-> RE Entity -> ReaderT Env (Either String) (FIName Utf8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity -> FIName Utf8
fqName (Either String Entity -> RE Entity
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Either String Entity
resolveIn)
                  MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodDescriptorProto
mdp1 {output_type :: Maybe Utf8
D.MethodDescriptorProto.output_type = Utf8 -> Maybe Utf8
forall a. a -> Maybe a
Just (FIName Utf8 -> Utf8
forall a. FIName a -> a
fiName FIName Utf8
new)})
      MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
forall a. ConsumeUNO a => a -> RE a
consumeUNO MethodDescriptorProto
mdp2
    Entity
_ -> String
-> MethodDescriptorProto
-> Entity
-> ReaderT Env (Either String) MethodDescriptorProto
forall a b. Show a => String -> a -> Entity -> RE b
fqFail String
"fqMethod.entity: did not resolve to a Method:" MethodDescriptorProto
mdp Entity
entity

-- The field is a bit more complicated to resolve.  The Key variant needs to resolve the extendee.
-- The type code from Parser.hs might be Nothing and this needs to be resolved to TYPE_MESSAGE or
-- TYPE_ENUM (at last!), and if it is the latter then any default value string is checked for
-- validity.
fqField :: Bool -> D.FieldDescriptorProto -> RE D.FieldDescriptorProto
fqField :: Bool
-> FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
fqField Bool
isKey FieldDescriptorProto
fdp = String
-> ReaderT Env (Either String) FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
forall (m :: * -> *) a. MonadError String m => String -> m a -> m a
annErr (String
"fqField FieldDescriptorProto name is "String -> String -> String
forall a. [a] -> [a] -> [a]
++Maybe Utf8 -> String
forall a. Show a => a -> String
show (FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.name FieldDescriptorProto
fdp)) (ReaderT Env (Either String) FieldDescriptorProto
 -> ReaderT Env (Either String) FieldDescriptorProto)
-> ReaderT Env (Either String) FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
forall a b. (a -> b) -> a -> b
$ do
  let isKey' :: Bool
isKey' = Bool -> (Utf8 -> Bool) -> Maybe Utf8 -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Utf8 -> Bool
forall a b. a -> b -> a
const Bool
True) (FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.extendee FieldDescriptorProto
fdp)
  Bool
-> ReaderT Env (Either String) () -> ReaderT Env (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isKeyBool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/=Bool
isKey') (ReaderT Env (Either String) () -> ReaderT Env (Either String) ())
-> ReaderT Env (Either String) () -> ReaderT Env (Either String) ()
forall a b. (a -> b) -> a -> b
$
    ReaderT Env (Either String) Env
forall r (m :: * -> *). MonadReader r m => m r
ask ReaderT Env (Either String) Env
-> (Env -> ReaderT Env (Either String) ())
-> ReaderT Env (Either String) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Env
env -> String -> ReaderT Env (Either String) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Env (Either String) ())
-> String -> ReaderT Env (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"fqField.isKey: Expected key and got field or vice-versa:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++((Bool, Bool), String, FieldDescriptorProto) -> String
forall a. Show a => a -> String
ishow ((Bool
isKey,Bool
isKey'),Env -> String
whereEnv Env
env,FieldDescriptorProto
fdp)
  Entity
entity <- Entity -> RE Entity
expectFK (Entity -> RE Entity) -> RE Entity -> RE Entity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Utf8 -> RE Entity
resolveRE (Utf8 -> RE Entity)
-> ReaderT Env (Either String) Utf8 -> RE Entity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe Utf8 -> ReaderT Env (Either String) Utf8
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"fqField.name" (FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.name FieldDescriptorProto
fdp)
  Maybe Utf8
newExtendee <- case (Bool
isKey,Entity
entity) of
                   (Bool
True,E'Key {eMsg :: Entity -> Either String Entity
eMsg=Either String Entity
msg,fNumber :: Entity -> FieldId
fNumber=FieldId
fNum}) -> do
                      Entity
ext <- Either String Entity -> RE Entity
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Either String Entity
msg
                      case Entity
ext of
                        E'Message {} -> Bool
-> ReaderT Env (Either String) () -> ReaderT Env (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([(FieldId, FieldId)] -> FieldId -> Bool
checkFI (Entity -> [(FieldId, FieldId)]
validExtensions Entity
ext) FieldId
fNum)) (ReaderT Env (Either String) () -> ReaderT Env (Either String) ())
-> ReaderT Env (Either String) () -> ReaderT Env (Either String) ()
forall a b. (a -> b) -> a -> b
$
                          String -> ReaderT Env (Either String) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Env (Either String) ())
-> String -> ReaderT Env (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"fqField.newExtendee: Field Number of extention key invalid:\n"
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++[String] -> String
unlines [String
"Number is "String -> String -> String
forall a. [a] -> [a] -> [a]
++FieldId -> String
forall a. Show a => a -> String
show (Entity -> FieldId
fNumber Entity
entity)
                                      ,String
"Valid ranges: "String -> String -> String
forall a. [a] -> [a] -> [a]
++[(FieldId, FieldId)] -> String
forall a. Show a => a -> String
show (Entity -> [(FieldId, FieldId)]
validExtensions Entity
ext)
                                      ,String
"Extendee: "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show (Entity -> [IName String]
eName Entity
ext)
                                      ,String
"Descriptor: "String -> String -> String
forall a. [a] -> [a] -> [a]
++FieldDescriptorProto -> String
forall a. Show a => a -> String
show FieldDescriptorProto
fdp]
                        Entity
_ -> String
-> FieldDescriptorProto -> Entity -> ReaderT Env (Either String) ()
forall a b. Show a => String -> a -> Entity -> RE b
fqFail String
"fqField.ext: Key's target is not an E'Message:" FieldDescriptorProto
fdp Entity
ext
                      (Entity -> Maybe Utf8)
-> RE Entity -> ReaderT Env (Either String) (Maybe Utf8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Utf8 -> Maybe Utf8
forall a. a -> Maybe a
Just (Utf8 -> Maybe Utf8) -> (Entity -> Utf8) -> Entity -> Maybe Utf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FIName Utf8 -> Utf8
forall a. FIName a -> a
fiName (FIName Utf8 -> Utf8) -> (Entity -> FIName Utf8) -> Entity -> Utf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> FIName Utf8
fqName) (RE Entity -> ReaderT Env (Either String) (Maybe Utf8))
-> (Entity -> RE Entity)
-> Entity
-> ReaderT Env (Either String) (Maybe Utf8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Entity -> RE Entity
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String Entity -> RE Entity)
-> (Entity -> Either String Entity) -> Entity -> RE Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> Either String Entity
eMsg (Entity -> ReaderT Env (Either String) (Maybe Utf8))
-> Entity -> ReaderT Env (Either String) (Maybe Utf8)
forall a b. (a -> b) -> a -> b
$ Entity
entity
                   (Bool
False,E'Field {}) -> Maybe Utf8 -> ReaderT Env (Either String) (Maybe Utf8)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Utf8
forall a. Maybe a
Nothing
                   (Bool, Entity)
_ -> String
-> FieldDescriptorProto
-> Entity
-> ReaderT Env (Either String) (Maybe Utf8)
forall a b. Show a => String -> a -> Entity -> RE b
fqFail String
"fqField.entity: did not resolve to expected E'Key or E'Field:" FieldDescriptorProto
fdp Entity
entity
  Maybe Entity
mTypeName <- (Either String Entity -> RE Entity)
-> Maybe (Either String Entity)
-> ReaderT Env (Either String) (Maybe Entity)
forall (m :: * -> *) x a.
Monad m =>
(x -> m a) -> Maybe x -> m (Maybe a)
maybeM Either String Entity -> RE Entity
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Entity -> Maybe (Either String Entity)
mVal Entity
entity) -- "Just (Left _)" triggers a throwError here (see comment for entityField)
  -- Finally fully determine D.Type, (type'==Nothing) meant ambiguously TYPE_MESSAGE or TYPE_ENUM from Parser.hs
  -- This has gotten more verbose with the addition of verifying packed is being used properly.
  Type
actualType <- case (Entity -> Maybe Type
fType Entity
entity,Maybe Entity
mTypeName) of
                  (Just Type
TYPE_GROUP, Just (E'Group {})) | FieldDescriptorProto -> Bool
isNotPacked FieldDescriptorProto
fdp -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TYPE_GROUP
                                                       | Bool
otherwise ->
                    String
-> FieldDescriptorProto
-> Entity
-> ReaderT Env (Either String) Type
forall a b. Show a => String -> a -> Entity -> RE b
fqFail (String
"fqField.actualType : This Group is invalid, you cannot pack a group field.") FieldDescriptorProto
fdp Entity
entity
                  (Maybe Type
Nothing, Just (E'Message {})) | FieldDescriptorProto -> Bool
isNotPacked FieldDescriptorProto
fdp -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TYPE_MESSAGE
                                                 | Bool
otherwise ->
                    String
-> FieldDescriptorProto
-> Entity
-> ReaderT Env (Either String) Type
forall a b. Show a => String -> a -> Entity -> RE b
fqFail (String
"fqField.actualType : This Message is invalid, you cannot pack a message field.") FieldDescriptorProto
fdp Entity
entity
                  (Maybe Type
Nothing, Just (E'Enum {})) | FieldDescriptorProto -> Bool
isNotPacked FieldDescriptorProto
fdp -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TYPE_ENUM
                                              | FieldDescriptorProto -> Bool
isRepeated FieldDescriptorProto
fdp -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TYPE_ENUM
                                              | Bool
otherwise ->
                    String
-> FieldDescriptorProto
-> Entity
-> ReaderT Env (Either String) Type
forall a b. Show a => String -> a -> Entity -> RE b
fqFail (String
"fqField.actualType : This Enum is invalid, you cannot pack a non-repeated field.") FieldDescriptorProto
fdp Entity
entity
                  (Just Type
t, Maybe Entity
Nothing) -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
                  (Just Type
TYPE_MESSAGE, Just (E'Message {})) -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TYPE_MESSAGE
                  (Just Type
TYPE_ENUM, Just (E'Enum {})) -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TYPE_ENUM
                  (Maybe Type
mt,Maybe Entity
me) -> String
-> FieldDescriptorProto
-> Entity
-> ReaderT Env (Either String) Type
forall a b. Show a => String -> a -> Entity -> RE b
fqFail (String
"fqField.actualType: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Maybe Type -> String
forall a. Show a => a -> String
show Maybe Type
mtString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" and "String -> String -> String
forall a. [a] -> [a] -> [a]
++Maybe [IName String] -> String
forall a. Show a => a -> String
show ((Entity -> [IName String]) -> Maybe Entity -> Maybe [IName String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity -> [IName String]
eName Maybe Entity
me)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" is invalid.") FieldDescriptorProto
fdp Entity
entity
  -- Check that a default value of an TYPE_ENUM is valid
  case (Maybe Entity
mTypeName,FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.default_value FieldDescriptorProto
fdp) of
    (Just ee :: Entity
ee@(E'Enum {eVals :: Entity -> Map (IName Utf8) Int32
eVals = Map (IName Utf8) Int32
enumVals}),Just Utf8
enumVal) ->
      let badVal :: ReaderT Env (Either String) ()
badVal = String -> ReaderT Env (Either String) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ReaderT Env (Either String) ())
-> String -> ReaderT Env (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"fqField.default_value: Default enum value is invalid:\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++[String] -> String
unlines [String
"Value is "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show (Utf8 -> String
toString Utf8
enumVal)
                               ,String
"Allowed values from "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show (Entity -> [IName String]
eName Entity
ee)
                               ,String
" are "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName Utf8] -> String
forall a. Show a => a -> String
show (Map (IName Utf8) Int32 -> [IName Utf8]
forall k a. Map k a -> [k]
M.keys Map (IName Utf8) Int32
enumVals)
                               ,String
"Descriptor: "String -> String -> String
forall a. [a] -> [a] -> [a]
++FieldDescriptorProto -> String
forall a. Show a => a -> String
show FieldDescriptorProto
fdp]
      in case Utf8 -> Maybe (IName Utf8)
forall a. Dotted a => a -> Maybe (IName a)
validI Utf8
enumVal of
          Maybe (IName Utf8)
Nothing -> ReaderT Env (Either String) ()
badVal
          Just IName Utf8
iVal -> Bool
-> ReaderT Env (Either String) () -> ReaderT Env (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IName Utf8 -> Map (IName Utf8) Int32 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember IName Utf8
iVal Map (IName Utf8) Int32
enumVals) ReaderT Env (Either String) ()
badVal
    (Maybe Entity, Maybe Utf8)
_ -> () -> ReaderT Env (Either String) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
forall a. ConsumeUNO a => a -> RE a
consumeUNO (FieldDescriptorProto
 -> ReaderT Env (Either String) FieldDescriptorProto)
-> FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
forall a b. (a -> b) -> a -> b
$
    if Bool
isKey then (FieldDescriptorProto
fdp { extendee :: Maybe Utf8
D.FieldDescriptorProto.extendee  = Maybe Utf8
newExtendee
                       , type' :: Maybe Type
D.FieldDescriptorProto.type'     = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
actualType
                       , type_name :: Maybe Utf8
D.FieldDescriptorProto.type_name = (Entity -> Utf8) -> Maybe Entity -> Maybe Utf8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FIName Utf8 -> Utf8
forall a. FIName a -> a
fiName (FIName Utf8 -> Utf8) -> (Entity -> FIName Utf8) -> Entity -> Utf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> FIName Utf8
fqName) Maybe Entity
mTypeName })
             else (FieldDescriptorProto
fdp { type' :: Maybe Type
D.FieldDescriptorProto.type'     = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
actualType
                       , type_name :: Maybe Utf8
D.FieldDescriptorProto.type_name = (Entity -> Utf8) -> Maybe Entity -> Maybe Utf8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FIName Utf8 -> Utf8
forall a. FIName a -> a
fiName (FIName Utf8 -> Utf8) -> (Entity -> FIName Utf8) -> Entity -> Utf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> FIName Utf8
fqName) Maybe Entity
mTypeName })

 where isRepeated :: D.FieldDescriptorProto -> Bool
       isRepeated :: FieldDescriptorProto -> Bool
isRepeated (D.FieldDescriptorProto {
                    label :: FieldDescriptorProto -> Maybe Label
D.FieldDescriptorProto.label =
                      Just Label
LABEL_REPEATED }) =
         Bool
True
       isRepeated FieldDescriptorProto
_ = Bool
False

       isNotPacked :: D.FieldDescriptorProto -> Bool
       isNotPacked :: FieldDescriptorProto -> Bool
isNotPacked (D.FieldDescriptorProto {
                     options :: FieldDescriptorProto -> Maybe FieldOptions
D.FieldDescriptorProto.options =
                      Just (D.FieldOptions {
                             packed :: FieldOptions -> Maybe Bool
D.FieldOptions.packed =
                               Just Bool
isPacked })}) =
         Bool -> Bool
not Bool
isPacked
       isNotPacked FieldDescriptorProto
_ = Bool
True

       expectFK :: Entity -> RE Entity
       expectFK :: Entity -> RE Entity
expectFK Entity
e | Bool
isFK = Entity -> RE Entity
forall (m :: * -> *) a. Monad m => a -> m a
return Entity
e
                  | Bool
otherwise = String -> RE Entity
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> RE Entity) -> String -> RE Entity
forall a b. (a -> b) -> a -> b
$ String
"expectF: Name resolution failed to find a Field or Key:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
ishow (Entity -> [IName String]
eName Entity
e)
         where isFK :: Bool
isFK = case Entity
e of E'Field {} -> Bool
True
                                E'Key {} -> Bool
True
                                Entity
_ -> Bool
False



fqEnum :: D.EnumDescriptorProto -> RE D.EnumDescriptorProto
fqEnum :: EnumDescriptorProto
-> ReaderT Env (Either String) EnumDescriptorProto
fqEnum EnumDescriptorProto
edp = do
  Entity
entity <- Utf8 -> RE Entity
resolveRE (Utf8 -> RE Entity)
-> ReaderT Env (Either String) Utf8 -> RE Entity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe Utf8 -> ReaderT Env (Either String) Utf8
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"fqEnum.name" (EnumDescriptorProto -> Maybe Utf8
D.EnumDescriptorProto.name EnumDescriptorProto
edp)
  case Entity
entity of
    E'Enum {} -> do Seq EnumValueDescriptorProto
evdps <- (EnumValueDescriptorProto
 -> ReaderT Env (Either String) EnumValueDescriptorProto)
-> Seq EnumValueDescriptorProto
-> ReaderT Env (Either String) (Seq EnumValueDescriptorProto)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM EnumValueDescriptorProto
-> ReaderT Env (Either String) EnumValueDescriptorProto
forall a. ConsumeUNO a => a -> RE a
consumeUNO (EnumDescriptorProto -> Seq EnumValueDescriptorProto
D.EnumDescriptorProto.value EnumDescriptorProto
edp)
                    EnumDescriptorProto
-> ReaderT Env (Either String) EnumDescriptorProto
forall a. ConsumeUNO a => a -> RE a
consumeUNO (EnumDescriptorProto
 -> ReaderT Env (Either String) EnumDescriptorProto)
-> EnumDescriptorProto
-> ReaderT Env (Either String) EnumDescriptorProto
forall a b. (a -> b) -> a -> b
$ EnumDescriptorProto
edp { value :: Seq EnumValueDescriptorProto
D.EnumDescriptorProto.value = Seq EnumValueDescriptorProto
evdps }
    Entity
_ -> String
-> EnumDescriptorProto
-> Entity
-> ReaderT Env (Either String) EnumDescriptorProto
forall a b. Show a => String -> a -> Entity -> RE b
fqFail String
"fqEnum.entity: did not resolve to an E'Enum:" EnumDescriptorProto
edp Entity
entity

{- The consumeUNO calls above hide this cut-and-pasted boilerplate between interpretOptions and the DescriptorProto type -}

class ConsumeUNO a where consumeUNO :: a -> RE a

instance ConsumeUNO D.EnumDescriptorProto where
  consumeUNO :: EnumDescriptorProto
-> ReaderT Env (Either String) EnumDescriptorProto
consumeUNO EnumDescriptorProto
a = ReaderT Env (Either String) EnumDescriptorProto
-> (EnumOptions -> ReaderT Env (Either String) EnumDescriptorProto)
-> Maybe EnumOptions
-> ReaderT Env (Either String) EnumDescriptorProto
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (EnumDescriptorProto
-> ReaderT Env (Either String) EnumDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return EnumDescriptorProto
a) (EnumOptions -> ReaderT Env (Either String) EnumOptions
processOpt (EnumOptions -> ReaderT Env (Either String) EnumOptions)
-> (EnumOptions -> ReaderT Env (Either String) EnumDescriptorProto)
-> EnumOptions
-> ReaderT Env (Either String) EnumDescriptorProto
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \EnumOptions
o -> EnumDescriptorProto
-> ReaderT Env (Either String) EnumDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumDescriptorProto
 -> ReaderT Env (Either String) EnumDescriptorProto)
-> EnumDescriptorProto
-> ReaderT Env (Either String) EnumDescriptorProto
forall a b. (a -> b) -> a -> b
$ EnumDescriptorProto
a { options :: Maybe EnumOptions
D.EnumDescriptorProto.options = EnumOptions -> Maybe EnumOptions
forall a. a -> Maybe a
Just EnumOptions
o })
                       (EnumDescriptorProto -> Maybe EnumOptions
D.EnumDescriptorProto.options EnumDescriptorProto
a)
    where processOpt :: EnumOptions -> ReaderT Env (Either String) EnumOptions
processOpt EnumOptions
m = do EnumOptions
m' <- String
-> EnumOptions
-> Seq UninterpretedOption
-> ReaderT Env (Either String) EnumOptions
forall msg.
ExtendMessage msg =>
String -> msg -> Seq UninterpretedOption -> RE msg
interpretOptions String
"EnumOptions" EnumOptions
m (EnumOptions -> Seq UninterpretedOption
D.EnumOptions.uninterpreted_option EnumOptions
m)
                            EnumOptions -> ReaderT Env (Either String) EnumOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumOptions
m' { uninterpreted_option :: Seq UninterpretedOption
D.EnumOptions.uninterpreted_option = Seq UninterpretedOption
forall a. Monoid a => a
mempty })

instance ConsumeUNO D.EnumValueDescriptorProto where
  consumeUNO :: EnumValueDescriptorProto
-> ReaderT Env (Either String) EnumValueDescriptorProto
consumeUNO EnumValueDescriptorProto
a = ReaderT Env (Either String) EnumValueDescriptorProto
-> (EnumValueOptions
    -> ReaderT Env (Either String) EnumValueDescriptorProto)
-> Maybe EnumValueOptions
-> ReaderT Env (Either String) EnumValueDescriptorProto
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (EnumValueDescriptorProto
-> ReaderT Env (Either String) EnumValueDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return EnumValueDescriptorProto
a) (EnumValueOptions -> ReaderT Env (Either String) EnumValueOptions
processOpt (EnumValueOptions -> ReaderT Env (Either String) EnumValueOptions)
-> (EnumValueOptions
    -> ReaderT Env (Either String) EnumValueDescriptorProto)
-> EnumValueOptions
-> ReaderT Env (Either String) EnumValueDescriptorProto
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \EnumValueOptions
o -> EnumValueDescriptorProto
-> ReaderT Env (Either String) EnumValueDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumValueDescriptorProto
 -> ReaderT Env (Either String) EnumValueDescriptorProto)
-> EnumValueDescriptorProto
-> ReaderT Env (Either String) EnumValueDescriptorProto
forall a b. (a -> b) -> a -> b
$ EnumValueDescriptorProto
a { options :: Maybe EnumValueOptions
D.EnumValueDescriptorProto.options = EnumValueOptions -> Maybe EnumValueOptions
forall a. a -> Maybe a
Just EnumValueOptions
o })
                       (EnumValueDescriptorProto -> Maybe EnumValueOptions
D.EnumValueDescriptorProto.options EnumValueDescriptorProto
a)
    where processOpt :: EnumValueOptions -> ReaderT Env (Either String) EnumValueOptions
processOpt EnumValueOptions
m = do EnumValueOptions
m' <- String
-> EnumValueOptions
-> Seq UninterpretedOption
-> ReaderT Env (Either String) EnumValueOptions
forall msg.
ExtendMessage msg =>
String -> msg -> Seq UninterpretedOption -> RE msg
interpretOptions String
"EnumValueOptions" EnumValueOptions
m (EnumValueOptions -> Seq UninterpretedOption
D.EnumValueOptions.uninterpreted_option EnumValueOptions
m)
                            EnumValueOptions -> ReaderT Env (Either String) EnumValueOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumValueOptions
m' { uninterpreted_option :: Seq UninterpretedOption
D.EnumValueOptions.uninterpreted_option = Seq UninterpretedOption
forall a. Monoid a => a
mempty })

instance ConsumeUNO D.MethodDescriptorProto where
  consumeUNO :: MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
consumeUNO MethodDescriptorProto
a = ReaderT Env (Either String) MethodDescriptorProto
-> (MethodOptions
    -> ReaderT Env (Either String) MethodDescriptorProto)
-> Maybe MethodOptions
-> ReaderT Env (Either String) MethodDescriptorProto
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return MethodDescriptorProto
a) (MethodOptions -> ReaderT Env (Either String) MethodOptions
processOpt (MethodOptions -> ReaderT Env (Either String) MethodOptions)
-> (MethodOptions
    -> ReaderT Env (Either String) MethodDescriptorProto)
-> MethodOptions
-> ReaderT Env (Either String) MethodDescriptorProto
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \MethodOptions
o -> MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodDescriptorProto
 -> ReaderT Env (Either String) MethodDescriptorProto)
-> MethodDescriptorProto
-> ReaderT Env (Either String) MethodDescriptorProto
forall a b. (a -> b) -> a -> b
$ MethodDescriptorProto
a { options :: Maybe MethodOptions
D.MethodDescriptorProto.options = MethodOptions -> Maybe MethodOptions
forall a. a -> Maybe a
Just MethodOptions
o })
                       (MethodDescriptorProto -> Maybe MethodOptions
D.MethodDescriptorProto.options MethodDescriptorProto
a)
    where processOpt :: MethodOptions -> ReaderT Env (Either String) MethodOptions
processOpt MethodOptions
m = do MethodOptions
m' <- String
-> MethodOptions
-> Seq UninterpretedOption
-> ReaderT Env (Either String) MethodOptions
forall msg.
ExtendMessage msg =>
String -> msg -> Seq UninterpretedOption -> RE msg
interpretOptions String
"MethodOptions" MethodOptions
m (MethodOptions -> Seq UninterpretedOption
D.MethodOptions.uninterpreted_option MethodOptions
m)
                            MethodOptions -> ReaderT Env (Either String) MethodOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodOptions
m' { uninterpreted_option :: Seq UninterpretedOption
D.MethodOptions.uninterpreted_option = Seq UninterpretedOption
forall a. Monoid a => a
mempty })

instance ConsumeUNO D.ServiceDescriptorProto where
  consumeUNO :: ServiceDescriptorProto
-> ReaderT Env (Either String) ServiceDescriptorProto
consumeUNO ServiceDescriptorProto
a = ReaderT Env (Either String) ServiceDescriptorProto
-> (ServiceOptions
    -> ReaderT Env (Either String) ServiceDescriptorProto)
-> Maybe ServiceOptions
-> ReaderT Env (Either String) ServiceDescriptorProto
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ServiceDescriptorProto
-> ReaderT Env (Either String) ServiceDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return ServiceDescriptorProto
a) (ServiceOptions -> ReaderT Env (Either String) ServiceOptions
processOpt (ServiceOptions -> ReaderT Env (Either String) ServiceOptions)
-> (ServiceOptions
    -> ReaderT Env (Either String) ServiceDescriptorProto)
-> ServiceOptions
-> ReaderT Env (Either String) ServiceDescriptorProto
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \ServiceOptions
o -> ServiceDescriptorProto
-> ReaderT Env (Either String) ServiceDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (ServiceDescriptorProto
 -> ReaderT Env (Either String) ServiceDescriptorProto)
-> ServiceDescriptorProto
-> ReaderT Env (Either String) ServiceDescriptorProto
forall a b. (a -> b) -> a -> b
$ ServiceDescriptorProto
a { options :: Maybe ServiceOptions
D.ServiceDescriptorProto.options = ServiceOptions -> Maybe ServiceOptions
forall a. a -> Maybe a
Just ServiceOptions
o })
                       (ServiceDescriptorProto -> Maybe ServiceOptions
D.ServiceDescriptorProto.options ServiceDescriptorProto
a)
    where processOpt :: ServiceOptions -> ReaderT Env (Either String) ServiceOptions
processOpt ServiceOptions
m = do ServiceOptions
m' <- String
-> ServiceOptions
-> Seq UninterpretedOption
-> ReaderT Env (Either String) ServiceOptions
forall msg.
ExtendMessage msg =>
String -> msg -> Seq UninterpretedOption -> RE msg
interpretOptions String
"ServiceOptions" ServiceOptions
m (ServiceOptions -> Seq UninterpretedOption
D.ServiceOptions.uninterpreted_option ServiceOptions
m)
                            ServiceOptions -> ReaderT Env (Either String) ServiceOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (ServiceOptions
m' { uninterpreted_option :: Seq UninterpretedOption
D.ServiceOptions.uninterpreted_option = Seq UninterpretedOption
forall a. Monoid a => a
mempty })

instance ConsumeUNO D.FieldDescriptorProto where
  consumeUNO :: FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
consumeUNO FieldDescriptorProto
a = ReaderT Env (Either String) FieldDescriptorProto
-> (FieldOptions
    -> ReaderT Env (Either String) FieldDescriptorProto)
-> Maybe FieldOptions
-> ReaderT Env (Either String) FieldDescriptorProto
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return FieldDescriptorProto
a) (FieldOptions -> ReaderT Env (Either String) FieldOptions
processOpt (FieldOptions -> ReaderT Env (Either String) FieldOptions)
-> (FieldOptions
    -> ReaderT Env (Either String) FieldDescriptorProto)
-> FieldOptions
-> ReaderT Env (Either String) FieldDescriptorProto
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \FieldOptions
o -> FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldDescriptorProto
 -> ReaderT Env (Either String) FieldDescriptorProto)
-> FieldDescriptorProto
-> ReaderT Env (Either String) FieldDescriptorProto
forall a b. (a -> b) -> a -> b
$ FieldDescriptorProto
a { options :: Maybe FieldOptions
D.FieldDescriptorProto.options = FieldOptions -> Maybe FieldOptions
forall a. a -> Maybe a
Just FieldOptions
o })
                       (FieldDescriptorProto -> Maybe FieldOptions
D.FieldDescriptorProto.options FieldDescriptorProto
a)
    where processOpt :: FieldOptions -> ReaderT Env (Either String) FieldOptions
processOpt FieldOptions
m = do FieldOptions
m' <- String
-> FieldOptions
-> Seq UninterpretedOption
-> ReaderT Env (Either String) FieldOptions
forall msg.
ExtendMessage msg =>
String -> msg -> Seq UninterpretedOption -> RE msg
interpretOptions String
"FieldOptions" FieldOptions
m (FieldOptions -> Seq UninterpretedOption
D.FieldOptions.uninterpreted_option FieldOptions
m)
                            FieldOptions -> ReaderT Env (Either String) FieldOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldOptions
m' { uninterpreted_option :: Seq UninterpretedOption
D.FieldOptions.uninterpreted_option = Seq UninterpretedOption
forall a. Monoid a => a
mempty })

instance ConsumeUNO D.FileDescriptorProto where
  consumeUNO :: FileDescriptorProto -> RE FileDescriptorProto
consumeUNO FileDescriptorProto
a = RE FileDescriptorProto
-> (FileOptions -> RE FileDescriptorProto)
-> Maybe FileOptions
-> RE FileDescriptorProto
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FileDescriptorProto -> RE FileDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return FileDescriptorProto
a) (FileOptions -> ReaderT Env (Either String) FileOptions
processOpt (FileOptions -> ReaderT Env (Either String) FileOptions)
-> (FileOptions -> RE FileDescriptorProto)
-> FileOptions
-> RE FileDescriptorProto
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \FileOptions
o -> FileDescriptorProto -> RE FileDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (FileDescriptorProto -> RE FileDescriptorProto)
-> FileDescriptorProto -> RE FileDescriptorProto
forall a b. (a -> b) -> a -> b
$ FileDescriptorProto
a { options :: Maybe FileOptions
D.FileDescriptorProto.options = FileOptions -> Maybe FileOptions
forall a. a -> Maybe a
Just FileOptions
o })
                       (FileDescriptorProto -> Maybe FileOptions
D.FileDescriptorProto.options FileDescriptorProto
a)
    where processOpt :: FileOptions -> ReaderT Env (Either String) FileOptions
processOpt FileOptions
m = do FileOptions
m' <- String
-> FileOptions
-> Seq UninterpretedOption
-> ReaderT Env (Either String) FileOptions
forall msg.
ExtendMessage msg =>
String -> msg -> Seq UninterpretedOption -> RE msg
interpretOptions String
"FileOptions" FileOptions
m (FileOptions -> Seq UninterpretedOption
D.FileOptions.uninterpreted_option FileOptions
m)
                            FileOptions -> ReaderT Env (Either String) FileOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (FileOptions
m' { uninterpreted_option :: Seq UninterpretedOption
D.FileOptions.uninterpreted_option = Seq UninterpretedOption
forall a. Monoid a => a
mempty })

instance ConsumeUNO D.DescriptorProto where
  consumeUNO :: DescriptorProto -> ReaderT Env (Either String) DescriptorProto
consumeUNO DescriptorProto
a = ReaderT Env (Either String) DescriptorProto
-> (MessageOptions -> ReaderT Env (Either String) DescriptorProto)
-> Maybe MessageOptions
-> ReaderT Env (Either String) DescriptorProto
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DescriptorProto -> ReaderT Env (Either String) DescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return DescriptorProto
a) (MessageOptions -> ReaderT Env (Either String) MessageOptions
processOpt (MessageOptions -> ReaderT Env (Either String) MessageOptions)
-> (MessageOptions -> ReaderT Env (Either String) DescriptorProto)
-> MessageOptions
-> ReaderT Env (Either String) DescriptorProto
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \MessageOptions
o -> DescriptorProto -> ReaderT Env (Either String) DescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (DescriptorProto -> ReaderT Env (Either String) DescriptorProto)
-> DescriptorProto -> ReaderT Env (Either String) DescriptorProto
forall a b. (a -> b) -> a -> b
$ DescriptorProto
a { options :: Maybe MessageOptions
D.DescriptorProto.options = MessageOptions -> Maybe MessageOptions
forall a. a -> Maybe a
Just MessageOptions
o })
                       (DescriptorProto -> Maybe MessageOptions
D.DescriptorProto.options DescriptorProto
a)
    where processOpt :: MessageOptions -> ReaderT Env (Either String) MessageOptions
processOpt MessageOptions
m = do MessageOptions
m' <- String
-> MessageOptions
-> Seq UninterpretedOption
-> ReaderT Env (Either String) MessageOptions
forall msg.
ExtendMessage msg =>
String -> msg -> Seq UninterpretedOption -> RE msg
interpretOptions String
"MessageOptions" MessageOptions
m (MessageOptions -> Seq UninterpretedOption
D.MessageOptions.uninterpreted_option MessageOptions
m)
                            MessageOptions -> ReaderT Env (Either String) MessageOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (MessageOptions
m' { uninterpreted_option :: Seq UninterpretedOption
D.MessageOptions.uninterpreted_option = Seq UninterpretedOption
forall a. Monoid a => a
mempty })

{- The boilerplate above feeds interpretOptions to do the real work -}

-- 'interpretOptions' is used by the 'consumeUNO' instances
-- This prepends the ["google","protobuf"] and updates all the options into the ExtField of msg
interpretOptions :: ExtendMessage msg => String -> msg -> Seq D.UninterpretedOption -> RE msg
interpretOptions :: String -> msg -> Seq UninterpretedOption -> RE msg
interpretOptions String
name msg
msg Seq UninterpretedOption
unos = do
  IName String
name' <- String
-> Maybe (IName String)
-> ReaderT Env (Either String) (IName String)
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust (String
"interpretOptions: invalid name "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
name) (String -> Maybe (IName String)
forall a. Dotted a => a -> Maybe (IName a)
validI String
name)
  [(FieldId, ExtFieldValue)]
ios <- (UninterpretedOption
 -> ReaderT Env (Either String) (FieldId, ExtFieldValue))
-> [UninterpretedOption]
-> ReaderT Env (Either String) [(FieldId, ExtFieldValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([IName String]
-> UninterpretedOption
-> ReaderT Env (Either String) (FieldId, ExtFieldValue)
interpretOption [String -> IName String
forall a. a -> IName a
IName String
"google",String -> IName String
forall a. a -> IName a
IName String
"protobuf",IName String
name']) ([UninterpretedOption]
 -> ReaderT Env (Either String) [(FieldId, ExtFieldValue)])
-> (Seq UninterpretedOption -> [UninterpretedOption])
-> Seq UninterpretedOption
-> ReaderT Env (Either String) [(FieldId, ExtFieldValue)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq UninterpretedOption -> [UninterpretedOption]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq UninterpretedOption
 -> ReaderT Env (Either String) [(FieldId, ExtFieldValue)])
-> Seq UninterpretedOption
-> ReaderT Env (Either String) [(FieldId, ExtFieldValue)]
forall a b. (a -> b) -> a -> b
$ Seq UninterpretedOption
unos
  let (ExtField Map FieldId ExtFieldValue
ef) = msg -> ExtField
forall msg. ExtendMessage msg => msg -> ExtField
getExtField msg
msg
      ef' :: Map FieldId ExtFieldValue
ef' = (Map FieldId ExtFieldValue
 -> (FieldId, ExtFieldValue) -> Map FieldId ExtFieldValue)
-> Map FieldId ExtFieldValue
-> [(FieldId, ExtFieldValue)]
-> Map FieldId ExtFieldValue
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map FieldId ExtFieldValue
m (FieldId
k,ExtFieldValue
v) -> ExtFieldValue
-> Map FieldId ExtFieldValue -> Map FieldId ExtFieldValue
seq ExtFieldValue
v (Map FieldId ExtFieldValue -> Map FieldId ExtFieldValue)
-> Map FieldId ExtFieldValue -> Map FieldId ExtFieldValue
forall a b. (a -> b) -> a -> b
$ (FieldId -> ExtFieldValue -> ExtFieldValue -> ExtFieldValue)
-> FieldId
-> ExtFieldValue
-> Map FieldId ExtFieldValue
-> Map FieldId ExtFieldValue
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWithKey FieldId -> ExtFieldValue -> ExtFieldValue -> ExtFieldValue
forall a.
Show a =>
a -> ExtFieldValue -> ExtFieldValue -> ExtFieldValue
mergeWires FieldId
k ExtFieldValue
v Map FieldId ExtFieldValue
m) Map FieldId ExtFieldValue
ef [(FieldId, ExtFieldValue)]
ios

      mergeWires :: a -> ExtFieldValue -> ExtFieldValue -> ExtFieldValue
mergeWires a
_k (ExtFromWire Seq EP
newData) (ExtFromWire Seq EP
oldData) =
          Seq EP -> ExtFieldValue
ExtFromWire (Seq EP -> Seq EP -> Seq EP
forall a. Monoid a => a -> a -> a
mappend Seq EP
oldData Seq EP
newData)
{-
      mergeWires k (ExtFromWire wt1 newData) (ExtFromWire wt2 oldData) =
        if wt1 /= wt2 then err $ "interpretOptions.mergeWires : ExtFromWire WireType mismatch while storing new options in extension fields: " ++ show (name,k,(wt1,wt2))
          else ExtFromWire wt2 (mappend oldData newData)
-}
      mergeWires a
k ExtFieldValue
a ExtFieldValue
b = String -> ExtFieldValue
forall b. String -> b
err (String -> ExtFieldValue) -> String -> ExtFieldValue
forall a b. (a -> b) -> a -> b
$ String
"interpretOptions.mergeWires : impossible case\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++(a, ExtFieldValue, ExtFieldValue) -> String
forall a. Show a => a -> String
show (a
k,ExtFieldValue
a,ExtFieldValue
b)
      msg' :: msg
msg' = Map FieldId ExtFieldValue -> msg -> msg
seq Map FieldId ExtFieldValue
ef' (ExtField -> msg -> msg
forall msg. ExtendMessage msg => ExtField -> msg -> msg
putExtField (Map FieldId ExtFieldValue -> ExtField
ExtField Map FieldId ExtFieldValue
ef') msg
msg)
  msg -> RE msg
forall (m :: * -> *) a. Monad m => a -> m a
return msg
msg'

-- | 'interpretOption' is called by 'interpretOptions'
-- The 'interpretOption' function is quite long because there are two things going on.
-- The first is the actual type must be retrieved from the UninterpretedOption and encoded.
-- The second is that messages/groups holding messages/groups ... holding the above must wrap this.
-- Both of the above might come from extension keys or from field names.
-- And as usual, there are many ways thing could conceivable go wrong or be out of bounds.
--
-- The first parameter must be a name such as ["google","protobuf","FieldOption"]
interpretOption :: [IName String] -> D.UninterpretedOption -> RE (FieldId,ExtFieldValue)
interpretOption :: [IName String]
-> UninterpretedOption
-> ReaderT Env (Either String) (FieldId, ExtFieldValue)
interpretOption [IName String]
optName UninterpretedOption
uno = case Seq NamePart -> [NamePart]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (UninterpretedOption -> Seq NamePart
D.UninterpretedOption.name UninterpretedOption
uno) of
                                [] -> String -> ReaderT Env (Either String) (FieldId, ExtFieldValue)
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) (FieldId, ExtFieldValue))
-> String -> ReaderT Env (Either String) (FieldId, ExtFieldValue)
forall a b. (a -> b) -> a -> b
$ String
"Empty name_part"
                                (NamePart
part:[NamePart]
parts) -> do
                                    (FieldId
fieldId, Seq EP
raw) <- Maybe Entity
-> [IName String] -> NamePart -> [NamePart] -> RE (FieldId, Seq EP)
go Maybe Entity
forall a. Maybe a
Nothing [IName String]
optName NamePart
part [NamePart]
parts
                                    (FieldId, ExtFieldValue)
-> ReaderT Env (Either String) (FieldId, ExtFieldValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldId
fieldId, Seq EP -> ExtFieldValue
ExtFromWire Seq EP
raw)
 where
  iFail :: String -> RE a  -- needed by ghc-7.0.2
  iFail :: String -> RE a
iFail String
msg = do Env
env <- ReaderT Env (Either String) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
                 String -> RE a
forall e (m :: * -> *) a.
(Error e, MonadError e m) =>
String -> m a
throw (String -> RE a) -> String -> RE a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
"interpretOption: Failed to handle UninterpretedOption for: "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show [IName String]
optName
                                 , String
"  environment: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Env -> String
whereEnv Env
env
                                 , String
"  value: "String -> String -> String
forall a. [a] -> [a] -> [a]
++UninterpretedOption -> String
forall a. Show a => a -> String
show UninterpretedOption
uno
                                 , String
"  message: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
msg ]

  -- This takes care of an intermediate message or group type
  go :: Maybe Entity {- E'Message E'Group -} -> [IName String] -> D.NamePart -> [D.NamePart] -> RE (FieldId,Seq EP)
  go :: Maybe Entity
-> [IName String] -> NamePart -> [NamePart] -> RE (FieldId, Seq EP)
go Maybe Entity
mParent [IName String]
names (D.NamePart { name_part :: NamePart -> Utf8
D.NamePart.name_part = Utf8
name
                               , is_extension :: NamePart -> Bool
D.NamePart.is_extension = Bool
isKey }) (NamePart
next:[NamePart]
rest) = do
    -- get entity (Field or Key) and the TYPE_*
    -- fk will ceratinly be E'Field or E'Key
    (Entity
fk,Entity
entity) <-
      if Bool -> Bool
not Bool
isKey
        then case Maybe Entity
mParent of
               Maybe Entity
Nothing -> String -> ReaderT Env (Either String) (Entity, Entity)
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) (Entity, Entity))
-> String -> ReaderT Env (Either String) (Entity, Entity)
forall a b. (a -> b) -> a -> b
$ String
"Cannot resolve local (is_extension False) name, no parent; expected (key)."
               Just Entity
parent -> do
                 Entity
entity'field <- Entity -> Utf8 -> RE Entity
resolveHere Entity
parent Utf8
name
                 case Entity
entity'field of
                   (E'Field {}) ->
                     case Entity -> Maybe (Either String Entity)
mVal Entity
entity'field of
                       Maybe (Either String Entity)
Nothing -> String -> ReaderT Env (Either String) (Entity, Entity)
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) (Entity, Entity))
-> String -> ReaderT Env (Either String) (Entity, Entity)
forall a b. (a -> b) -> a -> b
$ String
"Intermediate entry E'Field is of basic type, not E'Message or E'Group: "String -> String -> String
forall a. [a] -> [a] -> [a]
++([IName String], [IName String]) -> String
forall a. Show a => a -> String
show ([IName String]
names,Entity -> [IName String]
eName Entity
entity'field)
                       Just Either String Entity
val -> Either String Entity -> RE Entity
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Either String Entity
val RE Entity
-> (Entity -> ReaderT Env (Either String) (Entity, Entity))
-> ReaderT Env (Either String) (Entity, Entity)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Entity
e -> (Entity, Entity) -> ReaderT Env (Either String) (Entity, Entity)
forall (m :: * -> *) a. Monad m => a -> m a
return (Entity
entity'field,Entity
e)
                   Entity
_ -> String -> ReaderT Env (Either String) (Entity, Entity)
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) (Entity, Entity))
-> String -> ReaderT Env (Either String) (Entity, Entity)
forall a b. (a -> b) -> a -> b
$ String
"Name "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show (Utf8 -> String
toString Utf8
name)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" was resolved but was not an E'Field: "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show (Entity -> [IName String]
eName Entity
entity'field)
        else do Entity
entity'key <- Utf8 -> RE Entity
resolveRE Utf8
name
                case Entity
entity'key of
                  (E'Key {eMsg :: Entity -> Either String Entity
eMsg=Either String Entity
msg}) -> do
                    Entity
extendee <- Either String Entity -> RE Entity
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Either String Entity
msg
                    Bool
-> ReaderT Env (Either String) () -> ReaderT Env (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Entity -> [IName String]
eName Entity
extendee [IName String] -> [IName String] -> Bool
forall a. Eq a => a -> a -> Bool
/= [IName String]
names) (ReaderT Env (Either String) () -> ReaderT Env (Either String) ())
-> ReaderT Env (Either String) () -> ReaderT Env (Either String) ()
forall a b. (a -> b) -> a -> b
$
                      String -> ReaderT Env (Either String) ()
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) ())
-> String -> ReaderT Env (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"Intermediate entry E'Key extends wrong type: "String -> String -> String
forall a. [a] -> [a] -> [a]
++([IName String], [IName String]) -> String
forall a. Show a => a -> String
show ([IName String]
names,Entity -> [IName String]
eName Entity
extendee)
                    case Entity -> Maybe (Either String Entity)
mVal Entity
entity'key of
                      Maybe (Either String Entity)
Nothing-> String -> ReaderT Env (Either String) (Entity, Entity)
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) (Entity, Entity))
-> String -> ReaderT Env (Either String) (Entity, Entity)
forall a b. (a -> b) -> a -> b
$ String
"Intermediate entry E'Key is of basic type, not E'Message or E'Group: "String -> String -> String
forall a. [a] -> [a] -> [a]
++([IName String], [IName String]) -> String
forall a. Show a => a -> String
show ([IName String]
names,Entity -> [IName String]
eName Entity
entity'key)
                      Just Either String Entity
val -> Either String Entity -> RE Entity
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Either String Entity
val RE Entity
-> (Entity -> ReaderT Env (Either String) (Entity, Entity))
-> ReaderT Env (Either String) (Entity, Entity)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Entity
e -> (Entity, Entity) -> ReaderT Env (Either String) (Entity, Entity)
forall (m :: * -> *) a. Monad m => a -> m a
return (Entity
entity'key,Entity
e)
                  Entity
_ -> String -> ReaderT Env (Either String) (Entity, Entity)
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) (Entity, Entity))
-> String -> ReaderT Env (Either String) (Entity, Entity)
forall a b. (a -> b) -> a -> b
$ String
"Name "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show (Utf8 -> String
toString Utf8
name)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" was resolved but was not an E'Key: "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show (Entity -> [IName String]
eName Entity
entity'key)
    Type
t <- case Entity
entity of
      E'Message {} -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TYPE_MESSAGE
      E'Group {} -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TYPE_GROUP
      Entity
_ -> String -> ReaderT Env (Either String) Type
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) Type)
-> String -> ReaderT Env (Either String) Type
forall a b. (a -> b) -> a -> b
$ String
"Intermediate entry is not an E'Message or E'Group: "String -> String -> String
forall a. [a] -> [a] -> [a]
++[IName String] -> String
forall a. Show a => a -> String
show (Entity -> [IName String]
eName Entity
entity)
    -- recursive call to get inner result
    (FieldId
fid', Seq EP
raw') <- Maybe Entity
-> [IName String] -> NamePart -> [NamePart] -> RE (FieldId, Seq EP)
go (Entity -> Maybe Entity
forall a. a -> Maybe a
Just Entity
entity) (Entity -> [IName String]
eName Entity
entity) NamePart
next [NamePart]
rest
    -- wrap old tag + inner result with outer info
    let tag :: WireTag
tag@(WireTag Word32
tag') = FieldId -> WireType -> WireTag
mkWireTag FieldId
fid' WireType
wt'
        (EP WireType
wt' ByteString
bs') = Seq EP -> Int -> EP
forall a. Seq a -> Int -> a
Seq.index Seq EP
raw' Int
0
    let fid :: FieldId
fid = Entity -> FieldId
fNumber Entity
fk -- safe by construction of fk
        wt :: WireType
wt = FieldType -> WireType
toWireType (Int -> FieldType
FieldType (Type -> Int
forall a. Enum a => a -> Int
fromEnum Type
t))
        bs :: ByteString
bs = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$
          case Type
t of Type
TYPE_MESSAGE -> do WireSize -> Put
putSize (WireTag -> WireSize
size'WireTag WireTag
tag WireSize -> WireSize -> WireSize
forall a. Num a => a -> a -> a
+ ByteString -> WireSize
LC.length ByteString
bs')
                                       Word32 -> Put
forall a. (Integral a, Bits a) => a -> Put
putVarUInt Word32
tag'
                                       ByteString -> Put
putLazyByteString ByteString
bs'
                    Type
TYPE_GROUP -> do Word32 -> Put
forall a. (Integral a, Bits a) => a -> Put
putVarUInt Word32
tag'
                                     ByteString -> Put
putLazyByteString ByteString
bs'
                                     Word32 -> Put
forall a. (Integral a, Bits a) => a -> Put
putVarUInt (Word32 -> Word32
forall a. Enum a => a -> a
succ (WireTag -> Word32
getWireTag (FieldId -> WireType -> WireTag
mkWireTag FieldId
fid WireType
wt)))
                    Type
_ -> String -> Put
forall a. HasCallStack => String -> a
error (String -> Put) -> String -> Put
forall a b. (a -> b) -> a -> b
$ String
"bug! raw with type "String -> String -> String
forall a. [a] -> [a] -> [a]
++Type -> String
forall a. Show a => a -> String
show Type
tString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" should be impossible"
    (FieldId, Seq EP) -> RE (FieldId, Seq EP)
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldId
fid, EP -> Seq EP
forall a. a -> Seq a
Seq.singleton (WireType -> ByteString -> EP
EP WireType
wt ByteString
bs))

  -- This takes care of the acutal value of the option, which must be a basic type
  go Maybe Entity
mParent [IName String]
names (D.NamePart { name_part :: NamePart -> Utf8
D.NamePart.name_part = Utf8
name
                               , is_extension :: NamePart -> Bool
D.NamePart.is_extension = Bool
isKey }) [] = do
    -- get entity (Field or Key) and the TYPE_*
    Entity
fk <- if Bool
isKey then Utf8 -> RE Entity
resolveRE Utf8
name
                else case Maybe Entity
mParent of
                       Just Entity
parent -> Entity -> Utf8 -> RE Entity
resolveHere Entity
parent Utf8
name
                       Maybe Entity
Nothing -> String -> RE Entity
forall a. String -> RE a
iFail (String -> RE Entity) -> String -> RE Entity
forall a b. (a -> b) -> a -> b
$ String
"Cannot resolve local (is_extension False) name, no parent; expected (key)."
    case Entity
fk of
      E'Field {} | Bool -> Bool
not Bool
isKey -> () -> ReaderT Env (Either String) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      E'Key {} | Bool
isKey -> do
        Entity
ext <- Either String Entity -> RE Entity
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Entity -> Either String Entity
eMsg Entity
fk)
        Bool
-> ReaderT Env (Either String) () -> ReaderT Env (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Entity -> [IName String]
eName Entity
ext [IName String] -> [IName String] -> Bool
forall a. Eq a => a -> a -> Bool
/= [IName String]
names) (ReaderT Env (Either String) () -> ReaderT Env (Either String) ())
-> ReaderT Env (Either String) () -> ReaderT Env (Either String) ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT Env (Either String) ()
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) ())
-> String -> ReaderT Env (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"Last entry E'Key extends wrong type: "String -> String -> String
forall a. [a] -> [a] -> [a]
++([IName String], [IName String]) -> String
forall a. Show a => a -> String
show ([IName String]
names,Entity -> [IName String]
eName Entity
ext)
      Entity
_ -> String -> ReaderT Env (Either String) ()
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) ())
-> String -> ReaderT Env (Either String) ()
forall a b. (a -> b) -> a -> b
$ String
"Last entity was resolved but was not an E'Field or E'Key: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Entity -> String
forall a. Show a => a -> String
show Entity
fk
    Type
t <- case (Entity -> Maybe Type
fType Entity
fk) of
           Maybe Type
Nothing -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TYPE_ENUM -- XXX not a good assumption with aggregate types !!!!  This also covers groups and messages.
           Just Type
TYPE_GROUP -> String -> ReaderT Env (Either String) Type
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) Type)
-> String -> ReaderT Env (Either String) Type
forall a b. (a -> b) -> a -> b
$ String
"Last entry was a TYPE_GROUP instead of concrete value type" -- impossible
           Just Type
TYPE_MESSAGE -> {- impossible -} String -> ReaderT Env (Either String) Type
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) Type)
-> String -> ReaderT Env (Either String) Type
forall a b. (a -> b) -> a -> b
$ String
"Last entry was a TYPE_MESSAGE instead of concrete value type" -- impossible
           Just Type
typeCode -> Type -> ReaderT Env (Either String) Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
typeCode
    -- Need to define a polymorphic 'done' to convert actual data type to its wire encoding
    let done :: Wire v => v -> RE (FieldId,Seq EP)
        done :: v -> RE (FieldId, Seq EP)
done v
v = let ft :: FieldType
ft = Int -> FieldType
FieldType (Type -> Int
forall a. Enum a => a -> Int
fromEnum Type
t)
                     wt :: WireType
wt = FieldType -> WireType
toWireType FieldType
ft
                     fid :: FieldId
fid = Entity -> FieldId
fNumber Entity
fk
                 in (FieldId, Seq EP) -> RE (FieldId, Seq EP)
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldId
fid, EP -> Seq EP
forall a. a -> Seq a
Seq.singleton (WireType -> ByteString -> EP
EP WireType
wt (Put -> ByteString
runPut (FieldType -> v -> Put
forall b. Wire b => FieldType -> b -> Put
wirePut FieldType
ft v
v))))
    -- The actual type and value fed to 'done' depends on the values 't' and 'uno':
    case Type
t of
      Type
TYPE_ENUM -> -- Now must also also handle Message and Group
        case (Entity -> Maybe (Either String Entity)
mVal Entity
fk,UninterpretedOption -> Maybe Utf8
D.UninterpretedOption.identifier_value UninterpretedOption
uno,UninterpretedOption -> Maybe Utf8
D.UninterpretedOption.aggregate_value UninterpretedOption
uno) of
          (Just (Right (E'Enum {eVals :: Entity -> Map (IName Utf8) Int32
eVals=Map (IName Utf8) Int32
enumVals})),Just Utf8
enumVal,Maybe Utf8
_) ->
            case Utf8 -> Maybe (IName Utf8)
forall a. Dotted a => a -> Maybe (IName a)
validI Utf8
enumVal of
              Maybe (IName Utf8)
Nothing -> String -> RE (FieldId, Seq EP)
forall a. String -> RE a
iFail (String -> RE (FieldId, Seq EP)) -> String -> RE (FieldId, Seq EP)
forall a b. (a -> b) -> a -> b
$ String
"invalid D.UninterpretedOption.identifier_value: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Utf8 -> String
forall a. Show a => a -> String
show Utf8
enumVal
              Just IName Utf8
enumIVal -> case IName Utf8 -> Map (IName Utf8) Int32 -> Maybe Int32
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup IName Utf8
enumIVal Map (IName Utf8) Int32
enumVals of
                                 Maybe Int32
Nothing -> String -> RE (FieldId, Seq EP)
forall a. String -> RE a
iFail (String -> RE (FieldId, Seq EP)) -> String -> RE (FieldId, Seq EP)
forall a b. (a -> b) -> a -> b
$ String
"enumVal lookup failed: "String -> String -> String
forall a. [a] -> [a] -> [a]
++(IName Utf8, [IName Utf8]) -> String
forall a. Show a => a -> String
show (IName Utf8
enumIVal,Map (IName Utf8) Int32 -> [IName Utf8]
forall k a. Map k a -> [k]
M.keys Map (IName Utf8) Int32
enumVals)
                                 Just Int32
val -> Int -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Int32 -> Int
forall a. Enum a => a -> Int
fromEnum Int32
val) -- fromEnum :: Int32 -> Int
          (Just (Right (E'Enum {})),Maybe Utf8
Nothing,Maybe Utf8
_) -> String -> RE (FieldId, Seq EP)
forall a. String -> RE a
iFail (String -> RE (FieldId, Seq EP)) -> String -> RE (FieldId, Seq EP)
forall a b. (a -> b) -> a -> b
$ String
"No identifer_value value to lookup in E'Enum"
          (Just (Right (E'Message {})),Maybe Utf8
_,Maybe Utf8
Nothing) -> String -> RE (FieldId, Seq EP)
forall a. String -> RE a
iFail String
"Expected aggregate syntax to set a message option"
          (Just (Right (E'Message {})),Maybe Utf8
_,Just Utf8
aggVal) -> String -> RE (FieldId, Seq EP)
forall a. String -> RE a
iFail (String -> RE (FieldId, Seq EP)) -> String -> RE (FieldId, Seq EP)
forall a b. (a -> b) -> a -> b
$ String
"\n\n\
          \=========================================================================================\n\
          \Google's 2.4.0 aggregate syntax for message options is not yet supported, value would be:\n\
          \=========================================================================================\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Utf8 -> String
forall a. Show a => a -> String
show Utf8
aggVal
          (Just (Right (E'Group {})),Maybe Utf8
_,Maybe Utf8
Nothing) -> String -> RE (FieldId, Seq EP)
forall a. String -> RE a
iFail String
"Expected aggregate syntax to set a group option (impossible?)"
          (Just (Right (E'Group {})),Maybe Utf8
_,Just Utf8
aggVal) -> String -> RE (FieldId, Seq EP)
forall a. String -> RE a
iFail (String -> RE (FieldId, Seq EP)) -> String -> RE (FieldId, Seq EP)
forall a b. (a -> b) -> a -> b
$ String
"\n\n\
          \=========================================================================================\n\
          \Google's 2.4.0 aggregate syntax for message options is not yet supported, value would be:\n\
          \=========================================================================================\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Utf8 -> String
forall a. Show a => a -> String
show Utf8
aggVal
          (Maybe (Either String Entity)
me,Maybe Utf8
_,Maybe Utf8
_) -> String -> RE (FieldId, Seq EP)
forall a. String -> RE a
iFail (String -> RE (FieldId, Seq EP)) -> String -> RE (FieldId, Seq EP)
forall a b. (a -> b) -> a -> b
$ String
"Expected Just E'Enum or E'Message or E'Group, got:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++Maybe (Either String Entity) -> String
forall a. Show a => a -> String
show Maybe (Either String Entity)
me

      Type
TYPE_STRING   -> do
        ByteString
bs <- String
-> Maybe ByteString -> ReaderT Env (Either String) ByteString
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"UninterpretedOption.string_value" (UninterpretedOption -> Maybe ByteString
D.UninterpretedOption.string_value UninterpretedOption
uno)
        RE (FieldId, Seq EP)
-> (Int -> RE (FieldId, Seq EP))
-> Maybe Int
-> RE (FieldId, Seq EP)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Utf8 -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (ByteString -> Utf8
Utf8 ByteString
bs)) (\Int
i -> String -> RE (FieldId, Seq EP)
forall a. String -> RE a
iFail (String -> RE (FieldId, Seq EP)) -> String -> RE (FieldId, Seq EP)
forall a b. (a -> b) -> a -> b
$ String
"Invalid utf8 in string_value at index: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i)
              (ByteString -> Maybe Int
isValidUTF8 ByteString
bs)

      Type
TYPE_BYTES    -> ByteString -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (ByteString -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) ByteString -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
-> Maybe ByteString -> ReaderT Env (Either String) ByteString
forall e (m :: * -> *) a.
(Error e, MonadError e m, Typeable a) =>
String -> Maybe a -> m a
getJust String
"UninterpretedOption.string_value" (UninterpretedOption -> Maybe ByteString
D.UninterpretedOption.string_value UninterpretedOption
uno)
      Type
TYPE_BOOL     -> Bool -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Bool -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) Bool -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT Env (Either String) Bool
bVal
      Type
TYPE_DOUBLE   -> Double -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Double -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) Double -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT Env (Either String) Double
dVal
      Type
TYPE_FLOAT    -> Float -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Float -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) Float -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Double -> ReaderT Env (Either String) Float
asFloat (Double -> ReaderT Env (Either String) Float)
-> ReaderT Env (Either String) Double
-> ReaderT Env (Either String) Float
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT Env (Either String) Double
dVal
      Type
TYPE_INT64    -> WireSize -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (WireSize -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) WireSize -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ReaderT Env (Either String) WireSize
forall y. (Bounded y, Integral y) => RE y
iVal :: RE Int64)
      Type
TYPE_SFIXED64 -> WireSize -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (WireSize -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) WireSize -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ReaderT Env (Either String) WireSize
forall y. (Bounded y, Integral y) => RE y
iVal :: RE Int64)
      Type
TYPE_SINT64   -> WireSize -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (WireSize -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) WireSize -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ReaderT Env (Either String) WireSize
forall y. (Bounded y, Integral y) => RE y
iVal :: RE Int64)
      Type
TYPE_UINT64   -> Word64 -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Word64 -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) Word64 -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ReaderT Env (Either String) Word64
forall y. (Bounded y, Integral y) => RE y
iVal :: RE Word64)
      Type
TYPE_FIXED64  -> Word64 -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Word64 -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) Word64 -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ReaderT Env (Either String) Word64
forall y. (Bounded y, Integral y) => RE y
iVal :: RE Word64)
      Type
TYPE_INT32    -> Int32 -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Int32 -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) Int32 -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ReaderT Env (Either String) Int32
forall y. (Bounded y, Integral y) => RE y
iVal :: RE Int32)
      Type
TYPE_SFIXED32 -> Int32 -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Int32 -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) Int32 -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ReaderT Env (Either String) Int32
forall y. (Bounded y, Integral y) => RE y
iVal :: RE Int32)
      Type
TYPE_SINT32   -> Int32 -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Int32 -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) Int32 -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ReaderT Env (Either String) Int32
forall y. (Bounded y, Integral y) => RE y
iVal :: RE Int32)
      Type
TYPE_UINT32   -> Word32 -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Word32 -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) Word32 -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ReaderT Env (Either String) Word32
forall y. (Bounded y, Integral y) => RE y
iVal :: RE Word32)
      Type
TYPE_FIXED32  -> Word32 -> RE (FieldId, Seq EP)
forall v. Wire v => v -> RE (FieldId, Seq EP)
done (Word32 -> RE (FieldId, Seq EP))
-> ReaderT Env (Either String) Word32 -> RE (FieldId, Seq EP)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ReaderT Env (Either String) Word32
forall y. (Bounded y, Integral y) => RE y
iVal :: RE Word32)
      Type
_ -> String -> RE (FieldId, Seq EP)
forall a. String -> RE a
iFail (String -> RE (FieldId, Seq EP)) -> String -> RE (FieldId, Seq EP)
forall a b. (a -> b) -> a -> b
$ String
"bug! go with type "String -> String -> String
forall a. [a] -> [a] -> [a]
++Type -> String
forall a. Show a => a -> String
show Type
tString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" should be impossible"

  -- Machinery needed by the final call of go
  bVal :: RE Bool
  bVal :: ReaderT Env (Either String) Bool
bVal = let true :: Utf8
true = ByteString -> Utf8
Utf8 (String -> ByteString
U.fromString String
"true")
             false :: Utf8
false = ByteString -> Utf8
Utf8 (String -> ByteString
U.fromString String
"false")
         in case UninterpretedOption -> Maybe Utf8
D.UninterpretedOption.identifier_value UninterpretedOption
uno of
              Just Utf8
s | Utf8
s Utf8 -> Utf8 -> Bool
forall a. Eq a => a -> a -> Bool
== Utf8
true -> Bool -> ReaderT Env (Either String) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                     | Utf8
s Utf8 -> Utf8 -> Bool
forall a. Eq a => a -> a -> Bool
== Utf8
false -> Bool -> ReaderT Env (Either String) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
              Maybe Utf8
_ -> String -> ReaderT Env (Either String) Bool
forall a. String -> RE a
iFail String
"Expected 'true' or 'false' identifier_value"
  dVal :: RE Double
  dVal :: ReaderT Env (Either String) Double
dVal = case (UninterpretedOption -> Maybe WireSize
D.UninterpretedOption.negative_int_value UninterpretedOption
uno
              ,UninterpretedOption -> Maybe Word64
D.UninterpretedOption.positive_int_value UninterpretedOption
uno
              ,UninterpretedOption -> Maybe Double
D.UninterpretedOption.double_value UninterpretedOption
uno) of
           (Maybe WireSize
_,Maybe Word64
_,Just Double
d) -> Double -> ReaderT Env (Either String) Double
forall (m :: * -> *) a. Monad m => a -> m a
return Double
d
           (Maybe WireSize
_,Just Word64
p,Maybe Double
_) -> Double -> ReaderT Env (Either String) Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
p)
           (Just WireSize
n,Maybe Word64
_,Maybe Double
_) -> Double -> ReaderT Env (Either String) Double
forall (m :: * -> *) a. Monad m => a -> m a
return (WireSize -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral WireSize
n)
           (Maybe WireSize, Maybe Word64, Maybe Double)
_ -> String -> ReaderT Env (Either String) Double
forall a. String -> RE a
iFail String
"No numeric value"
  asFloat :: Double -> RE Float
  asFloat :: Double -> ReaderT Env (Either String) Float
asFloat Double
d = let fmax :: Ratio Integer
                  fmax :: Ratio Integer
fmax = (Ratio Integer
2Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
-(Integer
1Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
%Integer
2)Ratio Integer -> Int -> Ratio Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
23::Int)) Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
* (Ratio Integer
2Ratio Integer -> Int -> Ratio Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
127::Int))
                  d' :: Ratio Integer
d' = Double -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational Double
d
              in if (Ratio Integer -> Ratio Integer
forall a. Num a => a -> a
negate Ratio Integer
fmax Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Ratio Integer
d') Bool -> Bool -> Bool
&& (Ratio Integer
d' Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Ratio Integer
fmax)
                   then Float -> ReaderT Env (Either String) Float
forall (m :: * -> *) a. Monad m => a -> m a
return (Ratio Integer -> Float
forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
d')
                   else String -> ReaderT Env (Either String) Float
forall a. String -> RE a
iFail (String -> ReaderT Env (Either String) Float)
-> String -> ReaderT Env (Either String) Float
forall a b. (a -> b) -> a -> b
$ String
"Double out of range for Float: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Double -> String
forall a. Show a => a -> String
show Double
d
  rangeCheck :: forall a. (Bounded a,Integral a) => Integer -> RE a
  rangeCheck :: Integer -> RE a
rangeCheck Integer
i = let r :: (Integer, Integer)
r = (a -> Integer
forall a. Integral a => a -> Integer
toInteger (a
forall a. Bounded a => a
minBound ::a),a -> Integer
forall a. Integral a => a -> Integer
toInteger (a
forall a. Bounded a => a
maxBound :: a))
                 in if (Integer, Integer) -> Integer -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Integer, Integer)
r Integer
i then a -> RE a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
i) else String -> RE a
forall a. String -> RE a
iFail (String -> RE a) -> String -> RE a
forall a b. (a -> b) -> a -> b
$ String
"Constant out of range: "String -> String -> String
forall a. [a] -> [a] -> [a]
++((Integer, Integer), Integer) -> String
forall a. Show a => a -> String
show ((Integer, Integer)
r,Integer
i)
  asInt :: Double -> RE Integer
  asInt :: Double -> RE Integer
asInt Double
x = let (Integer
a,Double
b) = Double -> (Integer, Double)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
x
            in if Double
bDouble -> Double -> Bool
forall a. Eq a => a -> a -> Bool
==Double
0 then Integer -> RE Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
a
                 else String -> RE Integer
forall a. String -> RE a
iFail (String -> RE Integer) -> String -> RE Integer
forall a b. (a -> b) -> a -> b
$ String
"Double value not an integer: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Double -> String
forall a. Show a => a -> String
show Double
x
  iVal :: (Bounded y, Integral y) => RE y
  iVal :: RE y
iVal = case (UninterpretedOption -> Maybe WireSize
D.UninterpretedOption.negative_int_value UninterpretedOption
uno
              ,UninterpretedOption -> Maybe Word64
D.UninterpretedOption.positive_int_value UninterpretedOption
uno
              ,UninterpretedOption -> Maybe Double
D.UninterpretedOption.double_value UninterpretedOption
uno) of
           (Maybe WireSize
_,Just Word64
p,Maybe Double
_) -> Integer -> RE y
forall a. (Bounded a, Integral a) => Integer -> RE a
rangeCheck (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
p)
           (Just WireSize
n,Maybe Word64
_,Maybe Double
_) -> Integer -> RE y
forall a. (Bounded a, Integral a) => Integer -> RE a
rangeCheck (WireSize -> Integer
forall a. Integral a => a -> Integer
toInteger WireSize
n)
           (Maybe WireSize
_,Maybe Word64
_,Just Double
d) -> Integer -> RE y
forall a. (Bounded a, Integral a) => Integer -> RE a
rangeCheck (Integer -> RE y) -> RE Integer -> RE y
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Double -> RE Integer
asInt Double
d
           (Maybe WireSize, Maybe Word64, Maybe Double)
_ -> String -> RE y
forall a. String -> RE a
iFail String
"No numeric value"

-- | 'findFile' looks through the current and import directories to find the target file on the system.
-- It also converts the relative path to a standard form to use as the name of the FileDescriptorProto.
findFile :: [LocalFP] -> LocalFP -> IO (Maybe (LocalFP,CanonFP)) -- absolute and canonical parts
findFile :: [LocalFP] -> LocalFP -> IO (Maybe (LocalFP, CanonFP))
findFile [LocalFP]
paths (LocalFP String
target) = [LocalFP] -> IO (Maybe (LocalFP, CanonFP))
test [LocalFP]
paths where
  test :: [LocalFP] -> IO (Maybe (LocalFP, CanonFP))
test [] = Maybe (LocalFP, CanonFP) -> IO (Maybe (LocalFP, CanonFP))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LocalFP, CanonFP)
forall a. Maybe a
Nothing
  test (LocalFP String
path:[LocalFP]
rest) = do
    let fullname :: String
fullname = String -> String -> String
Local.combine String
path String
target
    Bool
found <- String -> IO Bool
doesFileExist String
fullname -- stop at first hit
    if Bool -> Bool
not Bool
found
      then [LocalFP] -> IO (Maybe (LocalFP, CanonFP))
test [LocalFP]
rest
      else do String
truepath <- String -> IO String
canonicalizePath String
path
              String
truefile <- String -> IO String
canonicalizePath String
fullname
              if String
truepath String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
truefile
                then do let rel :: CanonFP
rel = LocalFP -> CanonFP
fpLocalToCanon (String -> LocalFP
LocalFP (String -> String -> String
Local.makeRelative String
truepath String
truefile))
                        Maybe (LocalFP, CanonFP) -> IO (Maybe (LocalFP, CanonFP))
forall (m :: * -> *) a. Monad m => a -> m a
return ((LocalFP, CanonFP) -> Maybe (LocalFP, CanonFP)
forall a. a -> Maybe a
Just (String -> LocalFP
LocalFP String
truefile,CanonFP
rel))
                else String -> IO (Maybe (LocalFP, CanonFP))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Maybe (LocalFP, CanonFP)))
-> String -> IO (Maybe (LocalFP, CanonFP))
forall a b. (a -> b) -> a -> b
$ String
"file found but it is not below path, cannot make canonical name:\n  path: "
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
truepathString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n  file: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
truefile


-- | Given a path, tries to find and parse a FileDescriptorProto
-- corresponding to it; returns also a canonicalised path.
type DescriptorReader m = (Monad m) => LocalFP -> m (D.FileDescriptorProto, LocalFP)

loadProto' :: (Functor r,Monad r) => (forall a. String -> StateT (Map LocalFP Env) r a) -> DescriptorReader r -> LocalFP -> r (Env,[D.FileDescriptorProto])
loadProto' :: (forall a. String -> StateT (Map LocalFP Env) r a)
-> DescriptorReader r -> LocalFP -> r (Env, [FileDescriptorProto])
loadProto' forall a. String -> StateT (Map LocalFP Env) r a
doFail DescriptorReader r
fdpReader LocalFP
protoFile = StateT (Map LocalFP Env) r Env -> r (Env, [FileDescriptorProto])
forall (m :: * -> *) k a.
(Monad m, Ord k) =>
StateT (Map k Env) m a -> m (a, [FileDescriptorProto])
goState (Set LocalFP -> LocalFP -> StateT (Map LocalFP Env) r Env
load Set LocalFP
forall a. Set a
Set.empty LocalFP
protoFile) where
  goState :: StateT (Map k Env) m a -> m (a, [FileDescriptorProto])
goState StateT (Map k Env) m a
act = do (a
env,Map k Env
m) <- StateT (Map k Env) m a -> Map k Env -> m (a, Map k Env)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (Map k Env) m a
act Map k Env
forall a. Monoid a => a
mempty
                   let fromRight :: Either String p -> p
fromRight (Right p
x) = p
x
                       fromRight (Left String
s) = String -> p
forall a. HasCallStack => String -> a
error (String -> p) -> String -> p
forall a b. (a -> b) -> a -> b
$ String
"loadProto failed to resolve a FileDescriptorProto: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s
                   (a, [FileDescriptorProto]) -> m (a, [FileDescriptorProto])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
env,(Env -> FileDescriptorProto) -> [Env] -> [FileDescriptorProto]
forall a b. (a -> b) -> [a] -> [b]
map (Either String FileDescriptorProto -> FileDescriptorProto
forall p. Either String p -> p
fromRight (Either String FileDescriptorProto -> FileDescriptorProto)
-> (Env -> Either String FileDescriptorProto)
-> Env
-> FileDescriptorProto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> Either String FileDescriptorProto
top'FDP (TopLevel -> Either String FileDescriptorProto)
-> (Env -> TopLevel) -> Env -> Either String FileDescriptorProto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TopLevel, [TopLevel]) -> TopLevel
forall a b. (a, b) -> a
fst ((TopLevel, [TopLevel]) -> TopLevel)
-> (Env -> (TopLevel, [TopLevel])) -> Env -> TopLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> (TopLevel, [TopLevel])
getTLS) (Map k Env -> [Env]
forall k a. Map k a -> [a]
M.elems Map k Env
m))
  load :: Set LocalFP -> LocalFP -> StateT (Map LocalFP Env) r Env
load Set LocalFP
parentsIn LocalFP
file = do
    Map LocalFP Env
built <- StateT (Map LocalFP Env) r (Map LocalFP Env)
forall s (m :: * -> *). MonadState s m => m s
get
    Bool
-> StateT (Map LocalFP Env) r () -> StateT (Map LocalFP Env) r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalFP -> Set LocalFP -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member LocalFP
file Set LocalFP
parentsIn)
         (String -> StateT (Map LocalFP Env) r ()
forall a. String -> StateT (Map LocalFP Env) r a
doFail (String -> StateT (Map LocalFP Env) r ())
-> String -> StateT (Map LocalFP Env) r ()
forall a b. (a -> b) -> a -> b
$ LocalFP -> String -> String
loadFailed LocalFP
file ([String] -> String
unlines [String
"imports failed: recursive loop detected"
                                   ,[String] -> String
unlines ([String] -> String)
-> (Map LocalFP Env -> [String]) -> Map LocalFP Env -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LocalFP, Env) -> String) -> [(LocalFP, Env)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (LocalFP, Env) -> String
forall a. Show a => a -> String
show ([(LocalFP, Env)] -> [String])
-> (Map LocalFP Env -> [(LocalFP, Env)])
-> Map LocalFP Env
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map LocalFP Env -> [(LocalFP, Env)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map LocalFP Env -> String) -> Map LocalFP Env -> String
forall a b. (a -> b) -> a -> b
$ Map LocalFP Env
built,Set LocalFP -> String
forall a. Show a => a -> String
show Set LocalFP
parentsIn]))
    case LocalFP -> Map LocalFP Env -> Maybe Env
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup LocalFP
file Map LocalFP Env
built of  -- check memorized results
      Just Env
result -> Env -> StateT (Map LocalFP Env) r Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
result
      Maybe Env
Nothing -> do
            (FileDescriptorProto
parsed'fdp, LocalFP
canonicalFile) <- r (FileDescriptorProto, LocalFP)
-> StateT (Map LocalFP Env) r (FileDescriptorProto, LocalFP)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (r (FileDescriptorProto, LocalFP)
 -> StateT (Map LocalFP Env) r (FileDescriptorProto, LocalFP))
-> r (FileDescriptorProto, LocalFP)
-> StateT (Map LocalFP Env) r (FileDescriptorProto, LocalFP)
forall a b. (a -> b) -> a -> b
$ DescriptorReader r
LocalFP -> r (FileDescriptorProto, LocalFP)
fdpReader LocalFP
file
            let rawPackage :: PackageID Utf8
rawPackage = FileDescriptorProto -> PackageID Utf8
getPackage FileDescriptorProto
parsed'fdp
            PackageID [IName String]
packageName <- (String -> StateT (Map LocalFP Env) r (PackageID [IName String]))
-> (PackageID (Bool, [IName Utf8])
    -> StateT (Map LocalFP Env) r (PackageID [IName String]))
-> Either String (PackageID (Bool, [IName Utf8]))
-> StateT (Map LocalFP Env) r (PackageID [IName String])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> StateT (Map LocalFP Env) r (PackageID [IName String])
forall a. String -> StateT (Map LocalFP Env) r a
doFail (String -> StateT (Map LocalFP Env) r (PackageID [IName String]))
-> (String -> String)
-> String
-> StateT (Map LocalFP Env) r (PackageID [IName String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalFP -> String -> String
loadFailed LocalFP
canonicalFile (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show)
                                  (PackageID [IName String]
-> StateT (Map LocalFP Env) r (PackageID [IName String])
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageID [IName String]
 -> StateT (Map LocalFP Env) r (PackageID [IName String]))
-> (PackageID (Bool, [IName Utf8]) -> PackageID [IName String])
-> PackageID (Bool, [IName Utf8])
-> StateT (Map LocalFP Env) r (PackageID [IName String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, [IName Utf8]) -> [IName String])
-> PackageID (Bool, [IName Utf8]) -> PackageID [IName String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IName Utf8 -> IName String) -> [IName Utf8] -> [IName String]
forall a b. (a -> b) -> [a] -> [b]
map IName Utf8 -> IName String
iToString ([IName Utf8] -> [IName String])
-> ((Bool, [IName Utf8]) -> [IName Utf8])
-> (Bool, [IName Utf8])
-> [IName String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, [IName Utf8]) -> [IName Utf8]
forall a b. (a, b) -> b
snd)) -- 2012-09-19 suspicious
                                  (PackageID Utf8 -> Either String (PackageID (Bool, [IName Utf8]))
checkPackageID PackageID Utf8
rawPackage)

{-
-- OLD before 2012-09-19
            packageName <- either (loadFailed canonicalFile . show)
                                  (return . PackageID . map iToString . snd) -- 2012-09-19 suspicious
                                  (checkPackageID rawPackage)
-}

{-
   -- previously patched solution
            packageName <- case D.FileDescriptorProto.package parsed'fdp of
                             Nothing -> return []
                             Just p  -> either (loadFailed canonicalFile . show)
                                               (return . map iToString . snd) $
                                               (checkDIUtf8 p)
-}
            let parents :: Set LocalFP
parents = LocalFP -> Set LocalFP -> Set LocalFP
forall a. Ord a => a -> Set a -> Set a
Set.insert LocalFP
file Set LocalFP
parentsIn
                importList :: [LocalFP]
importList = (Utf8 -> LocalFP) -> [Utf8] -> [LocalFP]
forall a b. (a -> b) -> [a] -> [b]
map (CanonFP -> LocalFP
fpCanonToLocal (CanonFP -> LocalFP) -> (Utf8 -> CanonFP) -> Utf8 -> LocalFP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CanonFP
CanonFP (String -> CanonFP) -> (Utf8 -> String) -> Utf8 -> CanonFP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8 -> String
toString) ([Utf8] -> [LocalFP])
-> (FileDescriptorProto -> [Utf8])
-> FileDescriptorProto
-> [LocalFP]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Utf8 -> [Utf8]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq Utf8 -> [Utf8])
-> (FileDescriptorProto -> Seq Utf8)
-> FileDescriptorProto
-> [Utf8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileDescriptorProto -> Seq Utf8
D.FileDescriptorProto.dependency (FileDescriptorProto -> [LocalFP])
-> FileDescriptorProto -> [LocalFP]
forall a b. (a -> b) -> a -> b
$ FileDescriptorProto
parsed'fdp
            [TopLevel]
imports <- (LocalFP -> StateT (Map LocalFP Env) r TopLevel)
-> [LocalFP] -> StateT (Map LocalFP Env) r [TopLevel]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Env -> TopLevel)
-> StateT (Map LocalFP Env) r Env
-> StateT (Map LocalFP Env) r TopLevel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Env -> TopLevel
getTL (StateT (Map LocalFP Env) r Env
 -> StateT (Map LocalFP Env) r TopLevel)
-> (LocalFP -> StateT (Map LocalFP Env) r Env)
-> LocalFP
-> StateT (Map LocalFP Env) r TopLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set LocalFP -> LocalFP -> StateT (Map LocalFP Env) r Env
load Set LocalFP
parents) [LocalFP]
importList
            let eEnv :: Either String Env
eEnv = FileDescriptorProto
-> PackageID [IName String] -> [TopLevel] -> Either String Env
makeTopLevel FileDescriptorProto
parsed'fdp PackageID [IName String]
packageName [TopLevel]
imports -- makeTopLevel is the "internal entry point" of Resolve.hs
            -- Stricly force these two value to report errors here
            Env
global'env <- (String -> StateT (Map LocalFP Env) r Env)
-> (Env -> StateT (Map LocalFP Env) r Env)
-> Either String Env
-> StateT (Map LocalFP Env) r Env
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> StateT (Map LocalFP Env) r Env
forall a. String -> StateT (Map LocalFP Env) r a
doFail (String -> StateT (Map LocalFP Env) r Env)
-> (String -> String) -> String -> StateT (Map LocalFP Env) r Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalFP -> String -> String
loadFailed LocalFP
file) Env -> StateT (Map LocalFP Env) r Env
forall (m :: * -> *) a. Monad m => a -> m a
return Either String Env
eEnv
            FileDescriptorProto
_ <- (String -> StateT (Map LocalFP Env) r FileDescriptorProto)
-> (FileDescriptorProto
    -> StateT (Map LocalFP Env) r FileDescriptorProto)
-> Either String FileDescriptorProto
-> StateT (Map LocalFP Env) r FileDescriptorProto
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> StateT (Map LocalFP Env) r FileDescriptorProto
forall a. String -> StateT (Map LocalFP Env) r a
doFail (String -> StateT (Map LocalFP Env) r FileDescriptorProto)
-> (String -> String)
-> String
-> StateT (Map LocalFP Env) r FileDescriptorProto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalFP -> String -> String
loadFailed LocalFP
file) FileDescriptorProto
-> StateT (Map LocalFP Env) r FileDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (TopLevel -> Either String FileDescriptorProto
top'FDP (TopLevel -> Either String FileDescriptorProto)
-> (Env -> TopLevel) -> Env -> Either String FileDescriptorProto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> TopLevel
getTL (Env -> Either String FileDescriptorProto)
-> Env -> Either String FileDescriptorProto
forall a b. (a -> b) -> a -> b
$ Env
global'env)
            (Map LocalFP Env -> Map LocalFP Env)
-> StateT (Map LocalFP Env) r ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (LocalFP -> Env -> Map LocalFP Env -> Map LocalFP Env
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert LocalFP
file Env
global'env) -- add to memorized results
            Env -> StateT (Map LocalFP Env) r Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
global'env

loadFailed :: LocalFP -> String -> String
loadFailed :: LocalFP -> String -> String
loadFailed LocalFP
f String
msg = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String
"Parsing proto:",String -> String
forall a. Show a => a -> String
show (LocalFP -> String
unLocalFP LocalFP
f),String
"has failed with message",String
msg]

-- | Given a list of paths to search, loads proto files by
-- looking for them in the file system.
loadProto :: [LocalFP] -> LocalFP -> IO (Env,[D.FileDescriptorProto])
loadProto :: [LocalFP] -> LocalFP -> IO (Env, [FileDescriptorProto])
loadProto [LocalFP]
protoDirs LocalFP
protoFile = (forall a. String -> StateT (Map LocalFP Env) IO a)
-> DescriptorReader IO
-> LocalFP
-> IO (Env, [FileDescriptorProto])
forall (r :: * -> *).
(Functor r, Monad r) =>
(forall a. String -> StateT (Map LocalFP Env) r a)
-> DescriptorReader r -> LocalFP -> r (Env, [FileDescriptorProto])
loadProto' forall a. String -> StateT (Map LocalFP Env) IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail DescriptorReader IO
findAndParseSource LocalFP
protoFile where
      findAndParseSource :: DescriptorReader IO
      findAndParseSource :: LocalFP -> IO (FileDescriptorProto, LocalFP)
findAndParseSource LocalFP
file = do
        Maybe (LocalFP, CanonFP)
mayToRead <- IO (Maybe (LocalFP, CanonFP)) -> IO (Maybe (LocalFP, CanonFP))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (LocalFP, CanonFP)) -> IO (Maybe (LocalFP, CanonFP)))
-> IO (Maybe (LocalFP, CanonFP)) -> IO (Maybe (LocalFP, CanonFP))
forall a b. (a -> b) -> a -> b
$ [LocalFP] -> LocalFP -> IO (Maybe (LocalFP, CanonFP))
findFile [LocalFP]
protoDirs LocalFP
file
        case Maybe (LocalFP, CanonFP)
mayToRead of
          Maybe (LocalFP, CanonFP)
Nothing -> String -> IO (FileDescriptorProto, LocalFP)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (FileDescriptorProto, LocalFP))
-> String -> IO (FileDescriptorProto, LocalFP)
forall a b. (a -> b) -> a -> b
$ LocalFP -> String -> String
loadFailed LocalFP
file ([String] -> String
unlines ([String
"loading failed, could not find file: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show (LocalFP -> String
unLocalFP LocalFP
file)
                                               ,String
"Searched paths were:"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (LocalFP -> String) -> [LocalFP] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++)(String -> String) -> (LocalFP -> String) -> LocalFP -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
forall a. Show a => a -> String
show(String -> String) -> (LocalFP -> String) -> LocalFP -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LocalFP -> String
unLocalFP) [LocalFP]
protoDirs))
          Just (LocalFP
toRead,CanonFP
relpath) -> do
            ByteString
protoContents <- IO ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
putStrLn (String
"Loading filepath: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show (LocalFP -> String
unLocalFP LocalFP
toRead))
                                         String -> IO ByteString
LC.readFile (LocalFP -> String
unLocalFP LocalFP
toRead)
            FileDescriptorProto
parsed'fdp <- (ParseError -> IO FileDescriptorProto)
-> (FileDescriptorProto -> IO FileDescriptorProto)
-> Either ParseError FileDescriptorProto
-> IO FileDescriptorProto
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO FileDescriptorProto
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO FileDescriptorProto)
-> (ParseError -> String) -> ParseError -> IO FileDescriptorProto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalFP -> String -> String
loadFailed LocalFP
toRead (String -> String)
-> (ParseError -> String) -> ParseError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show) FileDescriptorProto -> IO FileDescriptorProto
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError FileDescriptorProto -> IO FileDescriptorProto)
-> Either ParseError FileDescriptorProto -> IO FileDescriptorProto
forall a b. (a -> b) -> a -> b
$
                          (String -> ByteString -> Either ParseError FileDescriptorProto
parseProto (CanonFP -> String
unCanonFP CanonFP
relpath) ByteString
protoContents)
            (FileDescriptorProto, LocalFP) -> IO (FileDescriptorProto, LocalFP)
forall (m :: * -> *) a. Monad m => a -> m a
return (FileDescriptorProto
parsed'fdp, LocalFP
toRead)

loadCodeGenRequest :: CGR.CodeGeneratorRequest -> LocalFP -> (Env,[D.FileDescriptorProto])
loadCodeGenRequest :: CodeGeneratorRequest -> LocalFP -> (Env, [FileDescriptorProto])
loadCodeGenRequest CodeGeneratorRequest
req LocalFP
protoFile = Identity (Env, [FileDescriptorProto])
-> (Env, [FileDescriptorProto])
forall a. Identity a -> a
runIdentity (Identity (Env, [FileDescriptorProto])
 -> (Env, [FileDescriptorProto]))
-> Identity (Env, [FileDescriptorProto])
-> (Env, [FileDescriptorProto])
forall a b. (a -> b) -> a -> b
$ (forall a. String -> StateT (Map LocalFP Env) Identity a)
-> DescriptorReader Identity
-> LocalFP
-> Identity (Env, [FileDescriptorProto])
forall (r :: * -> *).
(Functor r, Monad r) =>
(forall a. String -> StateT (Map LocalFP Env) r a)
-> DescriptorReader r -> LocalFP -> r (Env, [FileDescriptorProto])
loadProto' forall a. String -> StateT (Map LocalFP Env) Identity a
forall a. HasCallStack => String -> a
error DescriptorReader Identity
lookUpParsedSource LocalFP
protoFile where
  lookUpParsedSource :: DescriptorReader Identity
  lookUpParsedSource :: LocalFP -> Identity (FileDescriptorProto, LocalFP)
lookUpParsedSource LocalFP
file = case LocalFP
-> Map LocalFP FileDescriptorProto -> Maybe FileDescriptorProto
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup LocalFP
file Map LocalFP FileDescriptorProto
fdpsByName of
    Just FileDescriptorProto
result -> (FileDescriptorProto, LocalFP)
-> Identity (FileDescriptorProto, LocalFP)
forall (m :: * -> *) a. Monad m => a -> m a
return (FileDescriptorProto
result, LocalFP
file)
    Maybe FileDescriptorProto
Nothing -> String -> Identity (FileDescriptorProto, LocalFP)
forall a. HasCallStack => String -> a
error (String -> Identity (FileDescriptorProto, LocalFP))
-> String -> Identity (FileDescriptorProto, LocalFP)
forall a b. (a -> b) -> a -> b
$ LocalFP -> String -> String
loadFailed LocalFP
file (String
"Request refers to file: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show (LocalFP -> String
unLocalFP LocalFP
file)
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" but it was not supplied in the request.")
  fdpsByName :: Map LocalFP FileDescriptorProto
fdpsByName = [(LocalFP, FileDescriptorProto)] -> Map LocalFP FileDescriptorProto
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(LocalFP, FileDescriptorProto)]
 -> Map LocalFP FileDescriptorProto)
-> (CodeGeneratorRequest -> [(LocalFP, FileDescriptorProto)])
-> CodeGeneratorRequest
-> Map LocalFP FileDescriptorProto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileDescriptorProto -> (LocalFP, FileDescriptorProto))
-> [FileDescriptorProto] -> [(LocalFP, FileDescriptorProto)]
forall a b. (a -> b) -> [a] -> [b]
map FileDescriptorProto -> (LocalFP, FileDescriptorProto)
keyByName ([FileDescriptorProto] -> [(LocalFP, FileDescriptorProto)])
-> (CodeGeneratorRequest -> [FileDescriptorProto])
-> CodeGeneratorRequest
-> [(LocalFP, FileDescriptorProto)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq FileDescriptorProto -> [FileDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq FileDescriptorProto -> [FileDescriptorProto])
-> (CodeGeneratorRequest -> Seq FileDescriptorProto)
-> CodeGeneratorRequest
-> [FileDescriptorProto]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGeneratorRequest -> Seq FileDescriptorProto
CGR.proto_file (CodeGeneratorRequest -> Map LocalFP FileDescriptorProto)
-> CodeGeneratorRequest -> Map LocalFP FileDescriptorProto
forall a b. (a -> b) -> a -> b
$ CodeGeneratorRequest
req
  keyByName :: FileDescriptorProto -> (LocalFP, FileDescriptorProto)
keyByName FileDescriptorProto
fdp = (FileDescriptorProto -> LocalFP
fdpName FileDescriptorProto
fdp, FileDescriptorProto
fdp)
  fdpName :: FileDescriptorProto -> LocalFP
fdpName = String -> LocalFP
LocalFP (String -> LocalFP)
-> (FileDescriptorProto -> String)
-> FileDescriptorProto
-> LocalFP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Utf8 -> String) -> Maybe Utf8 -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (ByteString -> String
LC.unpack (ByteString -> String) -> (Utf8 -> ByteString) -> Utf8 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8 -> ByteString
utf8) (Maybe Utf8 -> String)
-> (FileDescriptorProto -> Maybe Utf8)
-> FileDescriptorProto
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileDescriptorProto -> Maybe Utf8
D.FileDescriptorProto.name

-- wart: descend should take (eName,eMvals) not Entity
-- wart: myFix* obviously implements a WriterT by hand.  Implement as WriterT ?