{-# LANGUAGE DeriveDataTypeable #-}
-- | A strong feature of the protocol-buffers package is that it does
-- not contain any structures defined by descriptor.proto!  This
-- prevents me hitting any annoying circular dependencies.  The
-- structures defined here are included in each module created by
-- 'hprotoc'.  They are optimized for use in code generation.
--
-- These values can be inspected at runtime by the user's code, but I
-- have yet to write much documentation.  Luckily the record field
-- names are somewhat descriptive.
--
-- The other reflection is using the 'fileDescriptorProto' which
-- is put into the top level module created by hprotoc.
module Text.ProtocolBuffers.Reflections
  ( ProtoName(..),ProtoFName(..),ProtoInfo(..),DescriptorInfo(..),FieldInfo(..),KeyInfo
  , HsDefault(..),SomeRealFloat(..),EnumInfo(..),EnumInfoApp
  , ReflectDescriptor(..),ReflectEnum(..),GetMessageInfo(..)
  , OneofInfo(..)
  , makePNF, toRF, fromRF
  ) where

import Text.ProtocolBuffers.Basic
import Text.ProtocolBuffers.Identifiers

import Data.List(sort)
import qualified Data.Foldable as F(toList)
import Data.Set(Set)
import qualified Data.Set as Set(fromDistinctAscList)
import Data.Generics(Data)
import Data.Typeable(Typeable)
import Data.Map(Map)

-- | 'makePNF' is used by the generated code to create a ProtoName with less newtype noise.
makePNF :: ByteString -> [String] -> [String] -> String -> ProtoName
makePNF a bs cs d =
  ProtoName (FIName (Utf8 a))
            (map MName bs)
            (map MName cs)
            (MName d)

-- | This is fully qualified name data type for code generation.  The
-- 'haskellPrefix' was possibly specified on the 'hprotoc' command
-- line.  The 'parentModule' is a combination of the module prefix
-- from the '.proto' file and any nested levels of definition.
--
-- The name components are likely to have been mangled to ensure the
-- 'baseName' started with an uppercase letter, in @ ['A'..'Z'] @.
data ProtoName = ProtoName { protobufName :: FIName Utf8     -- ^ fully qualified name using "package" prefix (no mangling)
                           , haskellPrefix :: [MName String] -- ^ Haskell specific prefix to module hierarchy (e.g. Text.Foo)
                           , parentModule :: [MName String]  -- ^ .proto specified namespace (like Com.Google.Bar)
                           , baseName :: MName String
                           }
  deriving (Show,Read,Eq,Ord,Data,Typeable)

data ProtoFName = ProtoFName { protobufName' :: FIName Utf8     -- ^ fully qualified name using "package" prefix (no mangling)
                             , haskellPrefix' :: [MName String] -- ^ Haskell specific prefix to module hierarchy (e.g. Text.Foo)
                             , parentModule' :: [MName String]  -- ^ .proto specified namespace (like Com.Google.Bar)
                             , baseName' :: FName String
                             , baseNamePrefix' :: String -- "_" if lenses are generated
                             }
  deriving (Show,Read,Eq,Ord,Data,Typeable)

data ProtoInfo = ProtoInfo { protoMod :: ProtoName        -- ^ blank protobufName, maybe blank haskellPrefix and/or parentModule
                           , protoFilePath :: [FilePath]  -- ^ path to haskell module
                           , protoSource :: FilePath      -- ^ filename without path of .proto file
                           , extensionKeys :: Seq KeyInfo -- ^ top level keys
                           , messages :: [DescriptorInfo] -- ^ all messages and groups
                           , enums :: [EnumInfo]          -- ^ all enums
                           , oneofs :: [OneofInfo]
                           , knownKeyMap :: Map ProtoName (Seq FieldInfo) -- all keys in namespace
                           }
  deriving (Show,Read,Eq,Ord,Data,Typeable)

data DescriptorInfo = DescriptorInfo { descName :: ProtoName
                                     , descFilePath :: [FilePath]
                                     , isGroup :: Bool
                                     , fields :: Seq FieldInfo
                                     , descOneofs :: Seq OneofInfo
                                     , keys :: Seq KeyInfo
                                     , extRanges :: [(FieldId,FieldId)]
                                     , knownKeys :: Seq FieldInfo
                                     , storeUnknown :: Bool
                                     , lazyFields :: Bool
                                     , makeLenses :: Bool
                                     , jsonInstances :: Bool
                                     }
  deriving (Show,Read,Eq,Ord,Data,Typeable)


-- | 'GetMessageInfo' is used in getting messages from the wire.  It
-- supplies the 'Set' of precomposed wire tags that must be found in
-- the message as well as a 'Set' of all allowed tags (including known
-- extension fields and all required wire tags).
--
-- Extension fields not in the allowedTags set are still loaded, but
-- only as 'ByteString' blobs that will have to interpreted later.
data GetMessageInfo = GetMessageInfo { requiredTags :: Set WireTag
                                     , allowedTags :: Set WireTag
                                     }
  deriving (Show,Read,Eq,Ord,Data,Typeable)

type KeyInfo = (ProtoName,FieldInfo) -- Extendee and FieldInfo

data FieldInfo = FieldInfo { fieldName     :: ProtoFName
                           , fieldNumber   :: FieldId
                           , wireTag       :: WireTag          -- ^ Used for writing and reading if packedTag is Nothing
                           , packedTag     :: Maybe (WireTag,WireTag) -- ^ used for reading when Just {} instead of wireTag
                           , wireTagLength :: WireSize         -- ^ Bytes required in the Varint formatted wireTag
                           , isPacked      :: Bool
                           , isRequired    :: Bool
                           , canRepeat     :: Bool             -- ^ True if repeated is the field type
                           , mightPack     :: Bool             -- ^ True if packed would be valid for this field type
                           , typeCode      :: FieldType        -- ^ fromEnum of Text.DescriptorProtos.FieldDescriptorProto.Type
                           , typeName      :: Maybe ProtoName  -- ^ Set for Messages,Groups,and Enums
                           , hsRawDefault  :: Maybe ByteString -- ^ crappy, but not escaped, thing
                           , hsDefault     :: Maybe HsDefault  -- ^ nice parsed thing
                           }
  deriving (Show,Read,Eq,Ord,Data,Typeable)

-- | 'HsDefault' stores the parsed default from the proto file in a
-- form that will make a nice literal in the
-- "Language.Haskell.Exts.Syntax" code generation by 'hprotoc'.
--
-- Note that Utf8 labeled byte sequences have been stripped to just
-- 'ByteString' here as this is sufficient for code generation.
--
-- 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.
data HsDefault = HsDef'Bool Bool
               | HsDef'ByteString ByteString
               | HsDef'RealFloat SomeRealFloat
               | HsDef'Integer Integer
               | HsDef'Enum String
  deriving (Show,Read,Eq,Ord,Data,Typeable)

-- | 'SomeRealFloat' projects Double/Float to Rational or a special IEEE type.
-- This is needed to track protobuf-2.3.0 which allows nan and inf and -inf default values.
data SomeRealFloat = SRF'Rational Rational | SRF'nan | SRF'ninf | SRF'inf
  deriving (Show,Read,Eq,Ord,Data,Typeable)

toRF :: (RealFloat a, Fractional a) => SomeRealFloat -> a
toRF (SRF'Rational r) = fromRational r
toRF SRF'nan = (0/0)
toRF SRF'ninf = (-1/0)
toRF SRF'inf = (1/0)

fromRF :: (RealFloat a, Fractional a) => a -> SomeRealFloat
fromRF x | isNaN x = SRF'nan
         | isInfinite x = if 0 < x then SRF'inf else SRF'ninf
         | otherwise = SRF'Rational (toRational x)

data OneofInfo = OneofInfo { oneofName :: ProtoName
                           , oneofFName :: ProtoFName
                           , oneofFilePath :: [FilePath]
                           , oneofFields :: Seq (ProtoName,FieldInfo)
                           , oneofMakeLenses :: Bool
                           }
  deriving (Show,Read,Eq,Ord,Data,Typeable)

data EnumInfo = EnumInfo { enumName :: ProtoName
                         , enumFilePath :: [FilePath]
                         , enumValues :: [(EnumCode,String)] -- ^ The String is the Haskell name to write into the generated source files
                         , enumJsonInstances :: Bool
                         }
  deriving (Show,Read,Eq,Ord,Data,Typeable)

type EnumInfoApp e = [(EnumCode,String,e)]


class ReflectEnum e where
  reflectEnum :: EnumInfoApp e
  reflectEnumInfo :: e -> EnumInfo            -- ^ Must not inspect argument
  parentOfEnum :: e -> Maybe DescriptorInfo   -- ^ Must not inspect argument
  parentOfEnum _ = Nothing

class ReflectDescriptor m where
  -- | This is obtained via 'read' on the stored 'show' output of the 'DescriptorInfo' in
  -- the module file. It is used in getting messages from the wire.
  -- 
  -- Must not inspect argument
  getMessageInfo :: m -> GetMessageInfo
  getMessageInfo x = cached
    where cached = makeMessageInfo (reflectDescriptorInfo (undefined `asTypeOf` x))
          makeMessageInfo :: DescriptorInfo -> GetMessageInfo
          makeMessageInfo di = GetMessageInfo { requiredTags = Set.fromDistinctAscList . sort $
                                                  [ wireTag f | f <- F.toList (fields di), isRequired f]
                                              , allowedTags = Set.fromDistinctAscList . sort $
                                                  [ wireTag f | f <- F.toList (fields di)] ++
                                                  [ wireTag f | f <- F.toList (knownKeys di)]
                                              }
  reflectDescriptorInfo :: m -> DescriptorInfo    -- ^ Must not inspect argument