module Language.MessagePack.IDL.CodeGen.Php (
Config(..),
generate,
) where
import Data.Char
import Data.List
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 Data.Monoid
import Language.MessagePack.IDL.Syntax
data Config
= Config
{ configFilePath :: FilePath
}
deriving (Show, Eq)
generate:: Config -> Spec -> IO ()
generate Config {..} spec = do
let name = takeBaseName configFilePath
once = map toUpper name
LT.writeFile (name ++ "_types.php") $ templ configFilePath once "TYPES" [lt|
include_once 'Net/MessagePackRPC.php';
#{LT.concat $ map genTypeDecl spec}
class ObjectDecoder {
public static $USER_DEFINED_CLASSES = array(
#{LT.concat $ map genClassName spec}
);
public static function decodeToObject($ret_array, $type_array) {
if ($type_array == "") {
// do nothing
$ret = $ret_array;
} else if (in_array($type_array, self::$USER_DEFINED_CLASSES)) {
// array -> object
$ret = new $type_array();
$ret_keys = array_keys((array)$ret);
for ($i = 0; $i < count($ret_keys); $i++) {
$ret->{$ret_keys[$i]} = $ret_array[$i];
}
} else {
// dissolve array
if (is_array($type_array)) {
if (count($type_array) == 1) {
// if array
foreach ($type_array as $key => $type) {
foreach ($ret_array as $ret_key => $ret_value) {
$ret[$ret_key] = $this->decodeToObject($ret_value, $type);
}
}
} else {
// if tuple
$ret = array();
$i = 0;
foreach ($type_array as $type) {
$ret[$i] = $this->decodeToObject($ret_array[$i], $type);
$i++;
}
}
} else {
// type error
return $ret_array;
}
}
return $ret;
}
}
|]
LT.writeFile (name ++ "_client.php") [lt|
<?php
include_once(dirname(__FILE__)."/#{name}_types.php");
#{LT.concat $ map genClient spec}
?>
|]
genClassName :: Decl -> LT.Text
genClassName MPMessage {..} =
[lt| "#{msgName}",
|]
genClassName _ = ""
genTypeDecl :: Decl -> LT.Text
genTypeDecl MPMessage {..} =
genMsg msgName msgFields False
genTypeDecl MPException {..} =
genMsg excName excFields True
genTypeDecl _ = ""
genMsg name flds isExc =
let fields = map f flds
fs = map (maybe undefined fldName) $ sortField flds
in [lt|
class #{name}#{e} {
#{LT.concat fields}
}
|]
where
e = if isExc then [lt| extends Exception|] else ""
f Field {..} = [lt| public $#{fldName};
|]
sortField flds =
flip map [0 .. maximum $ [1] ++ map fldId flds] $ \ix ->
find ((==ix). fldId) flds
genClient :: Decl -> LT.Text
genClient MPService {..} = [lt|
class #{serviceName} {
public function __construct($host, $port) {
$this->client = new MessagePackRPC_Client($host, $port);
}
#{LT.concat $ map genMethodCall serviceMethods}
private $client;
}
|]
where
genMethodCall Function {..} =
let args = LT.intercalate ", " $ map arg methodArgs in
let sortedArgs = LT.intercalate ", " $ map (maybe undefined arg) $ sortField methodArgs in
case methodRetType of
Nothing -> [lt|
public function #{methodName}(#{args}) {
$this->client->call("#{methodName}", array(#{sortedArgs}));
}
|]
Just typ -> [lt|
public function #{methodName}(#{args}) {
$ret = $this->client->call("#{methodName}", array(#{sortedArgs}));
$type_array = #{genTypeArray typ};
return ObjectDecoder::decodeToObject($ret, $type_array);
}
|]
where
arg Field {..} = [lt|$#{fldName}|]
genMethodCall _ = ""
genClient _ = ""
genTypeArray :: Type -> LT.Text
genTypeArray (TList typ) =
[lt|array(#{genTypeArray typ})|]
genTypeArray (TMap typ1 typ2) =
[lt|array(#{genTypeArray typ1} => #{genTypeArray typ2})|]
genTypeArray (TUserDef className params) =
[lt|"#{className}"|]
genTypeArray (TTuple ts) =
foldr1 (\t1 t2 -> [lt|array(#{t1}, #{t2})|]) $ map genTypeArray ts
genTypeArray _ = [lt|""|]
genType :: Type -> LT.Text
genType (TUserDef className params) =
[lt|#{className}|]
genType _ = ""
templ :: FilePath -> String -> String -> LT.Text -> LT.Text
templ filepath once name content = [lt|
// This file is autogenerated from #{filepath}
// *** DO NOT EDIT ***
<?php
#{content}
?>
|]
snoc xs x = xs ++ [x]