Types.hs

{-# LANGUAGE OverloadedStrings #-}
-- |ROS message types.
module Types (MsgType(..), MsgField(..), MsgConst(..),
              MsgName, msgName, requestMsgName, responseMsgName,
              shortName, rawName, fullRosMsgName,
              fullRosSrvName,
              Msg(..), hasHeader, Srv(..),
              requestResponseNames) where
import Data.ByteString.Char8 (ByteString)
import Data.Char (toUpper)

-- |A variant type describing the types that may be included in a ROS
-- message.
data MsgType = RBool | RInt8 | RUInt8 | RInt16 | RUInt16
             | RInt32 | RUInt32 | RInt64 | RUInt64
             | RFloat32 | RFloat64 | RString | RTime | RDuration
             | RFixedArray Int MsgType | RVarArray MsgType
             | RUserType ByteString | RByte | RChar
               deriving (Show, Eq, Ord)

data MsgField = MsgField { fieldName    :: ByteString
                         , fieldType    :: MsgType
                         , rawFieldName :: ByteString }
                deriving Show

data MsgConst = MsgConst { constName    :: ByteString
                         , constType    :: MsgType
                         , rawValue     :: ByteString 
                         , rawConstName :: ByteString }
                deriving Show

-- | A Haskell type name for a message definition.
data MsgName = MsgName { msgRawName :: String
                       , msgTypeName :: String } deriving Show

-- | Build a Haskell type name for a message. This ensures the name is
-- a valid Haskell type name.
msgName :: String -> MsgName
msgName [] = error "An empty message name is impossible!"
msgName n@(x:xs) = MsgName n (toUpper x : xs)

requestMsgName :: String -> MsgName
requestMsgName name = msgName $ name ++ "Request"

responseMsgName :: String -> MsgName
responseMsgName name = msgName $ name ++ "Response"

-- | Pull the Haskell type name for a message from a 'Msg'.
shortName :: Msg -> String
shortName = msgTypeName . shortTypeName

-- | Extract the original, raw, name of a message definition. This may
-- differ from the 'shortName' in that 'shortName' will always be
-- capitalized.
rawName :: Msg -> String
rawName = msgRawName . shortTypeName

-- | Get the full ROS name of a message type. This will be of the
-- form, @packageName/msgName@.
fullRosMsgName :: Msg -> String
fullRosMsgName m = msgPackage m ++ '/' : rawName m

fullRosSrvName :: Srv -> String
fullRosSrvName s = srvPackage s ++ '/' : (msgRawName . srvName) s

-- |A message has a short name, a long name, an md5 sum, and a list of
-- named, typed fields.
data Msg = Msg { shortTypeName :: MsgName
               , msgPackage    :: String
               , msgSource     :: ByteString
               , fields        :: [MsgField]
               , constants     :: [MsgConst] }

instance Show Msg where
    show (Msg sn ln _ f c) = unwords 
                             ["Msg", show sn, show ln, show f, show c]

hasHeader :: Msg -> Bool
hasHeader msg = case fields msg of
                  --((_, RUserType "Header"):_) -> True
                  (MsgField _ (RUserType "Header") _ : _) -> True
                  _ -> False

-- |A service has a request message, a response message, and a name.
data Srv = Srv { srvName :: MsgName
               , srvPackage :: String
               , srvSource :: ByteString
               , srvRequest :: Msg
               , srvResponse :: Msg
               }

instance Show Srv where
  show (Srv name package _ req res) =
    unwords ["Srv", show name, show package, show req, show res]

requestResponseNames :: Srv -> [String]
requestResponseNames srv = [reqName, resName]
  where
    reqName = shortName . srvRequest $ srv
    resName = shortName . srvResponse $ srv