Permalink
Browse files

Initial checkin for Haskell ROS bindings.

  • Loading branch information...
0 parents commit 82068576965778eade87ff67a31cdc1ee7d68ff4 Anthony Cowley committed Jun 2, 2010
Showing with 178 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +30 −0 LICENSE
  3. +62 −0 ROSTypes.hs
  4. +2 −0 Setup.hs
  5. +45 −0 SlaveAPI.hs
  6. +38 −0 roshask.cabal
1 .gitignore
@@ -0,0 +1 @@
+dist
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2010, Anthony Cowley
+
+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 Anthony Cowley 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.
62 ROSTypes.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE GADTs, ExistentialQuantification, ScopedTypeVariables #-}
+-- ROS Node implementation.
+module ROSTypes where
+import Data.Map (Map)
+import Data.Set (Set)
+--import qualified Network.XmlRpc.Internals as XmlRpc
+import Data.Typeable
+import Control.Concurrent (ThreadId)
+import Control.Concurrent.Chan
+import System.IO (Handle)
+
+type URI = String
+type CallerID = String
+type TopicName = String
+
+-- |A reflective interface for topics that names the type of data
+-- transmitted over the topic and includes the MD5 hash of the .msg
+-- file the type is derived from.
+class TopicType t where
+ name :: t -> String
+ md5 :: t -> String
+
+class Subscriber t where
+ subscribeTo :: t -> URI -> IO ThreadId
+
+class TopicType t => Publisher t where
+ publishTo :: t -> (a -> IO ThreadId)
+
+-- |A SubTopic has a function for connecting to a new publisher and the
+-- set of all known publishers of this topic.
+data SubTopic a where
+ SubTopic :: Typeable a => (URI -> IO ThreadId) -> Set URI -> SubTopic a
+
+instance Typeable a => Typeable (SubTopic a) where
+ typeOf (SubTopic _ _) = mkTyConApp subCon [typeOf (undefined::a)]
+ where subCon = mkTyCon "ROS.SubTopic"
+
+-- |A PubTopic has a list of actions for pushing new data to subscribers.
+data PubTopic a where
+ PubTopic :: Typeable a => [a -> IO ()] -> PubTopic a
+
+instance Typeable a => Typeable (PubTopic a) where
+ typeOf (PubTopic _) = mkTyConApp pubCon [typeOf (undefined::a)]
+ where pubCon = mkTyCon "ROS.PubTopic"
+
+instance TopicType a => TopicType (SubTopic a) where
+ name (SubTopic _ _) = name (undefined :: a)
+ md5 (SubTopic _ _) = md5 (undefined :: a)
+
+data ETopic = forall a. (TopicType a, Typeable a) => ETopic a
+
+instance Typeable ETopic where
+ typeOf (ETopic a) = typeOf a
+
+data Node = Node { master :: URI
+ , subscriptions :: Map TopicName ETopic
+ , publications :: Map TopicName ETopic
+ , threads :: [ThreadId]
+ , handles :: [Handle] }
+
+--, params :: Map String XmlRpc.Value }
+
2 Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
45 SlaveAPI.hs
@@ -0,0 +1,45 @@
+module SlaveAPI (getSubscriptions, getPublications) where
+import Control.Applicative
+import Control.Arrow (second)
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Typeable (cast)
+import ROSTypes
+
+data Slave = Slave { getSubscriptions :: [(TopicName, String)]
+ , getPublications :: [(TopicName, String)]
+ , publisherUpdate :: TopicName -> [URI] -> IO Slave }
+
+mkSlave :: Node -> Slave
+mkSlave = Slave <$> getSubs <*> getPubs <*> pubUpdate'
+
+topicType :: ETopic -> String
+topicType (ETopic t) = name t
+
+getSubs :: Node -> [(String, String)]
+getSubs = map (second topicType) . M.toList . subscriptions
+
+getPubs :: Node -> [(String, String)]
+getPubs = map (second topicType) . M.toList . publications
+
+pubUpdate :: Node -> TopicName -> [URI] -> Maybe (IO Node)
+pubUpdate n name publishers =
+ do topic <- M.lookup name (subscriptions n) :: Maybe ETopic
+ (SubTopic doSub knownPubs) <- cast topic
+ let pubs' = filter (flip S.notMember knownPubs) publishers
+ case pubs' of
+ [] -> Nothing
+ _ -> return $ do ts <- mapM doSub pubs'
+ let ts' = ts ++ threads n
+ pubs'' = S.union knownPubs (S.fromList pubs')
+ sub = SubTopic doSub pubs''
+ subs' = M.insert name (ETopic sub)
+ (subscriptions n)
+ return $ n { threads = ts'
+ , subscriptions = subs' }
+
+pubUpdate' :: Node -> TopicName -> [URI] -> IO Slave
+pubUpdate' n t pubs = case pubUpdate n t pubs of
+ Just updateNode -> do n' <- updateNode
+ return (mkSlave n')
+ Nothing -> return $ mkSlave n
38 roshask.cabal
@@ -0,0 +1,38 @@
+Name: roshask
+Version: 0.1
+Synopsis: Haskell support for ROS.
+-- A longer description of the package.
+-- Description:
+
+
+License: BSD3
+License-file: LICENSE
+Cabal-version: >=1.2
+Author: Anthony Cowley
+Maintainer: acowley@seas.upenn.edu
+
+-- A copyright notice.
+-- Copyright:
+
+Category: Robotics
+Build-type: Simple
+
+-- Extra files to be distributed with the package, such as examples or
+-- a README.
+-- Extra-source-files:
+
+Library
+ -- Modules exported by the library.
+ Exposed-modules: ROSTypes
+
+ -- Packages needed in order to build this package.
+ Build-depends: base >= 4,
+ containers,
+ haxr == 3000.*
+
+ -- Modules not exported by this package.
+ -- Other-modules:
+
+ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
+ -- Build-tools:
+

0 comments on commit 8206857

Please sign in to comment.