language-thrift-0.3.0.0: examples/generateHaskellTypes.hs
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
-- This is a fairly simple code generator that uses language-thrift to parse
-- IDL files and produces pretty printed Haskell code for all the types.
--
-- For services, it just generates a simple GADT that defines the inputs and
-- outputs for that service. Service inheritanec is not supported and
-- service method exceptions are ignored.
import Prelude hiding ((<$>))
import Data.Char (toLower, toUpper)
import Data.Maybe (isNothing)
import Data.Text (Text, unpack)
import System.Exit (exitFailure)
import System.IO (stderr, stdout)
import qualified Data.Text as Text
import qualified Text.PrettyPrint.ANSI.Leijen as AnsiPP
import Text.PrettyPrint.Leijen hiding (list, tupled)
import Text.Trifecta (Result (..), parseString)
import Text.Trifecta.Delta (Delta (Directed))
import Language.Thrift.Parser.Trifecta (thriftIDL)
import Language.Thrift.Types
die :: String -> IO a
die s = putStrLn s >> exitFailure
-- | '<$>' with the arguments flipped.
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip fmap
infixl 1 <&>
($$) :: Docstring -> Doc -> Doc
($$) Nothing y = y
($$) (Just t) y = case Text.lines t of
[] -> y
l:ls -> let docstring = align . vsep
$ (text "-- |" <+> text (unpack l))
: map ((text "--" <+>) . text . unpack) ls
in align (docstring <$> y)
infixr 1 $$
list :: [Doc] -> Doc
list = encloseSep lbracket rbracket (text ", ")
tupled :: [Doc] -> Doc
tupled = encloseSep lparen rparen (text ", ")
renderConstValue :: ConstValue -> Doc
renderConstValue (ConstInt i) = integer i
renderConstValue (ConstFloat f) = double f
renderConstValue (ConstLiteral l) = dquotes $ text (unpack l) -- TODO escaping
renderConstValue (ConstIdentifier i) = text (unpack i)
renderConstValue (ConstList l) = list (map renderConstValue l)
renderConstValue (ConstMap m) = text "Map.fromList" <+> list (map renderConstTuple m)
where
renderConstTuple (a, b) = tupled [
renderConstValue a
, renderConstValue b
]
renderFieldType :: FieldType -> Doc
renderFieldType (DefinedType t) = text (unpack t)
renderFieldType (StringType _) = text "Text"
renderFieldType (BinaryType _) = text "ByteString"
renderFieldType (BoolType _) = text "Bool"
renderFieldType (ByteType _) = text "Word8"
renderFieldType (I16Type _) = text "Word16"
renderFieldType (I32Type _) = text "Word32"
renderFieldType (I64Type _) = text "Word64"
renderFieldType (DoubleType _) = text "Double"
renderFieldType (MapType k v _) =
parens $ hsep [text "Map", renderFieldType k, renderFieldType v]
renderFieldType (SetType i _) = parens $ text "Set" <+> renderFieldType i
renderFieldType (ListType i _) = brackets $ renderFieldType i
renderFieldType t = error $ "Unsupported field type: " ++ show t
renderStructField :: Show a => Text -> Field a -> Doc
renderStructField structName (Field _ req ftype fname def _ docstring _) = hang 4 $
docstring $$
fieldName </>
hsep [
text "::"
, (if isOptional
then text "Maybe" <> space
else empty) <> renderFieldType ftype
]
where
isOptional
| isNothing req = False
| otherwise = r == Optional && isNothing def
where (Just r) = req
fieldName = text . unpack $ Text.concat [
structName
, underscoresToCamelCase False fname
]
renderType :: Show a => Type a -> Doc
renderType = go
where
derivingClause =
text "deriving" <+> tupled (map text ["Show", "Ord", "Eq"])
go (Typedef fieldType name docstring _) = docstring $$
hsep [text "type", typeName name, equals, renderFieldType fieldType]
go (Enum name defs docstring _) = docstring $$
text "data" <+> typeName name <>
encloseSep (text " = ") empty (text " | ") (map renderDef defs)
<$$> indent 4 derivingClause
where
renderDef (EnumDef e _ _ docstring _) = docstring $$ typeName e
go (Exception name fields docstring a) = go (Struct name fields docstring a)
go (Struct name fields docstring _) = docstring $$
text "data" <+> typeName name </> equals <+> typeName name <$$>
(if null fields
then empty
else indent 2 renderFields)
</> derivingClause
-- TODO prefix should be configurable using annotations
where
renderFields =
encloseSep (text "{ ") (line <> text "}") (text ", ") $
map (renderStructField structName) fields
structName = underscoresToCamelCase True name
go (Union name fields docstring _) =
hang 4
(docstring $$
text "data" <+> typeName name <$>
encloseSep (text "= ") empty (text " | ")
(map renderField fields))
<$$> indent 4 derivingClause
where
structName = underscoresToCamelCase False name
renderField (Field _ _ ftype fname _ _ docstring _) =
docstring $$ fieldName </> renderFieldType ftype
where
fieldName = text . unpack $ Text.concat [
structName
, underscoresToCamelCase False fname
]
go t = error $ "Unsupported type: " ++ show t
typeName :: Text -> Doc
typeName = mkName False
generateOutput :: Show a => Program a -> IO ()
generateOutput (Program _ definitions) = do
let doc = headers <$> empty <$>
vcat (map ((<$> empty) . genDef) definitions)
displayIO stdout $ renderPretty 0.8 80 doc
where
import_ m items = sep [
text "import"
, text m
, maybe empty (tupled . map string) items
]
importQualified m s = sep [
text "import qualified"
, text m
, text "as"
, text s
]
headers = vcat [
import_ "Data.Map" (Just ["Map"])
, import_ "Data.Set" (Just ["Set"])
, import_ "Data.Text" (Just ["Text"])
, import_ "Data.ByteString" (Just ["ByteString"])
, import_ "Data.Word" (Just ["Word8", "Word16", "Word32", "Word64"])
, text ""
, importQualified "Data.Map" "Map"
]
genDef :: Show a => Definition a -> Doc
genDef (ConstDefinition fieldType name value docstring _) = docstring $$
sep [fieldName name, text "::", renderFieldType fieldType] <$>
sep [fieldName name, text "=", renderConstValue value]
genDef (TypeDefinition typeDef _) = renderType typeDef
genDef (ServiceDefinition sname Nothing funcs _ docstring _) = docstring $$
text "data" <+> typeName sname <+> text "a where" <$$>
indent 2 (vcat (map renderFunc funcs))
where
renderFunc (Function False rtype name params _ _ docstring _) =
docstring $$
typeName name <+> text "::" <>
(if null params
then space
else linebreak <> renderParams name params) <>
typeName sname <+> returnType
<> linebreak
where
returnType = case rtype of
Nothing -> text "()"
Just t -> renderFieldType t
renderParams fname params = indent 2 $
encloseSep (text "{ ") (line <> text "} -> ") (text ", ") $
map (renderStructField structName) params
where
structName = underscoresToCamelCase True fname
fieldName = mkName True
mkName :: Bool -> Text -> Doc
mkName lowerFirst = text . unpack . underscoresToCamelCase lowerFirst
underscoresToCamelCase :: Bool -> Text -> Text
underscoresToCamelCase lowerFirst =
camelCase lowerFirst . Text.split (== '_')
camelCase :: Bool -> [Text] -> Text
camelCase lowerFirst =
maybeLower . Text.concat . map (transformIndex toUpper 0)
where
maybeLower = if lowerFirst then transformIndex toLower 0 else id
transformIndex :: (Char -> Char) -> Int -> Text -> Text
transformIndex f i s = Text.concat [
Text.take i s
, Text.singleton $ f (s `Text.index` i)
, Text.drop (i + 1) s
]
main :: IO ()
main = do
result <- getContents <&> parseString thriftIDL (Directed "stdin" 0 0 0 0)
case result of
Success p -> generateOutput p
Failure doc -> do
AnsiPP.displayIO stderr $ AnsiPP.renderPretty 0.8 80 doc
die "Parse Failed"