module Language.MessagePack.IDL.CodeGen.Haskell (
Config(..),
generate,
) where
import Data.Char
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 Text.Shakespeare.Text
import Language.MessagePack.IDL.Syntax as MP
data Config
= Config
{ configFilePath :: FilePath
}
generate :: Config -> Spec -> IO ()
generate Config {..} spec = do
LT.writeFile "Types.hs" [lt|
module Types where
import Data.Int
import Data.MessagePack
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Words
#{LT.concat $ map genTypeDecl spec}
|]
LT.writeFile "Server.hs" [lt|
|]
LT.writeFile "Client.hs" [lt|
module Server where
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Network.MessagePackRpc.Client as MP
import Types
#{LT.concat $ map genClient spec}
|]
genClient :: Decl -> LT.Text
genClient MPService {..} =
[lt|
newtype #{monadName} m a
= #{monadName} { un#{monadName} :: StateT () m a }
deriving (Monad, MonadIO, MonadTrans, MonadState ())
#{LT.concat $ map genMethod serviceMethods}
|]
where
monadName = classize (serviceName) `mappend` "T"
genMethod Function {..} =
let ts = map (genType . fldType) methodArgs in
let typs = ts ++ [ [lt|#{monadName} (#{genRetType methodRetType})|] ] in
[lt|
#{methodize methodName} :: #{LT.intercalate " -> " typs}
#{methodize methodName} = MP.method "#{methodName}"
|]
genMethod f = error $ "unsupported: " ++ show f
genClient _ = ""
genTypeDecl :: Decl -> LT.Text
genTypeDecl MPMessage {..} =
let mems = LT.intercalate "\n , " $ map f msgFields in
[lt|
data #{dataName}
= #{dataName}
{ #{mems}
}
deriving (Eq, Show)
deriveObject False ''#{dataName}
|]
where
dataName = classize msgName
f Field {..} =
let fname = uncapital dataName `mappend` (capital $ camelize fldName) in
[lt|#{fname} :: #{genType fldType}|]
genTypeDecl _ = ""
genType :: Type -> LT.Text
genType (TInt sign bits) =
let base = if sign then "Int" else "Word" :: T.Text in
[lt|#{base}#{show bits}|]
genType (TFloat False) =
[lt|Float|]
genType (TFloat True) =
[lt|Double|]
genType TBool =
[lt|Bool|]
genType TRaw =
[lt|ByteString|]
genType TString =
[lt|Text|]
genType (TList typ) =
[lt|[#{genType typ}]|]
genType (TMap typ1 typ2) =
[lt|Map (#{genType typ1}) (#{genType typ2})|]
genType (TTuple typs) =
[lt|(#{LT.intercalate ", " $ map genType typs})|]
genType (TUserDef name params) =
[lt|#{classize name}|]
genType (TObject) =
undefined
genRetType :: Maybe Type -> LT.Text
genRetType Nothing = "()"
genRetType (Just t) = genType t
classize :: T.Text -> T.Text
classize = capital . camelize
methodize :: T.Text -> T.Text
methodize = uncapital . camelize
camelize :: T.Text -> T.Text
camelize = T.concat . map capital . T.words . T.map ubToSpc where
ubToSpc '_' = ' '
ubToSpc c = c
capital :: T.Text -> T.Text
capital word =
(T.map toUpper $ T.take 1 word) `mappend` T.drop 1 word
uncapital :: T.Text -> T.Text
uncapital word =
(T.map toLower $ T.take 1 word) `mappend` T.drop 1 word