roshask 0.2 → 0.2.1
raw patch · 9 files changed
+403/−24 lines, 9 filesdep ~haxr
Dependency ranges changed: haxr
Files
- Tests/AllTests.hs +4/−1
- roshask.cabal +12/−14
- src/Ros/Graph/Master.hs +2/−3
- src/Ros/Internal/DepFinder.hs +3/−2
- src/Ros/Node/RosTcp.hs +1/−1
- src/Ros/Topic/Util.hs +14/−0
- src/executable/PkgBuilder.hs +253/−0
- src/executable/PkgInit.hs +14/−3
- src/executable/Types.hs +100/−0
Tests/AllTests.hs view
@@ -1,9 +1,12 @@ module Main where import qualified MsgGen+import qualified TopicTest import Test.Tasty main :: IO () main = do genTests <- MsgGen.tests- defaultMain $+ defaultMain $ testGroup "roshask" [ testGroup "roshask executable" [ genTests ]+ , testGroup "roshask library"+ [ TopicTest.topicTests]]
roshask.cabal view
@@ -1,5 +1,5 @@ Name: roshask-Version: 0.2+Version: 0.2.1 Synopsis: Haskell support for the ROS robotics framework. License: BSD3 License-file: LICENSE@@ -15,16 +15,14 @@ Description: Tools for working with ROS in Haskell. . ROS (<http://www.ros.org>) is a software- framework developed by Willow Garage- (<http://http://www.willowgarage.com/>) that aims- to provide a standard software architecture for- robotic systems. The main idea of the framework- is to support the development and execution of- loosely coupled /Node/s connected by typed- /Topic/s. Each Node represents a locus of- processing, ideally with a minimal interface- specified in terms of the types of Topics it- takes as input and offers as output.+ framework that provides a standard software+ architecture for robotic systems. The main idea+ of the framework is to support the development+ and execution of loosely coupled /Node/s+ connected by typed /Topic/s. Each Node represents+ a locus of processing, ideally with a minimal+ interface specified in terms of the types of+ Topics it takes as input and offers as output. . This package provides libraries for creating new ROS Nodes in Haskell, along with the @roshask@@@ -112,7 +110,7 @@ snap-server >= 0.9, storable-tuple >= 0.0.2, transformers >= 0.4,- haxr >= 3000.10.3,+ haxr >= 3000.10.4, utf8-string >= 0.3.6, uri >= 0.1.5, vector-space,@@ -126,7 +124,7 @@ Build-depends: unix - GHC-Options: -O2 -Wall+ GHC-Options: -Wall Hs-Source-Dirs: src default-language: Haskell2010 -- Modules not exported by this package.@@ -160,7 +158,7 @@ GHC-Options: -O2 -Wall Main-Is: Main.hs Other-modules: Analysis Gen MD5 Parse PkgInit ResolutionTypes- FieldImports Unregister+ FieldImports Unregister PkgBuilder Types Instances.Binary Instances.Storable Instances.NFData Paths_roshask Hs-Source-Dirs: src/executable
src/Ros/Graph/Master.hs view
@@ -5,9 +5,8 @@ import Ros.Internal.RosTypes import Ros.Service.ServiceTypes import Network.XmlRpc.Internals (fromValue, toValue)-import Control.Monad.Except (ExceptT(..))+import Control.Monad.Except (ExceptT(..), runExceptT) import System.IO.Error (catchIOError)-import Control.Monad.Error (runErrorT) -- |Subscribe the caller to the specified topic. In addition to -- receiving a list of current publishers, the subscriber will also@@ -53,7 +52,7 @@ lookupService :: URI -> String -> ServiceName -> ExceptT ServiceResponseExcept IO (Int, String, String) lookupService u s1 s2 = ExceptT . (flip catchIOError) handler $ do let res = call u "lookupService" (fmap toValue [s1, s2]) >>= fromValue- err <- runErrorT res+ err <- runExceptT res return $ case err of Left x -> Left $ MasterExcept $ "Could not look up service with master. Got message: " ++ x Right y -> Right y
src/Ros/Internal/DepFinder.hs view
@@ -65,8 +65,9 @@ -- Packages that we will ignore for tracking down message definition -- dependencies. ignoredPackages :: [String]-ignoredPackages = ["genmsg_cpp", "rospack", "rosconsole", "rosbagmigration", - "roscpp", "rospy", "roslisp", "roslib", "boost"]+ignoredPackages = [ "genmsg_cpp", "rospack", "rosconsole", "rosbagmigration"+ , "roscpp", "rospy", "roslisp", "roslib", "boost"+ , "libconsole-bridge-dev" ] -- |Find the names of the ROS packages this package depends on as -- indicated by the manifest.xml or package.xml file in this package's root
src/Ros/Node/RosTcp.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE BangPatterns, FlexibleContexts, ScopedTypeVariables #-} module Ros.Node.RosTcp (subStream, runServer, runServers, callServiceWithMaster) where import Control.Applicative ((<$>)) import Control.Arrow (first)
src/Ros/Topic/Util.hs view
@@ -195,6 +195,20 @@ go (Right _) (r@(Right _), t) = go r =<< runTopic t go (Right y) (Left x, t) = return ((x,y), Topic $ warmup =<< runTopic t) +-- |Returns a 'Topic' that produces a new pair every time a value of+-- first topic produces a new value, followed by a new value from the+-- second topic. This can be used for sampling the first topic with+-- the second topic.+firstThenSecond :: Topic IO a -> Topic IO b -> Topic IO (a,b)+firstThenSecond t1 t2 = leftThenRight (t1 <+> t2)++-- |Produces a value when a Left value is followed by a Right value.+leftThenRight :: (Monad m) => Topic m (Either a b) -> Topic m (a,b)+leftThenRight t1 = Topic $ warmup =<< runTopic t1+ where warmup (v,t) = go v =<< runTopic t+ go (Left x) (Right y, t) = return ((x,y), Topic $ warmup =<< runTopic t)+ go _ (x, t) = go x =<< runTopic t+ -- |Merge two 'Topic's into one. The items from each component -- 'Topic' will be added to the combined 'Topic' as they become -- available.
+ src/executable/PkgBuilder.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+-- |Build all messages defined in a ROS package.+module PkgBuilder where+import Analysis+import Control.Applicative+import Control.Concurrent (forkIO)+import Control.Concurrent (newEmptyMVar)+import Control.Concurrent (putMVar)+import Control.Concurrent (takeMVar)+import Control.DeepSeq (rnf)+import qualified Control.Exception as C+import Control.Monad (when, zipWithM_)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Char (isSpace)+import qualified Data.Foldable as F+import Data.List (intercalate, isSuffixOf, isPrefixOf, nub)+import Data.Version (versionBranch)+import Gen (generateMsgType, generateSrvTypes)+import Parse (parseMsg, parseSrv)+import Types (requestResponseNames, shortName)+import Paths_roshask (version, getBinDir)++import Ros.Internal.DepFinder (findMessages, findDepsWithMessages, hasMsgsOrSrvs, findServices)+import Ros.Internal.PathUtil (codeGenDir, cap)+import System.Directory (createDirectoryIfMissing, getDirectoryContents,+ doesDirectoryExist, removeFile)+import System.Exit (ExitCode(..))+import System.FilePath+import System.IO (hGetContents, hClose)+import System.Process (createProcess, proc, CreateProcess(..), waitForProcess, StdStream(CreatePipe))++-- | Determine if we are working in a sandbox by checking of roshask+-- was installed in one. If so, return the immediate parent of the+-- sandbox directory.+sandboxDir :: IO (Maybe FilePath)+sandboxDir = do d <- splitDirectories <$> getBinDir+ return $ case reverse d of+ ("bin" : ".cabal-sandbox" : ds) -> + Just . joinPath $ reverse ds+ _ -> Nothing++-- | Information on how to invoke @ghc-pkg@ (or @cabal sandbox+-- hc-pkg@) and the @cabal@ executable.+data ToolPaths = ToolPaths { ghcPkg :: [String] -> CreateProcess+ , cabalInstall :: [String] -> CreateProcess+ , forceFlag :: [String] }++-- | If we are not in a sandbox, then we can use 'ghc-pkg' to get a+-- list of installed packages, and 'cabal install' to install a+-- package. If we are in a sandbox, we must invoke the tools from the+-- directory containing the sandbox directory, and use @cabal sandbox+-- hc-pkg@ instead of @ghc-pkg@.+toolPaths :: IO ToolPaths+toolPaths =+ sandboxDir >>= \md -> return $ case md of+ Nothing -> ToolPaths (\args -> (proc "ghc-pkg" args)+ {std_in=CreatePipe, std_out=CreatePipe})+ (\args -> proc "cabal" args)+ ["--force"]+ Just _ -> ToolPaths (\args -> (proc "cabal" ("sandbox":"hc-pkg":args))+ {cwd=md, std_out=CreatePipe})+ (\args -> (proc "cabal" args) {cwd=md})+ ["--", "--force"]++-- The current version of roshask. We tag generated message packages+-- with the same version.+roshaskVersion :: B.ByteString+roshaskVersion = B.pack . intercalate "." $ map show (versionBranch version)++-- The current version of roshask with the patch level changed to an+-- asterisk. The intension is to allow a compiled roshask package to+-- work with newer patch levels of roshask itself.+roshaskMajorMinor :: B.ByteString+roshaskMajorMinor = B.pack . intercalate "." $+ map show (take 2 (versionBranch version)) ++ ["*"]++pathToRosPkg :: FilePath -> FilePath+pathToRosPkg = last . splitDirectories++-- | Somewhat more flexibile than 'System.Process.readProcess'. Not as+-- robust to exceptions.+myReadProcess :: CreateProcess -> IO String+myReadProcess cp =+ do (i, Just o, _, ph) <- createProcess cp+ F.mapM_ hClose i+ output <- hGetContents o+ done <- newEmptyMVar+ _ <- forkIO $ C.evaluate (rnf output) >> putMVar done ()+ takeMVar done+ hClose o+ ex <- waitForProcess ph+ case ex of+ ExitSuccess -> return output+ ExitFailure e -> error $ "Error reading process: "++show e++-- Determine if a roshask package is already registered with ghc-pkg+-- for the given ROS package.+packageRegistered :: ToolPaths -> FilePath -> IO Bool+packageRegistered tools pkg =+ any (isPrefixOf cabalPkg . dropWhile isSpace) . lines <$> getList+ where cabalPkg = (rosPkg2CabalPkg $ pathToRosPkg pkg) ++ + "-" ++ B.unpack roshaskVersion+ getList = myReadProcess $ ghcPkg tools ["list", cabalPkg]++-- | Build all messages defined by a ROS package unless the corresponding+-- Haskell package is already registered with ghc-pkg.+buildPkgMsgs :: FilePath -> MsgInfo ()+buildPkgMsgs fname = do tools <- liftIO toolPaths+ r <- liftIO $ packageRegistered tools fname+ if r+ then liftIO . putStrLn $ + "Using existing " ++ pathToRosPkg fname+ else buildNewPkgMsgs tools fname++parseErrorMsg :: Show a => a -> String -> Either String c -> c+parseErrorMsg = parseErrorHelper "message"++parseErrorSrv :: Show a => a -> String -> Either String c -> c+parseErrorSrv = parseErrorHelper "service"++parseErrorHelper :: Show a => String -> a -> String -> Either String c -> c+parseErrorHelper srvOrMsg pkgHier fileName =+ either+ (\s -> error $ "In package: " ++ show pkgHier ++ "Could not parse " ++ srvOrMsg ++ " in file " ++ fileName ++" . Got error :" ++ s)+ id++dirAndNameToFile :: FilePath -> String -> FilePath+dirAndNameToFile destDir = (destDir </>) . (++ ".hs")++-- | Given a FilePath to a service file, will parse the service, generate the Haskell+-- request and response types, and write these types to a directory. This requires+-- knowing the Haskell names for the other messages in the current package+parseGenWriteService :: ByteString -> String -> [ByteString] -> FilePath -> MsgInfo ()+parseGenWriteService pkgHier destDir haskellPkgMsgNames srvFile = do+ parsedSrv <- liftIO $ parseErrorSrv pkgHier srvFile <$> parseSrv srvFile+ (request, response) <- generateSrvTypes pkgHier haskellPkgMsgNames parsedSrv+ let fname = map (dirAndNameToFile destDir) $ requestResponseNames parsedSrv+ liftIO $ zipWithM_ B.writeFile fname [request, response]++-- | Given a FilePath to a message file, will parse the message and generate and write+-- the Haskell type to a directory.+parseGenWriteMsg :: ByteString -> String -> [ByteString] -> FilePath -> MsgInfo ()+parseGenWriteMsg pkgHier destDir haskellPkgMsgNames msgFile = do+ parsedMsg <- liftIO $ parseErrorMsg pkgHier msgFile <$> parseMsg msgFile+ generatedMsg <- generateMsgType pkgHier haskellPkgMsgNames parsedMsg+ let fname = dirAndNameToFile destDir $ shortName parsedMsg+ liftIO $ B.writeFile fname generatedMsg++-- | Generate Haskell implementations of all message definitions in+-- the given package.+buildNewPkgMsgs :: ToolPaths -> FilePath -> MsgInfo ()+buildNewPkgMsgs tools fname =+ do liftIO . putStrLn $ "Generating package " ++ fname+ destDir <- liftIO $ codeGenDir fname+ liftIO $ createDirectoryIfMissing True destDir+ pkgMsgs <- liftIO $ findMessages fname+ pkgSrvs <- liftIO $ findServices fname+ let haskellMsgNames = map (B.pack . cap . dropExtension . takeFileName) pkgMsgs+ mapM_ (parseGenWriteMsg pkgHier destDir haskellMsgNames) pkgMsgs+ mapM_ (parseGenWriteService pkgHier destDir haskellMsgNames) pkgSrvs+ liftIO $ do f <- hasMsgsOrSrvs fname+ when f (removeOldCabal fname >> compileMsgs)+ where pkgName = pathToRosPkg fname+ pkgHier = B.pack $ "Ros." ++ cap pkgName ++ "."+ compileMsgs = do cpath <- genMsgCabal fname pkgName+ (_,_,_,procH) <- createProcess $+ cabalInstall tools ["install", cpath]+ code <- waitForProcess procH+ when (code /= ExitSuccess)+ (error $ "Building messages for "+++ pkgName++" failed")++-- |Convert a ROS package name to the corresponding Cabal package name+-- defining the ROS package's msg types.+rosPkg2CabalPkg :: String -> String+rosPkg2CabalPkg = ("ROS-"++) . addSuffix . map sanitize+ where sanitize '_' = '-'+ sanitize c = c+ addSuffix n+ | "msgs" `isSuffixOf` n = n+ | otherwise = n ++ "-msgs"++removeOldCabal :: FilePath -> IO ()+removeOldCabal pkgPath = + do msgPath <- codeGenDir pkgPath+ f <- doesDirectoryExist msgPath+ when f (getDirectoryContents msgPath >>=+ mapM_ (removeFile . (msgPath </>)) . + filter ((== ".cabal") . takeExtension))++-- Extract a Msg module name from a Path+path2MsgModule :: FilePath -> String+path2MsgModule = intercalate "." . map cap . reverse . take 3 .+ reverse . splitDirectories . dropExtension++getHaskellFiles :: FilePath -> String -> IO [FilePath]+getHaskellFiles pkgPath _pkgName = do+ d <- codeGenDir pkgPath+ map (d </>) . filter ((== ".hs") . takeExtension) <$> getDirectoryContents d++-- Generate a .cabal file to build this ROS package's messages.+genMsgCabal :: FilePath -> String -> IO FilePath+genMsgCabal pkgPath pkgName = + do deps' <- map (B.pack . rosPkg2CabalPkg) <$> + findDepsWithMessages pkgPath+ cabalFilePath <- (</>cabalPkg++".cabal") . + joinPath . init . init . splitPath <$> + codeGenDir pkgPath+ let deps+ | pkgName == "std_msgs" = deps'+ | otherwise = nub ("ROS-std-msgs":deps')+ msgFiles <- getHaskellFiles pkgPath pkgName+ let msgModules = map (B.pack . path2MsgModule) msgFiles+ target = B.intercalate "\n" $+ [ "Library"+ , B.append " Exposed-Modules: " + (if not (null msgModules)+ then B.concat [ head msgModules+ , "\n" + , B.intercalate "\n" + (map indent (tail msgModules)) ]+ else "")+ , ""+ , " Build-Depends: base >= 4.2 && < 6,"+ , " vector > 0.7,"+ , " time >= 1.1,"+ , " data-default-generics >= 0.3,"+ , B.concat [ " roshask == "+ , roshaskMajorMinor+ , if null deps then "" else "," ]+ , B.intercalate ",\n" $+ map (B.append " ") deps+ , " GHC-Options: -O2" ]+ pkgDesc = B.concat [preamble, "\n", target]+ --cabalFilePath = pkgPath</>"msg"</>"haskell"</>cabalPkg++".cabal"+ B.writeFile cabalFilePath pkgDesc+ return cabalFilePath+ where cabalPkg = rosPkg2CabalPkg pkgName+ preamble = format [ ("Name", B.pack cabalPkg)+ , ("Version", roshaskVersion)+ , ("Synopsis", B.append "ROS Messages from " + (B.pack pkgName))+ , ("Cabal-version", ">=1.6")+ , ("Category", "Robotics")+ , ("Build-type", "Simple") ]+ indent = let spaces = B.replicate 19 ' ' in B.append spaces++format :: [(ByteString, ByteString)] -> ByteString+format fields = B.concat $ map indent fields+ where indent (k,v) = let spaces = flip B.replicate ' ' $ + 21 - B.length k - 1+ in B.concat [k,":",spaces,v,"\n"]
src/executable/PkgInit.hs view
@@ -5,10 +5,12 @@ import qualified Data.ByteString.Char8 as B import Data.Char (toLower, toUpper) import Data.List (intercalate)+import Data.Version (versionBranch) import System.Directory (createDirectory) import System.FilePath ((</>)) import System.Process (system) +import Paths_roshask (version) import PkgBuilder (rosPkg2CabalPkg) -- |Initialize a package with the given name in the eponymous@@ -39,6 +41,15 @@ prepCMakeLists pkgName = B.appendFile (pkgName</>"CMakeLists.txt") cmd where cmd = "\nadd_custom_target(roshask ALL roshask dep ${PROJECT_SOURCE_DIR} COMMAND cd ${PROJECT_SOURCE_DIR} && cabal install)\n" +-- | New packages are constrained to the same major version of roshask+-- that was used to create them.+roshaskVersionBound :: ByteString+roshaskVersionBound = B.pack . ("roshask == "++)+ . intercalate "."+ . (++["*"])+ . map show+ $ take 2 (versionBranch version ++ [0..])+ -- Generate a .cabal file and a Setup.hs that will perform the -- necessary dependency tracking and code generation. prepCabal :: String -> ByteString -> IO ()@@ -56,7 +67,7 @@ , " vector > 0.7," , " time >= 1.1," , " ROS-rosgraph-msgs,"- , B.append " roshask == 0.1.*" moreDeps+ , B.append " roshask == 0.2.*" moreDeps , rosDeps , " GHC-Options: -O2" , " Hs-Source-Dirs: src"@@ -67,7 +78,8 @@ , " Build-Depends: base >= 4.2 && < 6," , " vector > 0.7," , " time >= 1.1,"- , B.append " roshask == 0.1.*" moreDeps+ , B.concat [+ " ", roshaskVersionBound, moreDeps ] , rosDeps , " GHC-Options: -O2" , B.concat [" Exposed-Modules: ", pkgName']@@ -109,4 +121,3 @@ , nodeName++" = return ()\n"] where pkgName' = toUpper (head pkgName) : tail pkgName nodeName = toLower (head pkgName) : tail pkgName-
+ src/executable/Types.hs view
@@ -0,0 +1,100 @@+{-# 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