proto-lens-protoc-0.9.0.0: app/Data/ProtoLens/Compiler/Generate.hs
-- Copyright 2016 Google Inc. All Rights Reserved.
--
-- Use of this source code is governed by a BSD-style
-- license that can be found in the LICENSE file or at
-- https://developers.google.com/open-source/licenses/bsd
-- | This module builds the actual, generated Haskell file
-- for a given input .proto file.
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.ProtoLens.Compiler.Generate(
generateModule,
) where
import Control.Arrow (second)
import qualified Data.Foldable as F
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Maybe (isJust)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup ((<>))
#endif
import Data.Ord (comparing)
import qualified Data.Set as Set
import Data.String (fromString)
import Data.Text (unpack)
import qualified Data.Text as T
import Data.Tuple (swap)
import GHC.SourceGen
#if MIN_VERSION_ghc(8,10,0)
import GHC.Hs (ideclName, ideclAs)
#else
import HsSyn (ideclName, ideclAs)
#endif
#if MIN_VERSION_ghc(9,10,0)
import GHC.Parser.Annotation (noAnn)
#elif MIN_VERSION_ghc(9,2,0)
import GHC.Parser.Annotation (EpAnn(EpAnnNotUsed), SrcSpanAnn'(SrcSpanAnn))
#endif
#if MIN_VERSION_ghc(9,0,0)
#if MIN_VERSION_ghc(9,6,0)
import Language.Haskell.Syntax.Module.Name (moduleNameString, mkModuleName)
#else
import GHC.Unit.Module.Name (moduleNameString, mkModuleName)
#endif
import qualified GHC.Utils.Outputable as Outputable
import GHC.Types.SrcLoc (unLoc)
import qualified GHC.Types.SrcLoc as SrcLoc
#else
import Module (moduleNameString, mkModuleName)
import qualified Outputable
import SrcLoc (unLoc)
import qualified SrcLoc
#endif
import Lens.Family2 ((^.))
import Text.Printf (printf)
import Proto.Google.Protobuf.Descriptor
( EnumValueDescriptorProto
, FileDescriptorProto
, FieldDescriptorProto
, FieldDescriptorProto'Type(..)
)
import Data.ProtoLens.Compiler.Definitions
import Data.ProtoLens.Compiler.Generate.Commented
import Data.ProtoLens.Compiler.Generate.Encoding
import Data.ProtoLens.Compiler.Generate.Field
( hsFieldType
, hsFieldVectorType
)
import Data.ProtoLens.Encoding (encodeMessage)
import qualified Data.ByteString as BS
-- Whether to import the "Runtime" modules or the originals;
-- e.g., Data.ProtoLens.Runtime.Data.Map vs Data.Map.
data UseRuntime = UseRuntime | UseOriginal
deriving (Eq, Read)
-- | Generate a Haskell module for the given input file(s).
-- input contains all defined names, incl. those in this module
generateModule :: ModuleNameStr
-> FileDescriptorProto -- ^ The complete file descriptor
-> [ModuleNameStr] -- ^ The imported modules
-> [ModuleNameStr] -- ^ The publicly imported modules
-> Env OccNameStr -- ^ Definitions in this file
-> Env RdrNameStr -- ^ Definitions in the imported modules
-> [ServiceInfo]
-> [CommentedModule]
generateModule modName fdesc imports publicImports definitions importedEnv services
= [ CommentedModule pragmas
(module' (Just modName)
(Just $ serviceExports
++ concatMap generateExports (Map.elems definitions)
++ map moduleContents publicImports)
(mainImports ++ sharedImports
++ map importQualified (imports List.\\ publicImports)
++ map import' publicImports)
[])
$ concatMap generateDecls (Map.toList definitions)
++ map uncommented (concatMap (generateServiceDecls env) services)
++ map uncommented packedFileDescriptorProto
, CommentedModule pragmas
(module' (Just fieldModName) Nothing
(sharedImports ++ map importQualified imports) [])
$ map uncommented
$ concatMap generateFieldDecls allLensNames
]
where
fieldModName = fromString $ moduleNameString (unModuleNameStr modName) ++ "_Fields"
pragmas =
[ languagePragma $ List.intercalate ", " $ map fromString
["ScopedTypeVariables", "DataKinds", "TypeFamilies",
"UndecidableInstances", "GeneralizedNewtypeDeriving",
"MultiParamTypeClasses", "FlexibleContexts", "FlexibleInstances",
"PatternSynonyms", "MagicHash", "NoImplicitPrelude",
"DataKinds", "BangPatterns", "TypeApplications",
"OverloadedStrings", "DerivingStrategies"]
-- Allow unused imports in case we don't import anything from
-- Data.Text, Data.Int, etc.
, optionsGhcPragma "-Wno-unused-imports"
-- haskell-src-exts doesn't support exporting `Foo(..., A, B)`
-- in a single entry, so we use two: `Foo(..)` and `Foo(A, B)`.
, optionsGhcPragma "-Wno-duplicate-exports"
-- Don't warn if empty "import public" modules are reexported.
, optionsGhcPragma "-Wno-dodgy-exports"
]
mainImports = map (reexported . importQualified)
[ "Control.DeepSeq", "Data.ProtoLens.Prism" ]
sharedImports = map (reexported . importQualified)
[ "Prelude", "Data.Int", "Data.Monoid", "Data.Word"
, "Data.ProtoLens"
, "Data.ProtoLens.Encoding.Bytes"
, "Data.ProtoLens.Encoding.Growing"
, "Data.ProtoLens.Encoding.Parser.Unsafe"
, "Data.ProtoLens.Encoding.Wire"
, "Data.ProtoLens.Field"
, "Data.ProtoLens.Message.Enum"
, "Data.ProtoLens.Service.Types"
, "Lens.Family2", "Lens.Family2.Unchecked"
, "Data.Text", "Data.Map", "Data.ByteString", "Data.ByteString.Char8"
, "Data.Text.Encoding"
, "Data.Vector"
, "Data.Vector.Generic"
, "Data.Vector.Unboxed"
, "Text.Read"
]
env = Map.union (unqualifyEnv definitions) importedEnv
generateDecls (protoName, Message m)
= generateMessageDecls fieldModName env (stripDotPrefix protoName) m
++ map uncommented (concatMap (generatePrisms env) (messageOneofFields m))
generateDecls (_, Enum e) = map uncommented $ generateEnumDecls e
generateExports (Message m) = generateMessageExports m
++ concatMap generatePrismExports (messageOneofFields m)
generateExports (Enum e) = generateEnumExports e
serviceExports = fmap generateServiceExports services
allLensNames = F.toList $ Set.fromList
[ lensSymbol inst
| Message m <- Map.elems definitions
, info <- allMessageFields env m
, inst <- recordFieldLenses info
]
-- The packedFileDescriptorProto is a file level definition that's
-- shared across all message definitions. If there are no
-- messages, it's omitted since it's only used inside of Message
-- instances.
packedFileDescriptorProto
| null [m | Message m <- Map.elems definitions] = []
| otherwise = [
typeSig "packedFileDescriptor" $ var "Data.ByteString.ByteString",
valBind "packedFileDescriptor" $ string packedFDesc
]
where
packedFDesc = fmap (toEnum . fromEnum) . BS.unpack . encodeMessage $ fdesc
-- The Env uses the convention that Message names are prefixed with '.'
-- (since that's how the FileDescriptorProto refers to them).
-- Strip that off when defining MessageDescriptor.messageName.
stripDotPrefix s
| Just ('.', s') <- T.uncons s = s'
| otherwise = s
allMessageFields :: Env RdrNameStr -> MessageInfo OccNameStr -> [RecordField]
allMessageFields env info =
map (plainRecordField env) (messageFields info)
++ map (oneofRecordField env) (messageOneofFields info)
{- We import modules as follows:
1) Modules from proto-lens-runtime: import qualified, strip the prefix:
import qualified Data.ProtoLens.Runtime.Data.Text as Data.Text
2) Modules from "import" declarations: import qualified:
import qualified Proto.Foo.Bar
3) Modules from "import public" declarations: import unqualified:
import Proto.Foo.Bar
To reexport the imported declarations from the current module via
module ... (module Proto.Foo.Bar)
the module Proto.Foo.Bar needs to be unqualified.
Alternately we could explicitly enumerate every definition being reexported, but
that would lead to less readable Haddocks and also make codegen a little more
complicated.
-}
importQualified :: ModuleNameStr -> ImportDecl'
importQualified = qualified' . import'
type ModifyImports = ImportDecl' -> ImportDecl'
reexported :: ModifyImports
reexported imp = imp { ideclName = noLoc m', ideclAs = Just m }
where
#if MIN_VERSION_ghc(9,10,0)
noLoc = SrcLoc.L noAnn
#elif MIN_VERSION_ghc(9,2,0)
noLoc = SrcLoc.L (SrcSpanAnn EpAnnNotUsed SrcLoc.noSrcSpan)
#else
noLoc = SrcLoc.noLoc
#endif
m' = mkModuleName $ "Data.ProtoLens.Runtime." ++ moduleNameString (unLoc m)
m = ideclName imp
messageComment :: ModuleNameStr -> OccNameStr -> [RecordField] -> Outputable.SDoc
messageComment fieldModName n fields =
Outputable.vcat
$ [Outputable.text "Fields :", ""]
++ map item (concatMap recordFieldLenses fields)
where
item :: LensInstance -> Outputable.SDoc
item l = Outputable.text (printf " * '%s.%s' @:: "
(moduleNameStrToString fieldModName)
(occNameStrToString $ nameFromSymbol $ lensSymbol l))
Outputable.<>
Outputable.ppr (var "Lens'" @@ t @@ lensFieldType l)
Outputable.<> Outputable.char '@'
t = var (unqual n)
generateMessageExports :: MessageInfo OccNameStr -> [IE']
generateMessageExports m =
-- Hide the message contructor, but expose "oneof" case constructors.
thingWith (unqual $ messageName m) []
: map (thingAll . unqual . oneofTypeName)
(messageOneofFields m)
generateServiceDecls :: Env RdrNameStr -> ServiceInfo -> [HsDecl']
generateServiceDecls env si =
-- data MyService = MyService
[ data' serverDataName []
[ recordCon serverDataName []
]
[]
] ++
-- instance Data.ProtoLens.Service.Types.Service MyService where
-- type ServiceName MyService = "myService"
-- type ServicePackage MyService = "some.package"
-- type ServiceMethods MyService = '["normalMethod", "streamingMethod"]
-- packedServiceDescriptor _ = ...
[ instance' (var "Data.ProtoLens.Service.Types.Service" @@ serverRecordType)
[ tyFamInst "ServiceName" [serverRecordType]
. stringTy . T.unpack $ serviceName si
, tyFamInst "ServicePackage" [serverRecordType]
. stringTy . T.unpack $ servicePackage si
, tyFamInst "ServiceMethods" [serverRecordType]
$ listPromotedTy
[ stringTy . T.unpack $ methodIdent m
| m <- List.sortBy (comparing methodIdent) $ serviceMethods si
]
, funBind "packedServiceDescriptor" $ match [wildP] $ string svcDescriptor
]
] ++
-- instance Data.ProtoLens.Service.Types.HasMethodImpl MyService "normalMethod" where
-- type MethodInput MyService "normalMethod" = Foo
-- type MethodOutput MyService "normalMethod" = Bar
-- type IsClientStreaming MyService "normalMethod" = 'False
-- type IsServerStreaming MyService "normalMethod" = 'False
[ instance' (var "Data.ProtoLens.Service.Types.HasMethodImpl" @@ serverRecordType @@ instanceHead)
[ tyFamInst "MethodName" [serverRecordType, instanceHead]
. stringTy . T.unpack $ methodName m
, tyFamInst "MethodInput" [serverRecordType, instanceHead]
. lookupType $ methodInput m
, tyFamInst "MethodOutput" [serverRecordType, instanceHead]
. lookupType $ methodOutput m
, tyFamInst "MethodStreamingType" [serverRecordType, instanceHead]
. tyPromotedVar
$ case (methodClientStreaming m, methodServerStreaming m) of
(False, False) -> "Data.ProtoLens.Service.Types.NonStreaming"
(True, False) -> "Data.ProtoLens.Service.Types.ClientStreaming"
(False, True) -> "Data.ProtoLens.Service.Types.ServerStreaming"
(True, True) -> "Data.ProtoLens.Service.Types.BiDiStreaming"
]
| m <- serviceMethods si
, let instanceHead = stringTy (T.unpack $ methodIdent m)
]
where
svcDescriptor = fmap (toEnum . fromEnum) . BS.unpack . encodeMessage $ serviceDescriptor si
serverDataName = fromString . T.unpack $ serviceName si
serverRecordType = var $ unqual serverDataName
lookupType t = case definedType t env of
Message msg -> var $ messageName msg
Enum _ -> error "Service must have a message type"
generateMessageDecls :: ModuleNameStr -> Env RdrNameStr -> T.Text -> MessageInfo OccNameStr -> [CommentedDecl]
generateMessageDecls fieldModName env protoName info =
-- data Bar = Bar {
-- foo :: Baz
-- }
[ commented (messageComment fieldModName (messageName info) allFields)
$ data' dataName []
[recordCon (messageConstructorName info) $
[ (recordFieldName f, strict $ field $ recordFieldType f)
| f <- allFields
]
++ [(messageUnknownFields info, strict $ field $ var "Data.ProtoLens.FieldSet")]
]
[derivingStock [var "Prelude.Eq", var "Prelude.Ord"]]
-- instance Show Bar where
-- showsPrec __x __s = showChar '{' (showString (showMessageShort __x) (showChar '}' s))
, uncommented $
instance' (var "Prelude.Show" @@ dataType)
[funBind "showsPrec" $ match [bvar "_", bvar "__x", bvar "__s"]
$ var "Prelude.showChar" @@ char '{'
@@ (var "Prelude.showString"
@@ (var "Data.ProtoLens.showMessageShort" @@ var "__x")
@@ (var "Prelude.showChar" @@ char '}' @@ var "__s"))]
] ++
-- oneof field data type declarations
-- proto: message Foo {
-- oneof bar {
-- float c = 1;
-- Sub s = 2;
-- }
-- }
-- haskell: data Foo'Bar = Foo'Bar'c !Prelude.Float
-- | Foo'Bar's !Sub
[ uncommented $ data' (oneofTypeName oneofInfo) []
[ prefixCon consName [strict $ field $ hsFieldType env f]
| c <- oneofCases oneofInfo
, let f = caseField c
, let consName = caseConstructorName c
]
[derivingStock [var "Prelude.Show", var "Prelude.Eq", var "Prelude.Ord"]]
| oneofInfo <- messageOneofFields info
] ++
-- instance HasField Foo "foo" Bar
-- fieldOf _ = ...
-- Note: for optional fields, this generates an instance both for "foo" and
-- for "maybe'foo" (see plainRecordField below).
[ uncommented $ instance'
(var "Data.ProtoLens.Field.HasField" @@ dataType @@ sym @@ t)
[funBind "fieldOf" $ match [wildP] $
var "Prelude.."
@@ rawFieldAccessor (unqual $ recordFieldName li)
@@ lensExp i]
| li <- allFields
, i <- recordFieldLenses li
, let t = lensFieldType i
, let sym = promoteSymbol $ lensSymbol i
]
++
-- instance Message.Message Bar where
[ uncommented $ instance' (var "Data.ProtoLens.Message" @@ dataType)
$ messageInstance env protoName info
-- instance NFData Bar where
, uncommented $ instance' (var "Control.DeepSeq.NFData" @@ dataType)
[valBind "rnf" $ messageRnfExpr info]
] ++
-- instance NFData Foo'Bar where
[ uncommented $
instance' (var "Control.DeepSeq.NFData" @@
var (unqual $ oneofTypeName o))
[funBinds "rnf" $ map oneofRnfMatch $ oneofCases o]
| o <- messageOneofFields info
]
where
dataType = var $ unqual dataName
dataName = messageName info
allFields = allMessageFields env info
-- oneof Prism declarations
-- proto: message Foo {
-- oneof bar {
-- float c = 1;
-- Sub s = 2;
-- }
-- }
-- haskell: _Foo'C :: Prism' Bar'C Float
-- _Foo'S :: Prism' Bar'S Sub
--
-- example of the function definition for _Foo'C:
-- _Foo'C :: Prism' Bar'C Float
-- _Foo'C
-- = prism' Bar'C
-- (\ p__ ->
-- case p__ of
-- Bar'C p__val -> Prelude.Just p__val
-- _otherwise -> Prelude.Nothing)
generatePrisms :: Env RdrNameStr -> OneofInfo -> [HsDecl']
generatePrisms env oneofInfo =
if length cases > 1
then concatMap (generatePrism altOtherwise) cases
else concatMap (generatePrism mempty) cases
where
cases = oneofCases oneofInfo
altOtherwise = [match [bvar "_otherwise"] (var "Prelude.Nothing")]
-- Generate type signature
-- e.g. Prism' Bar'C Float
generateTypeSig f funName =
typeSig funName $ var "Data.ProtoLens.Prism.Prism'"
-- The oneof sum type name
@@ (var . unqual $ oneofTypeName oneofInfo)
-- The field contained in the sum
@@ hsFieldType env f
-- Generate function definition
-- Prism' is constructed with Constructor for building value
-- and Deconstructor and wrapping in Just for getting value
generateFunDef :: [RawMatch] -> OccNameStr -> HsExpr'
generateFunDef otherwiseCase consName =
var "Data.ProtoLens.Prism.prism'"
-- Sum type constructor
@@ var (unqual consName)
-- Case deconstruction
@@ lambda [bvar "p__"] (
case' (var "p__") $
match [conP (unqual consName) [bvar "p__val"]]
(var "Prelude.Just" @@ var "p__val")
-- We want to generate the otherwise case
-- depending on the amount of sum type cases there are
: otherwiseCase
)
generatePrism :: [RawMatch] -> OneofCase -> [HsDecl']
generatePrism otherwiseCase oneofCase =
let consName = caseConstructorName oneofCase
prismName = casePrismName oneofCase
in [ generateTypeSig (caseField oneofCase) prismName
, valBind prismName $ generateFunDef otherwiseCase consName
]
generatePrismExports :: OneofInfo -> [IE']
generatePrismExports = map (var . unqual . casePrismName) . oneofCases
generateEnumExports :: EnumInfo OccNameStr -> [IE']
generateEnumExports e = [thingAll n, thingWith n aliases] ++ proto3NewType
where
n = unqual $ enumName e
aliases = [enumValueName v | v <- enumValues e, needsManualExport v]
needsManualExport v = isJust (enumAliasOf v)
proto3NewType = case enumUnrecognized e of
Just u -> [var . unqual $ unrecognizedValueName u]
Nothing -> []
generateServiceExports :: ServiceInfo -> IE'
generateServiceExports si = thingAll $ unqual $ fromString $ T.unpack $ serviceName si
generateEnumDecls :: EnumInfo OccNameStr -> [HsDecl']
generateEnumDecls info =
-- Proto3-only:
-- newtype FooEnum'UnrecognizedValue = FooEnum'UnrecognizedValue Data.Int.Int32
-- deriving (Prelude.Eq, Prelude.Ord, Prelude.Show, Prelude.Read)
[ newtype' (unrecognizedValueName u) []
(prefixCon (unrecognizedValueName u) [field $ var "Data.Int.Int32"])
[derivingStock [var "Prelude.Eq", var "Prelude.Ord", var "Prelude.Show"]]
| Just u <- [unrecognized]
]
++
-- data FooEnum
-- = Enum1
-- | Enum2
-- | FooEnum'Unrecognized !FooEnum'UnrecognizedValue
-- deriving (Prelude.Show, Prelude.Eq, Prelude.Ord, Prelude.Read)
[ data' dataName []
( (flip prefixCon [] <$> constructorNames)
++ [ prefixCon (unrecognizedName u)
[strict $ field $ var $ unqual $ unrecognizedValueName u]
| Just u <- [unrecognized]
]
)
[derivingStock [var "Prelude.Show", var "Prelude.Eq", var "Prelude.Ord"]]
-- instance Data.ProtoLens.MessageEnum FooEnum where
-- maybeToEnum 0 = Prelude.Just Enum1
-- maybeToEnum 3 = Prelude.Just Enum2
-- maybeToEnum k
-- -- Proto3:
-- = Prelude.Just
-- (FooEnum'Unrecognized
-- (FooEnum'UnrecognizedValue (Prelude.fromIntegral k)))
-- -- Proto2:
-- = Nothing
--
-- showEnum Foo'Enum2 = "Enum2"
-- showEnum Foo'Enum1 = "Enum1"
-- showEnum (FooEnum'Unrecognized (FooEnum'UnrecognizedValue k))
-- = Prelude.show k
--
-- readEnum k
-- | k == "Enum2a" = Prelude.Just Enum2a -- alias
-- | k == "Enum2" = Prelude.Just Enum2
-- | k == "Enum1" = Prelude.Just Enum1
-- readEnum k = Text.Read.readMaybe k >>= maybeToEnum
, instance' (var "Data.ProtoLens.MessageEnum" @@ dataType)
[ funBinds "maybeToEnum" $
[ match [int k] $ var "Prelude.Just" @@ var (unqual c)
| (c, k) <- constructorNumbers
]
++
[ case enumUnrecognized info of
Nothing -> match [wildP] $ var "Prelude.Nothing"
Just u -> match [bvar "k"]
$ var "Prelude.Just" @@
(var (unqual $ unrecognizedName u)
@@ (var (unqual $ unrecognizedValueName u)
@@ (var "Prelude.fromIntegral" @@ var "k")
)
)
]
, funBinds "showEnum" $
[ match [conP_ (unqual n)] $ string pn
| v <- filter (null . enumAliasOf) $ enumValues info
, let n = enumValueName v
, let pn = T.unpack $ enumValueDescriptor v ^. #name
] ++
[ match [conP (unqual $ unrecognizedName u)
[conP (unqual $ unrecognizedValueName u) [bvar "k"]]
]
$ var "Prelude.show" @@ var "k"
| Just u <- [unrecognized]
]
, funBind "readEnum" $ matchGRHSs [bvar "k"] $ guardedRhs $
[ guard (var "Prelude.==" @@ var "k" @@ string pn)
$ var "Prelude.Just" @@ var (unqual n)
| v <- enumValues info
, let n = enumValueName v
, let pn = T.unpack $ enumValueDescriptor v ^. #name
]
++ [guard (var "Prelude.otherwise") $ var "Prelude.>>="
@@ (var "Text.Read.readMaybe" @@ var "k")
@@ var "Data.ProtoLens.maybeToEnum"]
]
-- instance Bounded Foo where
-- minBound = Foo1
-- maxBound = FooN
, instance' (var "Prelude.Bounded" @@ dataType)
[ valBind "minBound" $ var $ unqual minBoundName
, valBind "maxBound" $ var $ unqual maxBoundName
]
-- instance Enum Foo where
-- toEnum k = maybe (error ("Foo.toEnum: unknown argument for enum Foo: "
-- ++ show k))
-- id (maybeToEnum k)
-- fromEnum Foo1 = 1
-- fromEnum Foo2 = 2
-- ..
-- succ FooN = error "Foo.succ: bad argument FooN."
-- succ Foo1 = Foo2
-- succ Foo2 = Foo3
-- ..
-- pred Foo1 = error "Foo.succ: bad argument Foo1."
-- pred Foo2 = Foo1
-- pred Foo3 = Foo2
-- ..
-- enumFrom = messageEnumFrom
-- enumFromTo = messageEnumFromTo
-- enumFromThen = messageEnumFromThen
-- enumFromThenTo = messageEnumFromThenTo
, instance' (var "Prelude.Enum" @@ dataType)
[funBind "toEnum" $ match [bvar "k__"]
$ var "Prelude.maybe" @@ errorMessageExpr @@ var "Prelude.id"
@@ (var "Data.ProtoLens.maybeToEnum" @@ var "k__")
, funBinds "fromEnum" $
[ match [conP_ (unqual c)] $ int k
| (c, k) <- constructorNumbers
]
++
[ match [conP (unqual $ unrecognizedName u)
[conP (unqual $ unrecognizedValueName u) [bvar "k"]]
]
$ var "Prelude.fromIntegral" @@ var "k"
| Just u <- [unrecognized]
]
, succDecl "succ" maxBoundName succPairs
, succDecl "pred" minBoundName $ map swap succPairs
, valBind "enumFrom" $ var "Data.ProtoLens.Message.Enum.messageEnumFrom"
, valBind "enumFromTo" $ var "Data.ProtoLens.Message.Enum.messageEnumFromTo"
, valBind "enumFromThen" $ var "Data.ProtoLens.Message.Enum.messageEnumFromThen"
, valBind "enumFromThenTo"
$ var "Data.ProtoLens.Message.Enum.messageEnumFromThenTo"
]
-- instance Data.ProtoLens.FieldDefault Foo where
-- fieldDefault = FirstEnumValue
, instance' (var "Data.ProtoLens.FieldDefault" @@ dataType)
[valBind "fieldDefault" defaultCon]
-- instance NFData Foo where
-- rnf x__ = seq x__ ()
-- (Trivial since enum types are already strict)
, instance' (var "Control.DeepSeq.NFData" @@ dataType)
[ funBind "rnf" $ match [bvar "x__"]
$ var "Prelude.seq" @@ var "x__" @@ var "()" ]
] ++
-- pattern Enum2a :: FooEnum
-- pattern Enum2a = Enum2
concat
[ [ patSynSig aliasName dataType
, patSynBind aliasName [] (bvar originalName)
]
| EnumValueInfo
{ enumValueName = aliasName
, enumAliasOf = Just originalName
} <- enumValues info
]
where
EnumInfo { enumName = dataName
, enumUnrecognized = unrecognized
, enumDescriptor = ed
} = info
errorMessage = "toEnum: unknown value for enum " ++ unpack (ed ^. #name)
++ ": "
errorMessageExpr = var "Prelude.error"
@@ (var "Prelude.++" @@ string errorMessage
@@ (var "Prelude.show" @@ var "k__"))
dataType = var $ unqual dataName
constructors :: [(OccNameStr, EnumValueDescriptorProto)]
constructors = List.sortBy (comparing ((^. #number) . snd))
[(n, d) | EnumValueInfo
{ enumValueName = n
, enumValueDescriptor = d
, enumAliasOf = Nothing
} <- enumValues info
]
constructorNames = map fst constructors
defaultCon = var $ unqual minBoundName
(minBoundName, maxBoundName, succPairs) =
case constructorNames of
(c : cs) -> (c, last constructorNames, zip constructorNames cs)
_ -> error $ "Unexpected empty constructors in " <> show (enumName info)
constructorNumbers = map (second (fromIntegral . (^. #number))) constructors
succDecl :: OccNameStr -> OccNameStr -> [(OccNameStr, OccNameStr)] -> RawInstDecl
succDecl funName boundName thePairs = funBinds funName $
match [conP_ (unqual boundName)]
(var "Prelude.error" @@ string (concat
[ occNameStrToString dataName, "."
, occNameStrToString funName, ": bad argument "
, occNameStrToString boundName
, ". This value would be out of bounds."
]))
:
[ match [conP_ (unqual from')] $ var $ unqual to
| (from', to) <- thePairs
]
++
[ match [conP (unqual $ unrecognizedName u) [wildP]]
(var "Prelude.error" @@ string (concat
[ occNameStrToString dataName, "."
, occNameStrToString funName, ": bad argument: unrecognized value"
]))
| Just u <- [unrecognized]
]
generateFieldDecls :: Symbol -> [HsDecl']
generateFieldDecls xStr =
-- foo :: forall f s a
-- . (Functor f, HasLens s x a) => LensLike' f s a
-- foo = fieldOf @s
[ typeSig x
$ forall' [bvar "f", bvar "s", bvar "a"]
$ [ var "Prelude.Functor" @@ var "f"
, var "Data.ProtoLens.Field.HasField" @@ var "s" @@ xSym @@ var "a"
]
==> var "Lens.Family2.LensLike'" @@ var "f" @@ var "s" @@ var "a"
, valBind x $ fieldOfExp xStr
]
where
x = nameFromSymbol xStr
xSym = promoteSymbol xStr
------------------------------------------
-- | An individual field of the Haskell type corresponding to a proto message.
data RecordField = RecordField
{ recordFieldName :: OccNameStr -- ^ The Haskell name of this field (unique
-- within the module).
, recordFieldType :: HsType' -- ^ Internal type in the record
, recordFieldLenses :: [LensInstance]
-- ^ All of the (overloaded) lenses accessing this record field.
}
-- | An instance of HasLens' for a particular field.
data LensInstance = LensInstance
{ lensSymbol :: Symbol
-- ^ The overloaded name for this lens.
, lensFieldType :: HsType'
-- ^ The type pointed to from this lens.
, lensExp :: HsExpr'
-- ^ A lens from the recordFieldType to the lensFieldType; i.e.,
-- from how it's actually stored in the Haskell record to how the
-- lens views it.
}
-- | Compile information about the record field type and type/class instances
-- for this particular field.
--
-- Used for "plain" record fields that are not part of a oneof.
plainRecordField :: Env RdrNameStr -> PlainFieldInfo -> RecordField
plainRecordField env (PlainFieldInfo kind f) = case kind of
-- data Foo = Foo { _Foo_bar :: Bar }
-- type instance Field "bar" Foo = Bar
RequiredField
-> recordField baseType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = rawAccessor
}]
OptionalValueField
-> recordField baseType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = rawAccessor
}]
-- data Foo = Foo { _Foo_bar :: Maybe Bar }
-- type instance Field "bar" Foo = Bar
-- type instance Field "maybe'bar" Foo = Maybe Bar
OptionalMaybeField ->
recordField maybeType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = maybeAccessor
}
, LensInstance
{ lensSymbol = "maybe'" <> baseName
, lensFieldType = maybeType
, lensExp = rawAccessor
}
]
-- data Foo = Foo { _Foo_bar :: Map Bar Baz }
-- type instance Field "foo" Foo = Map Bar Baz
MapField entry ->
let mapType = var "Data.Map.Map"
@@ hsFieldType env (keyField entry)
@@ hsFieldType env (valueField entry)
in recordField mapType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = mapType
, lensExp = rawAccessor
}]
-- data Foo = Foo { _Foo_bar :: [Bar] }
-- type instance Field "bar" Foo = [Bar]
RepeatedField {} ->
recordField vectorType
[ LensInstance
{ lensSymbol = baseName
, lensFieldType = listType
, lensExp = vectorAccessor
}
, LensInstance
{ lensSymbol = "vec'" <> baseName
, lensFieldType = vectorType
, lensExp = rawAccessor
}
]
where
recordField = RecordField (haskellRecordFieldName $ fieldName f)
baseName = overloadedName $ fieldName f
fd = fieldDescriptor f
baseType = hsFieldType env f
maybeType = var "Prelude.Maybe" @@ baseType
listType = listTy baseType
vectorType = hsFieldVectorType f @@ baseType
rawAccessor = var "Prelude.id"
maybeAccessor = var "Data.ProtoLens.maybeLens"
@@ hsFieldValueDefault env fd
vectorAccessor :: HsExpr'
vectorAccessor = var "Lens.Family2.Unchecked.lens" @@ getter @@ setter
where
getter = var "Data.Vector.Generic.toList"
setter = lambda [wildP, bvar "y__"]
$ var "Data.Vector.Generic.fromList" @@ var "y__"
oneofRecordField :: Env RdrNameStr -> OneofInfo -> RecordField
oneofRecordField env oneofInfo
= RecordField
{ recordFieldName = haskellRecordFieldName $ oneofFieldName oneofInfo
, recordFieldType =
var "Prelude.Maybe" @@ var (unqual $ oneofTypeName oneofInfo)
, recordFieldLenses = lenses
}
where
lenses =
-- Only generate a "maybe" version of this lens,
-- since oneofs don't have a notion of a "default" case.
-- data Foo = Foo { _Foo'bar = Maybe Foo'Bar }
-- type instance Field "maybe'bar" Foo = Maybe Foo'Bar
LensInstance
{ lensSymbol = "maybe'" <> overloadedName
(oneofFieldName oneofInfo)
, lensFieldType =
var "Prelude.Maybe" @@ var (unqual $ oneofTypeName oneofInfo)
, lensExp = var "Prelude.id"
}
: concat
-- Generate the same lenses for each sub-field of the oneof
-- as if they were proto2 optional fields.
-- type instance Field "bar" Foo = Bar
-- type instance Field "maybe'bar" Foo = Maybe Bar
[ [ LensInstance
{ lensSymbol = maybeName
, lensFieldType = var "Prelude.Maybe" @@ baseType
, lensExp = oneofFieldAccessor c
}
, LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = var "Prelude.."
@@ oneofFieldAccessor c
@@ (var "Data.ProtoLens.maybeLens"
@@ hsFieldValueDefault env
(fieldDescriptor f))
}
]
| c <- oneofCases oneofInfo
, let f = caseField c
, let baseName = overloadedName $ fieldName f
, let baseType = hsFieldType env f
, let maybeName = "maybe'" <> baseName
]
hsFieldDefault :: Env RdrNameStr -> PlainFieldInfo -> HsExpr'
hsFieldDefault env f = case plainFieldKind f of
RequiredField -> hsFieldValueDefault env fd
OptionalValueField -> hsFieldValueDefault env fd
OptionalMaybeField -> var "Prelude.Nothing"
MapField {} -> var "Data.Map.empty"
RepeatedField {} -> var "Data.Vector.Generic.empty"
where
fd = fieldDescriptor (plainFieldInfo f)
hsFieldValueDefault :: Env RdrNameStr -> FieldDescriptorProto -> HsExpr'
hsFieldValueDefault env fd = case fd ^. #type' of
FieldDescriptorProto'TYPE_MESSAGE -> var "Data.ProtoLens.defMessage"
FieldDescriptorProto'TYPE_GROUP -> var "Data.ProtoLens.defMessage"
FieldDescriptorProto'TYPE_ENUM
| T.null def -> var "Data.ProtoLens.fieldDefault"
| Enum e <- definedFieldType fd env
, Just v <- List.lookup def [ (enumValueDescriptor v ^. #name, enumValueName v)
| v <- enumValues e
]
-> var v
| otherwise -> errorMessage "enum"
-- The rest of the cases are for scalar fields that have a fieldDefault
-- instance.
_ | T.null def -> var "Data.ProtoLens.fieldDefault"
FieldDescriptorProto'TYPE_BOOL
| def == "true" -> var "Prelude.True"
| def == "false" -> var "Prelude.False"
| otherwise -> errorMessage "bool"
FieldDescriptorProto'TYPE_STRING
-> var "Data.Text.pack" @@ string (T.unpack def)
FieldDescriptorProto'TYPE_BYTES
-> var "Data.ByteString.pack"
@@ list (mkByte . fromEnum <$> T.unpack def)
where mkByte c
| c > 0 && c < 255 = int $ fromIntegral c
| otherwise = errorMessage "bytes"
FieldDescriptorProto'TYPE_FLOAT -> defaultFrac $ T.unpack def
FieldDescriptorProto'TYPE_DOUBLE -> defaultFrac $ T.unpack def
-- Otherwise, assume it's an integral field:
_ -> defaultInt $ T.unpack def
where
def = fd ^. #defaultValue
errorMessage fieldType
= error $ "Bad default value " ++ show (T.unpack def)
++ " in default value for " ++ fieldType ++ " field "
++ unpack (fd ^. #name)
-- float/double fields can use nan, inf and -inf as default values.
-- The Prelude doesn't provide names for them, so we implement
-- them as division by zero.
defaultFrac "nan" = var "Prelude./" @@ frac 0 @@ frac 0
defaultFrac "inf" = var "Prelude./" @@ frac 1 @@ frac 0
defaultFrac "-inf" = var "Prelude./" @@ frac (negate 1) @@ frac 0
defaultFrac s = case reads s of
[(x, "")] -> frac $ toRational (x :: Double)
_ -> errorMessage "fractional"
defaultInt s = case reads s of
[(x, "")] -> int x
_ -> errorMessage "integral"
-- | A lens to access an internal field.
--
-- lens _Foo_bar (\x__ y__ -> x__ { _Foo_bar = y__ })
rawFieldAccessor :: RdrNameStr -> HsExpr'
rawFieldAccessor f = var "Lens.Family2.Unchecked.lens" @@ getter @@ setter
where
getter = var f
setter = lambda [bvar "x__", bvar "y__"]
$ recordUpd (var "x__") [(f, var "y__")]
-- | A lens that maps from a oneof sum type to one of its individual cases.
--
-- For example, with
-- data Foo = Bar Int32 | Baz Int64
--
-- this will generate a lens of type @Lens' (Maybe Foo) (Maybe Int32)@.
--
-- (Recall that oneofs are stored in a proto message as @Maybe Foo@, where
-- 'Nothing' means that it's either set to an unknown value or unset.)
--
-- lens
-- (\ x__ -> case x__ of
-- Prelude.Just (Foo'c x__val) -> Prelude.Just x__val
-- otherwise -> Prelude.Nothing)
-- (\ _ y__ -> fmap Foo'c y__
oneofFieldAccessor :: OneofCase -> HsExpr'
oneofFieldAccessor o
= var "Lens.Family2.Unchecked.lens" @@ getter @@ setter
where
consName = caseConstructorName o
getter = lambda [bvar "x__"] $
case' (var "x__")
[ match [conP "Prelude.Just" [conP (unqual consName) [bvar "x__val"]]]
$ var "Prelude.Just" @@ var "x__val"
, match [bvar "_otherwise"] $ var "Prelude.Nothing"
]
setter = lambda [wildP, bvar "y__"]
$ var "Prelude.fmap" @@ var (unqual consName) @@ var "y__"
messageInstance :: Env RdrNameStr -> T.Text -> MessageInfo OccNameStr -> [RawInstDecl]
messageInstance env protoName m =
[ funBind "messageName" $ match [wildP] $
var "Data.Text.pack" @@ string (T.unpack protoName)
, funBind "packedMessageDescriptor" $ match [wildP] $ string msgDescriptor
, funBind "packedFileDescriptor" $ match [wildP] $ var "packedFileDescriptor"
, valBind "fieldsByTag" $
let' (map (fieldDescriptorVarBind $ messageName m) fields)
$ var "Data.Map.fromList" @@ list fieldsByTag
, valBind "unknownFields"
$ rawFieldAccessor (unqual $ messageUnknownFields m)
, valBind "defMessage"
$ recordConE (unqual $ messageConstructorName m) $
[ (unqual $ haskellRecordFieldName
$ fieldName $ plainFieldInfo f,
hsFieldDefault env f)
| f <- messageFields m
] ++
[ (unqual $ haskellRecordFieldName $ oneofFieldName o,
var "Prelude.Nothing")
| o <- messageOneofFields m
] ++
[ (unqual $ messageUnknownFields m, var "[]")]
, valBind "parseMessage" $ generatedParser env m
, valBind "buildMessage" $ generatedBuilder m
]
where
msgDescriptor = fmap (toEnum . fromEnum) . BS.unpack . encodeMessage $ messageDescriptor m
fieldsByTag =
[tuple
[ t, fieldDescriptorVar f ]
| f <- fields
, let t = var "Data.ProtoLens.Tag"
@@ int (fromIntegral
$ fieldDescriptor (plainFieldInfo f) ^. #number)
]
fieldDescriptorVar = var . unqual . fieldDescriptorName
fieldDescriptorName f
= nameFromSymbol $ overloadedName (fieldName . plainFieldInfo $ f)
<> "__field_descriptor"
fieldDescriptorVarBind n f
= valBind (fieldDescriptorName f)
$ fieldDescriptorExpr env n f
fields = messageFields m
++ (messageOneofFields m >>= fmap casePlainField . oneofCases)
-- The cases of an optional are always treated like proto2 "maybe" fields.
-- This code here does not apply to proto3 optional fields which
-- are absent from messageOneofFields, but those get treated as
-- OptionalMaybeField by fieldKind so they behave the same.
casePlainField = PlainFieldInfo OptionalMaybeField . caseField
-- | Get the name of the field when used in a text format proto. Groups are
-- special because their text format field name is the name of their type,
-- not the name of the field in the descriptor (e.g. "Foo", not "foo").
textFormatFieldName :: Env RdrNameStr -> FieldDescriptorProto -> T.Text
textFormatFieldName env descr = case descr ^. #type' of
FieldDescriptorProto'TYPE_GROUP
| Message msg <- definedFieldType descr env
-> messageDescriptor msg ^. #name
| otherwise -> error $ "expected TYPE_GROUP for type name"
++ T.unpack (descr ^. #typeName)
_ -> descr ^. #name
fieldDescriptorExpr :: Env RdrNameStr -> OccNameStr -> PlainFieldInfo
-> HsExpr'
fieldDescriptorExpr env n f =
(var "Data.ProtoLens.FieldDescriptor"
-- Record the original .proto name for text format
@@ string (T.unpack $ textFormatFieldName env fd)
-- Force the type signature since it can't be inferred for Map entry
-- types.
@@ (fieldTypeDescriptorExpr (fd ^. #type')
@::@
(var "Data.ProtoLens.FieldTypeDescriptor"
@@ hsFieldType env (plainFieldInfo f)))
@@ fieldAccessorExpr f)
-- TODO: why is this type sig needed?
@::@
(var "Data.ProtoLens.FieldDescriptor" @@ var (unqual n))
where
fd = fieldDescriptor $ plainFieldInfo f
fieldAccessorExpr :: PlainFieldInfo -> HsExpr'
-- (PlainField Required foo), (OptionalField foo), etc...
fieldAccessorExpr (PlainFieldInfo kind f) = accessorCon @@ fieldOfExp hsFieldName
where
accessorCon = case kind of
RequiredField
-> var "Data.ProtoLens.PlainField" @@ var "Data.ProtoLens.Required"
OptionalValueField
-> var "Data.ProtoLens.PlainField" @@ var "Data.ProtoLens.Optional"
OptionalMaybeField
-> var "Data.ProtoLens.OptionalField"
MapField entry
-> var "Data.ProtoLens.MapField"
@@ fieldOfExp (overloadedField $ keyField entry)
@@ fieldOfExp (overloadedField $ valueField entry)
RepeatedField packed ->
var "Data.ProtoLens.RepeatedField"
@@ if packed == Packed
then var "Data.ProtoLens.Packed"
else var "Data.ProtoLens.Unpacked"
hsFieldName
= case kind of
OptionalMaybeField -> "maybe'" <> overloadedField f
_ -> overloadedField f
fieldOfExp :: Symbol -> HsExpr'
fieldOfExp sym = var "Data.ProtoLens.Field.field" `tyApp` promoteSymbol sym
overloadedField :: FieldInfo -> Symbol
overloadedField = overloadedName . fieldName
fieldTypeDescriptorExpr :: FieldDescriptorProto'Type -> HsExpr'
fieldTypeDescriptorExpr = \case
FieldDescriptorProto'TYPE_DOUBLE -> mk "ScalarField" "DoubleField"
FieldDescriptorProto'TYPE_FLOAT -> mk "ScalarField" "FloatField"
FieldDescriptorProto'TYPE_INT64 -> mk "ScalarField" "Int64Field"
FieldDescriptorProto'TYPE_UINT64 -> mk "ScalarField" "UInt64Field"
FieldDescriptorProto'TYPE_INT32 -> mk "ScalarField" "Int32Field"
FieldDescriptorProto'TYPE_FIXED64 -> mk "ScalarField" "Fixed64Field"
FieldDescriptorProto'TYPE_FIXED32 -> mk "ScalarField" "Fixed32Field"
FieldDescriptorProto'TYPE_BOOL -> mk "ScalarField" "BoolField"
FieldDescriptorProto'TYPE_STRING -> mk "ScalarField" "StringField"
FieldDescriptorProto'TYPE_GROUP -> mk "MessageField" "GroupType"
FieldDescriptorProto'TYPE_MESSAGE -> mk "MessageField" "MessageType"
FieldDescriptorProto'TYPE_BYTES -> mk "ScalarField" "BytesField"
FieldDescriptorProto'TYPE_UINT32 -> mk "ScalarField" "UInt32Field"
FieldDescriptorProto'TYPE_ENUM -> mk "ScalarField" "EnumField"
FieldDescriptorProto'TYPE_SFIXED32 -> mk "ScalarField" "SFixed32Field"
FieldDescriptorProto'TYPE_SFIXED64 -> mk "ScalarField" "SFixed64Field"
FieldDescriptorProto'TYPE_SINT32 -> mk "ScalarField" "SInt32Field"
FieldDescriptorProto'TYPE_SINT64 -> mk "ScalarField" "SInt64Field"
where
mk x y = var (fromString ("Data.ProtoLens." ++ x))
@@ var (fromString ("Data.ProtoLens." ++ y))
-- | Generate the implementation of NFData.rnf for the given message.
--
-- instance NFData Bar where
-- rnf = \x -> deepseq (_Bar'foo x) (deepseq (_Bar'bar x) ())
messageRnfExpr :: MessageInfo OccNameStr -> HsExpr'
messageRnfExpr msg = lambda [bvar "x__"] $ foldr ((@@) . seqField) unit fieldNames
where
fieldNames = messageUnknownFields msg
: map (haskellRecordFieldName . fieldName . plainFieldInfo)
(messageFields msg)
++ map (haskellRecordFieldName . oneofFieldName)
(messageOneofFields msg)
seqField :: OccNameStr -> HsExpr'
seqField f = var "Control.DeepSeq.deepseq" @@ (var (unqual f) @@ var "x__")
-- rnf (Foo'a x__) = rnf x__
-- rnf (Bar'b x__) = rnf x__
oneofRnfMatch :: OneofCase -> RawMatch
oneofRnfMatch c = match [unqual (caseConstructorName c) `conP` [bvar "x__"]]
$ var "Control.DeepSeq.rnf" @@ var "x__"