diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexander Krupenkin (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/rosmsg.cabal b/rosmsg.cabal new file mode 100644 --- /dev/null +++ b/rosmsg.cabal @@ -0,0 +1,39 @@ +name: rosmsg +version: 0.4.3.1 +synopsis: ROS message parser, render, TH +description: Please see README.md +homepage: https://github.com/akru/rosmsg#readme +license: BSD3 +license-file: LICENSE +author: Alexander Krupenkin +maintainer: mail@akru.me +copyright: (c) 2016 Alexander Krupenkin +category: Robotics +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Robotics.ROS.Msg + , Robotics.ROS.Msg.TH + , Robotics.ROS.Msg.Types + , Robotics.ROS.Msg.Parser + , Robotics.ROS.Msg.Render + build-depends: base >= 4.7 && < 5 + , text >= 1.2 && < 2 + , binary >= 0.7 && < 1 + , pureMD5 >= 2.1 && < 3 + , attoparsec >= 0.13 && < 1 + , bytestring >= 0.10 && < 1 + , lens-family >= 1.2 && < 2 + , data-default >= 0.5 && < 1 + , template-haskell >= 2.10 && < 3 + + other-modules: Robotics.ROS.Msg.ROSArray + default-language: Haskell2010 + ghc-options: -Wall + default-extensions: OverloadedStrings + +source-repository head + type: git + location: https://github.com/akru/rosmsg diff --git a/src/Robotics/ROS/Msg.hs b/src/Robotics/ROS/Msg.hs new file mode 100644 --- /dev/null +++ b/src/Robotics/ROS/Msg.hs @@ -0,0 +1,76 @@ +-- | +-- Module : Robotics.ROS.Msg +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : POSIX / WIN32 +-- +-- Robot Operating System (ROS) is a set of software libraries and tools +-- that help you build robot applications. From drivers to state-of-the-art +-- algorithms, and with powerful developer tools, ROS has what you need for +-- your next robotics project. And it's all open source. +-- +-- In ROS a node is a process that performs computation. +-- Nodes communicate with each other by publishing messages to topics. +-- A message is a simple data structure, comprising typed fields. Standard +-- primitive types (integer, floating point, boolean, etc.) are supported, +-- as are arrays of primitive types. Messages can include arbitrarily nested +-- structures and arrays (much like C structs). +-- +-- This package provide the ROS message language parser and builder. Abstract +-- message representation given by parser can be used in TemplateHaskell codegen +-- for native Haskell structures creation. +-- +-- >>> [rosmsgFrom|/opt/ros/jade/share/std_msgs/msg/Byte.msg|] +-- "[Variable (Simple RByte,\"data\")]" +-- +-- >>> [rosmsgFrom|/opt/ros/jade/share/geometry_msgs/msg/Polygon.msg|] +-- "[Variable (Array (Custom \"Point32\"),\"points\")]" +-- +module Robotics.ROS.Msg ( + -- * Message classes + Message(..) + , Stamped(..) + -- * Common used types + -- ** Array-like types + , ROSFixedArray(..) + , ROSArray(..) + -- ** Time description + , ROSDuration + , ROSTime + ) where + +import Data.Digest.Pure.MD5 (MD5Digest) +import Data.ByteString (ByteString) +import Data.Binary (Binary) +import Data.Word (Word32) +import Data.Text (Text) + +import Robotics.ROS.Msg.ROSArray +import Robotics.ROS.Msg.Types + +-- | 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@ + getType :: a -> Text + +-- | Sometime ROS messages have a special @Header@ field. +-- It used for tracking package sequence, time stamping +-- and frame tagging. Headers is frequently field. The +-- 'Stamped' type class lifts header fields on the top +-- of message and abstracting of type. +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/Parser.hs b/src/Robotics/ROS/Msg/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Robotics/ROS/Msg/Parser.hs @@ -0,0 +1,98 @@ +-- | +-- Module : Robotics.ROS.Msg.Parser +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : POSIX / WIN32 +-- +-- Parser components for the ROS message description language (@msg@ +-- files). See http://wiki.ros.org/msg for reference. +-- +module Robotics.ROS.Msg.Parser ( + -- * Attoparsec re-export + Result(..) + , parse + -- * The ROS message language parser + , rosmsg + ) where + +import Data.Text (Text, pack, toLower) +import Data.Char (isDigit, isAlpha) +import Data.Attoparsec.Text.Lazy +import Control.Arrow ((&&&)) +import Data.Either (rights) +import qualified Data.Text as T + +import Robotics.ROS.Msg.Types + +-- | Show simple type +showType :: Show a => a -> Text +showType = toLower . T.drop 1 . pack . show + +-- | All of simple type and its text representation list +simpleAssoc :: [(SimpleType, Text)] +simpleAssoc = (id &&& showType) <$> enumFrom RBool + +-- | Line getter +takeLine :: Parser Text +takeLine = pack <$> manyTill anyChar (eitherP endOfLine endOfInput) + +-- | Valid ROS identifier parser +identifier :: Parser Text +identifier = takeWhile1 validChar + where validChar c = any ($ c) [isDigit, isAlpha, (== '_'), (== '/')] + +-- | ROS message comments parser +comment :: Parser () +comment = skipSpace *> char '#' *> takeLine *> pure () + +-- | Parse fields defined in the message +variableParser :: Parser FieldDefinition +variableParser = do + typeIdent <- choice [simpleField, customField] + mkField <- choice [flat, array, fixedArray] + return (Variable $ mkField typeIdent) + where + simpleField = Simple . fst <$> choice (mapM string <$> simpleAssoc) + + customField = Custom <$> identifier + + -- | Flat type is no array + flat = do + name <- space *> skipSpace *> identifier <* takeLine + return $ flip (,) name + + -- | Variable lenght array + array = do + name <- skipSpace *> string "[]" *> skipSpace *> identifier <* takeLine + return $ flip (,) name . Array + + -- | Fixed lenght array + fixedArray = do + len <- skipSpace *> char '[' *> decimal <* char ']' + name <- skipSpace *> identifier <* takeLine + return $ flip (,) name . FixedArray len + +-- | Parse constants defined in the message +constantParser :: Parser FieldDefinition +constantParser = choice (go <$> enumFrom RBool) + where + go t = do + name <- string (showType t) *> skipSpace *> identifier <* space + value <- skipSpace *> char '=' *> skipSpace *> takeLine + return $ Constant (Simple t, name) $ + -- String constants are parsed somewhat differently from numeric + -- constants. For numerical constants, we drop comments and trailing + -- spaces. For strings, we take the whole line (so comments aren't + -- stripped). + case t of + RString -> value + _ -> T.takeWhile (/= '#') value + +-- | The ROS message language parser +rosmsg :: Parser MsgDefinition +rosmsg = rights <$> many' (eitherP junk field) + where field = choice [constantParser, variableParser] + junk = choice [comment, endOfLine] diff --git a/src/Robotics/ROS/Msg/ROSArray.hs b/src/Robotics/ROS/Msg/ROSArray.hs new file mode 100644 --- /dev/null +++ b/src/Robotics/ROS/Msg/ROSArray.hs @@ -0,0 +1,75 @@ +-- | +-- Module : Robotics.ROS.Msg.ROSArray +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : POSIX / WIN32 +-- +-- Array-like types and instances for Haskell implementation +-- of the ROS message structures. +-- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Robotics.ROS.Msg.ROSArray + ( ROSArray(..) + , ROSFixedArray(..) + ) where + +import GHC.TypeLits (Nat, KnownNat, natVal) +import Data.Binary (Binary(..), Get) +import Control.Monad (replicateM) +import Data.Default (Default(..)) +import Data.Typeable (Typeable) +import Data.Word (Word32) +import Data.Data (Data) + +-- | Simple 'Array' type +-- TODO: migrate to more performance vector type +type Array = [] + +-- | A type for arrays in ROS messages +newtype ROSArray a = ROSArray { unArray :: Array a } + deriving (Show, Eq, Ord, Data, Typeable, Functor, Applicative) + +instance Monoid (ROSArray a) where + mempty = ROSArray [] + mappend a b = ROSArray (unArray a ++ unArray b) + +instance Default (ROSArray a) where + def = mempty + +instance Binary a => Binary (ROSArray a) where + put (ROSArray arr) = put len >> sequence_ (put <$> arr) + where len :: Word32 + len = fromIntegral (length arr) + get = do len <- get :: Get Word32 + ROSArray <$> replicateM (fromIntegral len) get + +-- | A type for fixed arrays in ROS messages +newtype ROSFixedArray (n :: Nat) a = ROSFixedArray { unFixedArray :: Array a } + deriving (Show, Eq, Ord, Data, Typeable, Functor, Applicative) + +instance Monoid (ROSFixedArray n a) where + mempty = ROSFixedArray [] + mappend a b = ROSFixedArray (unFixedArray a ++ unFixedArray b) + +size :: (KnownNat n, Num b) => ROSFixedArray n a -> b +size = fromIntegral . natVal . proxy + where proxy :: ROSFixedArray n a -> proxy n + proxy _ = undefined + +modify :: ROSFixedArray n a -> Array b -> ROSFixedArray n b +modify a b = a { unFixedArray = b } + +instance (Default a, KnownNat n) => Default (ROSFixedArray n a) where + def = modify arr (replicate (size arr) def) + where arr = mempty + +instance (Binary a, KnownNat n) => Binary (ROSFixedArray n a) where + put (ROSFixedArray arr) = sequence_ (put <$> arr) + get = modify arr <$> replicateM (size arr) get + where arr = mempty diff --git a/src/Robotics/ROS/Msg/Render.hs b/src/Robotics/ROS/Msg/Render.hs new file mode 100644 --- /dev/null +++ b/src/Robotics/ROS/Msg/Render.hs @@ -0,0 +1,56 @@ +-- | +-- Module : Robotics.ROS.Msg.Render +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : POSIX / WIN32 +-- +-- The ROS message language builder from abstract message definition. +-- +module Robotics.ROS.Msg.Render ( + -- * Create lazy text builder from message definition + render + -- * Create builder with custom type hook + , render' + ) where + +import Data.Text.Lazy.Builder (Builder, fromText, fromString) +import Data.Char (toLower) +import Data.Monoid ((<>)) +import Data.Text (Text) + +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 + +-- | Render formal ROS message definition according to: +-- +-- * comments removed +-- +-- * whitespace removed +-- +-- * package names of dependencies removed +-- +-- * constants reordered ahead of other declarations +-- from http://www.ros.org/wiki/ROS/Technical%20Overview +-- +render :: MsgDefinition -> Builder +render = render' id diff --git a/src/Robotics/ROS/Msg/TH.hs b/src/Robotics/ROS/Msg/TH.hs new file mode 100644 --- /dev/null +++ b/src/Robotics/ROS/Msg/TH.hs @@ -0,0 +1,279 @@ +-- | +-- Module : Robotics.ROS.Msg.TH +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : POSIX / WIN32 +-- +-- Template Haskell driven code generator from ROS message language +-- to Haskell native representation. +-- +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +module Robotics.ROS.Msg.TH ( + -- * Native Haskell ROS message codegen + rosmsg + , 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.List (groupBy) +import Data.Default (def) +import Data.Monoid ((<>)) +import qualified Lens.Family2 as L +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.Types +import Robotics.ROS.Msg + +-- | Generate ROS message declarations from .msg file +rosmsgFrom :: QuasiQuoter +rosmsgFrom = quoteFile rosmsg + +-- | QQ for data type and instances generation +-- from ROS message declaration +rosmsg :: QuasiQuoter +rosmsg = QuasiQuoter + { quoteDec = quoteMsgDec + , quoteExp = quoteMsgExp + , quotePat = undefined + , quoteType = undefined + } + +-- | 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 + +-- | Field to Type converter +typeQ :: FieldType -> TypeQ +typeQ (Simple t) = conT $ mkName $ mkFlatType t +typeQ (Custom t) = customType t +typeQ (Array t) = [t|ROSArray $(typeQ t)|] +typeQ (FixedArray l t) = [t|ROSFixedArray $arrSize $(typeQ t)|] + where arrSize = litT $ numTyLit $ fromIntegral l + +-- | Ensure that field and constant names are valid Haskell identifiers +-- 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) + +-- | Sanitize identifier for valid Haskell +sanitize :: T.Text -> T.Text +sanitize x | isKeyword x = T.cons '_' x + | otherwise = x + where isKeyword = flip elem [ "as", "case", "of", "class" + , "data", "family", "instance" + , "default", "deriving", "do" + , "forall", "foreign", "hiding" + , "if", "then", "else", "import" + , "infix", "infixl", "infixr" + , "let", "in", "mdo", "module" + , "newtype", "proc", "qualified" + , "rec", "type", "where"] + +-- | Generate the name of the Haskell type that corresponds to a flat +-- (i.e. non-array) ROS type. +mkFlatType :: SimpleType -> String +mkFlatType t = case t of + RBool -> "P.Bool" + RInt8 -> "I.Int8" + RUInt8 -> "W.Word8" + RByte -> "W.Word8" + RChar -> "I.Int8" + RInt16 -> "I.Int16" + RUInt16 -> "W.Word16" + RInt32 -> "I.Int32" + RUInt32 -> "W.Word32" + RInt64 -> "I.Int64" + RUInt64 -> "W.Word64" + RFloat32 -> "P.Float" + RFloat64 -> "P.Double" + RString -> "BS.ByteString" + RDuration -> "ROSDuration" + 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|] + +-- | Field definition to record var converter +fieldQ :: FieldDefinition -> Maybe VarStrictTypeQ +fieldQ (Constant _ _) = Nothing +fieldQ (Variable (typ, name)) = Just $ varStrictType recName recType + where recName = mkName ('_' : T.unpack name) + recType = strictType notStrict (typeQ typ) + +-- | Generate the getDigest Message class implementation +mkGetDigest :: MsgDefinition -> DecQ +mkGetDigest msg = + funD' "getDigest" [wildP] [| md5 (LBS.pack $(appsE source)) |] + where + source = ([|printf $(stringE (render msg))|] + : (depDigest <$> externalTypes msg)) + depDigest t = [|show (getDigest (undefined :: $(t)))|] + render = unpack . toLazyText . render' (const "%s") + +-- | Generate the getType Message class implementation +mkGetType :: DecQ +mkGetType = do + l_mod <- loc_module <$> location + let msgType = let [m, p] = fmap (drop 1) $ take 2 $ + reverse $ groupBy (const (/= '.')) l_mod + in fmap toLower p ++ "/" ++ m + funD' "getType" [wildP] [|msgType|] + +-- | Lens signature +lensSig :: String -> TypeQ -> TypeQ -> DecQ +lensSig name a b = sigD (mkName name) + [t|forall f. Functor f => ($b -> f $b) -> $a -> f $a|] + +-- | Given a record field name, +-- produces a single function declaration: +-- lensName :: forall f. Functor f => (a -> f a') -> b -> f b' +-- lensName f a = (\x -> a { field = x }) `fmap` f (field a) +-- FROM: Lens.Family.THCore +deriveLens :: Name -> FieldDefinition -> [DecQ] +deriveLens _ (Constant _ _) = [] +deriveLens dataName (Variable (typ, name)) = + [ lensSig (T.unpack name) (conT dataName) (typeQ typ) + , funD' (T.unpack name) pats body] + where a = mkName "a" + f = mkName "f" + fieldName = mkName ('_' : T.unpack name) + pats = [varP f, varP a] + body = [| (\x -> $(record a fieldName [|x|])) + <$> $(appE (varE f) (appE (varE fieldName) (varE a))) + |] + record rec fld val = val >>= \v -> recUpdE (varE rec) [return (fld, v)] + +-- | Instance declaration with empty context +instanceD' :: Name -> TypeQ -> [DecQ] -> DecQ +instanceD' name insType insDecs = + instanceD (cxt []) (appT insType (conT name)) insDecs + +-- | Simple function declaration +funD' :: String -> [PatQ] -> ExpQ -> DecQ +funD' name p f = funD (mkName name) [clause p (normalB f) []] + +-- | Lenses declarations +mkLenses :: Name -> MsgDefinition -> [DecQ] +mkLenses name msg = + concat (deriveLens name . sanitizeField <$> msg) + +-- | Data type declaration +mkData :: Name -> MsgDefinition -> [DecQ] +mkData name msg = pure $ + dataD (cxt []) name [] [recs] derivingD + where + fields = sanitizeField <$> msg + recs = recC name (catMaybes (fieldQ <$> fields)) + derivingD = [ mkName "P.Show", mkName "P.Eq", mkName "P.Ord" + , mkName "Generic", mkName "Data", mkName "Typeable" + ] + +-- | Binary instance declaration +mkBinary :: Name -> a -> [DecQ] +mkBinary name _ = pure $ + instanceD' name binaryT [] + where + binaryT = conT (mkName "Binary") + +-- | Default instance declaration +mkDefault :: Name -> MsgDefinition -> [DecQ] +mkDefault name msg = pure $ + instanceD' name defaultT [defFun] + where + defaultT = conT (mkName "Default") + defaults = catMaybes (defValue . sanitizeField <$> 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] + where + messageT = conT (mkName "Message") + +-- | Stamped instance declaration +mkStamped :: Name -> MsgDefinition -> [DecQ] +mkStamped name msg | hasHeader msg = pure go + | otherwise = [] + where + hasHeader [Variable (Custom "Header", _), _] = True + hasHeader _ = False + + seqL = dyn "Header.seq" + stampL = dyn "Header.stamp" + frameL = dyn "Header.frame_id" + headerL = dyn "header" + + mkSetSequence = funD' "setSequence" [] [|L.set ($headerL . $seqL)|] + mkGetSequence = funD' "getSequence" [] [|L.view ($headerL . $seqL)|] + mkGetStamp = funD' "getStamp" [] [|L.view ($headerL . $stampL)|] + mkGetFrame = funD' "getFrame" [] [|L.view ($headerL . $frameL)|] + + stampedT = conT (mkName "Stamped") + + go = instanceD' name stampedT [ mkGetSequence + , mkSetSequence + , mkGetStamp + , mkGetFrame ] + +-- | TemplateHaskell codegen from the ROS message language +quoteMsgDec :: String -> Q [Dec] +quoteMsgDec txt = do + name <- mkDataName . loc_module <$> location + sequence $ concatMap (msgRun name) $ + [ mkData + , mkBinary + , mkDefault + , mkMessage + , mkStamped + , mkLenses + ] + where Done _ msg = Parser.parse Parser.rosmsg (pack txt) + mkDataName = mkName . drop 1 . last . groupBy (const isAlphaNum) + msgRun n = ($ (n, msg)) . uncurry + +-- | Simple parse ROS message and show +quoteMsgExp :: String -> ExpQ +quoteMsgExp txt = stringE (show msg) + where Done _ msg = Parser.parse Parser.rosmsg (pack txt) diff --git a/src/Robotics/ROS/Msg/Types.hs b/src/Robotics/ROS/Msg/Types.hs new file mode 100644 --- /dev/null +++ b/src/Robotics/ROS/Msg/Types.hs @@ -0,0 +1,79 @@ +-- | +-- Module : Robotics.ROS.Msg.Types +-- Copyright : Alexander Krupenkin 2016 +-- License : BSD3 +-- +-- Maintainer : mail@akru.me +-- Stability : experimental +-- Portability : POSIX / WIN32 +-- +-- Common used data types. +-- +module Robotics.ROS.Msg.Types ( + -- * ROS message abstract declaration types + FieldDefinition(..) + , SimpleType(..) + , FieldType(..) + , MsgDefinition + , FieldName + , Field + -- * Time describing + , ROSDuration + , ROSTime + ) where + +import Data.Word (Word32) +import Data.Text (Text) + +-- | A variant type describing the simple types +-- that may be included in a ROS message. +data SimpleType + = RBool + | RByte + | RChar + | RInt8 + | RUInt8 + | RInt16 + | RUInt16 + | RInt32 + | RUInt32 + | RInt64 + | RUInt64 + | RFloat32 + | RFloat64 + | RString + | RTime + | RDuration + deriving (Show, Enum, Eq) + +-- | A variant type describing the types that may be included in a ROS +-- message. +data FieldType + = Simple SimpleType + | Custom Text + | Array FieldType + | FixedArray Int FieldType + deriving (Show, Eq) + +-- | Field name is text encoded +type FieldName = Text + +-- | Field is a pair of name - value +type Field = (FieldType, FieldName) + +-- | ROS message field is a variable or constant declaration +data FieldDefinition + = Variable Field + -- ^ Variable field name and type + | Constant Field Text + -- ^ Constant field name, type and value + deriving (Show, Eq) + +-- | ROS message is a list of fields +type MsgDefinition = [FieldDefinition] + +-- | ROSDuration is a tuple of (seconds, nanoseconds) +type ROSDuration = (Word32, Word32) + +-- | ROSTime is a tuple of (seconds, nanoseconds) +type ROSTime = (Word32, Word32)