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 Alexander Krupenkin 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/app/genhs/Main.hs b/app/genhs/Main.hs new file mode 100644 --- /dev/null +++ b/app/genhs/Main.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +module Main (main) where + +import System.Environment +import Robotics.ROS.Pkg +import Data.Text (pack) +import System.IO.Temp +import Template +import Stack + +main :: IO () +main = withSystemTempDirectory "genhs" $ \tmpDir -> do + args <- getArgs + case args of + [name] -> do + putStr $ "Search package `" ++ name ++"`..." + Just pkg <- package (pack name) + putStrLn "DONE" + + msgs <- pkgMessages pkg + putStrLn "Found messages:" + mapM_ (putStrLn . (" - " ++)) msgs + + template <- newTemplate tmpDir pkg msgs + putStrLn $ "Template created: " ++ template + + msgPkg <- newPackage tmpDir (pkgName (meta pkg)) template + putStrLn $ "Package created: " ++ msgPkg + _ -> putStrLn "USAGE: genhs [PACKAGE_NAME]" diff --git a/app/genhs/Stack.hs b/app/genhs/Stack.hs new file mode 100644 --- /dev/null +++ b/app/genhs/Stack.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +module Stack (newPackage) where + +import qualified Data.Text as T +import Control.Monad.Logger + +import Stack.Types.TemplateName +import Stack.Types.PackageName +import Stack.Types.StackT +import Stack.Types.Config +import Stack.Config +import Stack.New + +newPackage :: FilePath -> T.Text -> String -> IO FilePath +newPackage dir name templatePath = do + case parseTemplateNameFromString templatePath of + Left e -> error e + Right template -> do manager <- newTLSManager + config <- (loadConfigWith manager :: IO Config) + runStackWith manager config $ do + n <- parsePackageName (sanitize name) + new (NewOpts n False (Just template) mempty) False + return (T.unpack (sanitize name)) + where + loadConfigWith m = lcConfig <$> + runStackLoggingT m logging False False + (loadConfig mempty Nothing Nothing) + runStackWith m c = runStackT m logging c False False + logging = LevelDebug + sanitize = T.replace "_" "-" diff --git a/app/genhs/Template.hs b/app/genhs/Template.hs new file mode 100644 --- /dev/null +++ b/app/genhs/Template.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} +module Template (newTemplate) where + +import Data.Text (Text, unpack, pack, + toUpper, replace, takeEnd) +import qualified Data.Text as T +import Data.Text.Lazy.IO as TL +import Data.Text.Lazy.Builder +import Data.Maybe (catMaybes) +import Control.Monad (forM) +import System.FilePath +import Data.Monoid + +import Robotics.ROS.Msg.Parser +import Robotics.ROS.Msg.Types +import Robotics.ROS.Pkg + +newTemplate :: FilePath -> Package -> [FilePath] -> IO FilePath +newTemplate dir pkg msgFiles = do + deps <- forM msgFiles $ \f -> do + let msgPath = joinPath [path pkg, "msg", f] + Done _ msg <- parse rosmsg <$> TL.readFile msgPath + depPkgs <- catMaybes <$> mapM package (pkgBuildDeps (meta pkg)) + deps <- zip depPkgs <$> mapM pkgMessages depPkgs + return $ concatMap (mkDeps msg) ((pkg, msgFiles) : deps) + + TL.writeFile tFileName $ toLazyText $ tBuilder deps + return tFileName + where + tFileName = joinPath [dir, unpack (pkgName (meta pkg)) ++ ".hsfiles"] + tBuilder deps = cabalBuilder pkg msgFiles + <> mconcat (msgBuilder pkg <$> zip msgFiles deps) + <> stackBuilder pkg + +upperFirst :: Text -> Text +upperFirst x = toUpper (T.take 1 x) <> T.drop 1 x + +-- List of custom type names in Message +customTypes :: MsgDefinition -> [Text] +customTypes = fmap pkgInTypeHook . catMaybes . fmap go + where go (Variable (t, _)) = custom t + go (Constant (t, _) _) = custom t + custom (Custom t) = Just t + custom (Array (Custom t)) = Just t + custom (FixedArray _ (Custom t)) = Just t + custom _ = Nothing + pkgInTypeHook = last . T.split (== '/') + +-- Associate used in message custom type with package +mkDeps :: MsgDefinition -> (Package, [FilePath]) -> [(Package, FilePath)] +mkDeps msg (pkg, files) = catMaybes (go <$> files) + where go m | isCustomType m = Just (pkg, m) + | otherwise = Nothing + messageName = pack . takeWhile (/= '.') + isCustomType m = messageName m `elem` customTypes msg + +cabalBuilder :: Package -> [FilePath] -> Builder +cabalBuilder pkg msgs = + "{-# START_FILE " <> fromText (sanitize name) <> ".cabal #-}" + <> "\nname: " <> fromText (sanitize name) + <> "\nversion: 0.1" + <> "\nsynopsis: Autogenerated " <> fromText name <> " ROS messages" + <> "\ndescription: " <> fromText description + <> "\nlicense: BSD3" + <> "\ncategory: Robotics" + <> "\nbuild-type: Simple" + <> "\ncabal-version: >=1.10" + <> "\n" + <> "\nlibrary" + <> "\n hs-source-dirs: src" + <> "\n default-language: Haskell2010" + <> "\n build-depends: base >= 4.7 && < 5" + <> "\n , binary" + <> "\n , pureMD5" + <> "\n , bytestring" + <> "\n , lens-family" + <> "\n , data-default" + <> mconcat (msgBuildDeps <$> pkgBuildDeps (meta pkg)) + <> "\n exposed-modules: " + <> msgMainModule <> "." <> messageName (head msgs) + <> mconcat (msgModule <$> drop 1 msgs) + <> "\n\n{-# START_FILE Setup.hs #-}" + <> "\nimport Distribution.Simple" + <> "\nmain = defaultMain\n" + + where name = pkgName (meta pkg) + description = replace "\n" "" $ pkgDescription (meta pkg) + sanitize = replace "_" "-" + messageName = fromString . takeWhile (/= '.') + space = " " + msgBuildDeps "message_generation" = "\n" <> space <> ", rosmsg" + msgBuildDeps dep = + case takeEnd 4 dep of + "msgs" -> "\n" <> space <> ", " <> fromText (sanitize dep) + _ -> mempty + msgMainModule = "Robotics.ROS.Msg." <> fromText (upperFirst name) + msgModule m = "\n" <> space <> ", " <> msgMainModule <> "." + <> messageName m + +msgBuilder :: Package -> (FilePath, [(Package, FilePath)]) -> Builder +msgBuilder pkg (msgFile, deps) = + "\n{-# START_FILE src/Robotics/ROS/Msg/" <> packageName pkg + <> "/" + <> messageName msgFile + <> ".hs #-}" + <> "\n{-# LANGUAGE DataKinds, KindSignatures, DeriveGeneric" + <> "\n , DeriveDataTypeable, QuasiQuotes, OverloadedStrings #-}" + <> "\nmodule " <> msgMainModule <> "." <> messageName msgFile <> " where\n" + <> "\nimport Data.Default (Default(..))" + <> "\nimport Data.Typeable (Typeable)" + <> "\nimport GHC.Generics (Generic)" + <> "\nimport Data.Binary (Binary)" + <> "\nimport Data.Data (Data)" + <> "\nimport qualified Data.ByteString as BS" + <> "\nimport qualified Data.Word as W" + <> "\nimport qualified Data.Int as I" + <> "\nimport qualified Prelude as P" + <> "\n" + <> mconcat (msgImport <$> deps) + <> "\n" + <> "\nimport Robotics.ROS.Msg.TH" + <> "\nimport Robotics.ROS.Msg" + <> "\n" + <> "\n[rosmsgFrom|" <> fromString (joinPath [path pkg, "msg", msgFile]) + <> "|]\n" + where packageName = fromText . upperFirst . pkgName . meta + messageName = fromString . takeWhile (/= '.') + msgMainModule = "Robotics.ROS.Msg." <> packageName pkg + msgImport (p, m) = + "\nimport qualified Robotics.ROS.Msg." + <> packageName p + <> "." + <> messageName m + <> " as " + <> messageName m + +stackBuilder :: Package -> Builder +stackBuilder pkg = + "\n{-# START_FILE stack.yaml #-}" + <> "\nresolver: lts-6.16" + <> "\npackages:" + <> "\n- '.'" + <> mconcat ((\p -> "\n- '../" <> fromText (sanitize p) <> "'") <$> deps) + <> "\nextra-deps:" + <> "\n- rosmsg-0.5.0.0" + <> "\nflags: {}" + <> "\nextra-package-dbs: []" + where deps = filter (elem "msgs" . T.tails) (pkgBuildDeps (meta pkg)) + sanitize = replace "_" "-" diff --git a/app/rosmsg/Main.hs b/app/rosmsg/Main.hs new file mode 100644 --- /dev/null +++ b/app/rosmsg/Main.hs @@ -0,0 +1,16 @@ +module Main (main) where + +import Robotics.ROS.Pkg (Package(..), PackageMeta(..), messageList) +import System.FilePath (takeBaseName) +import System.Environment (getArgs) +import Data.Text (unpack) + +main :: IO () +main = do + args <- getArgs + let arg1 = args !! 1 + case take 1 args of + ["list"] -> messageList >>= mapM_ printMessages + _ -> putStrLn "USAGE: rosmsg " + where printMessages (pkg, msgs) = mapM_ (putStrLn . format pkg) msgs + format p m = unpack (pkgName (meta p)) ++ "/" ++ takeBaseName m diff --git a/rosmsg-bin.cabal b/rosmsg-bin.cabal new file mode 100644 --- /dev/null +++ b/rosmsg-bin.cabal @@ -0,0 +1,43 @@ +name: rosmsg-bin +version: 0.1.0.0 +synopsis: ROS message management tools +description: Please see README.md +homepage: https://github.com/RoboticsHS/rosmsg-bin#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 + +executable rosmsg + hs-source-dirs: app/rosmsg + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base >= 4.7 && < 5 + , text + , rospkg >= 0.2.3 + , filepath + default-language: Haskell2010 + +executable genhs + hs-source-dirs: app/genhs + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base >= 4.7 && < 5 + , text + , stack >= 1.1 + , rospkg >= 0.2.3 + , rosmsg >= 0.5.1 + , filepath + , temporary + , monad-logger + other-modules: Template + , Stack + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/RoboticsHS/rosmsg-bin