module Language.MessagePack.IDL.CodeGen.Ruby (
Config(..),
generate,
) where
import Data.Char
import Data.List
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.IO as LT
import System.FilePath
import Text.Shakespeare.Text
import System.Directory
import Language.MessagePack.IDL.Syntax
data Config
= Config
{ configFilePath :: FilePath
, configModule :: String
}
deriving (Show, Eq)
generate:: Config -> Spec -> IO ()
generate Config {..} spec = do
createDirectoryIfMissing True (takeBaseName configFilePath);
setCurrentDirectory (takeBaseName configFilePath);
let
mods = LT.splitOn "::" $ LT.pack configModule
LT.writeFile "types.rb" $ [lt|
require 'msgpack/rpc'
#{genModule mods $ LT.concat $ map (genTypeDecl "") spec }
|]
LT.writeFile ("client.rb") $ templ configFilePath [lt|
require 'msgpack/rpc'
require './types'
#{genModule (snoc mods "Client") $ LT.concat $ map genClient spec}|]
genTypeDecl :: String -> Decl -> LT.Text
genTypeDecl _ MPType {..} = [lt|
class #{capitalizeT tyName}
def #{capitalizeT tyName}.from_tuple(tuple)
#{fromTuple tyType "tuple"}
end
def to_tuple(o)
o
end
end
|]
genTypeDecl _ MPMessage {..} =
genMsg msgName msgFields False
genTypeDecl _ MPException {..} =
genMsg excName excFields True
genTypeDecl _ _ = ""
genMsg :: T.Text -> [Field] -> Bool -> LT.Text
genMsg name flds isExc = [lt|
class #{capitalizeT name}#{deriveError}
def initialize(#{T.intercalate ", " fs})
#{LT.intercalate "\n " $ map makeSubst fs}
end
def to_tuple
[#{LT.intercalate ",\n " $ map make_tuple flds}]
end
def to_msgpack(out = '')
to_tuple.to_msgpack(out)
end
def #{capitalizeT name}.from_tuple(tuple)
#{capitalizeT name}.new(
#{LT.intercalate ",\n " $ map make_arg flds}
)
end
#{indent 2 $ genAccessors sorted_flds}
end
|]
where
sorted_flds = sortField flds
fs = map (maybe undefined fldName) sorted_flds
make_tuple Field {..} =
[lt|#{toTuple True fldType fldName}|]
deriveError = if isExc then [lt| < StandardError|] else ""
make_arg Field {..} =
let fldIdstr = T.concat $ map T.pack ["tuple[", (show fldId), "]"]
in [lt|#{fromTuple fldType fldIdstr}|]
makeSubst :: T.Text -> LT.Text
makeSubst fld = [lt| @#{fld} = #{fld} |]
toTuple :: Bool -> Type -> T.Text -> LT.Text
toTuple _ (TTuple ts) name =
let elems = map (f name) (zip [0..] ts) in
[lt| [#{LT.concat elems}] |]
where
f :: T.Text -> (Integer, Type) -> LT.Text
f n (i, (TUserDef _fg _ )) = [lt|#{n}[#{show i}].to_tuple}, |]
f n (i, _) = [lt|#{n}[#{show i}], |]
toTuple True t name = [lt|@#{toTuple False t name}|]
toTuple _ (TNullable t) name = [lt|#{toTuple False t name}|]
toTuple _ (TInt _ _) name = [lt|#{name}|]
toTuple _ (TFloat _) name = [lt|#{name}|]
toTuple _ TBool name = [lt|#{name}|]
toTuple _ TRaw name = [lt|#{name}|]
toTuple _ TString name = [lt|#{name}|]
toTuple _ (TList typ) name = [lt|#{name}.map {|x| #{toTuple False typ "x"}}|]
toTuple _ (TMap typ1 typ2) name =
[lt|#{name}.each_with_object({}) {|(k,v),h| h[#{toTuple False typ1 "k"}] = #{toTuple False typ2 "v"}}|]
toTuple _ (TUserDef _ _) name = [lt|#{name}.to_tuple|]
toTuple _ _ _ = ""
fromTuple :: Type -> T.Text -> LT.Text
fromTuple (TNullable t) name = [lt|#{fromTuple t name}|]
fromTuple (TInt _ _) name = [lt|#{name}|]
fromTuple (TFloat _) name = [lt|#{name}|]
fromTuple TBool name = [lt|#{name}|]
fromTuple TRaw name = [lt|#{name}|]
fromTuple TString name = [lt|#{name}|]
fromTuple (TList typ) name =
[lt|#{name}.map { |x| #{fromTuple typ "x"} }|]
fromTuple (TMap typ1 typ2) name =
[lt|#{name}.each_with_object({}) {|(k,v),h| h[#{fromTuple typ1 "k"}] = #{fromTuple typ2 "v"} }|]
fromTuple (TUserDef className _) name = [lt|#{capitalizeT className}.from_tuple(#{name})|]
fromTuple (TTuple ts) name =
let elems = map (f name) (zip [0..] ts) in
[lt| [#{LT.concat elems}] |]
where
f :: T.Text -> (Integer, Type) -> LT.Text
f n (i, (TUserDef className _ )) = [lt|#{capitalizeT className}.from_tuple(#{n}[#{show i}], |]
f n (i, _) = [lt|#{n}[#{show i}], |]
fromTuple (TObject) name = [lt|#{name}|]
fromTuple TVoid _ = ""
capitalizeT :: T.Text -> T.Text
capitalizeT a = T.cons (toUpper $ T.head a) (T.tail a)
sortField :: [Field] -> [Maybe Field]
sortField flds =
flip map [0 .. maximum $ [1] ++ map fldId flds] $ \ix -> find ((==ix). fldId) flds
indent :: Int -> LT.Text -> LT.Text
indent ind lines = indentedConcat ind $ LT.lines lines
indentedConcat :: Int -> [LT.Text] -> LT.Text
indentedConcat ind lines =
LT.dropAround (== '\n') $ LT.unlines $ map (indentLine ind) lines
indentLine :: Int -> LT.Text -> LT.Text
indentLine _ "" = ""
indentLine ind line = mappend (LT.pack $ replicate ind ' ') line
data AccessorType = Read | ReadWrite deriving Eq
getAccessorType :: Type -> AccessorType
getAccessorType TBool = Read
getAccessorType (TMap _ _) = Read
getAccessorType (TUserDef _ _) = Read
getAccessorType _ = ReadWrite
genAccessors :: [Maybe Field] -> LT.Text
genAccessors [] = ""
genAccessors fs = [lt|
#{genAccessors' Read "attr_reader" fs}#{genAccessors' ReadWrite "attr_accessor" fs}|]
genAccessors' :: AccessorType -> String -> [Maybe Field] -> LT.Text
genAccessors' at an flds = gen $ map (maybe undefined fldName) $ filter fldTypeEq flds
where
gen [] = ""
gen fs = [lt|
#{an} #{T.intercalate ", " $ map (mappend ":") fs}|]
fldTypeEq (Just Field {..}) = at == getAccessorType fldType
fldTypeEq Nothing = False
genClient :: Decl -> LT.Text
genClient MPService {..} = [lt|
class #{capitalizeT serviceName}
def initialize(host, port)
@cli = MessagePack::RPC::Client.new(host, port)
end#{LT.concat $ map genMethodCall serviceMethods}
end
|]
where
genMethodCall Function {..} = [lt|
def #{methodName}(#{defArgs})
#{indent 4 $ genConvertingType' callStr "v" methodRetType}
end|]
where
defArgs = T.intercalate ", " $ map fldName methodArgs
callStr = [lt|@cli.call(#{callArgs})|]
callArgs = mappend ":" $ T.intercalate ", " $ methodName : sortedArgNames
sortedArgNames = map (maybe undefined fldName) $ sortField methodArgs
genClient _ = ""
genConvertingType :: LT.Text -> LT.Text -> Type -> LT.Text
genConvertingType unpacked _ (TUserDef t _) = [lt|
#{capitalizeT t}.from_tuple(#{unpacked})|]
genConvertingType _ _ _ = ""
genConvertingType' :: LT.Text -> LT.Text -> Type -> LT.Text
genConvertingType' unpacked v (TUserDef t p) = [lt|
#{genConvertingType unpacked v (TUserDef t p)}
|]
genConvertingType' unpacked _ _ = [lt|#{unpacked}|]
templ :: FilePath -> LT.Text -> LT.Text
templ filepath content = [lt|# This file is autogenerated from #{filepath}
# *** DO NOT EDIT ***
#{content}
|]
genModule :: [LT.Text] -> LT.Text -> LT.Text
genModule modules content = f modules
where
f [] = [lt|#{content}|]
f (n:ns) = [lt|module #{n}
#{f ns}
end|]
snoc :: [a] -> a -> [a]
snoc xs x = xs ++ [x]