-- | The 'MakeReflections' module takes the 'FileDescriptorProto'
-- output from 'Resolve' and produces a 'ProtoInfo' from
-- 'Reflections'.  This also takes a Haskell module prefix and the
-- proto's package namespace as input.  The output is suitable
-- for passing to the 'Gen' module to produce the files.
--
-- This acheives several things: It moves the data from a nested tree
-- to flat lists and maps. It moves the group information from the
-- parent Descriptor to the actual Descriptor.  It moves the data out
-- of Maybe types.  It converts Utf8 to String.  Keys known to extend
-- a Descriptor are listed in that Descriptor.
--
-- In building the reflection info new things are computed. It changes
-- dotted names to ProtoName using the translator from
-- 'makeNameMaps'.  It parses the default value from the ByteString to
-- a Haskell type.  For fields, the value of the tag on the wire is
-- computed and so is its size on the wire.
module Text.ProtocolBuffers.ProtoCompile.MakeReflections(makeProtoInfo,serializeFDP) 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.DescriptorProto(ExtensionRange(ExtensionRange))
import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.DescriptorProto.ExtensionRange(ExtensionRange(..))
import qualified Text.DescriptorProtos.EnumDescriptorProto            as D(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)
import qualified Text.DescriptorProtos.FieldDescriptorProto           as D.FieldDescriptorProto(FieldDescriptorProto(..))
-- import qualified Text.DescriptorProtos.FieldDescriptorProto.Label     as D.FieldDescriptorProto(Label)
import           Text.DescriptorProtos.FieldDescriptorProto.Label     as D.FieldDescriptorProto.Label(Label(..))
-- import qualified Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto(Type)
import           Text.DescriptorProtos.FieldDescriptorProto.Type      as D.FieldDescriptorProto.Type(Type(..))
import qualified Text.DescriptorProtos.FieldOptions                   as D(FieldOptions(FieldOptions))
import qualified Text.DescriptorProtos.FieldOptions                   as D.FieldOptions(FieldOptions(..))
import qualified Text.DescriptorProtos.FileDescriptorProto            as D(FileDescriptorProto(FileDescriptorProto))
import qualified Text.DescriptorProtos.FileDescriptorProto            as D.FileDescriptorProto(FileDescriptorProto(..))
import qualified Text.DescriptorProtos.OneofDescriptorProto           as D(OneofDescriptorProto)
import qualified Text.DescriptorProtos.OneofDescriptorProto           as D.OneofDescriptorProto(OneofDescriptorProto(..))

import Text.ProtocolBuffers.Basic
import Text.ProtocolBuffers.Identifiers
import Text.ProtocolBuffers.Reflections
import Text.ProtocolBuffers.WireMessage(size'WireTag,toWireTag,toPackedWireTag,runPut,Wire(..))
import Text.ProtocolBuffers.ProtoCompile.Resolve(ReMap,NameMap(..),getPackageID)

-- import Text.ProtocolBuffers.Reflections

import qualified Data.Foldable as F(foldr,toList)
import           Data.Sequence ((<|))
import qualified Data.Sequence as Seq(fromList,empty,singleton,null,filter)
import Numeric(readHex,readOct,readDec)
import Data.Monoid(mconcat,mappend)
import qualified Data.Map as M(fromListWith,lookup,keys)
import Data.Maybe(fromMaybe,catMaybes,fromJust)
import System.FilePath

--import Debug.Trace (trace)

imp :: String -> a
imp :: String -> a
imp String
msg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Text.ProtocolBuffers.ProtoCompile.MakeReflections: Impossible?\n  "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
msg

pnPath :: ProtoName -> [FilePath]
pnPath :: ProtoName -> [String]
pnPath (ProtoName FIName Utf8
_ [MName String]
a [MName String]
b MName String
c) = String -> [String]
splitDirectories (String -> [String])
-> ([MName String] -> String) -> [MName String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String -> String -> String) -> String -> String -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> String
addExtension String
"hs" (String -> String)
-> ([MName String] -> String) -> [MName String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
joinPath ([String] -> String)
-> ([MName String] -> [String]) -> [MName String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MName String -> String) -> [MName String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map MName String -> String
forall a. MName a -> a
mName ([MName String] -> [String]) -> [MName String] -> [String]
forall a b. (a -> b) -> a -> b
$ [MName String]
a[MName String] -> [MName String] -> [MName String]
forall a. [a] -> [a] -> [a]
++[MName String]
b[MName String] -> [MName String] -> [MName String]
forall a. [a] -> [a] -> [a]
++[MName String
c]

serializeFDP :: D.FileDescriptorProto -> ByteString
serializeFDP :: FileDescriptorProto -> ByteString
serializeFDP FileDescriptorProto
fdp = Put -> ByteString
runPut (FieldType -> FileDescriptorProto -> Put
forall b. Wire b => FieldType -> b -> Put
wirePut FieldType
11 FileDescriptorProto
fdp)

toHaskell :: ReMap -> FIName Utf8 -> ProtoName
toHaskell :: ReMap -> FIName Utf8 -> ProtoName
toHaskell ReMap
reMap FIName Utf8
k = case FIName Utf8 -> ReMap -> Maybe ProtoName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FIName Utf8
k ReMap
reMap of
                      Maybe ProtoName
Nothing -> String -> ProtoName
forall a. String -> a
imp (String -> ProtoName) -> String -> ProtoName
forall a b. (a -> b) -> a -> b
$ String
"toHaskell failed to find "String -> String -> String
forall a. [a] -> [a] -> [a]
++FIName Utf8 -> String
forall a. Show a => a -> String
show FIName Utf8
kString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" among "String -> String -> String
forall a. [a] -> [a] -> [a]
++[FIName Utf8] -> String
forall a. Show a => a -> String
show (ReMap -> [FIName Utf8]
forall k a. Map k a -> [k]
M.keys ReMap
reMap)
                      Just ProtoName
pn -> ProtoName
pn

makeProtoInfo :: (Bool,Bool,Bool,Bool) -- unknownField, lazyFields, lenses and json for makeDescriptorInfo'
              -> NameMap
              -> D.FileDescriptorProto
              -> ProtoInfo
makeProtoInfo :: (Bool, Bool, Bool, Bool)
-> NameMap -> FileDescriptorProto -> ProtoInfo
makeProtoInfo (Bool
unknownField,Bool
lazyFieldsOpt,Bool
lenses,Bool
json) (NameMap (PackageID (FIName Utf8)
packageID,[MName String]
hPrefix,[MName String]
hParent) ReMap
reMap)
              fdp :: FileDescriptorProto
fdp@(D.FileDescriptorProto { name :: FileDescriptorProto -> Maybe Utf8
D.FileDescriptorProto.name = Just Utf8
rawName })
     = ProtoName
-> [String]
-> String
-> Seq KeyInfo
-> [DescriptorInfo]
-> [EnumInfo]
-> [OneofInfo]
-> Map ProtoName (Seq FieldInfo)
-> ProtoInfo
ProtoInfo ProtoName
protoName (ProtoName -> [String]
pnPath ProtoName
protoName) (Utf8 -> String
toString Utf8
rawName) Seq KeyInfo
keyInfos [DescriptorInfo]
allMessages [EnumInfo]
allEnums [OneofInfo]
allOneofs Map ProtoName (Seq FieldInfo)
allKeys where
  packageName :: FIName Utf8
packageName = PackageID (FIName Utf8) -> FIName Utf8
forall a. PackageID a -> a
getPackageID PackageID (FIName Utf8)
packageID :: FIName (Utf8)
  protoName :: ProtoName
protoName = case [MName String]
hParent of
                [] -> case [MName String]
hPrefix of
                        [] -> String -> ProtoName
forall a. String -> a
imp (String -> ProtoName) -> String -> ProtoName
forall a b. (a -> b) -> a -> b
$ String
"makeProtoInfo: no hPrefix or hParent in NameMap for: "String -> String -> String
forall a. [a] -> [a] -> [a]
++FileDescriptorProto -> String
forall a. Show a => a -> String
show FileDescriptorProto
fdp
                        [MName String]
_ -> FIName Utf8
-> [MName String] -> [MName String] -> MName String -> ProtoName
ProtoName FIName Utf8
packageName ([MName String] -> [MName String]
forall a. [a] -> [a]
init [MName String]
hPrefix) [] ([MName String] -> MName String
forall a. [a] -> a
last [MName String]
hPrefix)
                [MName String]
_ -> FIName Utf8
-> [MName String] -> [MName String] -> MName String -> ProtoName
ProtoName FIName Utf8
packageName [MName String]
hPrefix ([MName String] -> [MName String]
forall a. [a] -> [a]
init [MName String]
hParent) ([MName String] -> MName String
forall a. [a] -> a
last [MName String]
hParent)
  keyInfos :: Seq KeyInfo
keyInfos = [KeyInfo] -> Seq KeyInfo
forall a. [a] -> Seq a
Seq.fromList ([KeyInfo] -> Seq KeyInfo)
-> (FileDescriptorProto -> [KeyInfo])
-> FileDescriptorProto
-> Seq KeyInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDescriptorProto -> KeyInfo)
-> [FieldDescriptorProto] -> [KeyInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\FieldDescriptorProto
f -> (ReMap -> FieldDescriptorProto -> ProtoName
keyExtendee' ReMap
reMap FieldDescriptorProto
f,ReMap -> FIName Utf8 -> Bool -> FieldDescriptorProto -> FieldInfo
toFieldInfo' ReMap
reMap FIName Utf8
packageName Bool
lenses FieldDescriptorProto
f))
             ([FieldDescriptorProto] -> [KeyInfo])
-> (FileDescriptorProto -> [FieldDescriptorProto])
-> FileDescriptorProto
-> [KeyInfo]
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])
-> (FileDescriptorProto -> Seq FieldDescriptorProto)
-> FileDescriptorProto
-> [FieldDescriptorProto]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileDescriptorProto -> Seq FieldDescriptorProto
D.FileDescriptorProto.extension (FileDescriptorProto -> Seq KeyInfo)
-> FileDescriptorProto -> Seq KeyInfo
forall a b. (a -> b) -> a -> b
$ FileDescriptorProto
fdp
  allMessages :: [DescriptorInfo]
allMessages = (DescriptorProto -> [DescriptorInfo])
-> [DescriptorProto] -> [DescriptorInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FIName Utf8 -> Bool -> DescriptorProto -> [DescriptorInfo]
processMSG FIName Utf8
packageName Bool
False) (Seq DescriptorProto -> [DescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq DescriptorProto -> [DescriptorProto])
-> Seq DescriptorProto -> [DescriptorProto]
forall a b. (a -> b) -> a -> b
$ FileDescriptorProto -> Seq DescriptorProto
D.FileDescriptorProto.message_type FileDescriptorProto
fdp)
  allEnums :: [EnumInfo]
allEnums = (EnumDescriptorProto -> EnumInfo)
-> [EnumDescriptorProto] -> [EnumInfo]
forall a b. (a -> b) -> [a] -> [b]
map (ReMap -> FIName Utf8 -> Bool -> EnumDescriptorProto -> EnumInfo
makeEnumInfo' ReMap
reMap FIName Utf8
packageName Bool
json) (Seq EnumDescriptorProto -> [EnumDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq EnumDescriptorProto -> [EnumDescriptorProto])
-> Seq EnumDescriptorProto -> [EnumDescriptorProto]
forall a b. (a -> b) -> a -> b
$ FileDescriptorProto -> Seq EnumDescriptorProto
D.FileDescriptorProto.enum_type FileDescriptorProto
fdp)
             [EnumInfo] -> [EnumInfo] -> [EnumInfo]
forall a. [a] -> [a] -> [a]
++ (DescriptorProto -> [EnumInfo]) -> [DescriptorProto] -> [EnumInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FIName Utf8 -> DescriptorProto -> [EnumInfo]
processENM FIName Utf8
packageName) (Seq DescriptorProto -> [DescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq DescriptorProto -> [DescriptorProto])
-> Seq DescriptorProto -> [DescriptorProto]
forall a b. (a -> b) -> a -> b
$ FileDescriptorProto -> Seq DescriptorProto
D.FileDescriptorProto.message_type FileDescriptorProto
fdp)
  allOneofs :: [OneofInfo]
allOneofs = (DescriptorProto -> [OneofInfo])
-> [DescriptorProto] -> [OneofInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FIName Utf8 -> DescriptorProto -> [OneofInfo]
processONO FIName Utf8
packageName) (Seq DescriptorProto -> [DescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq DescriptorProto -> [DescriptorProto])
-> Seq DescriptorProto -> [DescriptorProto]
forall a b. (a -> b) -> a -> b
$ FileDescriptorProto -> Seq DescriptorProto
D.FileDescriptorProto.message_type FileDescriptorProto
fdp)
  allKeys :: Map ProtoName (Seq FieldInfo)
allKeys = (Seq FieldInfo -> Seq FieldInfo -> Seq FieldInfo)
-> [(ProtoName, Seq FieldInfo)] -> Map ProtoName (Seq FieldInfo)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Seq FieldInfo -> Seq FieldInfo -> Seq FieldInfo
forall a. Monoid a => a -> a -> a
mappend ([(ProtoName, Seq FieldInfo)] -> Map ProtoName (Seq FieldInfo))
-> ([Seq KeyInfo] -> [(ProtoName, Seq FieldInfo)])
-> [Seq KeyInfo]
-> Map ProtoName (Seq FieldInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyInfo -> (ProtoName, Seq FieldInfo))
-> [KeyInfo] -> [(ProtoName, Seq FieldInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ProtoName
k,FieldInfo
a) -> (ProtoName
k,FieldInfo -> Seq FieldInfo
forall a. a -> Seq a
Seq.singleton FieldInfo
a))
            ([KeyInfo] -> [(ProtoName, Seq FieldInfo)])
-> ([Seq KeyInfo] -> [KeyInfo])
-> [Seq KeyInfo]
-> [(ProtoName, Seq FieldInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq KeyInfo -> [KeyInfo]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq KeyInfo -> [KeyInfo])
-> ([Seq KeyInfo] -> Seq KeyInfo) -> [Seq KeyInfo] -> [KeyInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Seq KeyInfo] -> Seq KeyInfo
forall a. Monoid a => [a] -> a
mconcat ([Seq KeyInfo] -> Map ProtoName (Seq FieldInfo))
-> [Seq KeyInfo] -> Map ProtoName (Seq FieldInfo)
forall a b. (a -> b) -> a -> b
$ Seq KeyInfo
keyInfos Seq KeyInfo -> [Seq KeyInfo] -> [Seq KeyInfo]
forall a. a -> [a] -> [a]
: (DescriptorInfo -> Seq KeyInfo)
-> [DescriptorInfo] -> [Seq KeyInfo]
forall a b. (a -> b) -> [a] -> [b]
map DescriptorInfo -> Seq KeyInfo
keys [DescriptorInfo]
allMessages
  processMSG :: FIName Utf8 -> Bool -> DescriptorProto -> [DescriptorInfo]
processMSG FIName Utf8
parent Bool
msgIsGroup DescriptorProto
msg =
    let getKnownKeys :: ProtoName -> Seq FieldInfo
getKnownKeys ProtoName
protoName' = Seq FieldInfo -> Maybe (Seq FieldInfo) -> Seq FieldInfo
forall a. a -> Maybe a -> a
fromMaybe Seq FieldInfo
forall a. Seq a
Seq.empty (ProtoName -> Map ProtoName (Seq FieldInfo) -> Maybe (Seq FieldInfo)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ProtoName
protoName' Map ProtoName (Seq FieldInfo)
allKeys)
        groups :: [Utf8]
groups = DescriptorProto -> [Utf8]
collectedGroups DescriptorProto
msg
        checkGroup :: DescriptorProto -> Bool
checkGroup DescriptorProto
x = Utf8 -> [Utf8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Utf8 -> Maybe Utf8 -> Utf8
forall a. a -> Maybe a -> a
fromMaybe (String -> Utf8
forall a. String -> a
imp (String -> Utf8) -> String -> Utf8
forall a b. (a -> b) -> a -> b
$ String
"no message name in makeProtoInfo.processMSG.checkGroup:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++DescriptorProto -> String
forall a. Show a => a -> String
show DescriptorProto
msg)
                                       (DescriptorProto -> Maybe Utf8
D.DescriptorProto.name DescriptorProto
x))
                            [Utf8]
groups
        parent' :: FIName Utf8
parent' = FIName Utf8 -> [IName Utf8] -> FIName Utf8
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend FIName Utf8
parent [Utf8 -> IName Utf8
forall a. a -> IName a
IName (Maybe Utf8 -> Utf8
forall a. HasCallStack => Maybe a -> a
fromJust (DescriptorProto -> Maybe Utf8
D.DescriptorProto.name DescriptorProto
msg))]
    in ReMap
-> FIName Utf8
-> (ProtoName -> Seq FieldInfo)
-> Bool
-> (Bool, Bool, Bool, Bool)
-> DescriptorProto
-> DescriptorInfo
makeDescriptorInfo' ReMap
reMap FIName Utf8
parent ProtoName -> Seq FieldInfo
getKnownKeys Bool
msgIsGroup (Bool
unknownField,Bool
lazyFieldsOpt,Bool
lenses,Bool
json) DescriptorProto
msg
       DescriptorInfo -> [DescriptorInfo] -> [DescriptorInfo]
forall a. a -> [a] -> [a]
: (DescriptorProto -> [DescriptorInfo])
-> [DescriptorProto] -> [DescriptorInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\DescriptorProto
x -> FIName Utf8 -> Bool -> DescriptorProto -> [DescriptorInfo]
processMSG FIName Utf8
parent' (DescriptorProto -> Bool
checkGroup DescriptorProto
x) DescriptorProto
x)
                   (Seq DescriptorProto -> [DescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (DescriptorProto -> Seq DescriptorProto
D.DescriptorProto.nested_type DescriptorProto
msg))
  processENM :: FIName Utf8 -> DescriptorProto -> [EnumInfo]
processENM FIName Utf8
parent DescriptorProto
msg = (EnumDescriptorProto -> [EnumInfo] -> [EnumInfo])
-> [EnumInfo] -> [EnumDescriptorProto] -> [EnumInfo]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (EnumInfo -> [EnumInfo] -> [EnumInfo])
-> (EnumDescriptorProto -> EnumInfo)
-> EnumDescriptorProto
-> [EnumInfo]
-> [EnumInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReMap -> FIName Utf8 -> Bool -> EnumDescriptorProto -> EnumInfo
makeEnumInfo' ReMap
reMap FIName Utf8
parent' Bool
json) [EnumInfo]
nested
                          (Seq EnumDescriptorProto -> [EnumDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (DescriptorProto -> Seq EnumDescriptorProto
D.DescriptorProto.enum_type DescriptorProto
msg))
    where parent' :: FIName Utf8
parent' = FIName Utf8 -> [IName Utf8] -> FIName Utf8
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend FIName Utf8
parent [Utf8 -> IName Utf8
forall a. a -> IName a
IName (Maybe Utf8 -> Utf8
forall a. HasCallStack => Maybe a -> a
fromJust (DescriptorProto -> Maybe Utf8
D.DescriptorProto.name DescriptorProto
msg))]
          nested :: [EnumInfo]
nested = (DescriptorProto -> [EnumInfo]) -> [DescriptorProto] -> [EnumInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FIName Utf8 -> DescriptorProto -> [EnumInfo]
processENM FIName Utf8
parent') (Seq DescriptorProto -> [DescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (DescriptorProto -> Seq DescriptorProto
D.DescriptorProto.nested_type DescriptorProto
msg))
  processONO :: FIName Utf8 -> DescriptorProto -> [OneofInfo]
processONO FIName Utf8
parent DescriptorProto
msg = ((Int32, OneofDescriptorProto) -> [OneofInfo] -> [OneofInfo])
-> [OneofInfo] -> [(Int32, OneofDescriptorProto)] -> [OneofInfo]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (OneofInfo -> [OneofInfo] -> [OneofInfo])
-> ((Int32, OneofDescriptorProto) -> OneofInfo)
-> (Int32, OneofDescriptorProto)
-> [OneofInfo]
-> [OneofInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReMap
-> FIName Utf8
-> Bool
-> DescriptorProto
-> (Int32, OneofDescriptorProto)
-> OneofInfo
makeOneofInfo' ReMap
reMap FIName Utf8
parent' Bool
lenses DescriptorProto
msg) [OneofInfo]
nested
                          ([Int32]
-> [OneofDescriptorProto] -> [(Int32, OneofDescriptorProto)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int32
0..] (Seq OneofDescriptorProto -> [OneofDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (DescriptorProto -> Seq OneofDescriptorProto
D.DescriptorProto.oneof_decl DescriptorProto
msg)))
    where parent' :: FIName Utf8
parent' = FIName Utf8 -> [IName Utf8] -> FIName Utf8
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend FIName Utf8
parent [Utf8 -> IName Utf8
forall a. a -> IName a
IName (Maybe Utf8 -> Utf8
forall a. HasCallStack => Maybe a -> a
fromJust (DescriptorProto -> Maybe Utf8
D.DescriptorProto.name DescriptorProto
msg))]
          nested :: [OneofInfo]
nested = (DescriptorProto -> [OneofInfo])
-> [DescriptorProto] -> [OneofInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FIName Utf8 -> DescriptorProto -> [OneofInfo]
processONO FIName Utf8
parent') (Seq DescriptorProto -> [DescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (DescriptorProto -> Seq DescriptorProto
D.DescriptorProto.nested_type DescriptorProto
msg))
makeProtoInfo (Bool, Bool, Bool, Bool)
_ NameMap
_ FileDescriptorProto
_ = String -> ProtoInfo
forall a. String -> a
imp (String -> ProtoInfo) -> String -> ProtoInfo
forall a b. (a -> b) -> a -> b
$ String
"makeProtoInfo: missing name or package"

makeEnumInfo' :: ReMap -> FIName Utf8 -> Bool -> D.EnumDescriptorProto -> EnumInfo
makeEnumInfo' :: ReMap -> FIName Utf8 -> Bool -> EnumDescriptorProto -> EnumInfo
makeEnumInfo' ReMap
reMap FIName Utf8
parent Bool
json
              e :: EnumDescriptorProto
e@(D.EnumDescriptorProto.EnumDescriptorProto
                  { name :: EnumDescriptorProto -> Maybe Utf8
D.EnumDescriptorProto.name = Just Utf8
rawName
                  , value :: EnumDescriptorProto -> Seq EnumValueDescriptorProto
D.EnumDescriptorProto.value = Seq EnumValueDescriptorProto
value })
    = if Seq EnumValueDescriptorProto -> Bool
forall a. Seq a -> Bool
Seq.null Seq EnumValueDescriptorProto
value then String -> EnumInfo
forall a. String -> a
imp (String -> EnumInfo) -> String -> EnumInfo
forall a b. (a -> b) -> a -> b
$ String
"enum has no values: "String -> String -> String
forall a. [a] -> [a] -> [a]
++EnumDescriptorProto -> String
forall a. Show a => a -> String
show EnumDescriptorProto
e
        else ProtoName -> [String] -> [(EnumCode, String)] -> Bool -> EnumInfo
EnumInfo ProtoName
protoName (ProtoName -> [String]
pnPath ProtoName
protoName) [(EnumCode, String)]
enumVals Bool
json
  where protoName :: ProtoName
protoName = ReMap -> FIName Utf8 -> ProtoName
toHaskell ReMap
reMap (FIName Utf8 -> ProtoName) -> FIName Utf8 -> ProtoName
forall a b. (a -> b) -> a -> b
$ FIName Utf8 -> [IName Utf8] -> FIName Utf8
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend FIName Utf8
parent [Utf8 -> IName Utf8
forall a. a -> IName a
IName Utf8
rawName]
        enumVals ::[(EnumCode,String)]
        enumVals :: [(EnumCode, String)]
enumVals = (EnumValueDescriptorProto
 -> [(EnumCode, String)] -> [(EnumCode, String)])
-> [(EnumCode, String)]
-> Seq EnumValueDescriptorProto
-> [(EnumCode, String)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) ((EnumCode, String)
 -> [(EnumCode, String)] -> [(EnumCode, String)])
-> (EnumValueDescriptorProto -> (EnumCode, String))
-> EnumValueDescriptorProto
-> [(EnumCode, String)]
-> [(EnumCode, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumValueDescriptorProto -> (EnumCode, String)
oneValue) [] Seq EnumValueDescriptorProto
value
          where oneValue :: D.EnumValueDescriptorProto -> (EnumCode,String)
                oneValue :: EnumValueDescriptorProto -> (EnumCode, String)
oneValue (D.EnumValueDescriptorProto.EnumValueDescriptorProto
                          { name :: EnumValueDescriptorProto -> Maybe Utf8
D.EnumValueDescriptorProto.name = Just Utf8
name
                          , number :: EnumValueDescriptorProto -> Maybe Int32
D.EnumValueDescriptorProto.number = Just Int32
number })
                    = (Int32 -> EnumCode
EnumCode Int32
number,MName String -> String
forall a. MName a -> a
mName (MName String -> String)
-> (FIName Utf8 -> MName String) -> FIName Utf8 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtoName -> MName String
baseName (ProtoName -> MName String)
-> (FIName Utf8 -> ProtoName) -> FIName Utf8 -> MName String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReMap -> FIName Utf8 -> ProtoName
toHaskell ReMap
reMap (FIName Utf8 -> String) -> FIName Utf8 -> String
forall a b. (a -> b) -> a -> b
$ FIName Utf8 -> [IName Utf8] -> FIName Utf8
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend (ProtoName -> FIName Utf8
protobufName ProtoName
protoName) [Utf8 -> IName Utf8
forall a. a -> IName a
IName Utf8
name])
                oneValue EnumValueDescriptorProto
evdp = String -> (EnumCode, String)
forall a. String -> a
imp (String -> (EnumCode, String)) -> String -> (EnumCode, String)
forall a b. (a -> b) -> a -> b
$ String
"no name or number for evdp passed to makeEnumInfo.oneValue: "String -> String -> String
forall a. [a] -> [a] -> [a]
++EnumValueDescriptorProto -> String
forall a. Show a => a -> String
show EnumValueDescriptorProto
evdp
makeEnumInfo' ReMap
_ FIName Utf8
_ Bool
_ EnumDescriptorProto
_ = String -> EnumInfo
forall a. String -> a
imp String
"makeEnumInfo: missing name"

makeOneofInfo' :: ReMap -> FIName Utf8
               -> Bool -- ^ makeLenses
               -> D.DescriptorProto -> (Int32,D.OneofDescriptorProto) -> OneofInfo
makeOneofInfo' :: ReMap
-> FIName Utf8
-> Bool
-> DescriptorProto
-> (Int32, OneofDescriptorProto)
-> OneofInfo
makeOneofInfo' ReMap
reMap FIName Utf8
parent Bool
lenses DescriptorProto
parentProto
              (Int32
n, e :: OneofDescriptorProto
e@(D.OneofDescriptorProto.OneofDescriptorProto
                  { name :: OneofDescriptorProto -> Maybe Utf8
D.OneofDescriptorProto.name = Just Utf8
rawName }))
    = ProtoName
-> ProtoFName -> [String] -> Seq KeyInfo -> Bool -> OneofInfo
OneofInfo ProtoName
protoName ProtoFName
protoFName (ProtoName -> [String]
pnPath ProtoName
protoName) Seq KeyInfo
fieldInfos Bool
lenses
  where protoName :: ProtoName
protoName@(ProtoName FIName Utf8
x [MName String]
a [MName String]
b MName String
c) = ReMap -> FIName Utf8 -> ProtoName
toHaskell ReMap
reMap (FIName Utf8 -> ProtoName) -> FIName Utf8 -> ProtoName
forall a b. (a -> b) -> a -> b
$ FIName Utf8 -> [IName Utf8] -> FIName Utf8
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend FIName Utf8
parent [Utf8 -> IName Utf8
forall a. a -> IName a
IName Utf8
rawName]
        protoFName :: ProtoFName
protoFName = FIName Utf8
-> [MName String]
-> [MName String]
-> FName String
-> String
-> ProtoFName
ProtoFName FIName Utf8
x [MName String]
a [MName String]
b (MName String -> FName String
forall a b. Mangle a b => a -> b
mangle MName String
c) (if Bool
lenses then String
"_" else String
"")
        rawFields :: Seq FieldDescriptorProto
rawFields = DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.field DescriptorProto
parentProto
        rawFieldsOneof :: Seq FieldDescriptorProto
rawFieldsOneof = (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
n) (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
rawFields
        getFieldProtoName :: FieldDescriptorProto -> ProtoName
getFieldProtoName FieldDescriptorProto
fdp
          = case FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.name FieldDescriptorProto
fdp of
              Just Utf8
name -> ReMap -> FIName Utf8 -> ProtoName
toHaskell ReMap
reMap (FIName Utf8 -> ProtoName) -> FIName Utf8 -> ProtoName
forall a b. (a -> b) -> a -> b
$ FIName Utf8 -> [IName Utf8] -> FIName Utf8
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend (ProtoName -> FIName Utf8
protobufName ProtoName
protoName) [Utf8 -> IName Utf8
forall a. a -> IName a
IName Utf8
name]
              Maybe Utf8
Nothing -> String -> ProtoName
forall a. String -> a
imp (String -> ProtoName) -> String -> ProtoName
forall a b. (a -> b) -> a -> b
$ String
"getFieldProtoName: missing info in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FieldDescriptorProto -> String
forall a. Show a => a -> String
show FieldDescriptorProto
fdp
        getFieldInfo :: FieldDescriptorProto -> FieldInfo
getFieldInfo = ReMap -> FIName Utf8 -> Bool -> FieldDescriptorProto -> FieldInfo
toFieldInfo' ReMap
reMap (ProtoName -> FIName Utf8
protobufName ProtoName
protoName) Bool
lenses
        fieldInfos :: Seq KeyInfo
fieldInfos = (FieldDescriptorProto -> KeyInfo)
-> Seq FieldDescriptorProto -> Seq KeyInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldDescriptorProto
x->(FieldDescriptorProto -> ProtoName
getFieldProtoName FieldDescriptorProto
x,FieldDescriptorProto -> FieldInfo
getFieldInfo FieldDescriptorProto
x)) Seq FieldDescriptorProto
rawFieldsOneof
makeOneofInfo' ReMap
_ FIName Utf8
_ Bool
_ DescriptorProto
_ (Int32, OneofDescriptorProto)
_ = String -> OneofInfo
forall a. String -> a
imp String
"makeOneofInfo: missing name"


keyExtendee' :: ReMap -> D.FieldDescriptorProto.FieldDescriptorProto -> ProtoName
keyExtendee' :: ReMap -> FieldDescriptorProto -> ProtoName
keyExtendee' ReMap
reMap FieldDescriptorProto
f = case FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.extendee FieldDescriptorProto
f of
                         Maybe Utf8
Nothing -> String -> ProtoName
forall a. String -> a
imp (String -> ProtoName) -> String -> ProtoName
forall a b. (a -> b) -> a -> b
$ String
"keyExtendee expected Just but found Nothing: "String -> String -> String
forall a. [a] -> [a] -> [a]
++FieldDescriptorProto -> String
forall a. Show a => a -> String
show FieldDescriptorProto
f
                         Just Utf8
extName -> ReMap -> FIName Utf8 -> ProtoName
toHaskell ReMap
reMap (Utf8 -> FIName Utf8
forall a. a -> FIName a
FIName Utf8
extName)
                           -- let debugMsg = unlines [ "MakeReflections.keyExtendee'.debugMsg"
                           --                        , "extName is " ++ show extName
                           --                        , "reMap is :"
                           --                        , show reMap ]

makeDescriptorInfo' :: ReMap -> FIName Utf8
                    -> (ProtoName -> Seq FieldInfo)
                    -> Bool -- msgIsGroup
                    -> (Bool,Bool,Bool,Bool) -- unknownField, lazyFields, lenses, json
                    -> D.DescriptorProto -> DescriptorInfo
makeDescriptorInfo' :: ReMap
-> FIName Utf8
-> (ProtoName -> Seq FieldInfo)
-> Bool
-> (Bool, Bool, Bool, Bool)
-> DescriptorProto
-> DescriptorInfo
makeDescriptorInfo' ReMap
reMap FIName Utf8
parent ProtoName -> Seq FieldInfo
getKnownKeys Bool
msgIsGroup (Bool
unknownField,Bool
lazyFieldsOpt,Bool
lenses,Bool
json)
                    msg :: DescriptorProto
msg@(D.DescriptorProto.DescriptorProto
                      { name :: DescriptorProto -> Maybe Utf8
D.DescriptorProto.name = Just Utf8
rawName
                      , field :: DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.field = Seq FieldDescriptorProto
rawFields
                      , oneof_decl :: DescriptorProto -> Seq OneofDescriptorProto
D.DescriptorProto.oneof_decl = Seq OneofDescriptorProto
rawOneofs
                      , extension :: DescriptorProto -> Seq FieldDescriptorProto
D.DescriptorProto.extension = Seq FieldDescriptorProto
rawKeys
                      , extension_range :: DescriptorProto -> Seq ExtensionRange
D.DescriptorProto.extension_range = Seq ExtensionRange
extension_range })
    = let di :: DescriptorInfo
di = ProtoName
-> [String]
-> Bool
-> Seq FieldInfo
-> Seq OneofInfo
-> Seq KeyInfo
-> [(FieldId, FieldId)]
-> Seq FieldInfo
-> Bool
-> Bool
-> Bool
-> Bool
-> DescriptorInfo
DescriptorInfo ProtoName
protoName (ProtoName -> [String]
pnPath ProtoName
protoName) Bool
msgIsGroup
                              Seq FieldInfo
fieldInfos Seq OneofInfo
oneofInfos Seq KeyInfo
keyInfos [(FieldId, FieldId)]
extRangeList
                              (ProtoName -> Seq FieldInfo
getKnownKeys ProtoName
protoName)
                              Bool
unknownField Bool
lazyFieldsOpt Bool
lenses Bool
json
      in DescriptorInfo
di -- trace (toString rawName ++ "\n" ++ show di ++ "\n\n") $ di
  where protoName :: ProtoName
protoName = ReMap -> FIName Utf8 -> ProtoName
toHaskell ReMap
reMap (FIName Utf8 -> ProtoName) -> FIName Utf8 -> ProtoName
forall a b. (a -> b) -> a -> b
$ FIName Utf8 -> [IName Utf8] -> FIName Utf8
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend FIName Utf8
parent [Utf8 -> IName Utf8
forall a. a -> IName a
IName Utf8
rawName]
        rawFieldsNotOneof :: Seq FieldDescriptorProto
rawFieldsNotOneof = (FieldDescriptorProto -> Bool)
-> Seq FieldDescriptorProto -> Seq FieldDescriptorProto
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (\FieldDescriptorProto
x -> FieldDescriptorProto -> Maybe Int32
D.FieldDescriptorProto.oneof_index FieldDescriptorProto
x Maybe Int32 -> Maybe Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int32
forall a. Maybe a
Nothing) Seq FieldDescriptorProto
rawFields
        fieldInfos :: Seq FieldInfo
fieldInfos = (FieldDescriptorProto -> FieldInfo)
-> Seq FieldDescriptorProto -> Seq FieldInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReMap -> FIName Utf8 -> Bool -> FieldDescriptorProto -> FieldInfo
toFieldInfo' ReMap
reMap (ProtoName -> FIName Utf8
protobufName ProtoName
protoName) Bool
lenses) Seq FieldDescriptorProto
rawFieldsNotOneof
        oneofInfos :: Seq OneofInfo
oneofInfos = ((Int32, OneofDescriptorProto) -> Seq OneofInfo -> Seq OneofInfo)
-> Seq OneofInfo
-> [(Int32, OneofDescriptorProto)]
-> Seq OneofInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (OneofInfo -> Seq OneofInfo -> Seq OneofInfo
forall a. a -> Seq a -> Seq a
(<|) (OneofInfo -> Seq OneofInfo -> Seq OneofInfo)
-> ((Int32, OneofDescriptorProto) -> OneofInfo)
-> (Int32, OneofDescriptorProto)
-> Seq OneofInfo
-> Seq OneofInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReMap
-> FIName Utf8
-> Bool
-> DescriptorProto
-> (Int32, OneofDescriptorProto)
-> OneofInfo
makeOneofInfo' ReMap
reMap (ProtoName -> FIName Utf8
protobufName ProtoName
protoName) Bool
lenses DescriptorProto
msg) Seq OneofInfo
forall a. Seq a
Seq.empty
                          ([Int32]
-> [OneofDescriptorProto] -> [(Int32, OneofDescriptorProto)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int32
0..] (Seq OneofDescriptorProto -> [OneofDescriptorProto]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq OneofDescriptorProto
rawOneofs))

        keyInfos :: Seq KeyInfo
keyInfos = (FieldDescriptorProto -> KeyInfo)
-> Seq FieldDescriptorProto -> Seq KeyInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldDescriptorProto
f -> (ReMap -> FieldDescriptorProto -> ProtoName
keyExtendee' ReMap
reMap FieldDescriptorProto
f,ReMap -> FIName Utf8 -> Bool -> FieldDescriptorProto -> FieldInfo
toFieldInfo' ReMap
reMap (ProtoName -> FIName Utf8
protobufName ProtoName
protoName) Bool
lenses FieldDescriptorProto
f)) Seq FieldDescriptorProto
rawKeys
        extRangeList :: [(FieldId, FieldId)]
extRangeList = ((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) [] Seq ExtensionRange
extension_range
                extToPair :: ExtensionRange -> (FieldId, FieldId)
extToPair (D.DescriptorProto.ExtensionRange
                            { start :: ExtensionRange -> Maybe Int32
D.DescriptorProto.ExtensionRange.start = Maybe Int32
mStart
                            , end :: ExtensionRange -> Maybe Int32
D.DescriptorProto.ExtensionRange.end = Maybe Int32
mEnd }) =
                  (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
mStart, 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
mEnd)
makeDescriptorInfo' ReMap
_ FIName Utf8
_ ProtoName -> Seq FieldInfo
_ Bool
_ (Bool, Bool, Bool, Bool)
_ DescriptorProto
_ = String -> DescriptorInfo
forall a. String -> a
imp (String -> DescriptorInfo) -> String -> DescriptorInfo
forall a b. (a -> b) -> a -> b
$ String
"makeDescriptorInfo: missing name"

toFieldInfo'
  :: ReMap
  -> FIName Utf8
  -> Bool -- ^ whether to use lences (if True, an underscore prefix is used)
  -> D.FieldDescriptorProto
  -> FieldInfo
toFieldInfo' :: ReMap -> FIName Utf8 -> Bool -> FieldDescriptorProto -> FieldInfo
toFieldInfo' ReMap
reMap FIName Utf8
parent Bool
lenses
             f :: FieldDescriptorProto
f@(D.FieldDescriptorProto.FieldDescriptorProto
                 { name :: FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.name = Just Utf8
name
                 , number :: FieldDescriptorProto -> Maybe Int32
D.FieldDescriptorProto.number = Just Int32
number
                 , label :: FieldDescriptorProto -> Maybe Label
D.FieldDescriptorProto.label = Just Label
label
                 , type' :: FieldDescriptorProto -> Maybe Type
D.FieldDescriptorProto.type' = Just Type
type'
                 , type_name :: FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.type_name = Maybe Utf8
mayTypeName
                 , default_value :: FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.default_value = Maybe Utf8
mayRawDef
                 , options :: FieldDescriptorProto -> Maybe FieldOptions
D.FieldDescriptorProto.options = Maybe FieldOptions
mayOpt })
    = FieldInfo
fieldInfo
  where mayDef :: Maybe HsDefault
mayDef = FieldDescriptorProto -> Maybe HsDefault
parseDefaultValue FieldDescriptorProto
f
        fieldInfo :: FieldInfo
fieldInfo = let (ProtoName FIName Utf8
x [MName String]
a [MName String]
b MName String
c) = ReMap -> FIName Utf8 -> ProtoName
toHaskell ReMap
reMap (FIName Utf8 -> ProtoName) -> FIName Utf8 -> ProtoName
forall a b. (a -> b) -> a -> b
$ FIName Utf8 -> [IName Utf8] -> FIName Utf8
forall a. Dotted a => FIName a -> [IName a] -> FIName a
fqAppend FIName Utf8
parent [Utf8 -> IName Utf8
forall a. a -> IName a
IName Utf8
name]
                        protoFName :: ProtoFName
protoFName = FIName Utf8
-> [MName String]
-> [MName String]
-> FName String
-> String
-> ProtoFName
ProtoFName FIName Utf8
x [MName String]
a [MName String]
b (MName String -> FName String
forall a b. Mangle a b => a -> b
mangle MName String
c) (if Bool
lenses then String
"_" else String
"")
                        fieldId :: FieldId
fieldId = (Int32 -> FieldId
FieldId (Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
number))
                        fieldType :: FieldType
fieldType = (Int -> FieldType
FieldType (Type -> Int
forall a. Enum a => a -> Int
fromEnum Type
type'))
{- removed to update 1.5.5 to be compatible with protobuf-2.3.0
                        wt | packedOption = toPackedWireTag fieldId
                           | otherwise = toWireTag fieldId fieldType
-}
                        wt :: WireTag
wt | Bool
packedOption = FieldId -> WireTag
toPackedWireTag FieldId
fieldId                -- write packed
                           | Bool
otherwise = FieldId -> FieldType -> WireTag
toWireTag FieldId
fieldId FieldType
fieldType               -- write unpacked

                        wt2 :: Maybe (WireTag, WireTag)
wt2 | Bool
validPacked = (WireTag, WireTag) -> Maybe (WireTag, WireTag)
forall a. a -> Maybe a
Just (FieldId -> FieldType -> WireTag
toWireTag FieldId
fieldId FieldType
fieldType      -- read unpacked
                                                 ,FieldId -> WireTag
toPackedWireTag FieldId
fieldId)         -- read packed
                            | Bool
otherwise = Maybe (WireTag, WireTag)
forall a. Maybe a
Nothing
                        wtLength :: Int64
wtLength = WireTag -> Int64
size'WireTag WireTag
wt
                        packedOption :: Bool
packedOption = case Maybe FieldOptions
mayOpt of
                                         Just (D.FieldOptions { packed :: FieldOptions -> Maybe Bool
D.FieldOptions.packed = Just Bool
True }) -> Bool
True
                                         Maybe FieldOptions
_ -> Bool
False
                        validPacked :: Bool
validPacked = Label -> FieldType -> Bool
isValidPacked Label
label FieldType
fieldType
                    in ProtoFName
-> FieldId
-> WireTag
-> Maybe (WireTag, WireTag)
-> Int64
-> Bool
-> Bool
-> Bool
-> Bool
-> FieldType
-> Maybe ProtoName
-> Maybe ByteString
-> Maybe HsDefault
-> FieldInfo
FieldInfo ProtoFName
protoFName
                                 FieldId
fieldId
                                 WireTag
wt
                                 Maybe (WireTag, WireTag)
wt2
                                 Int64
wtLength
                                 Bool
packedOption
                                 (Label
label Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
LABEL_REQUIRED)
                                 (Label
label Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
LABEL_REPEATED)
                                 Bool
validPacked
                                 FieldType
fieldType
                                 ((Utf8 -> ProtoName) -> Maybe Utf8 -> Maybe ProtoName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReMap -> FIName Utf8 -> ProtoName
toHaskell ReMap
reMap (FIName Utf8 -> ProtoName)
-> (Utf8 -> FIName Utf8) -> Utf8 -> ProtoName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8 -> FIName Utf8
forall a. a -> FIName a
FIName) Maybe Utf8
mayTypeName)
                                 ((Utf8 -> ByteString) -> Maybe Utf8 -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Utf8 -> ByteString
utf8 Maybe Utf8
mayRawDef)
                                 Maybe HsDefault
mayDef
toFieldInfo' ReMap
_ FIName Utf8
_ Bool
_ FieldDescriptorProto
f = String -> FieldInfo
forall a. String -> a
imp (String -> FieldInfo) -> String -> FieldInfo
forall a b. (a -> b) -> a -> b
$ String
"toFieldInfo: missing info in "String -> String -> String
forall a. [a] -> [a] -> [a]
++FieldDescriptorProto -> String
forall a. Show a => a -> String
show FieldDescriptorProto
f

collectedGroups :: D.DescriptorProto -> [Utf8]
collectedGroups :: DescriptorProto -> [Utf8]
collectedGroups = [Maybe Utf8] -> [Utf8]
forall a. [Maybe a] -> [a]
catMaybes
                ([Maybe Utf8] -> [Utf8])
-> (DescriptorProto -> [Maybe Utf8]) -> DescriptorProto -> [Utf8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDescriptorProto -> Maybe Utf8)
-> [FieldDescriptorProto] -> [Maybe Utf8]
forall a b. (a -> b) -> [a] -> [b]
map FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.type_name
                ([FieldDescriptorProto] -> [Maybe Utf8])
-> (DescriptorProto -> [FieldDescriptorProto])
-> DescriptorProto
-> [Maybe Utf8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDescriptorProto -> Bool)
-> [FieldDescriptorProto] -> [FieldDescriptorProto]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FieldDescriptorProto
f -> FieldDescriptorProto -> Maybe Type
D.FieldDescriptorProto.type' FieldDescriptorProto
f Maybe Type -> Maybe Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Maybe Type
forall a. a -> Maybe a
Just Type
TYPE_GROUP)
                ([FieldDescriptorProto] -> [FieldDescriptorProto])
-> (DescriptorProto -> [FieldDescriptorProto])
-> DescriptorProto
-> [FieldDescriptorProto]
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

-- "Nothing" means no value specified
-- A failure to parse a provided value will result in an error at the moment
parseDefaultValue :: D.FieldDescriptorProto -> Maybe HsDefault
parseDefaultValue :: FieldDescriptorProto -> Maybe HsDefault
parseDefaultValue f :: FieldDescriptorProto
f@(D.FieldDescriptorProto.FieldDescriptorProto
                     { type' :: FieldDescriptorProto -> Maybe Type
D.FieldDescriptorProto.type' = Maybe Type
type'
                     , default_value :: FieldDescriptorProto -> Maybe Utf8
D.FieldDescriptorProto.default_value = Maybe Utf8
mayRawDef })
    = do Utf8
bs <- Maybe Utf8
mayRawDef
         Type
t <- Maybe Type
type'
         Utf8 -> Maybe HsDefault
todo <- case Type
t of
                   Type
TYPE_MESSAGE -> Maybe (Utf8 -> Maybe HsDefault)
forall a. Maybe a
Nothing
                   Type
TYPE_GROUP   -> Maybe (Utf8 -> Maybe HsDefault)
forall a. Maybe a
Nothing
                   Type
TYPE_ENUM    -> (Utf8 -> Maybe HsDefault) -> Maybe (Utf8 -> Maybe HsDefault)
forall a. a -> Maybe a
Just Utf8 -> Maybe HsDefault
parseDefEnum
                   Type
TYPE_BOOL    -> (Utf8 -> Maybe HsDefault) -> Maybe (Utf8 -> Maybe HsDefault)
forall a. a -> Maybe a
Just Utf8 -> Maybe HsDefault
parseDefBool
                   Type
TYPE_BYTES   -> (Utf8 -> Maybe HsDefault) -> Maybe (Utf8 -> Maybe HsDefault)
forall a. a -> Maybe a
Just Utf8 -> Maybe HsDefault
parseDefBytes
                   Type
TYPE_DOUBLE  -> (Utf8 -> Maybe HsDefault) -> Maybe (Utf8 -> Maybe HsDefault)
forall a. a -> Maybe a
Just Utf8 -> Maybe HsDefault
parseDefDouble
                   Type
TYPE_FLOAT   -> (Utf8 -> Maybe HsDefault) -> Maybe (Utf8 -> Maybe HsDefault)
forall a. a -> Maybe a
Just Utf8 -> Maybe HsDefault
parseDefFloat
                   Type
TYPE_STRING  -> (Utf8 -> Maybe HsDefault) -> Maybe (Utf8 -> Maybe HsDefault)
forall a. a -> Maybe a
Just Utf8 -> Maybe HsDefault
parseDefString
                   Type
_            -> (Utf8 -> Maybe HsDefault) -> Maybe (Utf8 -> Maybe HsDefault)
forall a. a -> Maybe a
Just Utf8 -> Maybe HsDefault
parseDefInteger
         case Utf8 -> Maybe HsDefault
todo Utf8
bs of
           Maybe HsDefault
Nothing -> String -> Maybe HsDefault
forall a. HasCallStack => String -> a
error (String -> Maybe HsDefault) -> String -> Maybe HsDefault
forall a b. (a -> b) -> a -> b
$ String
"Could not parse as type "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" the default value (raw) is "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Utf8 -> String
forall a. Show a => a -> String
show Maybe Utf8
mayRawDef String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" for field "String -> String -> String
forall a. [a] -> [a] -> [a]
++FieldDescriptorProto -> String
forall a. Show a => a -> String
show FieldDescriptorProto
f
           Just HsDefault
value -> HsDefault -> Maybe HsDefault
forall (m :: * -> *) a. Monad m => a -> m a
return HsDefault
value

--- From here down is code used to parse the format of the default values in the .proto files

-- On 25 August 2010 20:12, George van den Driessche <georgevdd@google.com> sent Chris Kuklewicz a
-- patch to MakeReflections.parseDefEnum to ensure that HsDef'Enum holds the mangled form of the
-- name.
parseDefEnum :: Utf8 -> Maybe HsDefault
parseDefEnum :: Utf8 -> Maybe HsDefault
parseDefEnum = HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (HsDefault -> Maybe HsDefault)
-> (Utf8 -> HsDefault) -> Utf8 -> Maybe HsDefault
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsDefault
HsDef'Enum (String -> HsDefault) -> (Utf8 -> String) -> Utf8 -> HsDefault
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MName String -> String
forall a. MName a -> a
mName (MName String -> String)
-> (Utf8 -> MName String) -> Utf8 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IName String -> MName String
forall a b. Mangle a b => a -> b
mangle (IName String -> MName String)
-> (Utf8 -> IName String) -> Utf8 -> MName String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IName String
forall a. a -> IName a
IName (String -> IName String)
-> (Utf8 -> String) -> Utf8 -> IName String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8 -> String
uToString

{-# INLINE mayRead #-}
mayRead :: ReadS a -> String -> Maybe a
mayRead :: ReadS a -> String -> Maybe a
mayRead ReadS a
f String
s = case ReadS a
f String
s of [(a
a,String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
a; [(a, String)]
_ -> Maybe a
forall a. Maybe a
Nothing

parseDefDouble :: Utf8 -> Maybe HsDefault
parseDefDouble :: Utf8 -> Maybe HsDefault
parseDefDouble Utf8
bs = case (Utf8 -> String
uToString Utf8
bs) of
                      String
"nan" -> HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (SomeRealFloat -> HsDefault
HsDef'RealFloat SomeRealFloat
SRF'nan)
                      String
"-inf" -> HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (SomeRealFloat -> HsDefault
HsDef'RealFloat SomeRealFloat
SRF'ninf)
                      String
"inf" -> HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (SomeRealFloat -> HsDefault
HsDef'RealFloat SomeRealFloat
SRF'inf)
                      String
s -> (Double -> HsDefault) -> Maybe Double -> Maybe HsDefault
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SomeRealFloat -> HsDefault
HsDef'RealFloat (SomeRealFloat -> HsDefault)
-> (Double -> SomeRealFloat) -> Double -> HsDefault
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> SomeRealFloat
SRF'Rational (Rational -> SomeRealFloat)
-> (Double -> Rational) -> Double -> SomeRealFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
forall a. Real a => a -> Rational
toRational) (Maybe Double -> Maybe HsDefault)
-> (String -> Maybe Double) -> String -> Maybe HsDefault
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadS Double -> String -> Maybe Double
forall a. ReadS a -> String -> Maybe a
mayRead ReadS Double
reads'(String -> Maybe HsDefault) -> String -> Maybe HsDefault
forall a b. (a -> b) -> a -> b
$ String
s
  where reads' :: ReadS Double
        reads' :: ReadS Double
reads' = ReadS Double -> ReadS Double
forall a t. Num a => (String -> [(a, t)]) -> String -> [(a, t)]
readSigned' ReadS Double
forall a. Read a => ReadS a
reads

{-
parseDefDouble :: Utf8 -> Maybe HsDefault
parseDefDouble bs |
                  | otherwise = fmap (HsDef'Rational . toRational)
                                . mayRead reads' . uToString $ bs
-}


parseDefFloat :: Utf8 -> Maybe HsDefault
parseDefFloat :: Utf8 -> Maybe HsDefault
parseDefFloat Utf8
bs = case (Utf8 -> String
uToString Utf8
bs) of
                      String
"nan" -> HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (SomeRealFloat -> HsDefault
HsDef'RealFloat SomeRealFloat
SRF'nan)
                      String
"-inf" -> HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (SomeRealFloat -> HsDefault
HsDef'RealFloat SomeRealFloat
SRF'ninf)
                      String
"inf" -> HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (SomeRealFloat -> HsDefault
HsDef'RealFloat SomeRealFloat
SRF'inf)
                      String
s -> (Float -> HsDefault) -> Maybe Float -> Maybe HsDefault
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SomeRealFloat -> HsDefault
HsDef'RealFloat (SomeRealFloat -> HsDefault)
-> (Float -> SomeRealFloat) -> Float -> HsDefault
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> SomeRealFloat
SRF'Rational (Rational -> SomeRealFloat)
-> (Float -> Rational) -> Float -> SomeRealFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Rational
forall a. Real a => a -> Rational
toRational) (Maybe Float -> Maybe HsDefault)
-> (String -> Maybe Float) -> String -> Maybe HsDefault
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadS Float -> String -> Maybe Float
forall a. ReadS a -> String -> Maybe a
mayRead ReadS Float
reads'(String -> Maybe HsDefault) -> String -> Maybe HsDefault
forall a b. (a -> b) -> a -> b
$ String
s
  where reads' :: ReadS Float
        reads' :: ReadS Float
reads' = ReadS Float -> ReadS Float
forall a t. Num a => (String -> [(a, t)]) -> String -> [(a, t)]
readSigned' ReadS Float
forall a. Read a => ReadS a
reads

{-
parseDefFloat :: Utf8 -> Maybe HsDefault
parseDefFloat bs = fmap  (HsDef'Rational . toRational)
                   . mayRead reads' . uToString $ bs
  where reads' :: ReadS Float
        reads' = readSigned' reads
-}

parseDefString :: Utf8 -> Maybe HsDefault
parseDefString :: Utf8 -> Maybe HsDefault
parseDefString Utf8
bs = HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (ByteString -> HsDefault
HsDef'ByteString (Utf8 -> ByteString
utf8 Utf8
bs))

parseDefBytes :: Utf8 -> Maybe HsDefault
parseDefBytes :: Utf8 -> Maybe HsDefault
parseDefBytes Utf8
bs = HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (ByteString -> HsDefault
HsDef'ByteString (Utf8 -> ByteString
utf8 Utf8
bs))

parseDefInteger :: Utf8 -> Maybe HsDefault
parseDefInteger :: Utf8 -> Maybe HsDefault
parseDefInteger Utf8
bs = (Integer -> HsDefault) -> Maybe Integer -> Maybe HsDefault
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> HsDefault
HsDef'Integer (Maybe Integer -> Maybe HsDefault)
-> (Utf8 -> Maybe Integer) -> Utf8 -> Maybe HsDefault
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadS Integer -> String -> Maybe Integer
forall a. ReadS a -> String -> Maybe a
mayRead ReadS Integer
checkSign (String -> Maybe Integer)
-> (Utf8 -> String) -> Utf8 -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8 -> String
uToString (Utf8 -> Maybe HsDefault) -> Utf8 -> Maybe HsDefault
forall a b. (a -> b) -> a -> b
$ Utf8
bs
    where checkSign :: ReadS Integer
checkSign = ReadS Integer -> ReadS Integer
forall a t. Num a => (String -> [(a, t)]) -> String -> [(a, t)]
readSigned' ReadS Integer
forall a. (Eq a, Num a) => String -> [(a, String)]
checkBase
          checkBase :: String -> [(a, String)]
checkBase (Char
'0':Char
'x':xs :: String
xs@(Char
_:String
_)) = String -> [(a, String)]
forall a. (Eq a, Num a) => String -> [(a, String)]
readHex String
xs
          checkBase (Char
'0':xs :: String
xs@(Char
_:String
_)) = String -> [(a, String)]
forall a. (Eq a, Num a) => String -> [(a, String)]
readOct String
xs
          checkBase String
xs = String -> [(a, String)]
forall a. (Eq a, Num a) => String -> [(a, String)]
readDec String
xs

parseDefBool :: Utf8 -> Maybe HsDefault
parseDefBool :: Utf8 -> Maybe HsDefault
parseDefBool Utf8
bs | Utf8
bs Utf8 -> Utf8 -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Utf8
uFromString String
"true" = HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (Bool -> HsDefault
HsDef'Bool Bool
True)
                | Utf8
bs Utf8 -> Utf8 -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Utf8
uFromString String
"false" = HsDefault -> Maybe HsDefault
forall a. a -> Maybe a
Just (Bool -> HsDefault
HsDef'Bool Bool
False)
                | Bool
otherwise = Maybe HsDefault
forall a. Maybe a
Nothing

-- The Numeric.readSigned does not handle '+' for some odd reason
readSigned' :: (Num a) => ([Char] -> [(a, t)]) -> [Char] -> [(a, t)]
readSigned' :: (String -> [(a, t)]) -> String -> [(a, t)]
readSigned' String -> [(a, t)]
f (Char
'-':String
xs) = ((a, t) -> (a, t)) -> [(a, t)] -> [(a, t)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
v,t
s) -> (-a
v,t
s)) ([(a, t)] -> [(a, t)])
-> (String -> [(a, t)]) -> String -> [(a, t)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(a, t)]
f (String -> [(a, t)]) -> String -> [(a, t)]
forall a b. (a -> b) -> a -> b
$ String
xs
readSigned' String -> [(a, t)]
f (Char
'+':String
xs) = String -> [(a, t)]
f String
xs
readSigned' String -> [(a, t)]
f String
xs = String -> [(a, t)]
f String
xs

-- Must keep synchronized with Parser.isValidPacked
isValidPacked :: Label -> FieldType -> Bool
isValidPacked :: Label -> FieldType -> Bool
isValidPacked Label
LABEL_REPEATED FieldType
fieldType =
  case FieldType
fieldType of
    FieldType
9 -> Bool
False
    FieldType
10 -> Bool
False
    FieldType
11 -> Bool
False -- Impossible value for typeCode from parseType, but here for completeness
    FieldType
12 -> Bool
False
    FieldType
_ -> Bool
True
isValidPacked Label
_ FieldType
_ = Bool
False