packages feed

rosmsg 0.4.4.0 → 0.5.0.0

raw patch · 7 files changed

+149/−80 lines, 7 files

Files

rosmsg.cabal view
@@ -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
src/Robotics/ROS/Msg.hs view
@@ -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
+ src/Robotics/ROS/Msg/MD5.hs view
@@ -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
src/Robotics/ROS/Msg/Parser.hs view
@@ -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
src/Robotics/ROS/Msg/Render.hs view
@@ -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
src/Robotics/ROS/Msg/TH.hs view
@@ -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"
src/Robotics/ROS/Msg/Types.hs view
@@ -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)