protobuf-simple-0.1.0.5: src/Parser/MessageGenerator.hs
-- |
-- Module: Parser.MessageGenerator
-- Copyright: (c) 2015-2016 Martijn Rijkeboer <mrr@sru-systems.com>
-- License: MIT
-- Maintainer: Martijn Rijkeboer <mrr@sru-systems.com>
--
-- Generate code for Message types.
module Parser.MessageGenerator
( getMessageCode
) where
import Control.Monad.State (State, get)
import Data.List (foldl', intersperse)
import Data.Monoid ((<>))
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (Builder, fromString, toLazyText)
import Parser.CaseUtils (toPascal)
import Parser.FieldDesc (FieldDesc)
import Parser.FileDesc (FileDesc)
import Parser.GeneratorUtils
import Parser.MessageDesc (MessageDesc)
import qualified Parser.FieldDesc as FieldDesc
import qualified Parser.FileDesc as FileDesc
import qualified Parser.Label as Label
import qualified Parser.MessageDesc as MessageDesc
import qualified Parser.Type as Type
getMessageCode :: FileDesc -> MessageDesc -> State GenState Text
getMessageCode f md = do
commentLine <- getComment
moduleLine <- getModule f md
importLines <- getImports f md
typeLines <- getType f md
defaultInst <- getDefaultInst f md
mergeableInst <- getMergeableInst md
requiredInst <- getRequiredInst f md
wireMessageInst <- getWireMessageInst f md
return $ toLazyText $
commentLine <> nl <>
moduleLine <> nl <>
importLines <> nl <>
typeLines <> nl <>
defaultInst <> nl <>
mergeableInst <> nl <>
requiredInst <> nl <>
wireMessageInst <> nl
getModule :: FileDesc -> MessageDesc -> State GenState Builder
getModule f md = do
modName <- getModuleName f md
return $
fromString "module " <>
fromString modName <>
fromString " where" <> nl
getModuleName :: FileDesc -> MessageDesc -> State GenState String
getModuleName f md = return $ case FileDesc.getPackage f of
Just package -> package ++ "." ++ messageName
Nothing -> fileName ++ "." ++ messageName
where
fileName = FileDesc.getName f
messageName = MessageDesc.getName md
getImports :: FileDesc -> MessageDesc -> State GenState Builder
getImports f md = return $
(if null (MessageDesc.getFields md)
then fromString ""
else getUnqualifiedImport "Control.Applicative" "(<$>)") <>
getUnqualifiedImport "Prelude" "" <>
getQualifiedAsImport "Data.ProtoBufInt" "PB" <>
getExtraImports f md
getExtraImports :: FileDesc -> MessageDesc -> Builder
getExtraImports f md = foldl' (<>) empty imports
where
imports = map (getExtraImport f) cfields
cfields = filter FieldDesc.isCustom $ MessageDesc.getFields md
getExtraImport :: FileDesc -> FieldDesc -> Builder
getExtraImport f fd = getQualifiedImport $ getNamespace f ++ "." ++ typeName
where
typeName = FieldDesc.getTypeName fd
getType :: FileDesc -> MessageDesc -> State GenState Builder
getType f md = case MessageDesc.getFields md of
[] -> getUnitType f md
[fd] -> getNewtypeType f md fd
fds -> getDataType f md fds
getUnitType :: FileDesc -> MessageDesc -> State GenState Builder
getUnitType _ md = return $
fromString "data " <>
fromString name <>
fromString " = " <>
fromString name <>
nl <>
tab <>
fromString "deriving (PB.Show, PB.Eq, PB.Ord)" <>
nl
where name = MessageDesc.getName md
getNewtypeType :: FileDesc -> MessageDesc -> FieldDesc -> State GenState Builder
getNewtypeType f md fd = do
fieldLine <- getFieldLine f md fd
return $
fromString "newtype " <>
fromString name <>
fromString " = " <>
fromString name <>
nl <>
tab <>
fromString "{ " <>
fieldLine <>
nl <>
tab <>
fromString "} deriving (PB.Show, PB.Eq, PB.Ord)" <>
nl
where
name = MessageDesc.getName md
getDataType :: FileDesc -> MessageDesc -> [FieldDesc] -> State GenState Builder
getDataType f md fds = do
fieldLines <- getFieldLines f md fds
return $
fromString "data " <>
fromString name <>
fromString " = " <>
fromString name <>
nl <> tab <>
fromString "{ " <>
fieldLines <>
nl <>
tab <>
fromString "} deriving (PB.Show, PB.Eq, PB.Ord)" <> nl
where name = MessageDesc.getName md
getDefaultInst :: FileDesc -> MessageDesc -> State GenState Builder
getDefaultInst f md = do
defaultLines <- getDefaultLines f fields
return $
fromString "instance PB.Default " <> fromString name <> fromString " where" <> nl <>
tab <> fromString "defaultVal = " <> fromString name <> nl <>
tab <> tab <> fromString "{ " <>
defaultLines <> nl <>
tab <> tab <> fromString "}" <> nl
where
name = MessageDesc.getName md
fields = MessageDesc.getFields md
getDefaultLines :: FileDesc -> [FieldDesc] -> State GenState Builder
getDefaultLines f fds = fmap (foldl' (<>) empty) ilines
where
ilines = fmap (intersperse separator) flines
flines = mapM (getDefaultLine f) fds
separator = nl <> tab <> tab <> fromString ", "
getDefaultLine :: FileDesc -> FieldDesc -> State GenState Builder
getDefaultLine f fd = do
dval <- getDefaultValue f fd
return $ fname <> fromString " = " <> dval
where fname = fromString $ FieldDesc.getName fd
getDefaultValue :: FileDesc -> FieldDesc -> State GenState Builder
getDefaultValue f fd = do
state <- get
return $ fromString $ case FieldDesc.getLabel fd of
Label.Required -> "PB.defaultVal"
Label.Repeated -> "PB.defaultVal"
Label.Optional -> case FieldDesc.getDefaultValue fd of
Nothing -> "PB.defaultVal"
Just val -> case FieldDesc.getType fd of
(Just Type.Bool) -> if val == "true"
then "PB.Just PB.True"
else "PB.Just PB.False"
(Just Type.Bytes) -> "PB.DefaultVal"
(Just Type.String) -> "PB.Just (PB.pack " ++ val ++ ")"
(Just Type.Double) -> "PB.Just " ++ val
(Just Type.Fixed32) -> "PB.Just " ++ val
(Just Type.Fixed64) -> "PB.Just " ++ val
(Just Type.Float) -> "PB.Just " ++ val
(Just Type.Int32) -> "PB.Just " ++ val
(Just Type.Int64) -> "PB.Just " ++ val
(Just Type.SFixed32) -> "PB.Just " ++ val
(Just Type.SFixed64) -> "PB.Just " ++ val
(Just Type.SInt32) -> "PB.Just " ++ val
(Just Type.SInt64) -> "PB.Just " ++ val
(Just Type.UInt32) -> "PB.Just " ++ val
(Just Type.UInt64) -> "PB.Just " ++ val
_ -> if isEnum f fd state
then "PB.Just " ++ enumValue val
else "PB.DefaultVal"
where
enumValue v = namespace ++ "." ++ enumType ++ "." ++ enumName v
namespace = getNamespace f
enumType = FieldDesc.getTypeName fd
enumName v = toPascal [v]
getFieldLines :: FileDesc -> MessageDesc -> [FieldDesc] -> State GenState Builder
getFieldLines f md fds = fmap (foldl' (<>) empty) ilines
where
ilines = fmap (intersperse separator) flines
flines = mapM (getFieldLine f md) fds
separator = nl <> tab <> fromString ", "
getFieldLine :: FileDesc -> MessageDesc -> FieldDesc -> State GenState Builder
getFieldLine f md fd = do
fname <- getFieldName fd
ftype <- getFieldType f md fd
return $ fname <> fromString " :: " <> ftype
getFieldName :: FieldDesc -> State GenState Builder
getFieldName = return . fromString . FieldDesc.getName
getFieldType :: FileDesc -> MessageDesc -> FieldDesc -> State GenState Builder
getFieldType f md fd = return $ case FieldDesc.getLabel fd of
Label.Optional ->
if fieldCount > 1
then fromString "!(PB.Maybe " <> innerType <> fromString ")"
else fromString "PB.Maybe " <> innerType
Label.Required ->
if fieldCount > 1
then fromString "!" <> innerType
else innerType
Label.Repeated ->
if fieldCount > 1
then fromString "!(PB.Seq " <> innerType <> fromString ")"
else fromString "PB.Seq " <> innerType
where
fieldCount = length $ MessageDesc.getFields md
innerType = getFieldInnerType f fd
getFieldInnerType :: FileDesc -> FieldDesc -> Builder
getFieldInnerType f fd = fromString $ case FieldDesc.getType fd of
(Just Type.Bool) -> "PB.Bool"
(Just Type.Bytes) -> "PB.ByteString"
(Just Type.Double) -> "PB.Double"
(Just Type.Fixed32) -> "PB.Word32"
(Just Type.Fixed64) -> "PB.Word64"
(Just Type.Float) -> "PB.Float"
(Just Type.Int32) -> "PB.Int32"
(Just Type.Int64) -> "PB.Int64"
(Just Type.SFixed32) -> "PB.Int32"
(Just Type.SFixed64) -> "PB.Int64"
(Just Type.SInt32) -> "PB.Int32"
(Just Type.SInt64) -> "PB.Int64"
(Just Type.String) -> "PB.Text"
(Just Type.UInt32) -> "PB.Word32"
(Just Type.UInt64) -> "PB.Word64"
_ -> namespace ++ "." ++ typeName ++ "." ++ typeName
where
namespace = getNamespace f
typeName = FieldDesc.getTypeName fd
getMergeableInst :: MessageDesc -> State GenState Builder
getMergeableInst md = do
mergeableLines <- getMergeableLines fields
return $
fromString "instance PB.Mergeable " <> fromString name <> fromString " where" <> nl <>
tab <> (if mergeableLines == fromString ""
then fromString "merge _ _ = "
else fromString "merge a b = ") <> fromString name <> nl <>
tab <> tab <> fromString "{ " <>
mergeableLines <> nl <>
tab <> tab <> fromString "}" <> nl
where
name = MessageDesc.getName md
fields = MessageDesc.getFields md
getMergeableLines :: [FieldDesc] -> State GenState Builder
getMergeableLines fds = fmap (foldl' (<>) empty) ilines
where
ilines = fmap (intersperse separator) flines
flines = mapM getMergeableLine fds
separator = nl <> tab <> tab <> fromString ", "
getMergeableLine :: FieldDesc -> State GenState Builder
getMergeableLine fd = return $
fieldName <>
fromString " = PB.merge (" <>
fieldName <>
fromString " a) (" <>
fieldName <>
fromString " b)"
where fieldName = fromString $ FieldDesc.getName fd
getRequiredInst :: FileDesc -> MessageDesc -> State GenState Builder
getRequiredInst f md = do
reqTags <- getRequiredWireTags f fields
return $
fromString "instance PB.Required " <> name <> fromString " where" <> nl <>
tab <> fromString "reqTags _ = PB.fromList [" <>
reqTags <>
fromString "]" <> nl
where
name = fromString $ MessageDesc.getName md
fields = MessageDesc.getFields md
getRequiredWireTags :: FileDesc -> [FieldDesc] -> State GenState Builder
getRequiredWireTags f fds = do
tags <- mapM (getWireTag False f) rfields
return $ foldl' (<>) empty (intersperse separator tags)
where
separator = fromString ", "
rfields = filter FieldDesc.isRequired fds
getWireTag :: Packed -> FileDesc -> FieldDesc -> State GenState Builder
getWireTag packed f fd = do
wireType <- getWireType packed f fd
return $ header <> space <> fieldNumber <> space <> wireType
where
header = fromString "PB.WireTag"
fieldNumber = fromString $ show $ FieldDesc.getNumber fd
getWireType :: Packed -> FileDesc -> FieldDesc -> State GenState Builder
getWireType packed f fd = do
state <- get
return $ fromString $ if packed
then "PB.LenDelim"
else case FieldDesc.getType fd of
(Just Type.Bool) -> "PB.VarInt"
(Just Type.Bytes) -> "PB.LenDelim"
(Just Type.Double) -> "PB.Bit64"
(Just Type.Fixed32) -> "PB.Bit32"
(Just Type.Fixed64) -> "PB.Bit64"
(Just Type.Float) -> "PB.Bit32"
(Just Type.Int32) -> "PB.VarInt"
(Just Type.Int64) -> "PB.VarInt"
(Just Type.SFixed32) -> "PB.Bit32"
(Just Type.SFixed64) -> "PB.Bit64"
(Just Type.SInt32) -> "PB.VarInt"
(Just Type.SInt64) -> "PB.VarInt"
(Just Type.String) -> "PB.LenDelim"
(Just Type.UInt32) -> "PB.VarInt"
(Just Type.UInt64) -> "PB.VarInt"
_ -> if isEnum f fd state
then "PB.VarInt"
else "PB.LenDelim"
getWireMessageInst :: FileDesc -> MessageDesc -> State GenState Builder
getWireMessageInst f md = do
mlines <- getMessageToFieldLines f fields
flines <- getFieldToValueLines f fields
return $
fromString "instance PB.WireMessage " <> fromString name <> fromString " where" <> nl <>
flines <> nl <>
tab <> if mlines == fromString ""
then fromString "messageToFields _ = PB.return ()" <> nl
else fromString "messageToFields self = do" <> nl <>
mlines <> nl
where
name = MessageDesc.getName md
fields = MessageDesc.getFields md
getMessageToFieldLines :: FileDesc -> [FieldDesc] -> State GenState Builder
getMessageToFieldLines f fds = do
flines <- mapM (getMessageToFieldLine f) fds
return $ foldl' (<>) empty flines
getMessageToFieldLine :: FileDesc -> FieldDesc -> State GenState Builder
getMessageToFieldLine f fd = do
state <- get
fun <- getMessageToFieldFun f fd
tag <- getWireTag (isPacked f fd state) f fd
return $
tab <> tab <>
fun <>
fromString " (" <>
tag <>
fromString ") (" <>
name <>
fromString " self)" <>
nl
where
name = fromString $ FieldDesc.getName fd
getMessageToFieldFun :: FileDesc -> FieldDesc -> State GenState Builder
getMessageToFieldFun f fd = case FieldDesc.getLabel fd of
Label.Optional -> getMessageToFieldFunOpt f fd
Label.Repeated -> getMessageToFieldFunRep f fd
Label.Required -> getMessageToFieldFunReq f fd
getMessageToFieldFunOpt :: FileDesc -> FieldDesc -> State GenState Builder
getMessageToFieldFunOpt f fd = do
fun <- getMessageToFieldFunReq f fd
return $ fun <> fromString "Opt"
getMessageToFieldFunRep :: FileDesc -> FieldDesc -> State GenState Builder
getMessageToFieldFunRep f fd = do
state <- get
fun <- getMessageToFieldFunReq f fd
return $ fun <> if isPacked f fd state
then fromString "Packed"
else fromString "List"
getMessageToFieldFunReq :: FileDesc -> FieldDesc -> State GenState Builder
getMessageToFieldFunReq f fd = do
state <- get
return $ fromString $ case FieldDesc.getType fd of
(Just Type.Bool) -> "PB.putBool"
(Just Type.Bytes) -> "PB.putBytes"
(Just Type.Double) -> "PB.putDouble"
(Just Type.Fixed32) -> "PB.putFixed32"
(Just Type.Fixed64) -> "PB.putFixed64"
(Just Type.Float) -> "PB.putFloat"
(Just Type.Int32) -> "PB.putInt32"
(Just Type.Int64) -> "PB.putInt64"
(Just Type.SFixed32) -> "PB.putSFixed32"
(Just Type.SFixed64) -> "PB.putSFixed64"
(Just Type.SInt32) -> "PB.putSInt32"
(Just Type.SInt64) -> "PB.putSInt64"
(Just Type.String) -> "PB.putString"
(Just Type.UInt32) -> "PB.putUInt32"
(Just Type.UInt64) -> "PB.putUInt64"
_ -> if isEnum f fd state
then "PB.putEnum"
else "PB.putMessage"
getFieldToValueDefault :: Builder
getFieldToValueDefault =
tab <>
fromString "fieldToValue tag self = PB.getUnknown tag self" <>
nl
getFieldToValueLines :: FileDesc -> [FieldDesc] -> State GenState Builder
getFieldToValueLines f fds = do
flines <- mapM (getFieldToValueLine f) fds
return $ foldl' (<>) empty flines <> getFieldToValueDefault
getFieldToValueLine :: FileDesc -> FieldDesc -> State GenState Builder
getFieldToValueLine f fd = case FieldDesc.getLabel fd of
Label.Optional -> (<> nl) <$> getFieldToValueOpt f fd
Label.Repeated -> (<> nl) <$> getFieldToValueRep f fd
Label.Required -> (<> nl) <$> getFieldToValueReq f fd
getFieldToValueOpt :: FileDesc -> FieldDesc -> State GenState Builder
getFieldToValueOpt f fd = do
line <- getFieldToValueReq f fd
return $ line <> fromString "Opt"
getFieldToValueRep :: FileDesc -> FieldDesc -> State GenState Builder
getFieldToValueRep f fd = do
state <- get
if isPacked f fd state
then do
packedLine <- getFieldToValueRepPacked f fd
listLine <- getFieldToValueRepList f fd
return $ packedLine <> nl <> listLine
else getFieldToValueRepList f fd
getFieldToValueRepList :: FileDesc -> FieldDesc -> State GenState Builder
getFieldToValueRepList f fd = do
fun <- getFieldToValueFun f fd
tag <- getWireTag False f fd
return $
tab <>
fromString "fieldToValue (" <>
tag <>
fromString ") self = (\\v -> self{" <>
name <>
fromString " = PB.append (" <>
name <>
fromString " self) v}) <$> " <>
fun
where
name = fromString $ FieldDesc.getName fd
getFieldToValueRepPacked :: FileDesc -> FieldDesc -> State GenState Builder
getFieldToValueRepPacked f fd = do
line <- getFieldToValueReq f fd
return $ line <> fromString "Packed"
getFieldToValueReq :: FileDesc -> FieldDesc -> State GenState Builder
getFieldToValueReq f fd = do
state <- get
fun <- getFieldToValueFun f fd
tag <- getWireTag (isPacked f fd state) f fd
return $
tab <>
fromString "fieldToValue (" <>
tag <>
fromString ") self = (\\v -> self{" <>
name <>
fromString " = PB.merge (" <>
name <>
fromString " self) v}) <$> " <>
fun
where
name = fromString $ FieldDesc.getName fd
getFieldToValueFun :: FileDesc -> FieldDesc -> State GenState Builder
getFieldToValueFun f fd = do
state <- get
return $ fromString $ case FieldDesc.getType fd of
(Just Type.Bool) -> "PB.getBool"
(Just Type.Bytes) -> "PB.getBytes"
(Just Type.Double) -> "PB.getDouble"
(Just Type.Fixed32) -> "PB.getFixed32"
(Just Type.Fixed64) -> "PB.getFixed64"
(Just Type.Float) -> "PB.getFloat"
(Just Type.Int32) -> "PB.getInt32"
(Just Type.Int64) -> "PB.getInt64"
(Just Type.SFixed32) -> "PB.getSFixed32"
(Just Type.SFixed64) -> "PB.getSFixed64"
(Just Type.SInt32) -> "PB.getSInt32"
(Just Type.SInt64) -> "PB.getSInt64"
(Just Type.String) -> "PB.getString"
(Just Type.UInt32) -> "PB.getUInt32"
(Just Type.UInt64) -> "PB.getUInt64"
_ -> if isEnum f fd state
then "PB.getEnum"
else "PB.getMessage"