{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.ProtoLens.Compiler.Generate(
generateModule,
ModifyImports,
reexported,
) 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)
import Data.Monoid ((<>))
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 Lens.Family2 ((^.))
import Text.Printf (printf)
import Proto.Google.Protobuf.Descriptor
( EnumValueDescriptorProto
, FieldDescriptorProto
, FieldDescriptorProto'Type(..)
)
import Proto.Google.Protobuf.Descriptor_Fields
( defaultValue
, name
, number
, type'
, typeName
)
import Data.ProtoLens.Compiler.Combinators
import Data.ProtoLens.Compiler.Definitions
import Data.ProtoLens.Compiler.Generate.Encoding
import Data.ProtoLens.Compiler.Generate.Field
( hsFieldType
, hsFieldVectorType
)
data UseRuntime = UseRuntime | UseOriginal
deriving (Eq, Read)
generateModule :: ModuleName
-> [ModuleName]
-> ModifyImports
-> Env Name
-> Env QName
-> [ServiceInfo]
-> [Module]
generateModule modName imports modifyImport definitions importedEnv services
= [ Module modName
(Just $ (serviceExports ++) $ concatMap generateExports $ Map.elems definitions)
pragmas
(mainImports ++ sharedImports)
$ (concatMap generateDecls $ Map.toList definitions)
++ map uncommented (concatMap (generateServiceDecls env) services)
, Module fieldModName
Nothing
pragmas
sharedImports
. map uncommented
$ concatMap generateFieldDecls allLensNames
]
where
fieldModName = modifyModuleName (++ "_Fields") modName
pragmas =
[ languagePragma $ map fromString
["ScopedTypeVariables", "DataKinds", "TypeFamilies",
"UndecidableInstances", "GeneralizedNewtypeDeriving",
"MultiParamTypeClasses", "FlexibleContexts", "FlexibleInstances",
"PatternSynonyms", "MagicHash", "NoImplicitPrelude",
"DataKinds", "BangPatterns", "TypeApplications"]
, optionsGhcPragma "-fno-warn-unused-imports"
, optionsGhcPragma "-fno-warn-duplicate-exports"
]
mainImports = map (modifyImport . importSimple)
[ "Control.DeepSeq", "Data.ProtoLens.Prism" ]
sharedImports = map (modifyImport . importSimple)
[ "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"
]
++ map importSimple imports
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
]
stripDotPrefix s
| Just ('.', s') <- T.uncons s = s'
| otherwise = s
allMessageFields :: Env QName -> MessageInfo Name -> [RecordField]
allMessageFields env info =
map (plainRecordField env) (messageFields info)
++ map (oneofRecordField env) (messageOneofFields info)
importSimple :: ModuleName -> ImportDecl ()
importSimple m = ImportDecl
{ importAnn = ()
, importModule = m
, importQualified = True
, importSrc = False
, importSafe = False
, importPkg = Nothing
, importAs = Nothing
, importSpecs = Nothing
}
type ModifyImports = ImportDecl () -> ImportDecl ()
reexported :: ModifyImports
reexported imp@ImportDecl {importModule = m}
= imp { importAs = Just m, importModule = m' }
where
m' = fromString $ "Data.ProtoLens.Runtime." ++ prettyPrint m
messageComment :: ModuleName -> Name -> [RecordField] -> String
messageComment fieldModName n fields = unlines
$ ["Fields :", ""]
++ map item (concatMap recordFieldLenses fields)
where
item :: LensInstance -> String
item l = (printf " * '%s.%s' @:: %s@"
(prettyPrint fieldModName)
(prettyPrint $ nameFromSymbol $ lensSymbol l)
(prettyPrint $ "Lens'" @@ t @@ (lensFieldType l)))
t = tyCon (unQual n)
generateMessageExports :: MessageInfo Name -> [ExportSpec]
generateMessageExports m =
exportWith (unQual $ messageName m) []
: map (exportAll . unQual . oneofTypeName)
(messageOneofFields m)
generateServiceDecls :: Env QName -> ServiceInfo -> [Decl]
generateServiceDecls env si =
[ dataDecl serverDataName
[ recDecl serverDataName []
]
$ deriving' []
] ++
[ instDeclWithTypes [] ("Data.ProtoLens.Service.Types.Service" `ihApp` [serverRecordType])
[ instType ("ServiceName" @@ serverRecordType)
. tyPromotedString . T.unpack $ serviceName si
, instType ("ServicePackage" @@ serverRecordType)
. tyPromotedString . T.unpack $ servicePackage si
, instType ("ServiceMethods" @@ serverRecordType)
$ tyPromotedList
[ tyPromotedString . T.unpack $ methodIdent m
| m <- List.sortBy (comparing methodIdent) $ serviceMethods si
]
]
] ++
[ instDeclWithTypes [] ("Data.ProtoLens.Service.Types.HasMethodImpl" `ihApp` [serverRecordType, instanceHead])
[ instType ("MethodName" @@ serverRecordType @@ instanceHead)
. tyPromotedString . T.unpack $ methodName m
, instType ("MethodInput" @@ serverRecordType @@ instanceHead)
. lookupType $ methodInput m
, instType ("MethodOutput" @@ serverRecordType @@ instanceHead)
. lookupType $ methodOutput m
, instType ("MethodStreamingType" @@ serverRecordType @@ instanceHead)
. tyPromotedCon
$ 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 = tyPromotedString (T.unpack $ methodIdent m)
]
where
serverDataName = fromString . T.unpack $ serviceName si
serverRecordType = tyCon $ unQual serverDataName
lookupType t = case definedType t env of
Message msg -> tyCon $ messageName msg
Enum _ -> error "Service must have a message type"
generateMessageDecls :: ModuleName -> Env QName -> T.Text -> MessageInfo Name -> [CommentedDecl]
generateMessageDecls fieldModName env protoName info =
[ commented (messageComment fieldModName (messageName info) allFields)
$ dataDecl dataName
[recDecl dataName $
[ (recordFieldName f, recordFieldType f)
| f <- allFields
]
++ [(messageUnknownFields info, "Data.ProtoLens.FieldSet")]
]
$ deriving' ["Prelude.Eq", "Prelude.Ord"]
, uncommented $
instDecl [] ("Prelude.Show" `ihApp` [dataType])
[[match "showsPrec" ["_", "__x", "__s"]
$ "Prelude.showChar" @@ charExp '{'
@@ ("Prelude.showString" @@ ("Data.ProtoLens.showMessageShort" @@ "__x")
@@ ("Prelude.showChar" @@ charExp '}' @@ "__s"))]]
] ++
[ uncommented $ dataDecl (oneofTypeName oneofInfo)
[ conDecl consName [hsFieldType env f]
| c <- oneofCases oneofInfo
, let f = caseField c
, let consName = caseConstructorName c
]
$ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]
| oneofInfo <- messageOneofFields info
] ++
[ uncommented $ instDecl []
("Data.ProtoLens.Field.HasField" `ihApp`
[dataType, sym, tyParen t])
[[match "fieldOf" [pWildCard] $
"Prelude.."
@@ rawFieldAccessor (unQual $ recordFieldName li)
@@ lensExp i]]
| li <- allFields
, i <- recordFieldLenses li
, let t = lensFieldType i
, let sym = promoteSymbol $ lensSymbol i
]
++
[ uncommented $ instDecl [] ("Data.ProtoLens.Message" `ihApp` [dataType])
$ messageInstance env protoName info
, uncommented $ instDecl [] ("Control.DeepSeq.NFData" `ihApp` [dataType])
[[match "rnf" [] $ messageRnfExpr info]]
] ++
[ uncommented $
instDecl [] ("Control.DeepSeq.NFData" `ihApp`
[tyCon $ unQual $ oneofTypeName o])
[map oneofRnfMatch $ oneofCases o]
| o <- messageOneofFields info
]
where
dataType = tyCon $ unQual dataName
dataName = messageName info
allFields = allMessageFields env info
generatePrisms :: Env QName -> OneofInfo -> [Decl]
generatePrisms env oneofInfo =
if length cases > 1
then concatMap (generatePrism altOtherwise) cases
else concatMap (generatePrism mempty) cases
where
cases = oneofCases oneofInfo
altOtherwise = [ "_otherwise" --> "Prelude.Nothing" ]
generateTypeSig f funName =
typeSig [funName] $ "Data.ProtoLens.Prism.Prism'"
@@ (tyCon . unQual $ oneofTypeName oneofInfo)
@@ (hsFieldType env f)
generateFunDef otherwiseCase consName =
"Data.ProtoLens.Prism.prism'"
@@ con (unQual consName)
@@ (lambda ["p__"] $
case' "p__" $
[ pApp (unQual consName) ["p__val"]
--> "Prelude.Just" @@ "p__val"
]
++ otherwiseCase
)
generatePrism :: [Alt] -> OneofCase -> [Decl]
generatePrism otherwiseCase oneofCase =
let consName = caseConstructorName oneofCase
prismName = casePrismName oneofCase
in [ generateTypeSig (caseField oneofCase) prismName
, funBind [ match prismName [] $ generateFunDef otherwiseCase consName ]
]
generatePrismExports :: OneofInfo -> [ExportSpec]
generatePrismExports = map (exportVar . unQual . casePrismName) . oneofCases
generateEnumExports :: EnumInfo Name -> [ExportSpec]
generateEnumExports e = [exportAll n, exportWith 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 -> [exportVar . unQual $ unrecognizedValueName u]
Nothing -> []
generateServiceExports :: ServiceInfo -> ExportSpec
generateServiceExports si = exportAll $ unQual $ fromString $ T.unpack $ serviceName si
generateEnumDecls :: EnumInfo Name -> [Decl]
generateEnumDecls info =
[ newtypeDecl (unrecognizedValueName u)
"Data.Int.Int32"
$ deriving' ["Prelude.Eq", "Prelude.Ord", "Prelude.Show"]
| Just u <- [unrecognized]
]
++
[ dataDecl dataName
( (flip conDecl [] <$> constructorNames)
++ [ conDecl (unrecognizedName u) [tyCon $ unQual (unrecognizedValueName u)]
| Just u <- [unrecognized]
]
)
$ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]
, instDecl [] ("Data.ProtoLens.MessageEnum" `ihApp` [dataType])
[ [ match "maybeToEnum" [pLitInt k] $ "Prelude.Just" @@ con (unQual c)
| (c, k) <- constructorNumbers
]
++
[ case enumUnrecognized info of
Nothing -> match "maybeToEnum" [pWildCard] "Prelude.Nothing"
Just u -> match "maybeToEnum" ["k"]
$ "Prelude.Just" @@
(con (unQual $ unrecognizedName u)
@@ (con (unQual $ unrecognizedValueName u)
@@ ("Prelude.fromIntegral" @@ "k")
)
)
]
, [ match "showEnum" [pApp (unQual n) []]
$ stringExp pn
| v <- filter (null . enumAliasOf) $ enumValues info
, let n = enumValueName v
, let pn = T.unpack $ enumValueDescriptor v ^. name
] ++
[ match "showEnum" [pApp (unQual $ unrecognizedName u)
[pApp (unQual $ unrecognizedValueName u) [pVar "k"]]
]
$ "Prelude.show" @@ "k"
| Just u <- [unrecognized]
]
, [ guardedMatch "readEnum" [pVar "k"]
[ ("Prelude.==" @@ "k" @@ stringExp pn, "Prelude.Just" @@ con (unQual n))
| v <- enumValues info
, let n = enumValueName v
, let pn = T.unpack $ enumValueDescriptor v ^. name
]
, match "readEnum" [pVar "k"] $ "Prelude.>>="
@@ ("Text.Read.readMaybe" @@ "k")
@@ "Data.ProtoLens.maybeToEnum"]
]
, instDecl [] ("Prelude.Bounded" `ihApp` [dataType])
[[ match "minBound" [] $ con $ unQual minBoundName
, match "maxBound" [] $ con $ unQual maxBoundName
]]
, instDecl [] ("Prelude.Enum" `ihApp` [dataType])
[[match "toEnum" ["k__"]
$ "Prelude.maybe" @@ errorMessageExpr @@ "Prelude.id"
@@ ("Data.ProtoLens.maybeToEnum" @@ "k__")]
, [ match "fromEnum" [pApp (unQual c) []] $ litInt k
| (c, k) <- constructorNumbers
]
++
[ match "fromEnum" [pApp (unQual $ unrecognizedName u)
[pApp (unQual $ unrecognizedValueName u) [pVar "k"]]
]
$ "Prelude.fromIntegral" @@ "k"
| Just u <- [unrecognized]
]
, succDecl "succ" maxBoundName succPairs
, succDecl "pred" minBoundName $ map swap succPairs
, alias "enumFrom" "Data.ProtoLens.Message.Enum.messageEnumFrom"
, alias "enumFromTo" "Data.ProtoLens.Message.Enum.messageEnumFromTo"
, alias "enumFromThen" "Data.ProtoLens.Message.Enum.messageEnumFromThen"
, alias "enumFromThenTo"
"Data.ProtoLens.Message.Enum.messageEnumFromThenTo"
]
, instDecl [] ("Data.ProtoLens.FieldDefault" `ihApp` [dataType])
[[match "fieldDefault" [] defaultCon]]
, instDecl [] ("Control.DeepSeq.NFData" `ihApp` [dataType])
[[ match "rnf" ["x__"] $ "Prelude.seq" @@ "x__" @@ "()" ]]
] ++
concat
[ [ patSynSig aliasName dataType
, patSyn (pVar aliasName) (pVar 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 = "Prelude.error"
@@ ("Prelude.++" @@ stringExp errorMessage
@@ ("Prelude.show" @@ "k__"))
alias funName implName = [match funName [] implName]
dataType = tyCon $ unQual dataName
constructors :: [(Name, EnumValueDescriptorProto)]
constructors = List.sortBy (comparing ((^. number) . snd))
[(n, d) | EnumValueInfo
{ enumValueName = n
, enumValueDescriptor = d
, enumAliasOf = Nothing
} <- enumValues info
]
constructorNames = map fst constructors
defaultCon = con $ unQual $ head constructorNames
minBoundName = head constructorNames
maxBoundName = last constructorNames
constructorNumbers = map (second (fromIntegral . (^. number))) constructors
succPairs = zip constructorNames $ tail constructorNames
succDecl funName boundName thePairs =
match funName [pApp (unQual boundName) []]
("Prelude.error" @@ stringExp (concat
[ prettyPrint dataName, ".", prettyPrint funName, ": bad argument "
, prettyPrint boundName, ". This value would be out of bounds."
]))
:
[ match funName [pApp (unQual from) []] $ con $ unQual to
| (from, to) <- thePairs
]
++
[ match funName [pApp (unQual $ unrecognizedName u) [pWildCard]]
("Prelude.error" @@ stringExp (concat
[ prettyPrint dataName, ".", prettyPrint funName, ": bad argument: unrecognized value"
]))
| Just u <- [unrecognized]
]
generateFieldDecls :: Symbol -> [Decl]
generateFieldDecls xStr =
[ typeSig [x]
$ tyForAll ["f", "s", "a"]
[classA "Prelude.Functor" ["f"],
classA "Data.ProtoLens.Field.HasField" ["s", xSym, "a"]]
$ "Lens.Family2.LensLike'" @@ "f" @@ "s" @@ "a"
, funBind [match x [] $ fieldOfExp xStr]
]
where
x = nameFromSymbol xStr
xSym = promoteSymbol xStr
data RecordField = RecordField
{ recordFieldName :: Name
, recordFieldType :: Type
, recordFieldLenses :: [LensInstance]
}
data LensInstance = LensInstance
{ lensSymbol :: Symbol
, lensFieldType :: Type
, lensExp :: Exp
}
plainRecordField :: Env QName -> PlainFieldInfo -> RecordField
plainRecordField env (PlainFieldInfo kind f) = case kind of
RequiredField
-> recordField baseType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = rawAccessor
}]
OptionalValueField
-> recordField baseType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = rawAccessor
}]
OptionalMaybeField ->
recordField maybeType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = maybeAccessor
}
, LensInstance
{ lensSymbol = "maybe'" <> baseName
, lensFieldType = maybeType
, lensExp = rawAccessor
}
]
MapField entry ->
let mapType = "Data.Map.Map"
@@ hsFieldType env (keyField entry)
@@ hsFieldType env (valueField entry)
in recordField mapType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = mapType
, lensExp = rawAccessor
}]
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 = "Prelude.Maybe" @@ baseType
listType = tyList baseType
vectorType = hsFieldVectorType f @@ baseType
rawAccessor = "Prelude.id"
maybeAccessor = "Data.ProtoLens.maybeLens"
@@ hsFieldValueDefault env fd
vectorAccessor :: Exp
vectorAccessor = "Lens.Family2.Unchecked.lens" @@ getter @@ setter
where
getter = "Data.Vector.Generic.toList"
setter = lambda ["_", "y__"]
$ "Data.Vector.Generic.fromList" @@ "y__"
oneofRecordField :: Env QName -> OneofInfo -> RecordField
oneofRecordField env oneofInfo
= RecordField
{ recordFieldName = haskellRecordFieldName $ oneofFieldName oneofInfo
, recordFieldType =
"Prelude.Maybe" @@ tyCon (unQual $ oneofTypeName oneofInfo)
, recordFieldLenses = lenses
}
where
lenses =
[LensInstance
{ lensSymbol = "maybe'" <> overloadedName
(oneofFieldName oneofInfo)
, lensFieldType =
"Prelude.Maybe" @@ tyCon (unQual $ oneofTypeName oneofInfo)
, lensExp = "Prelude.id"
}
]
++ concat
[ [ LensInstance
{ lensSymbol = maybeName
, lensFieldType = "Prelude.Maybe" @@ baseType
, lensExp = oneofFieldAccessor c
}
, LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = "Prelude.."
@@ oneofFieldAccessor c
@@ ("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 QName -> PlainFieldInfo -> Exp
hsFieldDefault env f = case plainFieldKind f of
RequiredField -> hsFieldValueDefault env fd
OptionalValueField -> hsFieldValueDefault env fd
OptionalMaybeField -> "Prelude.Nothing"
MapField {} -> "Data.Map.empty"
RepeatedField {} -> "Data.Vector.Generic.empty"
where
fd = fieldDescriptor (plainFieldInfo f)
hsFieldValueDefault :: Env QName -> FieldDescriptorProto -> Exp
hsFieldValueDefault env fd = case fd ^. type' of
FieldDescriptorProto'TYPE_MESSAGE -> "Data.ProtoLens.defMessage"
FieldDescriptorProto'TYPE_GROUP -> "Data.ProtoLens.defMessage"
FieldDescriptorProto'TYPE_ENUM
| T.null def -> "Data.ProtoLens.fieldDefault"
| Enum e <- definedFieldType fd env
, Just v <- List.lookup def [ (enumValueDescriptor v ^. name, enumValueName v)
| v <- enumValues e
]
-> con v
| otherwise -> errorMessage "enum"
_ | T.null def -> "Data.ProtoLens.fieldDefault"
FieldDescriptorProto'TYPE_BOOL
| def == "true" -> "Prelude.True"
| def == "false" -> "Prelude.False"
| otherwise -> errorMessage "bool"
FieldDescriptorProto'TYPE_STRING
-> "Data.Text.pack" @@ stringExp (T.unpack def)
FieldDescriptorProto'TYPE_BYTES
-> "Data.ByteString.pack"
@@ list ((mkByte . fromEnum) <$> T.unpack def)
where mkByte c
| c > 0 && c < 255 = litInt $ fromIntegral c
| otherwise = errorMessage "bytes"
FieldDescriptorProto'TYPE_FLOAT -> defaultFrac $ T.unpack def
FieldDescriptorProto'TYPE_DOUBLE -> defaultFrac $ T.unpack def
_ -> 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)
defaultFrac "nan" = "Prelude./" @@ litFrac 0 @@ litFrac 0
defaultFrac "inf" = "Prelude./" @@ litFrac 1 @@ litFrac 0
defaultFrac "-inf" = "Prelude./" @@ litFrac (negate 1) @@ litFrac 0
defaultFrac s = case reads s of
[(x, "")] -> litFrac $ toRational (x :: Double)
_ -> errorMessage "fractional"
defaultInt s = case reads s of
[(x, "")] -> litInt x
_ -> errorMessage "integral"
rawFieldAccessor :: QName -> Exp
rawFieldAccessor f = "Lens.Family2.Unchecked.lens" @@ getter @@ setter
where
getter = var f
setter = lambda ["x__", "y__"]
$ recUpdate "x__" [fieldUpdate f "y__"]
oneofFieldAccessor :: OneofCase -> Exp
oneofFieldAccessor o
= "Lens.Family2.Unchecked.lens" @@ getter @@ setter
where
consName = caseConstructorName o
getter = lambda ["x__"] $
case' "x__"
[ pApp "Prelude.Just" [pApp (unQual consName) ["x__val"]]
--> "Prelude.Just" @@ "x__val"
, "_otherwise" --> "Prelude.Nothing"
]
setter = lambda ["_", "y__"]
$ "Prelude.fmap" @@ con (unQual consName) @@ "y__"
messageInstance :: Env QName -> T.Text -> MessageInfo Name -> [[Match]]
messageInstance env protoName m =
[ [ match "messageName" [pWildCard] $
"Data.Text.pack" @@ stringExp (T.unpack protoName)]
, [ match "fieldsByTag" [] $
let' (map (fieldDescriptorVarBind $ messageName m) $ fields)
$ "Data.Map.fromList" @@ list fieldsByTag ]
, [ match "unknownFields" [] $ rawFieldAccessor (unQual $ messageUnknownFields m) ]
, [ match "defMessage" []
$ recConstr (unQual $ messageName m) $
[ fieldUpdate (unQual $ haskellRecordFieldName
$ fieldName $ plainFieldInfo f)
(hsFieldDefault env f)
| f <- messageFields m
] ++
[ fieldUpdate (unQual $ haskellRecordFieldName $ oneofFieldName o)
"Prelude.Nothing"
| o <- messageOneofFields m
] ++
[ fieldUpdate (unQual $ messageUnknownFields m)
"[]"]
]
, [ match "parseMessage" [] $ generatedParser env m ]
, [ match "buildMessage" [] $ generatedBuilder m ]
]
where
fieldsByTag =
[tuple
[ t, fieldDescriptorVar f ]
| f <- fields
, let t = "Data.ProtoLens.Tag"
@@ litInt (fromIntegral
$ fieldDescriptor (plainFieldInfo f) ^. number)
]
fieldDescriptorVar = var . unQual . fieldDescriptorName
fieldDescriptorName f
= nameFromSymbol $ overloadedName (fieldName . plainFieldInfo $ f)
<> "__field_descriptor"
fieldDescriptorVarBind n f
= funBind
[match (fieldDescriptorName f) []
$ fieldDescriptorExpr env n f
]
fields = messageFields m
++ (messageOneofFields m >>= fmap casePlainField . oneofCases)
casePlainField = PlainFieldInfo OptionalMaybeField . caseField
textFormatFieldName :: Env QName -> 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 QName -> Name -> PlainFieldInfo
-> Exp
fieldDescriptorExpr env n f =
("Data.ProtoLens.FieldDescriptor"
@@ stringExp (T.unpack $ textFormatFieldName env fd)
@@ (fieldTypeDescriptorExpr (fd ^. type')
@::@
("Data.ProtoLens.FieldTypeDescriptor"
@@ hsFieldType env (plainFieldInfo f)))
@@ fieldAccessorExpr f)
@::@
("Data.ProtoLens.FieldDescriptor" @@ tyCon (unQual n))
where
fd = fieldDescriptor $ plainFieldInfo f
fieldAccessorExpr :: PlainFieldInfo -> Exp
fieldAccessorExpr (PlainFieldInfo kind f) = accessorCon @@ fieldOfExp hsFieldName
where
accessorCon = case kind of
RequiredField
-> "Data.ProtoLens.PlainField" @@ "Data.ProtoLens.Required"
OptionalValueField
-> "Data.ProtoLens.PlainField" @@ "Data.ProtoLens.Optional"
OptionalMaybeField
-> "Data.ProtoLens.OptionalField"
MapField entry
-> "Data.ProtoLens.MapField"
@@ fieldOfExp (overloadedField $ keyField entry)
@@ fieldOfExp (overloadedField $ valueField entry)
RepeatedField packed ->
"Data.ProtoLens.RepeatedField"
@@ if packed == Packed
then "Data.ProtoLens.Packed"
else "Data.ProtoLens.Unpacked"
hsFieldName
= case kind of
OptionalMaybeField -> "maybe'" <> overloadedField f
_ -> overloadedField f
fieldOfExp :: Symbol -> Exp
fieldOfExp sym = "Data.ProtoLens.Field.field" @@ typeApp (promoteSymbol sym)
overloadedField :: FieldInfo -> Symbol
overloadedField = overloadedName . fieldName
fieldTypeDescriptorExpr :: FieldDescriptorProto'Type -> Exp
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 = fromString ("Data.ProtoLens." ++ x)
@@ fromString ("Data.ProtoLens." ++ y)
messageRnfExpr :: MessageInfo Name -> Exp
messageRnfExpr msg = lambda ["x__"] $ foldr (@@) "()" (map seqField fieldNames)
where
fieldNames = messageUnknownFields msg
: map (haskellRecordFieldName . fieldName . plainFieldInfo)
(messageFields msg)
++ map (haskellRecordFieldName . oneofFieldName)
(messageOneofFields msg)
seqField :: Name -> Exp
seqField f = "Control.DeepSeq.deepseq" @@ (var (unQual f) @@ "x__")
oneofRnfMatch :: OneofCase -> Match
oneofRnfMatch c = match "rnf" [unQual (caseConstructorName c) `pApp` ["x__"]]
$ "Control.DeepSeq.rnf" @@ "x__"