{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.ProtoLens.Compiler.Generate(
generateModule,
fileSyntaxType,
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 (isNothing, 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'Label(..)
, FieldDescriptorProto'Type(..)
, FileDescriptorProto
)
import Proto.Google.Protobuf.Descriptor_Fields
( defaultValue
, label
, mapEntry
, maybe'oneofIndex
, maybe'packed
, name
, number
, options
, syntax
, type'
, typeName
)
import Data.ProtoLens.Compiler.Combinators
import Data.ProtoLens.Compiler.Definitions
data SyntaxType = Proto2 | Proto3
deriving (Show, Eq)
fileSyntaxType :: FileDescriptorProto -> SyntaxType
fileSyntaxType f = case f ^. syntax of
"proto2" -> Proto2
"proto3" -> Proto3
"" -> Proto2
s -> error $ "Unknown syntax type " ++ show s
data UseReexport = UseReexport | UseOriginal
deriving (Eq, Read)
generateModule :: ModuleName
-> [ModuleName]
-> SyntaxType
-> ModifyImports
-> Env Name
-> Env QName
-> [ServiceInfo]
-> [Module]
generateModule modName imports syntaxType modifyImport definitions importedEnv services
= [ Module modName
(Just $ (serviceExports ++) $ concatMap generateExports $ Map.elems definitions)
pragmas
(prismImport: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"]
, optionsGhcPragma "-fno-warn-unused-imports"
, optionsGhcPragma "-fno-warn-duplicate-exports"
]
prismImport = modifyImport $ importSimple "Lens.Labels.Prism"
sharedImports = map (modifyImport . importSimple)
[ "Prelude", "Data.Int", "Data.Word"
, "Data.ProtoLens", "Data.ProtoLens.Message.Enum", "Data.ProtoLens.Service.Types"
, "Lens.Family2", "Lens.Family2.Unchecked", "Data.Default.Class"
, "Data.Text", "Data.Map", "Data.ByteString", "Data.ByteString.Char8"
, "Lens.Labels", "Text.Read"
]
++ map importSimple imports
env = Map.union (unqualifyEnv definitions) importedEnv
generateDecls (protoName, Message m)
= generateMessageDecls fieldModName syntaxType env (stripDotPrefix protoName) m
++ map uncommented (concatMap (generatePrisms env) (messageOneofFields m))
generateDecls (_, Enum e) = map uncommented $ generateEnumDecls syntaxType e
generateExports (Message m) = generateMessageExports m
++ concatMap generatePrismExports (messageOneofFields m)
generateExports (Enum e) = generateEnumExports syntaxType e
serviceExports = fmap generateServiceExports services
allLensNames = F.toList $ Set.fromList
[ lensSymbol inst
| Message m <- Map.elems definitions
, info <- allMessageFields syntaxType env m
, inst <- recordFieldLenses info
]
stripDotPrefix s
| Just ('.', s') <- T.uncons s = s'
| otherwise = s
allMessageFields :: SyntaxType -> Env QName -> MessageInfo Name -> [RecordField]
allMessageFields syntaxType env info =
map (plainRecordField syntaxType 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.Reexport." ++ 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 =
map (exportAll . unQual)
$ messageName m : map 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 -> SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> [CommentedDecl]
generateMessageDecls fieldModName syntaxType 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.Show", "Prelude.Eq", "Prelude.Ord"]
] ++
[ uncommented $ dataDecl (oneofTypeName oneofInfo)
[ conDecl consName [hsFieldType env $ fieldDescriptor f]
| c <- oneofCases oneofInfo
, let f = caseField c
, let consName = caseConstructorName c
]
$ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]
| oneofInfo <- messageOneofFields info
] ++
[ uncommented $
instDecl [classA "Lens.Labels.HasLens'" ["f", dataType, "x", "a"],
equalP "a" "b"]
("Lens.Labels.HasLens" `ihApp`
["f", dataType, dataType, "x", "a", "b"])
[[match "lensOf" [] "Lens.Labels.lensOf'"]]
]
++
[ uncommented $ instDecl [classA "Prelude.Functor" ["f"]]
("Lens.Labels.HasLens'" `ihApp`
["f", dataType, sym, tyParen t])
[[match "lensOf'" [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.Default.Class.Default" `ihApp` [dataType])
[
[ match "def" []
$ recConstr (unQual dataName) $
[ fieldUpdate (unQual $ haskellRecordFieldName $ plainFieldName f)
(hsFieldDefault syntaxType env (fieldDescriptor f))
| f <- messageFields info
] ++
[ fieldUpdate (unQual $ haskellRecordFieldName $ oneofFieldName o)
"Prelude.Nothing"
| o <- messageOneofFields info
] ++
[ fieldUpdate (unQual $ messageUnknownFields info)
"[]"]
]
]
, uncommented $ instDecl [] ("Data.ProtoLens.Message" `ihApp` [dataType])
$ messageInstance syntaxType env protoName info
]
where
dataType = tyCon $ unQual dataName
dataName = messageName info
allFields = allMessageFields syntaxType 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 = [ alt "_otherwise" "Prelude.Nothing" ]
generateTypeSig f funName =
typeSig [funName] $ "Lens.Labels.Prism.Prism'"
@@ (tyCon . unQual $ oneofTypeName oneofInfo)
@@ (hsFieldType env $ fieldDescriptor f)
generateFunDef otherwiseCase consName =
"Lens.Labels.Prism.prism'"
@@ con (unQual consName)
@@ (lambda ["p__"] $
case' "p__" $
[ alt (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 :: SyntaxType -> EnumInfo Name -> [ExportSpec]
generateEnumExports syntaxType 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 = if syntaxType == Proto3
then [exportVar . unQual $ enumUnrecognizedValueName e]
else []
generateServiceExports :: ServiceInfo -> ExportSpec
generateServiceExports si = exportAll $ unQual $ fromString $ T.unpack $ serviceName si
generateEnumDecls :: SyntaxType -> EnumInfo Name -> [Decl]
generateEnumDecls Proto3 info =
[ dataDecl dataName
( (flip conDecl [] <$> constructorNames)
++ [conDecl unrecognizedName [tyCon $ unQual unrecognizedValueName]]
)
$ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]
, newtypeDecl unrecognizedValueName
"Data.Int.Int32"
$ deriving' ["Prelude.Eq", "Prelude.Ord", "Prelude.Show"]
, instDecl [] ("Data.ProtoLens.MessageEnum" `ihApp` [dataType])
[ [ match "maybeToEnum" [pLitInt k] $ "Prelude.Just" @@ con (unQual c)
| (c, k) <- constructorNumbers
]
++
[match "maybeToEnum" ["k"]
$ "Prelude.Just" @@
(con (unQual unrecognizedName)
@@ (con (unQual unrecognizedValueName)
@@ ("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)
[pApp (unQual unrecognizedValueName) [pVar "k"]]
]
$ "Prelude.show" @@ "k"
]
, [ match "readEnum" [stringPat 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)
[pApp (unQual unrecognizedValueName) [pVar "k"]]
]
$ "Prelude.fromIntegral" @@ "k"
]
, 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.Default.Class.Default" `ihApp` [dataType])
[[match "def" [] defaultCon]]
, instDecl [] ("Data.ProtoLens.FieldDefault" `ihApp` [dataType])
[[match "fieldDefault" [] defaultCon]]
] ++
concat
[ [ patSynSig aliasName dataType
, patSyn (pVar aliasName) (pVar originalName)
]
| EnumValueInfo
{ enumValueName = aliasName
, enumAliasOf = Just originalName
} <- enumValues info
]
where
EnumInfo { enumName = dataName
, enumUnrecognizedName = unrecognizedName
, enumUnrecognizedValueName = unrecognizedValueName
, 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 [pWildCard]
("Prelude.error" @@ stringExp (concat
[ prettyPrint dataName, ".", prettyPrint funName, ": bad argument: unrecognized value"
]))
]
generateEnumDecls Proto2 info =
[ dataDecl dataName
[conDecl n [] | n <- constructorNames]
$ deriving' ["Prelude.Show", "Prelude.Eq", "Prelude.Ord"]
, instDecl [] ("Data.Default.Class.Default" `ihApp` [dataType])
[[match "def" [] defaultCon]]
, instDecl [] ("Data.ProtoLens.FieldDefault" `ihApp` [dataType])
[[match "fieldDefault" [] defaultCon]]
, instDecl [] ("Data.ProtoLens.MessageEnum" `ihApp` [dataType])
[
[ match "maybeToEnum" [pLitInt k]
$ "Prelude.Just" @@ con (unQual n)
| (n, k) <- constructorNumbers
]
++
[ match "maybeToEnum" [pWildCard] "Prelude.Nothing"
]
++
[ match "showEnum" [pVar n] $ stringExp $ T.unpack pn
| (n, pn) <- constructorProtoNames
]
++
[ match "readEnum" [stringPat $ T.unpack pn]
$ "Prelude.Just" @@ con (unQual n)
| (n, pn) <- constructorProtoNames
]
++
[ match "readEnum" [pWildCard] "Prelude.Nothing"
]
]
, 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
]
, 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 [] ("Prelude.Bounded" `ihApp` [dataType])
[[ match "minBound" [] $ con $ unQual minBoundName
, match "maxBound" [] $ con $ unQual maxBoundName
]]
]
++
concat
[ [ patSynSig aliasName dataType
, patSyn (pVar aliasName) (pVar originalName)
]
| EnumValueInfo
{ enumValueName = aliasName
, enumAliasOf = Just originalName
} <- enumValues info
]
where
dataType = tyCon $ unQual dataName
EnumInfo { enumName = dataName, enumDescriptor = ed } = info
constructors :: [(Name, EnumValueDescriptorProto)]
constructors = List.sortBy (comparing ((^. number) . snd))
[(n, d) | EnumValueInfo
{ enumValueName = n
, enumValueDescriptor = d
, enumAliasOf = Nothing
} <- enumValues info
]
constructorNames = map fst constructors
minBoundName = head constructorNames
maxBoundName = last constructorNames
constructorProtoNames = map (second (^. name)) constructors
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
]
alias funName implName = [match funName [] implName]
defaultCon = con $ unQual $ head constructorNames
errorMessageExpr = "Prelude.error"
@@ ("Prelude.++" @@ stringExp errorMessage
@@ ("Prelude.show" @@ "k__"))
errorMessage = "toEnum: unknown value for enum " ++ unpack (ed ^. name)
++ ": "
generateFieldDecls :: Symbol -> [Decl]
generateFieldDecls xStr =
[ typeSig [x]
$ tyForAll ["f", "s", "t", "a", "b"]
[classA "Lens.Labels.HasLens" ["f", "s", "t", xSym, "a", "b"]]
$ "Lens.Family2.LensLike" @@ "f" @@ "s" @@ "t" @@ "a" @@ "b"
, funBind [match x [] $ lensOfExp 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 :: SyntaxType -> Env QName -> FieldInfo -> RecordField
plainRecordField syntaxType env f = case fd ^. label of
FieldDescriptorProto'LABEL_REQUIRED
-> recordField baseType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = rawAccessor
}]
FieldDescriptorProto'LABEL_OPTIONAL
| isDefaultingOptional syntaxType fd
-> recordField baseType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = rawAccessor
}]
| otherwise ->
recordField maybeType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = baseType
, lensExp = maybeAccessor
}
, LensInstance
{ lensSymbol = "maybe'" <> baseName
, lensFieldType = maybeType
, lensExp = rawAccessor
}
]
FieldDescriptorProto'LABEL_REPEATED
| Just (k,v) <- getMapFields env fd -> let
mapType = "Data.Map.Map" @@ hsFieldType env (fieldDescriptor k)
@@ hsFieldType env (fieldDescriptor v)
in recordField mapType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = mapType
, lensExp = rawAccessor
}]
| otherwise -> recordField listType
[LensInstance
{ lensSymbol = baseName
, lensFieldType = listType
, lensExp = rawAccessor
}]
where
recordField = RecordField (haskellRecordFieldName $ plainFieldName f)
baseName = overloadedName $ plainFieldName f
fd = fieldDescriptor f
baseType = hsFieldType env fd
maybeType = "Prelude.Maybe" @@ baseType
listType = tyList baseType
rawAccessor = "Prelude.id"
maybeAccessor = "Data.ProtoLens.maybeLens"
@@ hsFieldValueDefault env fd
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 $ plainFieldName f
, let baseType = hsFieldType env $ fieldDescriptor f
, let maybeName = "maybe'" <> baseName
]
getMapFields :: Env QName -> FieldDescriptorProto
-> Maybe (FieldInfo, FieldInfo)
getMapFields env f
| f ^. type' == FieldDescriptorProto'TYPE_MESSAGE
, Message m@MessageInfo { messageDescriptor = d } <- definedFieldType f env
, d ^. options.mapEntry
, [f1, f2] <- messageFields m = Just (f1, f2)
| otherwise = Nothing
hsFieldType :: Env QName -> FieldDescriptorProto -> Type
hsFieldType env fd = case fd ^. type' of
FieldDescriptorProto'TYPE_DOUBLE -> "Prelude.Double"
FieldDescriptorProto'TYPE_FLOAT -> "Prelude.Float"
FieldDescriptorProto'TYPE_INT64 -> "Data.Int.Int64"
FieldDescriptorProto'TYPE_UINT64 -> "Data.Word.Word64"
FieldDescriptorProto'TYPE_INT32 -> "Data.Int.Int32"
FieldDescriptorProto'TYPE_FIXED64 -> "Data.Word.Word64"
FieldDescriptorProto'TYPE_FIXED32 -> "Data.Word.Word32"
FieldDescriptorProto'TYPE_BOOL -> "Prelude.Bool"
FieldDescriptorProto'TYPE_STRING -> "Data.Text.Text"
FieldDescriptorProto'TYPE_GROUP
| Message m <- definedFieldType fd env -> tyCon $ messageName m
| otherwise -> error $ "expected TYPE_GROUP for type name"
++ unpack (fd ^. typeName)
FieldDescriptorProto'TYPE_MESSAGE
| Message m <- definedFieldType fd env -> tyCon $ messageName m
| otherwise -> error $ "expected TYPE_MESSAGE for type name"
++ unpack (fd ^. typeName)
FieldDescriptorProto'TYPE_BYTES -> "Data.ByteString.ByteString"
FieldDescriptorProto'TYPE_UINT32 -> "Data.Word.Word32"
FieldDescriptorProto'TYPE_ENUM
| Enum e <- definedFieldType fd env -> tyCon $ enumName e
| otherwise -> error $ "expected TYPE_ENUM for type name"
++ unpack (fd ^. typeName)
FieldDescriptorProto'TYPE_SFIXED32 -> "Data.Int.Int32"
FieldDescriptorProto'TYPE_SFIXED64 -> "Data.Int.Int64"
FieldDescriptorProto'TYPE_SINT32 -> "Data.Int.Int32"
FieldDescriptorProto'TYPE_SINT64 -> "Data.Int.Int64"
hsFieldDefault :: SyntaxType -> Env QName -> FieldDescriptorProto -> Exp
hsFieldDefault syntaxType env fd
= case fd ^. label of
FieldDescriptorProto'LABEL_OPTIONAL
| isDefaultingOptional syntaxType fd -> hsFieldValueDefault env fd
| otherwise -> "Prelude.Nothing"
FieldDescriptorProto'LABEL_REPEATED
| Just _ <- getMapFields env fd -> "Data.Map.empty"
| otherwise -> list []
FieldDescriptorProto'LABEL_REQUIRED -> hsFieldValueDefault env fd
hsFieldValueDefault :: Env QName -> FieldDescriptorProto -> Exp
hsFieldValueDefault env fd = case fd ^. type' of
FieldDescriptorProto'TYPE_MESSAGE -> "Data.Default.Class.def"
FieldDescriptorProto'TYPE_GROUP -> "Data.Default.Class.def"
FieldDescriptorProto'TYPE_ENUM
| T.null def -> "Data.Default.Class.def"
| 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__"
[ alt
(pApp "Prelude.Just" [pApp (unQual consName) ["x__val"]])
("Prelude.Just" @@ "x__val")
, alt
"_otherwise"
"Prelude.Nothing"
]
setter = lambda ["_", "y__"]
$ "Prelude.fmap" @@ con (unQual consName) @@ "y__"
messageInstance :: SyntaxType -> Env QName -> T.Text -> MessageInfo Name -> [[Match]]
messageInstance syntaxType 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) ]
]
where
fieldsByTag =
[tuple
[ t, fieldDescriptorVar f ]
| f <- fields
, let t = "Data.ProtoLens.Tag"
@@ litInt (fromIntegral
$ fieldDescriptor f ^. number)
]
fieldDescriptorVar = var . unQual . fieldDescriptorName
fieldDescriptorName f
= nameFromSymbol $ overloadedName (plainFieldName f) <> "__field_descriptor"
fieldDescriptorVarBind n f
= funBind
[match (fieldDescriptorName f) []
$ fieldDescriptorExpr syntaxType env n f
]
fields = messageFields m
++ (messageOneofFields m >>= fmap caseField . oneofCases)
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 :: SyntaxType -> Env QName -> Name -> FieldInfo
-> Exp
fieldDescriptorExpr syntaxType env n f =
("Data.ProtoLens.FieldDescriptor"
@@ stringExp (T.unpack $ textFormatFieldName env fd)
@@ (fieldTypeDescriptorExpr (fd ^. type')
@::@
("Data.ProtoLens.FieldTypeDescriptor"
@@ hsFieldType env fd))
@@ fieldAccessorExpr syntaxType env f)
@::@
("Data.ProtoLens.FieldDescriptor" @@ tyCon (unQual n))
where
fd = fieldDescriptor f
fieldAccessorExpr :: SyntaxType -> Env QName -> FieldInfo -> Exp
fieldAccessorExpr syntaxType env f = accessorCon @@ lensOfExp hsFieldName
where
fd = fieldDescriptor f
accessorCon = case fd ^. label of
FieldDescriptorProto'LABEL_REQUIRED
-> "Data.ProtoLens.PlainField" @@ "Data.ProtoLens.Required"
FieldDescriptorProto'LABEL_OPTIONAL
| isDefaultingOptional syntaxType fd
-> "Data.ProtoLens.PlainField" @@ "Data.ProtoLens.Optional"
| otherwise -> "Data.ProtoLens.OptionalField"
FieldDescriptorProto'LABEL_REPEATED
| Just (k, v) <- getMapFields env fd
-> "Data.ProtoLens.MapField"
@@ lensOfExp (overloadedField k)
@@ lensOfExp (overloadedField v)
| otherwise -> "Data.ProtoLens.RepeatedField"
@@ if isPackedField syntaxType fd
then "Data.ProtoLens.Packed"
else "Data.ProtoLens.Unpacked"
hsFieldName
= case fd ^. label of
FieldDescriptorProto'LABEL_OPTIONAL
| not (isDefaultingOptional syntaxType fd)
-> "maybe'" <> overloadedField f
_ -> overloadedField f
lensOfExp :: Symbol -> Exp
lensOfExp sym = ("Lens.Labels.lensOf"
@@ ("Lens.Labels.proxy#" @::@
("Lens.Labels.Proxy#" @@ promoteSymbol sym)))
overloadedField :: FieldInfo -> Symbol
overloadedField = overloadedName . plainFieldName
isDefaultingOptional :: SyntaxType -> FieldDescriptorProto -> Bool
isDefaultingOptional syntaxType f
= f ^. label == FieldDescriptorProto'LABEL_OPTIONAL
&& syntaxType == Proto3
&& f ^. type' /= FieldDescriptorProto'TYPE_MESSAGE
&& isNothing (f ^. maybe'oneofIndex)
isPackedField :: SyntaxType -> FieldDescriptorProto -> Bool
isPackedField s f = case f ^. options . maybe'packed of
Just t -> t
Nothing -> s == Proto3
&& f ^. type' `notElem`
[ FieldDescriptorProto'TYPE_MESSAGE
, FieldDescriptorProto'TYPE_GROUP
, FieldDescriptorProto'TYPE_STRING
, FieldDescriptorProto'TYPE_BYTES
]
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)