diff --git a/rosmsg.cabal b/rosmsg.cabal --- a/rosmsg.cabal +++ b/rosmsg.cabal @@ -1,5 +1,5 @@ name: rosmsg -version: 0.4.4.0 +version: 0.5.0.0 synopsis: ROS message parser, render, TH description: Please see README.md homepage: https://github.com/RoboticsHS/rosmsg#readme @@ -16,6 +16,7 @@ hs-source-dirs: src exposed-modules: Robotics.ROS.Msg , Robotics.ROS.Msg.TH + , Robotics.ROS.Msg.MD5 , Robotics.ROS.Msg.Types , Robotics.ROS.Msg.Parser , Robotics.ROS.Msg.Render diff --git a/src/Robotics/ROS/Msg.hs b/src/Robotics/ROS/Msg.hs --- a/src/Robotics/ROS/Msg.hs +++ b/src/Robotics/ROS/Msg.hs @@ -30,11 +30,11 @@ -- "[Variable (Array (Custom \"Point32\"),\"points\")]" -- module Robotics.ROS.Msg ( - -- * Message classes + -- * ROS Message classes Message(..) , Stamped(..) -- * Common used types - -- ** Array-like types + -- ** Array-like , ROSFixedArray(..) , ROSArray(..) -- ** Time description @@ -42,7 +42,6 @@ , ROSTime ) where -import Data.Digest.Pure.MD5 (MD5Digest) import Data.ByteString (ByteString) import Data.Binary (Binary) import Data.Word (Word32) @@ -50,16 +49,21 @@ import Robotics.ROS.Msg.ROSArray import Robotics.ROS.Msg.Types +import Robotics.ROS.Msg.MD5 -- | Haskell native type for ROS message language described -- data structure. Serialization guaranted by 'Binary' super -- class. And no more is needed for transfer over socket. class Binary a => Message a where - -- | Get MD5 of formal message representation - getDigest :: a -> MD5Digest - -- | Get message type, e.g. @std_msgs/Char@ + -- | Get message type string, e.g. @std_msgs/Char@ getType :: a -> Text + -- | Get message source + getSource :: a -> Text + + -- | Get recurrent MD5 of message source + getDigest :: a -> MD5Digest + -- | Sometime ROS messages have a special @Header@ field. -- It used for tracking package sequence, time stamping -- and frame tagging. Headers is frequently field. The @@ -68,9 +72,12 @@ class Message a => Stamped a where -- | Get sequence number getSequence :: a -> Word32 + -- | Set sequence number setSequence :: Word32 -> a -> a + -- | Get timestamp of message getStamp :: a -> ROSTime + -- | Get frame of message getFrame :: a -> ByteString diff --git a/src/Robotics/ROS/Msg/MD5.hs b/src/Robotics/ROS/Msg/MD5.hs new file mode 100644 --- /dev/null +++ b/src/Robotics/ROS/Msg/MD5.hs @@ -0,0 +1,33 @@ +-- | +-- Module : Robotics.ROS.Msg.MD5 +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : exp +-- Portability : POSIX / WIN32 +-- +-- ROS message MD5 recurrent hash. Replace user types by it's MD5 and +-- take hash of result. +-- +module Robotics.ROS.Msg.MD5 ( + MD5Digest + , computeMD5 + ) where + +import Data.Digest.Pure.MD5 (MD5Digest, md5) +import Data.ByteString.Lazy (fromStrict) +import Data.Text.Encoding (encodeUtf8) +import Data.Text (Text, replace, pack) + +-- | Compute MD5 for given message with user type hashes +-- +-- Recursively generate MD5 for subtype. Have to build up +-- dependency representation for subtype in order to +-- generate MD5. +computeMD5 :: [(Text, MD5Digest)] -- ^ List of pairs: user type name, message hash + -> Text -- ^ Full message source + -> MD5Digest -- ^ Message MD5 +computeMD5 [] msg = md5 (fromStrict (encodeUtf8 msg)) +computeMD5 ((dep, hash) : xs) msg = computeMD5 xs msg' + where msg' = replace dep (pack $ show hash) msg diff --git a/src/Robotics/ROS/Msg/Parser.hs b/src/Robotics/ROS/Msg/Parser.hs --- a/src/Robotics/ROS/Msg/Parser.hs +++ b/src/Robotics/ROS/Msg/Parser.hs @@ -55,21 +55,26 @@ mkField <- choice [flat, array, fixedArray] return (Variable $ mkField typeIdent) where + -- Build-in type parser simpleField = Simple . fst <$> choice (mapM string <$> simpleAssoc) - customField = Custom <$> identifier + -- User type parser + customField = Custom . dropPkgSpec <$> identifier - -- | Flat type is no array + -- Drop package spec from user type + dropPkgSpec = last . T.split (== '/') + + -- Flat type is no array flat = do name <- space *> skipSpace *> identifier <* takeLine return $ flip (,) name - -- | Variable lenght array + -- Variable lenght array array = do name <- skipSpace *> string "[]" *> skipSpace *> identifier <* takeLine return $ flip (,) name . Array - -- | Fixed lenght array + -- Fixed lenght array fixedArray = do len <- skipSpace *> char '[' *> decimal <* char ']' name <- skipSpace *> identifier <* takeLine diff --git a/src/Robotics/ROS/Msg/Render.hs b/src/Robotics/ROS/Msg/Render.hs --- a/src/Robotics/ROS/Msg/Render.hs +++ b/src/Robotics/ROS/Msg/Render.hs @@ -10,13 +10,15 @@ -- The ROS message language builder from abstract message definition. -- module Robotics.ROS.Msg.Render ( - -- * Create lazy text builder from message definition + -- * Lazy Text builder render - -- * Create builder with custom type hook - , render' + -- * Stric Text render + , renderT ) where -import Data.Text.Lazy.Builder (Builder, fromText, fromString) +import Data.Text.Lazy.Builder (Builder, fromText, + fromString, toLazyText) +import Data.Text.Lazy (toStrict) import Data.Char (toLower) import Data.Monoid ((<>)) import Data.Text (Text) @@ -24,25 +26,16 @@ import Robotics.ROS.Msg.Types -- | Builder creator from 'FieldType' -rosType :: (Text -> Text) -> FieldType -> Builder -rosType _ (Simple t) = fromString $ fmap toLower $ drop 1 $ show t -rosType u (Custom t) = fromText $ u t -rosType u (Array t) = rosType u t <> "[]" -rosType u (FixedArray l t) = rosType u t <> "[" <> fromString (show l) <> "]" - --- | Like 'render' by first argument is custom type modifier hook -render' :: (Text -> Text) -> MsgDefinition -> Builder -render' uType = foldl (\a b -> a <> "\n" <> b) mempty . fmap go . sort - where sort v = filter isConstant v ++ filter (not . isConstant) v - go (Constant (typ, name) val) = rosType uType typ <> " " <> - fromText name <> "=" <> fromText val - go (Variable (typ, name)) = rosType uType typ <> " " <> fromText name - isConstant x = case x of - Constant _ _ -> True - _ -> False +rosType :: FieldType -> Builder +rosType (Simple t) = fromString $ fmap toLower $ drop 1 $ show t +rosType (Custom t) = fromText t +rosType (Array t) = rosType t <> "[]" +rosType (FixedArray l t) = rosType t <> "[" <> fromString (show l) <> "]" --- | Render formal ROS message definition according to: +-- | Create lazy text builder from message definition -- +-- Render formal ROS message definition according to: +-- -- * comments removed -- -- * whitespace removed @@ -52,5 +45,27 @@ -- * constants reordered ahead of other declarations -- from http://www.ros.org/wiki/ROS/Technical%20Overview -- +-- The @genmsg@ python implementation says: +-- Compute the text used for md5 calculation. MD5 spec states that we +-- removes comments and non-meaningful whitespace. We also strip +-- packages names from type names. For convenience sake, constants are +-- reordered ahead of other declarations, in the order that they were +-- originally defined. +-- render :: MsgDefinition -> Builder -render = render' id +render [] = "" +render msgdef = unlines1 (go <$> specOrder msgdef) + where specOrder v = filter isConstant v ++ filter (not . isConstant) v + unlines1 = foldl1 (\a b -> a <> "\n" <> b) + + go (Constant (typ, name) val) = rosType typ <> " " <> + fromText name <> "=" <> fromText val + go (Variable (typ, name)) = rosType typ <> " " <> fromText name + + isConstant x = case x of + Constant _ _ -> True + _ -> False + +-- | Render message definition to 'Text' instantly +renderT :: MsgDefinition -> Text +renderT = toStrict . toLazyText . render diff --git a/src/Robotics/ROS/Msg/TH.hs b/src/Robotics/ROS/Msg/TH.hs --- a/src/Robotics/ROS/Msg/TH.hs +++ b/src/Robotics/ROS/Msg/TH.hs @@ -21,26 +21,24 @@ , rosmsgFrom ) where -import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Attoparsec.Text.Lazy (Result(..)) -import Data.Text.Lazy.Builder (toLazyText) import Data.Char (isAlphaNum, toLower) -import Data.Text.Lazy (pack, unpack) -import Data.Digest.Pure.MD5 (md5) import Data.Maybe (catMaybes) -import Text.Printf (printf) +import Data.Text.Lazy (pack) import Data.List (groupBy) import Data.Default (def) import Data.Monoid ((<>)) import qualified Lens.Family2 as L +import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH.Quote import Language.Haskell.TH import qualified Robotics.ROS.Msg.Parser as Parser -import Robotics.ROS.Msg.Render (render') +import Robotics.ROS.Msg.Render (renderT) import Robotics.ROS.Msg.Types +import Robotics.ROS.Msg.MD5 import Robotics.ROS.Msg -- | Generate ROS message declarations from .msg file @@ -58,23 +56,9 @@ } -- | Take user type from text type name -customType :: T.Text -> TypeQ -customType = conT . mkName . T.unpack . qualify . pkgInTypeHook - where -- Some messages (e.g. geometry_msgs/Inertia in `com` field) - -- contains package name in field type declarations - -- it's too strange but exits now, this fix drop - -- package name from type declaration - pkgInTypeHook = last . T.split (== '/') - qualify t = t <> "." <> t - --- | Take list of external types used in message -externalTypes :: MsgDefinition -> [TypeQ] -externalTypes msg = customType <$> catMaybes (go <$> msg) - where - go (Variable (Custom t, _)) = Just t - go (Variable (Array (Custom t), _)) = Just t - go (Variable (FixedArray _ (Custom t), _)) = Just t - go _ = Nothing +customType :: Text -> TypeQ +customType = conT . mkName . T.unpack . qualify + where qualify t = t <> "." <> t -- | Field to Type converter typeQ :: FieldType -> TypeQ @@ -88,12 +72,12 @@ -- and do not coincide with Haskell reserved words. sanitizeField :: FieldDefinition -> FieldDefinition sanitizeField (Constant (a, b) c) = Constant (a, sanitize b) c -sanitizeField (Variable (a, b)) = Variable (a, sanitize b) +sanitizeField (Variable (a, b)) = Variable (a, sanitize b) -- | Sanitize identifier for valid Haskell -sanitize :: T.Text -> T.Text +sanitize :: Text -> Text sanitize x | isKeyword x = T.cons '_' x - | otherwise = x + | otherwise = T.toLower (T.take 1 x) <> T.drop 1 x where isKeyword = flip elem [ "as", "case", "of", "class" , "data", "family", "instance" , "default", "deriving", "do" @@ -126,14 +110,15 @@ RTime -> "ROSTime" -- | Default value of field -defValue :: FieldDefinition -> Maybe ExpQ -defValue (Constant _ _) = Nothing -defValue (Variable (Simple t, _)) = Just $ - case t of - RBool -> [|False|] - RString -> [|""|] - _ -> [|def|] -defValue (Variable _) = Just [|def|] +defField :: FieldDefinition -> Maybe ExpQ +defField (Constant _ _) = Nothing +defField (Variable (a, _)) = Just (defValue a) + where defValue :: FieldType -> ExpQ + defValue (Array _) = [|ROSArray mempty|] + defValue (FixedArray l t) = [|ROSFixedArray (replicate l $(defValue t))|] + defValue (Simple RBool) = [|False|] + defValue (Simple RString) = [|""|] + defValue _ = [|def|] -- | Field definition to record var converter fieldQ :: FieldDefinition -> Maybe VarStrictTypeQ @@ -142,15 +127,36 @@ where recName = mkName ('_' : T.unpack name) recType = strictType notStrict (typeQ typ) --- | Generate the getDigest Message class implementation +-- | Generate the 'getSource' 'Message' class implementation +mkGetSource :: MsgDefinition -> DecQ +mkGetSource msg = + funD' "getSource" [wildP] (renderString msg) + where + renderString = stringE . T.unpack . renderT + +-- | Take list of external types and it's TypeQ +-- +-- XXX: Original python @genmsg@ implementation ignore arrays +-- for hashing, it seems that types `A` and `A[]` has the same hash. +-- +userTypes :: MsgDefinition -> [(ExpQ, TypeQ)] +userTypes = catMaybes . fmap go + where + textE = stringE . T.unpack + go x = case x of + Variable (Custom t, _) -> Just (textE t, customType t) + Variable (Array (Custom t), _) -> Just (textE (t <> "[]"), customType t) + Variable (FixedArray l (Custom t), _) -> + Just (textE (t <> "[" <> T.pack (show l) <> "]"), customType t) + _ -> Nothing + +-- | Generate the 'getDigest' 'Message' class implementation mkGetDigest :: MsgDefinition -> DecQ mkGetDigest msg = - funD' "getDigest" [wildP] [| md5 (LBS.pack $(appsE source)) |] + funD' "getDigest" [] [|computeMD5 $digestMap . getSource|] where - source = ([|printf $(stringE (render msg))|] - : (depDigest <$> externalTypes msg)) - depDigest t = [|show (getDigest (undefined :: $(t)))|] - render = unpack . toLazyText . render' (const "%s") + digestMap = listE (digestPair <$> userTypes msg) + digestPair (name, typ) = [|($name, getDigest (undefined :: $typ))|] -- | Generate the getType Message class implementation mkGetType :: DecQ @@ -211,10 +217,9 @@ -- | Data type declaration mkData :: Name -> MsgDefinition -> [DecQ] mkData name msg = pure $ - dataD' name recs derivingD + dataD' name (recC name fieldTypes) derivingD where - fields = sanitizeField <$> msg - recs = recC name (catMaybes (fieldQ <$> fields)) + fieldTypes = catMaybes (fieldQ . sanitizeField <$> msg) derivingD = [ mkName "P.Show", mkName "P.Eq", mkName "P.Ord" , mkName "Generic", mkName "Data", mkName "Typeable" ] @@ -232,13 +237,15 @@ instanceD' name defaultT [defFun] where defaultT = conT (mkName "Default") - defaults = catMaybes (defValue . sanitizeField <$> msg) + defaults = catMaybes (defField <$> msg) defFun = funD' "def" [] $ appsE (conE name : defaults) -- | Message instance declaration mkMessage :: Name -> MsgDefinition -> [DecQ] mkMessage name msg = pure $ - instanceD' name messageT [mkGetDigest msg, mkGetType] + instanceD' name messageT [ mkGetType + , mkGetSource msg + , mkGetDigest msg ] where messageT = conT (mkName "Message") @@ -247,7 +254,7 @@ mkStamped name msg | hasHeader msg = pure go | otherwise = [] where - hasHeader [Variable (Custom "Header", _), _] = True + hasHeader (Variable (Custom "Header", "header") : _) = True hasHeader _ = False seqL = dyn "Header.seq" diff --git a/src/Robotics/ROS/Msg/Types.hs b/src/Robotics/ROS/Msg/Types.hs --- a/src/Robotics/ROS/Msg/Types.hs +++ b/src/Robotics/ROS/Msg/Types.hs @@ -24,6 +24,7 @@ import Data.Word (Word32) import Data.Text (Text) +import Data.Int (Int32) -- | A variant type describing the simple types -- that may be included in a ROS message. @@ -73,7 +74,7 @@ type MsgDefinition = [FieldDefinition] -- | ROSDuration is a tuple of (seconds, nanoseconds) -type ROSDuration = (Word32, Word32) +type ROSDuration = (Int32, Int32) -- | ROSTime is a tuple of (seconds, nanoseconds) type ROSTime = (Word32, Word32)