Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Address all compiler warnings.

  • Loading branch information...
commit aa521a6ef08a26a566411ce9f638f2e114ce8e15 1 parent 3d5df65
@acowley authored
Showing with 150 additions and 148 deletions.
  1. +5 −4 roshask.cabal
  2. 0  { → src}/Ros/BinaryIter.hs
  3. 0  { → src}/Ros/ConnectionHeader.hs
  4. 0  { → src}/Ros/Core/Build/DepFinder.hs
  5. 0  { → src}/Ros/Core/Build/Init.hs
  6. 0  { → src}/Ros/Core/Build/SetupUtil.hs
  7. 0  { → src}/Ros/Core/Header.hs
  8. +7 −7 { → src}/Ros/Core/Log.hs
  9. 0  { → src}/Ros/Core/Msg/Analysis.hs
  10. 0  { → src}/Ros/Core/Msg/FieldImports.hs
  11. 0  { → src}/Ros/Core/Msg/Gen.hs
  12. 0  { → src}/Ros/Core/Msg/HeaderSupport.hs
  13. 0  { → src}/Ros/Core/Msg/Instances/Binary.hs
  14. 0  { → src}/Ros/Core/Msg/Instances/NFData.hs
  15. 0  { → src}/Ros/Core/Msg/Instances/Storable.hs
  16. 0  { → src}/Ros/Core/Msg/MD5.hs
  17. 0  { → src}/Ros/Core/Msg/Main.hs
  18. 0  { → src}/Ros/Core/Msg/MsgInfo.hs
  19. 0  { → src}/Ros/Core/Msg/Parse.hs
  20. 0  { → src}/Ros/Core/Msg/PkgBuilder.hs
  21. 0  { → src}/Ros/Core/Msg/ResolutionTypes.hs
  22. 0  { → src}/Ros/Core/Msg/Test.hs
  23. 0  { → src}/Ros/Core/Msg/Types.hs
  24. +1 −1  { → src}/Ros/Core/PathUtil.hs
  25. +2 −4 { → src}/Ros/Core/RosBinary.hs
  26. 0  { → src}/Ros/Core/RosTime.hs
  27. 0  { → src}/Ros/Core/RosTypes.hs
  28. 0  { → src}/Ros/Core/Util/AppConfig.hs
  29. 0  { → src}/Ros/Core/Util/ArgRemapping.hs
  30. 0  { → src}/Ros/Core/Util/BytesToVector.hs
  31. +6 −5 { → src}/Ros/Core/Util/RingChan.hs
  32. 0  { → src}/Ros/Core/Util/StorableMonad.hs
  33. +9 −8 { → src}/Ros/Logging.hs
  34. 0  { → src}/Ros/MasterAPI.hs
  35. +16 −16 { → src}/Ros/Node.hs
  36. +4 −4 { → src}/Ros/NodeType.hs
  37. 0  { → src}/Ros/ParameterServerAPI.hs
  38. 0  { → src}/Ros/Rate.hs
  39. +7 −8 { → src}/Ros/RosTcp.hs
  40. +5 −6 { → src}/Ros/RunNode.hs
  41. +17 −14 { → src}/Ros/SlaveAPI.hs
  42. +10 −10 { → src}/Ros/Topic.hs
  43. 0  { → src}/Ros/TopicMT.hs
  44. 0  { → src}/Ros/TopicPID.hs
  45. +5 −5 { → src}/Ros/TopicStamped.hs
  46. 0  { → src}/Ros/TopicStats.hs
  47. +52 −52 { → src}/Ros/TopicUtil.hs
  48. +4 −4 { → src}/Ros/Util/PID.hs
View
9 roshask.cabal
@@ -1,5 +1,5 @@
Name: roshask
-Version: 0.1.0
+Version: 0.1.1
Synopsis: Haskell support for the ROS robotics framework.
License: BSD3
License-file: LICENSE
@@ -108,6 +108,7 @@ Library
BoundedChan >= 1.0.0.2,
parsec >= 3.1,
process >= 1.0.1.3,
+ SafeSemaphore,
snap-core >= 0.9,
snap-server >= 0.9,
storable-tuple >= 0.0.2,
@@ -121,8 +122,8 @@ Library
Build-depends: unix
- GHC-Options: -Odph -Wall -fno-warn-name-shadowing -fno-warn-duplicate-exports
- Hs-Source-Dirs: .
+ GHC-Options: -O2 -Wall
+ Hs-Source-Dirs: src
-- Modules not exported by this package.
Other-modules: Ros.MasterAPI Ros.SlaveAPI Ros.ParameterServerAPI
@@ -156,4 +157,4 @@ Executable roshask
Ros.Core.Msg.Instances.Binary Ros.Core.Msg.Instances.Storable
Ros.Core.Msg.FieldImports Ros.Core.Msg.Instances.NFData
Ros.Core.PathUtil Paths_roshask
- Hs-Source-Dirs: .
+ Hs-Source-Dirs: src
View
0  Ros/BinaryIter.hs → src/Ros/BinaryIter.hs
File renamed without changes
View
0  Ros/ConnectionHeader.hs → src/Ros/ConnectionHeader.hs
File renamed without changes
View
0  Ros/Core/Build/DepFinder.hs → src/Ros/Core/Build/DepFinder.hs
File renamed without changes
View
0  Ros/Core/Build/Init.hs → src/Ros/Core/Build/Init.hs
File renamed without changes
View
0  Ros/Core/Build/SetupUtil.hs → src/Ros/Core/Build/SetupUtil.hs
File renamed without changes
View
0  Ros/Core/Header.hs → src/Ros/Core/Header.hs
File renamed without changes
View
14 Ros/Core/Log.hs → src/Ros/Core/Log.hs
@@ -10,14 +10,14 @@ import Ros.Core.Msg.HeaderSupport
import qualified Data.Word as Word
import qualified Ros.Core.Header as Header
-data Log = Log { header :: Header.Header
- , level :: Word.Word8
- , name :: P.String
- , msg :: P.String
- , file :: P.String
+data Log = Log { header :: Header.Header
+ , level :: Word.Word8
+ , name :: P.String
+ , msg :: P.String
+ , file :: P.String
, function :: P.String
- , line :: Word.Word32
- , topics :: [P.String]
+ , line :: Word.Word32
+ , topics :: [P.String]
} deriving (P.Show, P.Eq, P.Ord, T.Typeable)
instance RosBinary Log where
View
0  Ros/Core/Msg/Analysis.hs → src/Ros/Core/Msg/Analysis.hs
File renamed without changes
View
0  Ros/Core/Msg/FieldImports.hs → src/Ros/Core/Msg/FieldImports.hs
File renamed without changes
View
0  Ros/Core/Msg/Gen.hs → src/Ros/Core/Msg/Gen.hs
File renamed without changes
View
0  Ros/Core/Msg/HeaderSupport.hs → src/Ros/Core/Msg/HeaderSupport.hs
File renamed without changes
View
0  Ros/Core/Msg/Instances/Binary.hs → src/Ros/Core/Msg/Instances/Binary.hs
File renamed without changes
View
0  Ros/Core/Msg/Instances/NFData.hs → src/Ros/Core/Msg/Instances/NFData.hs
File renamed without changes
View
0  Ros/Core/Msg/Instances/Storable.hs → src/Ros/Core/Msg/Instances/Storable.hs
File renamed without changes
View
0  Ros/Core/Msg/MD5.hs → src/Ros/Core/Msg/MD5.hs
File renamed without changes
View
0  Ros/Core/Msg/Main.hs → src/Ros/Core/Msg/Main.hs
File renamed without changes
View
0  Ros/Core/Msg/MsgInfo.hs → src/Ros/Core/Msg/MsgInfo.hs
File renamed without changes
View
0  Ros/Core/Msg/Parse.hs → src/Ros/Core/Msg/Parse.hs
File renamed without changes
View
0  Ros/Core/Msg/PkgBuilder.hs → src/Ros/Core/Msg/PkgBuilder.hs
File renamed without changes
View
0  Ros/Core/Msg/ResolutionTypes.hs → src/Ros/Core/Msg/ResolutionTypes.hs
File renamed without changes
View
0  Ros/Core/Msg/Test.hs → src/Ros/Core/Msg/Test.hs
File renamed without changes
View
0  Ros/Core/Msg/Types.hs → src/Ros/Core/Msg/Types.hs
File renamed without changes
View
2  Ros/Core/PathUtil.hs → src/Ros/Core/PathUtil.hs
@@ -42,6 +42,6 @@ codeGenDir f = do s <- stackName f
r <- getDataDir
let base = case s of
Nothing -> r
- Just s -> r </> s
+ Just s' -> r </> s'
return $ base </> pkg </> "Ros" </> pkg
where pkg = pathToPkgName f
View
6 Ros/Core/RosBinary.hs → src/Ros/Core/RosBinary.hs
@@ -1,8 +1,6 @@
{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-}
--- |Binary serialization deserialization utilities for types used in
--- ROS messages. This module is used by generated code for .msg
--- types.
-
+-- |Binary serialization/deserialization utilities for types used in
+-- ROS messages. This module is used by generated code for .msg types.
-- NOTE: The native byte ordering of the host is used to support the
-- common scenario of same-machine transport.
module Ros.Core.RosBinary where
View
0  Ros/Core/RosTime.hs → src/Ros/Core/RosTime.hs
File renamed without changes
View
0  Ros/Core/RosTypes.hs → src/Ros/Core/RosTypes.hs
File renamed without changes
View
0  Ros/Core/Util/AppConfig.hs → src/Ros/Core/Util/AppConfig.hs
File renamed without changes
View
0  Ros/Core/Util/ArgRemapping.hs → src/Ros/Core/Util/ArgRemapping.hs
File renamed without changes
View
0  Ros/Core/Util/BytesToVector.hs → src/Ros/Core/Util/BytesToVector.hs
File renamed without changes
View
11 Ros/Core/Util/RingChan.hs → src/Ros/Core/Util/RingChan.hs
@@ -2,7 +2,8 @@ module Ros.Core.Util.RingChan (RingChan, newRingChan, writeChan,
readChan, getChanContents, getBuffered) where
import Control.Monad (join)
import Control.Concurrent.MVar
-import Control.Concurrent.QSem
+import Control.Concurrent.SSem (SSem)
+import qualified Control.Concurrent.SSem as Sem
import qualified Data.Foldable as F
import Data.Sequence (Seq, (|>), viewl, ViewL(..))
import qualified Data.Sequence as Seq
@@ -17,11 +18,11 @@ import System.IO.Unsafe (unsafeInterleaveIO)
-- |A 'RingChan' is an 'MVar' containing a triple of maximum capacity, a
-- semaphore used to indicate that the chan has gone from empty to
-- non-empty, and a sequence of items.
-type RingChan a = (Int, QSem, MVar (Seq a))
+type RingChan a = (Int, SSem, MVar (Seq a))
-- |Create a 'RingChan' with the specified maximum capacity.
newRingChan :: Int -> IO (RingChan a)
-newRingChan n = do sem <- newQSem 0
+newRingChan n = do sem <- Sem.new 0
q <- newMVar Seq.empty
return (n,sem,q)
@@ -30,14 +31,14 @@ newRingChan n = do sem <- newQSem 0
writeChan :: RingChan a -> a -> IO ()
writeChan (n,sem,mv) x =
join $ modifyMVar mv (\q -> if Seq.length q < n
- then return (q |> x, signalQSem sem)
+ then return (q |> x, Sem.signal sem)
else let _ :< t = viewl q
in return (t |> x, return ()))
-- else return (q, return ()))
-- |Read an item from the channel. Blocks until an item is available.
readChan :: RingChan a -> IO a
-readChan (_,sem,mv) = do waitQSem sem
+readChan (_,sem,mv) = do Sem.wait sem
modifyMVar mv (\q -> let h :< t = viewl q
in return (t,h))
View
0  Ros/Core/Util/StorableMonad.hs → src/Ros/Core/Util/StorableMonad.hs
File renamed without changes
View
17 Ros/Logging.hs → src/Ros/Logging.hs
@@ -9,7 +9,8 @@ import Control.Monad (when)
import Data.IORef
import System.IO.Unsafe
import Data.Word (Word8)
-import Ros.Core.Log
+import Ros.Core.Log (Log(Log))
+import qualified Ros.Core.Log as Log
import Ros.Core.Header
import Ros.Node
import Ros.TopicUtil (fromList)
@@ -31,11 +32,11 @@ mkLogMsg level msg = do Loc fname _ _ start _ <- location
--
-- > $(logDebug "This is my message to you")
logDebug, logWarn, logInfo, logError, logFatal :: String -> Q Exp
-logDebug = mkLogMsg dEBUG
-logInfo = mkLogMsg iNFO
-logWarn = mkLogMsg wARN
-logError = mkLogMsg eRROR
-logFatal = mkLogMsg fATAL
+logDebug = mkLogMsg Log.dEBUG
+logInfo = mkLogMsg Log.iNFO
+logWarn = mkLogMsg Log.wARN
+logError = mkLogMsg Log.eRROR
+logFatal = mkLogMsg Log.fATAL
-- The 'Chan' into which all log messages are funneled. This Chan's
-- contents are fed into the /rosout 'Topic'.
@@ -58,7 +59,7 @@ nodeName = unsafePerformIO $ newIORef ""
-- Publish a log message.
sendMsg :: Log -> IO ()
sendMsg msg = do n <- readIORef nodeName
- let msg' = msg { name = n }
+ let msg' = msg { Log.name = n }
($ msg') =<< readIORef showLevel
writeChan rosOutChan msg'
@@ -66,7 +67,7 @@ sendMsg msg = do n <- readIORef nodeName
-- specified level.
printLog :: LogLevel -> Log -> IO ()
printLog lvl = let code = 2 ^ fromEnum lvl
- in \msg -> when (level msg >= code) (putStrLn (show msg))
+ in \msg -> when (Log.level msg >= code) (putStrLn (show msg))
-- |Log message levels. These allow for simple filtering of messages.
data LogLevel = Debug | Info | Warn | Error | Fatal deriving (Eq, Enum)
View
0  Ros/MasterAPI.hs → src/Ros/MasterAPI.hs
File renamed without changes
View
32 Ros/Node.hs → src/Ros/Node.hs
@@ -129,14 +129,14 @@ advertise :: (RosBinary a, MsgInfo a, Typeable a) =>
TopicName -> Topic IO a -> Node ()
advertise = advertiseBuffered 1
--- |Existentially quantified message type that roshask can
--- serialize. This type provides a way to work with collections of
--- differently typed 'Topic's.
-data SomeMsg = forall a. (RosBinary a, MsgInfo a, Typeable a) => SomeMsg a
+-- -- |Existentially quantified message type that roshask can
+-- -- serialize. This type provides a way to work with collections of
+-- -- differently typed 'Topic's.
+-- data SomeMsg = forall a. (RosBinary a, MsgInfo a, Typeable a) => SomeMsg a
--- |Advertise projections of a 'Topic' as discrete 'Topic's.
-advertiseSplit :: [(TopicName, a -> SomeMsg)] -> Topic IO a -> Node ()
-advertiseSplit = undefined
+-- -- |Advertise projections of a 'Topic' as discrete 'Topic's.
+-- advertiseSplit :: [(TopicName, a -> SomeMsg)] -> Topic IO a -> Node ()
+-- advertiseSplit = undefined
-- |Get an action that will shutdown this Node.
getShutdownAction :: Node (IO ())
@@ -193,27 +193,27 @@ getNamespace = namespace <$> get
-- |Run a ROS Node.
runNode :: NodeName -> Node a -> IO ()
-runNode name (Node n) =
+runNode name (Node nConf) =
do myURI <- newEmptyMVar
sigStop <- newEmptyMVar
env <- liftIO getEnvironment
(conf, args) <- parseAppConfig <$> liftIO getArgs
let getConfig' var def = maybe def id $ lookup var env
getConfig = flip lookup env
- master = getConfig' "ROS_MASTER_URI" "http://localhost:11311"
- namespace = let ns = getConfig' "ROS_NAMESPACE" "/"
- in if last ns == '/' then ns else ns ++ "/"
+ masterConf = getConfig' "ROS_MASTER_URI" "http://localhost:11311"
+ namespaceConf = let ns = getConfig' "ROS_NAMESPACE" "/"
+ in if last ns == '/' then ns else ns ++ "/"
(nameMap, params) = parseRemappings args
name' = case lookup "__name" params of
Just x -> fromParam x
Nothing -> case name of
'/':_ -> name
- _ -> namespace ++ name
+ _ -> namespaceConf ++ name
-- Name remappings apply to exact strings and resolved names.
resolve p@(('/':_),_) = [p]
resolve (('_':n),v) = [(name'++"/"++n, v)]
resolve (('~':n),v) = [(name'++"/"++ n, v)] --, ('_':n,v)]
- resolve (n,v) = [(namespace ++ n,v), (n,v)]
+ resolve (n,v) = [(namespaceConf ++ n,v), (n,v)]
nameMap' = concatMap resolve nameMap
params' = concatMap resolve params
when (not $ null nameMap')
@@ -225,8 +225,8 @@ runNode name (Node n) =
Nothing -> return ()
Just n -> putMVar myURI $! "http://"++n
Just ip -> putMVar myURI $! "http://"++ip
- let configuredNode = runReaderT n (NodeConfig params' nameMap' conf)
- initialState = NodeState name' namespace master myURI sigStop
- M.empty M.empty
+ let configuredNode = runReaderT nConf (NodeConfig params' nameMap' conf)
+ initialState = NodeState name' namespaceConf masterConf myURI
+ sigStop M.empty M.empty
statefulNode = execStateT configuredNode initialState
statefulNode >>= flip runReaderT conf . RN.runNode name'
View
8 Ros/NodeType.hs → src/Ros/NodeType.hs
@@ -83,11 +83,11 @@ instance RosSlave NodeState where
Nothing -> return (return ())
Just sub -> do let add = addPub sub >=> \_ -> return ()
known <- readTVar (knownPubs sub)
- (act,known') <- foldM (connectToPub add)
- (return (), known)
- uris
+ (act',known') <- foldM (connectToPub add)
+ (return (), known)
+ uris
writeTVar (knownPubs sub) known'
- return act
+ return act'
in act
getTopicPortTCP = ((pubPort <$> ) .) . flip M.lookup . publications
setShutdownAction ns a = putMVar (signalShutdown ns) a
View
0  Ros/ParameterServerAPI.hs → src/Ros/ParameterServerAPI.hs
File renamed without changes
View
0  Ros/Rate.hs → src/Ros/Rate.hs
File renamed without changes
View
15 Ros/RosTcp.hs → src/Ros/RosTcp.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
-module Ros.RosTcp (subStream, runServer) where
-import Prelude hiding (catch)
+module Ros.RosTcp (subStream, runServer, runServers) where
import Control.Applicative ((<$>))
import Control.Arrow (first)
import Control.Concurrent (forkIO, killThread, newEmptyMVar, takeMVar, putMVar)
@@ -40,7 +39,7 @@ serviceClient c s = forever $ do bs <- readChan c
sendMany s (BL.toChunks (BL.append len bs))
recvAll :: Socket -> Int -> IO B.ByteString
-recvAll s len = go len []
+recvAll s = flip go []
where go len acc = do bs <- recv s len
if B.length bs < len
then go (len - B.length bs) (bs:acc)
@@ -103,7 +102,7 @@ acceptClients sock clients negotiate mkBuffer = forever acceptClient
-- |Publish each item obtained from a 'Topic' to each connected client.
pubStream :: RosBinary a => Topic IO a -> TVar [(b, RingChan ByteString)] -> Config ()
-pubStream t clients = liftIO $ go 0 t
+pubStream t0 clients = liftIO $ go 0 t0
where go !n t = do (x, t') <- runTopic t
let bytes = runPut $ putMsg n x
cs <- readTVarIO clients
@@ -173,7 +172,7 @@ subStream target tname _updateStats =
return $ streamIn h
where host = case parseURI target of
Just u -> case uriRegName u of
- Just host -> host
+ Just host' -> host'
Nothing -> error $ "Couldn't parse hostname "++
"from "++target
Nothing -> error $ "Couldn't parse URI "++target
@@ -222,7 +221,7 @@ runServer stream = runServerAux (mkPubNegotiator (undefined::a))
-- |The 'MsgInfo' type class dictionary made explicit to strip off the
-- actual message type.
-data MsgInfoRcd = MsgInfoRcd { md5, typeName :: String }
+data MsgInfoRcd = MsgInfoRcd { _md5, _typeName :: String }
-- |A 'Feeder' represents a 'Topic' fully prepared to accept
-- subscribers.
@@ -251,6 +250,6 @@ feedTopic updateStats bufSize =
-- the input 'Feeder's.
runServers :: [Feeder] -> Config (Config (), [Int])
runServers = return . first sequence_ . unzip <=< mapM feed
- where feed (Feeder info bufSize stats push) =
- let pub = negotiatePub (typeName info) (md5 info)
+ where feed (Feeder (MsgInfoRcd md5 typeName) bufSize stats push) =
+ let pub = negotiatePub typeName md5
in runServerAux pub push stats bufSize
View
11 Ros/RunNode.hs → src/Ros/RunNode.hs
@@ -1,7 +1,6 @@
module Ros.RunNode (runNode) where
-import Prelude hiding (catch)
import Control.Concurrent (readMVar,forkIO, killThread)
-import Control.Concurrent.QSem (newQSem, signalQSem, waitQSem)
+import qualified Control.Concurrent.SSem as Sem
import Control.Exception (catch, SomeException)
import Control.Monad.IO.Class
import System.Posix.Signals (installHandler, Handler(..), sigINT)
@@ -49,14 +48,14 @@ runNode :: RosSlave s => String -> s -> Config ()
runNode name s = do (wait, _port) <- liftIO $ runSlave s
registerNode name s
debug "Spinning"
- allDone <- liftIO $ newQSem 0
+ allDone <- liftIO $ Sem.new 0
let ignoreEx :: SomeException -> IO ()
ignoreEx _ = return ()
shutdown = do putStrLn "Shutting down"
cleanupNode s `catch` ignoreEx
- signalQSem allDone
+ Sem.signal allDone
liftIO $ setShutdownAction s shutdown
_ <- liftIO $ installHandler sigINT (CatchOnce shutdown) Nothing
- t <- liftIO . forkIO $ wait >> signalQSem allDone
- liftIO $ waitQSem allDone
+ t <- liftIO . forkIO $ wait >> Sem.signal allDone
+ liftIO $ Sem.wait allDone
liftIO $ killThread t `catch` ignoreEx
View
31 Ros/SlaveAPI.hs → src/Ros/SlaveAPI.hs
@@ -4,15 +4,18 @@ module Ros.SlaveAPI (RosSlave(..), runSlave, requestTopicClient,
import Control.Applicative
import Control.Concurrent (killThread, forkIO, threadDelay, MVar, putMVar,
isEmptyMVar, readMVar, modifyMVar_)
-import Control.Concurrent.QSem
+import Control.Concurrent.SSem (SSem)
+import qualified Control.Concurrent.SSem as Sem
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.UTF8 ()
import qualified Data.ByteString.Lazy.UTF8 as BLU
import Snap.Http.Server (simpleHttpServe)
import Snap.Http.Server.Config (defaultConfig, setPort, Config, ConfigLog(..),
setVerbose, setAccessLog, setErrorLog)
-import Snap.Types (Snap, getRequestBody, writeLBS,
- getResponse, putResponse, setContentLength)
+-- import Snap.Types (Snap, getRequestBody, writeLBS,
+-- getResponse, putResponse, setContentLength)
+import Snap.Core (Snap, readRequestBody, writeLBS, getResponse, putResponse,
+ setContentLength)
import Network.Socket hiding (Stream)
import qualified Network.Socket as Net
import Network.XmlRpc.Internals (Value)
@@ -23,7 +26,7 @@ import System.Posix.Process (getProcessID)
#endif
import System.Process (readProcess)
import Ros.Core.RosTypes
-import Ros.TopicStats
+import Ros.TopicStats (PubStats(PubStats), SubStats(SubStats))
import Ros.MasterAPI
class RosSlave a where
@@ -93,8 +96,8 @@ getBusInfo n _ = do
getMaster' :: RosSlave a => a -> CallerID -> IO (Int, String, URI)
getMaster' n _ = return (1, "", getMaster n)
-shutdown' :: RosSlave a => a -> QSem -> CallerID -> IO (Int, String, Bool)
-shutdown' n q _ = stopNode n >> signalQSem q >> return (1, "", True)
+shutdown' :: RosSlave a => a -> SSem -> CallerID -> IO (Int, String, Bool)
+shutdown' n q _ = stopNode n >> Sem.signal q >> return (1, "", True)
-- This requires a dependency on the unix package and so is not cross
-- platform.
@@ -103,13 +106,13 @@ getPid' _ = do pid <- getProcessID
return (1, "", fromEnum pid)
getSubscriptions' :: RosSlave a => a -> CallerID -> RpcResult [(String, String)]
-getSubscriptions' n _ = do
- subs <- map (\(n,t,_) -> (n,t)) <$> getSubscriptions n
+getSubscriptions' node _ = do
+ subs <- map (\(n,t,_) -> (n,t)) <$> getSubscriptions node
return (1, "", subs)
getPublications' :: RosSlave a => a -> CallerID -> RpcResult [(String, String)]
-getPublications' n _ = do
- pubs <- map (\(n,t,_) -> (n,t)) <$> getPublications n
+getPublications' node _ = do
+ pubs <- map (\(n,t,_) -> (n,t)) <$> getPublications node
return (1, "", pubs)
paramUpdate' :: RosSlave a => a -> CallerID -> String -> Value -> RpcResult Bool
@@ -143,7 +146,7 @@ requestTopicClient = flip remote "requestTopic"
-- parameter is a value that provides the necessary reflective API as
-- to ROS Node state. The second parameter is a semaphore indicating
-- that the node should terminate.
-slaveRPC :: (RosSlave a) => a -> QSem -> String -> IO BLU.ByteString
+slaveRPC :: (RosSlave a) => a -> SSem -> String -> IO BLU.ByteString
slaveRPC n = -- \q s -> putStrLn ("Slave call "++s)>>(handleCall (dispatch q) s)
handleCall . dispatch
where dispatch q = methods [ ("getBusStats", fun (getBusStats n))
@@ -180,7 +183,7 @@ findFreePort = do s <- socket AF_INET Net.Stream defaultProtocol
-- |Run a ROS slave node. Returns an action that will wait for the
-- node to shutdown along with the port the server is running on.
runSlave :: RosSlave a => a -> IO (IO (), Int)
-runSlave n = do quitNow <- newQSem 0
+runSlave n = do quitNow <- Sem.new 0
port <- findFreePort
let myUri = getNodeURI n
myPort = ":" ++ show port
@@ -190,13 +193,13 @@ runSlave n = do quitNow <- newQSem 0
putMVar myUri $! "http://"++myIP++myPort
else modifyMVar_ myUri ((return $!) . (++myPort))
t <- forkIO $ simpleServe port (rpc (slaveRPC n quitNow))
- let wait = do waitQSem quitNow
+ let wait = do Sem.wait quitNow
-- Wait a second for the response to flush
threadDelay 1000000
stopNode n
killThread t
return (wait, port)
- where rpc f = do body <- BLU.toString <$> getRequestBody
+ where rpc f = do body <- BLU.toString <$> readRequestBody 4096
response <- liftIO $ f body
writeLBS response
let len = fromIntegral $ BLU.length response
View
20 Ros/Topic.hs → src/Ros/Topic.hs
@@ -25,7 +25,7 @@ instance Applicative m => Applicative (Topic m) where
instance (Typeable1 m, Typeable a) => Typeable (Topic m a) where
- typeOf _ = mkTyConApp (mkTyCon "Topic")
+ typeOf _ = mkTyConApp (mkTyCon3 "roshask" "Ros.Topic" "Topic")
[typeOf1 (undefined::m a), typeOf (undefined::a)]
-- |Return the first value produced by a 'Topic'.
@@ -68,10 +68,10 @@ filter p = metamorph go
-- |@take n t@ returns the prefix of @t@ of length @n@.
take :: Monad m => Int -> Topic m a -> m [a]
-take n t = aux n t []
- where aux 0 _ acc = return (reverse acc)
- aux n t acc = do (x, t') <- runTopic t
- aux (n-1) t' (x:acc)
+take = aux []
+ where aux acc 0 _ = return (reverse acc)
+ aux acc n' t = do (x, t') <- runTopic t
+ aux (x:acc) (n'-1) t'
-- |Run a 'Topic' for the specified number of iterations, discarding
-- the values it produces.
@@ -81,7 +81,7 @@ take_ n = take_ (n-1) . snd <=< runTopic
-- |@drop n t@ returns the suffix of @t@ after the first @n@ elements.
drop :: Monad m => Int -> Topic m a -> Topic m a
-drop n = Topic . aux n
+drop = (Topic .) . aux
where aux 0 = runTopic
aux n = aux (n-1) . snd <=< runTopic
@@ -116,10 +116,10 @@ break p = go []
-- @t@ of length @n@, and whose second element is the remainder of the
-- 'Topic'.
splitAt :: Monad m => Int -> Topic m a -> m ([a], Topic m a)
-splitAt n = go n []
- where go 0 acc t = return (reverse acc, t)
- go n acc t = do (x,t') <- runTopic t
- go (n-1) (x:acc) t'
+splitAt = go []
+ where go acc 0 t = return (reverse acc, t)
+ go acc n t = do (x,t') <- runTopic t
+ go (x:acc) (n-1) t'
-- |Returns a 'Topic' that includes only the 'Just' values from the
-- given 'Topic'.
View
0  Ros/TopicMT.hs → src/Ros/TopicMT.hs
File renamed without changes
View
0  Ros/TopicPID.hs → src/Ros/TopicPID.hs
File renamed without changes
View
10 Ros/TopicStamped.hs → src/Ros/TopicStamped.hs
@@ -85,9 +85,9 @@ interpolate :: (HasHeader a, HasHeader b) =>
(a -> a -> Double -> a) -> Topic IO a -> Topic IO b ->
Topic IO (a,b)
interpolate f t1 t2 = interp `fmap` findBrackets t1 t2
- where interp ((x1,x2,dt),y) = let t1 = getStamp x1
+ where interp ((x1,x2,dt),y) = let tx1 = getStamp x1
ty = getStamp y
- in (f x1 x2 (diffSeconds ty t1 / dt), y)
+ in (f x1 x2 (diffSeconds ty tx1 / dt), y)
-- |Batch 'Topic' values that arrive within the given time window
-- (expressed in seconds). When a value arrives, the window opens and
@@ -99,8 +99,8 @@ interpolate f t1 t2 = interp `fmap` findBrackets t1 t2
-- window, rather than having to admit any message that ever arrives
-- with a compatible time stamp.
batch :: Double -> Topic IO a -> Topic IO [a]
-batch timeWindow t =
- Topic $ do (x,t') <- runTopic t
+batch timeWindow t0 =
+ Topic $ do (x,t') <- runTopic t0
start <- getCurrentTime
let go acc t = do now <- getCurrentTime
let dt = fromRational . toRational $
@@ -110,7 +110,7 @@ batch timeWindow t =
then return (reverse acc, k t)
else do r <- timeout dMs $ runTopic t
case r of
- Just (x,t') -> go (x:acc) t'
+ Just (x',t'') -> go (x':acc) t''
Nothing -> return (reverse acc, k t)
go [x] t'
where k = batch timeWindow
View
0  Ros/TopicStats.hs → src/Ros/TopicStats.hs
File renamed without changes
View
104 Ros/TopicUtil.hs → src/Ros/TopicUtil.hs
@@ -19,12 +19,12 @@ import Ros.Topic hiding (mapM_)
-- |Produce an infinite list from a 'Topic'.
toList :: Topic IO a -> IO [a]
-toList t = do c <- newChan
- let feed t = do (x, t') <- runTopic t
- writeChan c x
- feed t'
- _ <- forkIO $ feed t
- getChanContents c
+toList t0 = do c <- newChan
+ let feed t = do (x, t') <- runTopic t
+ writeChan c x
+ feed t'
+ _ <- forkIO $ feed t0
+ getChanContents c
-- |Produce a 'Topic' from an infinite list.
fromList :: Monad m => [a] -> Topic m a
@@ -49,20 +49,20 @@ fromList [] = error "Ran out of list elements"
-- one consumer might get the first value from the 'Topic' before the
-- second consumer's buffer is created since buffer creation is lazy.
tee :: Topic IO a -> IO (Topic IO a, Topic IO a)
-tee t = do c1 <- newTChanIO
- c2 <- newTChanIO
- signal <- newTVarIO True
- let feed c = do atomically $ do f <- isEmptyTChan c
- when f (writeTVar signal False)
- atomically $ readTChan c
- produce t = do atomically $ readTVar signal >>= flip when retry
- (x,t') <- runTopic t
- atomically $ writeTChan c1 x >>
- writeTChan c2 x >>
- writeTVar signal True
- produce t'
- _ <- forkIO $ produce t
- return (repeatM (feed c1), repeatM (feed c2))
+tee t0 = do c1 <- newTChanIO
+ c2 <- newTChanIO
+ signal <- newTVarIO True
+ let feed c = do atomically $ do f <- isEmptyTChan c
+ when f (writeTVar signal False)
+ atomically $ readTChan c
+ produce t = do atomically $ readTVar signal >>= flip when retry
+ (x,t') <- runTopic t
+ atomically $ writeTChan c1 x >>
+ writeTChan c2 x >>
+ writeTVar signal True
+ produce t'
+ _ <- forkIO $ produce t0
+ return (repeatM (feed c1), repeatM (feed c2))
-- |This version of @tee@ eagerly pulls data from the
-- original 'Topic' as soon as it is available. This behavior is
@@ -85,18 +85,18 @@ teeEager t = do c1 <- newChan
-- when a known number of consumers must see exactly all the same
-- elements.
fan :: Int -> Topic IO a -> IO [Topic IO a]
-fan n t = do cs <- replicateM n newTChanIO
- signal <- newTVarIO True
- let feed c = do atomically $ do f <- isEmptyTChan c
- when f (writeTVar signal False)
- atomically $ readTChan c
- produce t = do atomically $ readTVar signal >>= flip when retry
- (x,t') <- runTopic t
- atomically $ mapM_ (flip writeTChan x) cs >>
- writeTVar signal True
- produce t'
- _ <- forkIO $ produce t
- return $ map (repeatM . feed) cs
+fan n t0 = do cs <- replicateM n newTChanIO
+ signal <- newTVarIO True
+ let feed c = do atomically $ do f <- isEmptyTChan c
+ when f (writeTVar signal False)
+ atomically $ readTChan c
+ produce t = do atomically $ readTVar signal >>= flip when retry
+ (x,t') <- runTopic t
+ atomically $ mapM_ (flip writeTChan x) cs >>
+ writeTVar signal True
+ produce t'
+ _ <- forkIO $ produce t0
+ return $ map (repeatM . feed) cs
-- |Make a 'Topic' shareable among multiple consumers. Each consumer
-- of a Topic gets its own read buffer automatically as soon as it
@@ -107,23 +107,23 @@ fan n t = do cs <- replicateM n newTChanIO
-- with some unpredictable interleaving). Note that Topics returned by
-- the @Ros.Node.subscribe@ are already shared.
share :: Topic IO a -> IO (Topic IO a)
-share t = do cs <- newTVarIO [] -- A list for the individual client buffers
- signal <- newTVarIO True
- let addClient = atomically $ do cs0 <- readTVar cs
- c <- newTChan
- writeTVar cs (c:cs0)
- return c
- feed c = do atomically $ do f <- isEmptyTChan c
- when f (writeTVar signal False)
- atomically $ readTChan c
- produce t = do atomically $ readTVar signal >>= flip when retry
- (x,t') <- runTopic t
- atomically $ do cs' <- readTVar cs
- mapM_ (flip writeTChan x) cs'
- writeTVar signal True
- produce t'
- _ <- forkIO $ produce t
- return . Topic $ addClient >>= runTopic . repeatM . feed
+share t0 = do cs <- newTVarIO [] -- A list for the individual client buffers
+ signal <- newTVarIO True
+ let addClient = atomically $ do cs0 <- readTVar cs
+ c <- newTChan
+ writeTVar cs (c:cs0)
+ return c
+ feed c = do atomically $ do f <- isEmptyTChan c
+ when f (writeTVar signal False)
+ atomically $ readTChan c
+ produce t = do atomically $ readTVar signal >>= flip when retry
+ (x,t') <- runTopic t
+ atomically $ do cs' <- readTVar cs
+ mapM_ (flip writeTChan x) cs'
+ writeTVar signal True
+ produce t'
+ _ <- forkIO $ produce t0
+ return . Topic $ addClient >>= runTopic . repeatM . feed
-- |The application @topicRate rate t@ runs 'Topic' @t@ no faster than
-- @rate@ Hz.
@@ -234,8 +234,8 @@ weightedMeanNormalized alpha invAlpha plus scale normalize = Topic . warmup
-- by a fractional number.
simpsonsRule :: (Monad m, Fractional n) =>
(a -> a -> a) -> (n -> a -> a) -> Topic m a -> Topic m a
-simpsonsRule plus scale t = Topic $ do ([x,y], t') <- splitAt 2 t
- go x y t'
+simpsonsRule plus scale t0 = Topic $ do ([x,y], t') <- splitAt 2 t0
+ go x y t'
where go x y t = do (z,t') <- runTopic t
return (simpson x y z, Topic $ go y z t')
simpson a mid b = scale c $ plus (plus a (scale 4 mid)) b
@@ -290,7 +290,7 @@ gate t1 t2 = const <$> t1 <*> t2
-- element from each list in sequence.
concats :: (Monad m, F.Foldable f) => Topic m (f a) -> Topic m a
concats t = Topic $ do (x, t') <- runTopic t
- F.foldr (\x z -> return (x, Topic z))
+ F.foldr (\x' z -> return (x', Topic z))
(runTopic $ concats t')
x
View
8 Ros/Util/PID.hs → src/Ros/Util/PID.hs
@@ -47,8 +47,8 @@ pidFixedIO kp ki kd dt =
return $ \setpoint ->
let pid' = pidFixed kp ki kd setpoint dt
in \x ->
- do init <- readIORef initialized
- case init of
+ do init' <- readIORef initialized
+ case init' of
0 -> do writeIORef e1 (x - setpoint)
writeIORef initialized 1
return 0
@@ -88,8 +88,8 @@ pidWithTimeIO kp ki kd =
return $ \setpoint ->
let pid' = pidTimed kp ki kd setpoint
in \(t,x) ->
- do init <- readIORef initialized
- case init of
+ do init' <- readIORef initialized
+ case init' of
0 -> do writeIORef e1 (t, x - setpoint)
writeIORef initialized 1
return 0
Please sign in to comment.
Something went wrong with that request. Please try again.