Permalink
Browse files

Save code for generated message types in a Cabal data directory.

  • Loading branch information...
1 parent 069eb6a commit c2e4eae65fa46f5fb8d53770040840f84cf548d6 Anthony Cowley committed Jul 30, 2011
View
9 Ros/Core/Build/DepFinder.hs
@@ -3,7 +3,8 @@
module Ros.Core.Build.DepFinder (findPackageDeps, findPackageDepNames,
findPackageDepsTrans,
findMessages, findMessage, findMessagesInPkg,
- findDepsWithMessages, hasMsgs) where
+ findDepsWithMessages, hasMsgs
+ ) where
import Control.Applicative ((<$>))
import Control.Monad (when, filterM)
import Data.Maybe (mapMaybe, isNothing, fromJust)
@@ -15,6 +16,8 @@ import System.FilePath ((</>), splitSearchPath, takeExtension,
dropExtension, takeFileName, splitPath)
import Text.XML.Light
+import Ros.Core.PathUtil (isPkg, isStack)
+
type Package = String
-- Find the path to a package based on the given search paths.
@@ -58,9 +61,7 @@ packagePaths path = do p <- isPkg path
(mapM stackPackages =<<
filterM isStack =<<
dir path)
- where isPkg = doesFileExist . (</> "manifest.xml")
- isStack = doesFileExist . (</> "stack.xml")
- stackPackages p = do isDir <- doesDirectoryExist p
+ where stackPackages p = do isDir <- doesDirectoryExist p
if isDir
then do isp <- isPkg p
if isp
View
8 Ros/Core/Msg/Analysis.hs
@@ -64,10 +64,10 @@ getMsg msgName = check <$>
check :: Maybe SerialMsg -> SerialMsg
check Nothing = error $ "Couldn't resolve type " ++ unpack msgName
check (Just m) = m
- checkLocal :: Maybe SerialMsg -> MsgInfo (Maybe SerialMsg)
- checkLocal Nothing = do home <- homePkg <$> get
- getMsgFromPkg home msgName
- checkLocal info = return info
+ -- checkLocal :: Maybe SerialMsg -> MsgInfo (Maybe SerialMsg)
+ -- checkLocal Nothing = do home <- homePkg <$> get
+ -- getMsgFromPkg home msgName
+ -- checkLocal info = return info
(<||>) :: (Applicative f, Alternative g) => f (g a) -> f (g a) -> f (g a)
(<||>) = liftA2 (<|>)
View
6 Ros/Core/Msg/Gen.hs
@@ -7,10 +7,10 @@ import qualified Data.ByteString.Char8 as B
import Data.Char (toUpper)
import Ros.Core.Msg.Analysis (MsgInfo, SerialInfo(..), withMsg, getTypeInfo)
import Ros.Core.Msg.Types
-import Ros.Core.Msg.BinaryInstance
import Ros.Core.Msg.FieldImports
-import Ros.Core.Msg.StorableInstance
---import Ros.Core.Msg.NFDataInstance
+import Ros.Core.Msg.Instances.Binary
+import Ros.Core.Msg.Instances.Storable
+--import Ros.Core.Msg.Instances.NFData
import Ros.Core.Msg.MD5
generateMsgType :: ByteString -> [ByteString] -> Msg -> MsgInfo ByteString
View
20 Ros/Core/Msg/Main.hs
@@ -2,24 +2,20 @@
module Main (main) where
import Control.Applicative
import qualified Data.ByteString.Char8 as B
-import Data.Char (toUpper)
import System.Directory (createDirectoryIfMissing, getCurrentDirectory,
getDirectoryContents)
import System.Environment (getArgs)
import System.Exit (exitWith, ExitCode(..))
-import System.FilePath (replaceExtension, splitFileName, splitPath, isRelative,
- (</>), dropFileName, dropExtension, takeExtension)
+import System.FilePath (replaceExtension, isRelative, (</>), dropFileName,
+ takeFileName, dropExtension, takeExtension)
import Ros.Core.Msg.Analysis (runAnalysis)
import Ros.Core.Msg.Parse
import Ros.Core.Msg.Gen
import Ros.Core.Msg.MD5
import Ros.Core.Msg.PkgBuilder (buildPkgMsgs)
import Ros.Core.Build.DepFinder (findPackageDeps, findPackageDepsTrans)
import Ros.Core.Build.Init (initPkg)
-
--- Ensure that the first character in a String is capitalized.
-cap :: String -> String
-cap s = toUpper (head s) : tail s
+import Ros.Core.PathUtil (cap, codeGenDir, pathToPkgName)
-- Get a list of all messages defined in a directory.
pkgMessages :: FilePath -> IO [FilePath]
@@ -31,11 +27,11 @@ generateAndSave :: FilePath -> IO ()
generateAndSave fname = do msgType <- fst <$> generate fname
fname' <- hsName
B.writeFile fname' msgType
- where hsName = do createDirectoryIfMissing True d'
+ where hsName = do d' <- codeGenDir fname
+ createDirectoryIfMissing True d'
return $ d' </> f
- (d,f) = splitFileName $ replaceExtension fname ".hs"
- pkgName = cap . last . init . splitPath $ d
- d' = d </> "haskell" </> "Ros" </> pkgName
+ f = replaceExtension (takeFileName fname) ".hs"
+ -- d' = d </> "haskell" </> "Ros" </> pkgName
generate :: FilePath -> IO (B.ByteString, String)
generate fname =
@@ -50,7 +46,7 @@ generate fname =
return (hMsg, md5)
where pkgHier = B.pack $ "Ros." ++ init pkgName ++ "."
dir = dropFileName fname
- pkgName = cap . last . init . splitPath $ dir
+ pkgName = pathToPkgName dir
-- |Run "roshask gen" on all the .msg files in each of the given
-- package directories.
View
9 Ros/Core/Msg/PkgBuilder.hs
@@ -16,6 +16,7 @@ import Ros.Core.Build.DepFinder (findMessages, findDepsWithMessages, hasMsgs)
import Ros.Core.Msg.Analysis
import Ros.Core.Msg.Gen (generateMsgType)
import Ros.Core.Msg.Parse (parseMsg)
+import Ros.Core.PathUtil (codeGenDir)
import Data.ByteString.Char8 (ByteString)
import Paths_roshask (version)
import Data.Version (versionBranch)
@@ -34,6 +35,7 @@ roshaskMajorMinor = B.pack . intercalate "." $
-- Build all messages defined by a package.
buildPkgMsgs :: FilePath -> MsgInfo ()
buildPkgMsgs fname = do liftIO . putStrLn $ "Generating package " ++ fname
+ destDir <- liftIO $ codeGenDir fname
liftIO $ createDirectoryIfMissing True destDir
pkgMsgs <- liftIO $ findMessages fname
let pkgMsgs' = map (B.pack . cap .
@@ -55,7 +57,7 @@ buildPkgMsgs fname = do liftIO . putStrLn $ "Generating package " ++ fname
when f (removeOldCabal fname >> compileMsgs)
where err pkg = error $ "Couldn't parse message " ++ pkg
- destDir = fname </> "msg" </> "haskell" </> "Ros" </> cap pkgName
+ --destDir = fname </> "msg" </> "haskell" </> "Ros" </> cap pkgName
pkgName = last . splitDirectories $ fname
pkgHier = B.pack $ "Ros." ++ cap pkgName ++ "."
isLeft (Left _) = True
@@ -108,6 +110,7 @@ genMsgCabal :: FilePath -> String -> IO FilePath
genMsgCabal pkgPath pkgName =
do deps' <- map (B.pack . rosPkg2CabalPkg) <$>
findDepsWithMessages pkgPath
+ cabalFilePath <- (</>cabalPkg) . init . init <$> codeGenDir pkgPath
let deps
| pkgName == "std_msgs" = deps'
| otherwise = nub ("ROS-std-msgs":deps')
@@ -133,10 +136,10 @@ genMsgCabal pkgPath pkgName =
map (B.append " ") deps
, " GHC-Options: -Odph" ]
pkgDesc = B.concat [preamble, "\n", target]
- cabalFilePath = pkgPath</>"msg"</>"haskell"</>cabalPkg++".cabal"
+ --cabalFilePath = pkgPath</>"msg"</>"haskell"</>cabalPkg++".cabal"
B.writeFile cabalFilePath pkgDesc
return cabalFilePath
- where cabalPkg = rosPkg2CabalPkg pkgName
+ where cabalPkg = rosPkg2CabalPkg pkgName ++ ".cabal"
preamble = format [ ("Name", B.pack cabalPkg)
, ("Version", roshaskVersion)
, ("Synopsis", B.append "ROS Messages from "
View
46 Ros/Core/PathUtil.hs
@@ -0,0 +1,46 @@
+module Ros.Core.PathUtil where
+import Data.Char (toUpper)
+import Data.List (tails)
+import System.Directory (doesFileExist)
+import System.FilePath
+import Paths_roshask
+
+-- |Ensure that the first character in a String is capitalized.
+cap :: String -> String
+cap [] = []
+cap (x:xs) = toUpper x : xs
+
+-- |Determine if a path is a directory containing a ROS package.
+isPkg :: FilePath -> IO Bool
+isPkg = doesFileExist . (</> "manifest.xml")
+
+-- |Determine if a path is a directory containing a ROS stack.
+isStack :: FilePath -> IO Bool
+isStack = doesFileExist . (</> "stack.xml")
+
+-- |Identify the name of the package defining a msg.
+pathToPkgName :: FilePath -> String
+pathToPkgName = cap . last . init . splitPath
+
+-- |Identify the name of the stack in which a msg is defined. If the
+-- package definining the message does not live in a stack, the result
+-- is 'Nothing'.
+stackName :: FilePath -> IO (Maybe String)
+stackName = go . tails . reverse . splitPath
+ where go :: [[FilePath]] -> IO (Maybe String)
+ go [] = return Nothing
+ go [[]] = return Nothing
+ go (d:ds) = do b <- isStack . joinPath . reverse $ d
+ if b then return (Just (head d)) else go ds
+
+-- |Given a path to a msg definition file, compute a destination
+-- directory for generated Haskell code. A typical path will be under,
+-- @~/.cabal/share/roshask/@.
+codeGenDir :: FilePath -> IO FilePath
+codeGenDir f = do s <- stackName f
+ r <- getDataDir
+ let base = case s of
+ Nothing -> r
+ Just s -> r </> s
+ return $ base </> pkg </> "Ros" </> pkg
+ where pkg = pathToPkgName f
View
6 Ros/SlaveAPI.hs
@@ -9,8 +9,8 @@ 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, addListen, Config,
- ConfigListen(..), setAccessLog, setErrorLog)
+import Snap.Http.Server.Config (defaultConfig, setPort, Config,
+ setAccessLog, setErrorLog)
import Snap.Types (Snap, getRequestBody, writeLBS,
getResponse, putResponse, setContentLength)
import Network.Socket hiding (Stream)
@@ -164,7 +164,7 @@ simpleServe port handler = simpleHttpServe conf handler
where conf :: Config Snap ()
conf = setAccessLog Nothing .
setErrorLog Nothing .
- addListen (ListenHttp "*" port) $
+ setPort port $
defaultConfig
-- Find a free port by opening a socket, getting its port, then
View
4 Ros/TopicStamped.hs
@@ -11,7 +11,7 @@
-- common use case is calling the 'bothNew' function with a 'Topic'
-- that produces very quickly (faster than the minimum required update
-- rate), and another 'Topic' that imposes a rate limit.
-module Ros.TopicStamped (everyNew, interpolate) where
+module Ros.TopicStamped (everyNew, interpolate, batch) where
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import qualified Ros.Topic as T
import Ros.Topic (Topic(..), metamorphM, yieldM)
@@ -96,7 +96,7 @@ interpolate f t1 t2 = interp `fmap` findBrackets t1 t2
-- usage is to gather approximately simultaneous events into
-- batches. Note that the times used to batch messages are arrival
-- times rather than time stamps. This is what lets us close the
--- window, rather than having to admit any message that every arrives
+-- 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 =
View
2 roshask.cabal
@@ -85,6 +85,7 @@ Library
Ros.Core.RosTypes
Ros.Core.RosBinary
Ros.Core.Build.SetupUtil
+ Ros.Core.PathUtil
Ros.Util.PID
-- The Log and Header message types must be generated by a
@@ -153,4 +154,5 @@ Executable roshask
Ros.Core.Build.Init Ros.Core.Build.SetupUtil
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: .

0 comments on commit c2e4eae

Please sign in to comment.