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 Language.MessagePack.IDL.Syntax
data Config
= Config
{ configFilePath :: FilePath
, configModule :: String
}
deriving (Show, Eq)
generate:: Config -> Spec -> IO ()
generate Config {..} spec = do
let name = takeBaseName configFilePath
once = map toUpper name
mods = LT.splitOn "::" $ LT.pack configModule
LT.writeFile (name ++ "_types.rb") $ templ configFilePath [lt|
require 'msgpack/rpc'
#{genModule mods $ LT.concat $ map (genTypeDecl name) spec }|]
LT.writeFile (name ++ "_client.rb") $ templ configFilePath [lt|
require 'msgpack/rpc'
require './#{name}_types'
#{genModule (snoc mods "Client") $ LT.concat $ map genClient spec}|]
genTypeDecl :: String -> Decl -> LT.Text
genTypeDecl _ MPMessage {..} =
genMsg msgName msgFields False
genTypeDecl _ MPException {..} =
genMsg excName excFields True
genTypeDecl _ _ = ""
genMsg name flds isExc = [lt|
class #{capitalizeT name}#{deriveError}
def to_msgpack(out = '')
[#{afs}].to_msgpack(out)
end
def from_unpacked(unpacked)
#{afs} = unpacked
end
#{indent 2 $ LT.concat writers}
#{indent 2 $ genAccessors sorted_flds}
end
|]
where
sorted_flds = sortField flds
fs = map (maybe undefined fldName) sorted_flds
writers = map (maybe undefined genAttrWriter) sorted_flds
afs = T.intercalate ", " $ map (mappend "@") fs
deriveError = if isExc then [lt| < StandardError|] else ""
capitalizeT :: T.Text -> T.Text
capitalizeT a = T.cons (toUpper $ T.head a) (T.tail a)
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 ind "" = ""
indentLine ind line = mappend (LT.pack $ replicate ind ' ') line
extractJust :: [Maybe a] -> [a]
extractJust [] = []
extractJust (Nothing:xs) = extractJust xs
extractJust (Just v:xs) = v : extractJust xs
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
genAttrWriter :: Field -> LT.Text
genAttrWriter Field {..} = genAttrWriter' fldType fldName
genAttrWriter' :: Type -> T.Text -> LT.Text
genAttrWriter' TBool n = [lt|
def #{n}=(val)
@#{n} = val.to_b
end
|]
genAttrWriter' (TMap kt vt) n = [lt|
def #{n}=(val)
@#{n} = {}
val.each do |k, v|
#{indent 4 $ convert "k" "newk" kt}
#{indent 4 $ convert "v" "newv" vt}
end
end
|]
where
convert from to (TUserDef t p) =
genConvertingType from to (TUserDef t p)
convert from to _ = [lt|#{to} = #{from}|]
genAttrWriter' (TUserDef name types) n = [lt|
def #{n}=(val)
#{indent 2 $ convert "val" atn (TUserDef name types)}
end
|]
where
atn = [lt|@#{n}|]
convert from to (TUserDef t p) =
genConvertingType from to (TUserDef t p)
genAttrWriter' _ _ = ""
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 v (TUserDef t _) = [lt|
#{v} = #{capitalizeT t}.new
#{v}.from_unpacked(#{unpacked})|]
genConvertingType _ _ _ = ""
genConvertingType' :: LT.Text -> LT.Text -> Type -> LT.Text
genConvertingType' unpacked v (TUserDef t p) = [lt|
#{genConvertingType unpacked v (TUserDef t p)}
return v|]
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 xs x = xs ++ [x]