module Data.ProtoLens.Compiler.Definitions
( Env
, Definition(..)
, MessageInfo(..)
, FieldInfo(..)
, OneofInfo(..)
, OneofCase(..)
, FieldName(..)
, Symbol
, nameFromSymbol
, promoteSymbol
, EnumInfo(..)
, EnumValueInfo(..)
, qualifyEnv
, unqualifyEnv
, collectDefinitions
, definedFieldType
) where
import Data.Char (isUpper, toUpper)
import Data.Int (Int32)
import Data.List (mapAccumL)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid
import qualified Data.Set as Set
import Data.String (IsString(..))
import Data.Text (Text, cons, splitOn, toLower, uncons, unpack)
import qualified Data.Text as T
import Lens.Family2 ((^.), (^..))
import Proto.Google.Protobuf.Descriptor
( DescriptorProto
, EnumDescriptorProto
, EnumValueDescriptorProto
, FieldDescriptorProto
, FileDescriptorProto
, enumType
, field
, maybe'oneofIndex
, messageType
, name
, nestedType
, number
, oneofDecl
, package
, typeName
, value
)
import Data.ProtoLens.Compiler.Combinators
( Name
, QName
, ModuleName
, Type
, qual
, tyPromotedString
, unQual
)
type Env n = Map.Map Text (Definition n)
data Definition n = Message (MessageInfo n) | Enum (EnumInfo n)
deriving Functor
data MessageInfo n = MessageInfo
{ messageName :: n
, messageDescriptor :: DescriptorProto
, messageFields :: [FieldInfo]
, messageOneofFields :: [OneofInfo]
} deriving Functor
data FieldInfo = FieldInfo
{ fieldDescriptor :: FieldDescriptorProto
, plainFieldName :: FieldName
}
data OneofInfo = OneofInfo
{ oneofFieldName :: FieldName
, oneofTypeName :: Name
, oneofCases :: [OneofCase]
}
data OneofCase = OneofCase
{ caseField :: FieldInfo
, caseConstructorName :: Name
}
data FieldName = FieldName
{ overloadedName :: Symbol
, haskellRecordFieldName :: Name
}
newtype Symbol = Symbol String
deriving (Eq, Ord, IsString, Monoid)
nameFromSymbol :: Symbol -> Name
nameFromSymbol (Symbol s) = fromString s
promoteSymbol :: Symbol -> Type
promoteSymbol (Symbol s) = tyPromotedString s
data EnumInfo n = EnumInfo
{ enumName :: n
, enumDescriptor :: EnumDescriptorProto
, enumValues :: [EnumValueInfo n]
} deriving Functor
data EnumValueInfo n = EnumValueInfo
{ enumValueName :: n
, enumValueDescriptor :: EnumValueDescriptorProto
, enumAliasOf :: Maybe Name
} deriving Functor
mapEnv :: (n -> n') -> Env n -> Env n'
mapEnv f = fmap $ fmap f
qualifyEnv :: ModuleName -> Env Name -> Env QName
qualifyEnv m = mapEnv (qual m)
unqualifyEnv :: Env Name -> Env QName
unqualifyEnv = mapEnv unQual
definedFieldType :: FieldDescriptorProto -> Env QName -> Definition QName
definedFieldType fd env = fromMaybe err $ Map.lookup (fd ^. typeName) env
where
err = error $ "definedFieldType: Field type " ++ unpack (fd ^. typeName)
++ " not found in environment."
collectDefinitions :: FileDescriptorProto -> Env Name
collectDefinitions fd = let
protoPrefix = case fd ^. package of
"" -> "."
p -> "." <> p <> "."
hsPrefix = ""
in Map.fromList $ messageAndEnumDefs protoPrefix hsPrefix
(fd ^. messageType) (fd ^. enumType)
messageAndEnumDefs :: Text -> String -> [DescriptorProto]
-> [EnumDescriptorProto] -> [(Text, Definition Name)]
messageAndEnumDefs protoPrefix hsPrefix messages enums
= concatMap (messageDefs protoPrefix hsPrefix) messages
++ map (enumDef protoPrefix hsPrefix) enums
messageDefs :: Text -> String -> DescriptorProto
-> [(Text, Definition Name)]
messageDefs protoPrefix hsPrefix d
= (protoName, thisDef)
: messageAndEnumDefs
(protoName <> ".")
hsPrefix'
(d ^. nestedType)
(d ^. enumType)
where
protoName = protoPrefix <> d ^. name
hsPrefix' = hsPrefix ++ hsName (d ^. name) ++ "'"
hsName = unpack . capitalize . camelCase
allFields = collectFieldsByOneofIndex (d ^. field)
thisDef =
Message MessageInfo
{ messageName = fromString $ hsPrefix ++ hsName (d ^. name)
, messageDescriptor = d
, messageFields =
map fieldInfo $ Map.findWithDefault [] Nothing allFields
, messageOneofFields =
zipWith oneofInfo [0..]
$ d ^.. oneofDecl . traverse . name
}
fieldInfo f = FieldInfo f $ mkFieldName $ f ^. name
mkFieldName n = FieldName
{ overloadedName = fromString n'
, haskellRecordFieldName = fromString $ "_" ++ hsPrefix' ++ n'
}
where
n' = fieldName n
oneofInfo :: Int32 -> Text -> OneofInfo
oneofInfo idx n = OneofInfo
{ oneofFieldName = mkFieldName n
, oneofTypeName = fromString $ hsPrefix' ++ hsName n
, oneofCases = map oneofCase
$ Map.findWithDefault [] (Just idx)
allFields
}
oneofCase f = OneofCase
{ caseField = fieldInfo f
, caseConstructorName =
fromString $ hsPrefix' ++ hsName (f ^. name)
}
collectFieldsByOneofIndex
:: [FieldDescriptorProto] -> Map.Map (Maybe Int32) [FieldDescriptorProto]
collectFieldsByOneofIndex =
fmap reverse
. Map.fromListWith (++)
. fmap (\f -> (f ^. maybe'oneofIndex, [f]))
fieldName :: Text -> String
fieldName = unpack . disambiguate . camelCase
where
disambiguate s
| s `Set.member` reservedKeywords = s <> "'"
| otherwise = s
camelCase :: Text -> Text
camelCase s =
let (underlines, rest) = T.span (== '_') s
in case splitOn "_" rest of
[] -> error $ "camelCase: splitOn returned empty list: "
++ show rest
[""] -> error $ "camelCase: name consists only of underscores: "
++ show s
s':ss -> T.concat $ underlines : lowerInitialChars s' : map capitalize ss
lowerInitialChars :: Text -> Text
lowerInitialChars s = toLower pre <> post
where (pre, post) = T.span isUpper s
reservedKeywords :: Set.Set Text
reservedKeywords = Set.fromList $
[ "case"
, "class"
, "data"
, "default"
, "deriving"
, "do"
, "else"
, "foreign"
, "if"
, "import"
, "in"
, "infix"
, "infixl"
, "infixr"
, "instance"
, "let"
, "module"
, "newtype"
, "of"
, "then"
, "type"
, "where"
]
++
[ "mdo"
, "rec"
, "pattern"
, "proc"
]
enumDef :: Text -> String -> EnumDescriptorProto
-> (Text, Definition Name)
enumDef protoPrefix hsPrefix d = let
mkText n = protoPrefix <> n
mkHsName n = fromString $ hsPrefix ++ unpack n
in (mkText (d ^. name)
, Enum EnumInfo
{ enumName = mkHsName (d ^. name)
, enumDescriptor = d
, enumValues = collectEnumValues mkHsName $ d ^. value
})
collectEnumValues :: (Text -> Name) -> [EnumValueDescriptorProto]
-> [EnumValueInfo Name]
collectEnumValues mkHsName = snd . mapAccumL helper Map.empty
where
helper :: Map.Map Int32 Name -> EnumValueDescriptorProto
-> (Map.Map Int32 Name, EnumValueInfo Name)
helper seenNames v
| Just n' <- Map.lookup k seenNames = (seenNames, mkValue (Just n'))
| otherwise = (Map.insert k hsName seenNames, mkValue Nothing)
where
mkValue = EnumValueInfo hsName v
hsName = mkHsName n
n = v ^. name
k = v ^. number
capitalize :: Text -> Text
capitalize s
| Just (c, s') <- uncons s = cons (toUpper c) s'
| otherwise = s