diff --git a/HsWebots.cabal b/HsWebots.cabal --- a/HsWebots.cabal +++ b/HsWebots.cabal @@ -4,15 +4,15 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d7399ff5367c55e2b2afaaae32dcf8116890e0a71844b15a4b105fd4f5564ee8 +-- hash: b96f385147c1443ab495b6f5dfa3fff31e763c413f6518c2dc558d80d71b6926 name: HsWebots -version: 0.1.1.0 +version: 0.1.1.1 synopsis: Webots bindings for Haskell -description: Please see the README on GitHub at +description: Please see the README on GitHub at category: Robotics -homepage: https://github.com/junjihashimoto/HsWebots#readme -bug-reports: https://github.com/junjihashimoto/HsWebots/issues +homepage: https://github.com/cyberbotics/HsWebots#readme +bug-reports: https://github.com/cyberbotics/HsWebots/issues author: Junji Hashimoto maintainer: junji.hashimoto@gmail.com copyright: 2020 Junji Hashimoto @@ -25,7 +25,7 @@ source-repository head type: git - location: https://github.com/junjihashimoto/HsWebots + location: https://github.com/cyberbotics/HsWebots library exposed-modules: @@ -78,30 +78,6 @@ , inline-c-cpp >=0.4.0.0 , safe-exceptions , template-haskell - , vector - default-language: Haskell2010 - -executable HsWebots-exe - main-is: Main.hs - other-modules: - Paths_HsWebots - hs-source-dirs: - app - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - HsWebots - , JuicyPixels - , base >=4.7 && <5 - , bytestring - , inline-c >=0.9.0.0 - , inline-c-cpp >=0.4.0.0 - , language-c - , pretty - , safe-exceptions - , shakespeare - , syb - , template-haskell - , text , vector default-language: Haskell2010 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,25 @@ # HsWebots +[![Hackage version](https://img.shields.io/hackage/v/HsWebots.svg?style=flat)](https://hackage.haskell.org/package/HsWebots) +![linux](https://github.com/cyberbotics/HsWebots/workflows/stack-linux/badge.svg) +![macos](https://github.com/cyberbotics/HsWebots/workflows/stack-macos/badge.svg) + + + Webots bindings for Haskell + +# Usage + +``` +#setup WEBOTS_HOME and LD_LIBRARY_PATH +source setenv + +#Build +stack build +``` + +# Supported Platform + +* Webots: R2020a revision 1 +* OS: ubuntu/bionic and macos(Mojave) +* Build Tools: stack diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - - -module Main where - -import System.IO -import System.Environment -import Data.Generics -import Data.List -import Language.C -import Language.C.System.GCC -import Language.C.Data -import Language.C.Data.Ident -import Text.PrettyPrint -import Control.Monad -import Text.Shakespeare.Text -import qualified Data.Text.IO as T - -whenM cond exp = if cond then exp else pure () - -main = do - (filename:[]) <- getArgs - parseMyFile filename >>= \i -> do - case i of - CTranslUnit v a -> do - forM_ v $ \i -> do - printFunc filename i - -parseMyFile :: FilePath -> IO CTranslUnit -parseMyFile input_file = - do parse_result <- parseCFile (newGCC "gcc") Nothing ["-Ideps/webots/include"] input_file - case parse_result of - Left parse_err -> error (show parse_err) - Right ast -> return ast - -class CIdent a where - toIdent :: a -> String - -instance CIdent Ident where - toIdent a = identToString a - -instance CIdent (CStorageSpecifier NodeInfo) where - toIdent a = render $ pretty a - -instance CIdent (CTypeSpecifier NodeInfo) where - toIdent a = render $ pretty a - -instance CIdent (CTypeQualifier NodeInfo) where - toIdent a = render $ pretty a - -instance CIdent (CFunctionSpecifier NodeInfo) where - toIdent a = render $ pretty a - -instance CIdent (CAlignmentSpecifier NodeInfo) where - toIdent a = render $ pretty a - -instance CIdent (CDeclarationSpecifier NodeInfo) where - toIdent a = render $ pretty a - -instance CIdent (CDeclaration NodeInfo) where - toIdent (CDecl [CStorageSpec a] _ _) = toIdent a - toIdent (CDecl [CTypeSpec a] _ _) = toIdent a - toIdent (CDecl [CTypeQual a] _ _) = toIdent a - toIdent (CDecl [CFunSpec a] _ _) = toIdent a - toIdent (CDecl [CAlignSpec a] _ _) = toIdent a - toIdent (CDecl a _ _) = intercalate "," $ map toIdent a - toIdent a = "not-parsed" - - -csnd (CDecl [CStorageSpec a] b _) = b -csnd (CDecl [CTypeSpec a] b _) = b -csnd (CDecl [CTypeQual a] b _) = b -csnd (CDecl [CFunSpec a] b _) = b -csnd (CDecl [CAlignSpec a] b _) = b -csnd (CDecl a b _) = b -csnd a = undefined - -getArgIds [] = [] -getArgIds ((Just (CDeclr - (Just arg) - _ - _ - _ - _ - )):xs) = toIdent arg : getArgIds xs -getArgIds (_:xs) = "xxx" : getArgIds xs - -printFunc :: FilePath -> CExternalDeclaration NodeInfo -> IO () -printFunc path (CDeclExt (CDecl - rets - [(Just (CDeclr - (Just func_name) - (CFunDeclr (Right (args,_)) _ _:_) - _ - _ - _ - ) - ,_ - ,_)] - (NodeInfo pos _ _) - ) - ) = whenM (path == posFile pos) $ do - T.putStr [st| -#{toIdent func_name} :: #{argsH}IO #{retH} -#{toIdent func_name} #{argIds} = - #{bra} #{retC} { #{toIdent func_name}(#{argsC}) } #{ket} -|] - where - bra = "[C.exp|" - ket = "|]" - retH = case map toIdent rets of - ["void"] -> "()" - ["char"] -> "CBool" - ["int"] -> "CInt" - ["double"] -> "CDouble" - ["const","char"] -> "String" - ["const","double"] -> "Ptr CDouble" - [a] -> a - _ -> "UnKnown" - retC = case map toIdent rets of - ["void"] -> "void" - ["char"] -> "bool" - ["int"] -> "int" - ["double"] -> "double" - ["const","char"] -> "const char*" - ["const","double"] -> "const double*" - [a] -> a - argH arg = case arg of - "void" -> "()" - "char" -> "CBool" - "int" -> "CInt" - "double" -> "CDouble" - "const,char" -> "String" - "const,double" -> "Ptr CDouble" - a -> a - _ -> "UnKnown" - argsH = - case map (\(i :: CDeclaration NodeInfo) -> argH (toIdent i)) args of - [] -> "" - a -> (intercalate " -> " a) ++ " -> " - argC arg = case arg of - "void" -> "void" - "char" -> "bool" - "int" -> "int" - "double" -> "double" - "const,char" -> "const char*" - "const,double" -> "const double*" - a -> a - args' = getArgIds (map (\(a,b,c) -> a) $ concat $ map (\a -> csnd a) args) - argsC = - case (map (\(i :: CDeclaration NodeInfo) -> argC (toIdent i)) args,args') of - ([],_) -> "" - (_,[]) -> "" - (a,b) -> intercalate ", " $ map (\(aa,bb) -> "$("++ aa ++ " " ++ bb ++")" ) $ zip a b - argIds = intercalate " " args' -printFunc path (CDeclExt a@(CDecl ret body (NodeInfo pos _ _))) = return () --- whenM (path == posFile pos) $ print a -printFunc path (CDeclExt a@(CStaticAssert exp lit _)) = return () -printFunc path (CFDefExt a) = return () -printFunc path (CAsmExt a _) = return () -