Permalink
Browse files

move librarybuilder to interpolated strings

  • Loading branch information...
1 parent 5dff480 commit a5bf5ce9ac7ffb4f25b25a4b557fa6aab522e002 @mwotton committed Jan 15, 2013
Showing with 69 additions and 69 deletions.
  1. +67 −68 Haskell/Language/Ruby/Hubris/LibraryBuilder.hs
  2. +2 −1 Haskell/hubris.cabal
@@ -1,5 +1,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE QuasiQuotes #-}
module Language.Ruby.Hubris.LibraryBuilder where
import Language.Ruby.Hubris
import Language.Haskell.Interpreter
@@ -13,7 +14,7 @@ import Control.Applicative
import Control.Monad
import Control.Monad.Error.Class
import Data.Maybe(catMaybes,fromJust, isJust)
-
+import Text.InterpolatedString.Perl6(qq)
import GHC(parseStaticFlags, noLoc)
@@ -70,8 +71,7 @@ exportable moduleName func = do say $ "checking " ++ qualName
return $ guard checked>> return (func, i, genWrapper (func,i) moduleName)
where qualName = moduleName ++ "." ++ func
- rubyVal = "(fromIntegral $ fromEnum $ Language.Ruby.Hubris.Binding.RUBY_Qtrue)"
- haskellVal = "(Language.Ruby.Hubris.toHaskell " ++ rubyVal ++ ")"
+ haskellVal = "(Language.Ruby.Hubris.toHaskell (fromIntegral $ fromEnum $ Language.Ruby.Hubris.Binding.RUBY_Qtrue))"
genApp qualName i = unwords (qualName:replicate i haskellVal)
generateSource :: [Filename] -> -- optional haskell source to load into the interpreter
@@ -93,85 +93,84 @@ getFunctions moduleName = (\ x -> [a |Fun a <- x]) <$> getModuleExports moduleNa
genC :: [(String,Int)] -> Zname -> String
-genC exports (Zname zmoduleName) = unlines $
- ["#include <stdio.h>"
- ,"#include <stdlib.h>"
- ,"#define HAVE_STRUCT_TIMESPEC 1"
- ,"#include <ruby.h>"
--- ,"#define DEBUG 1"
- ,"#ifdef DEBUG"
- ,"#define eprintf printf"
- ,"#else"
- ,"int eprintf(const char *f, ...){}"
- ,"#endif"
- ] ++
--- map (("VALUE hubrish_"++) . (++"(VALUE);")) exports ++
--- map (("VALUE hubrish_"++) . (++"(VALUE);")) exports ++
- map cWrapper exports ++
- ["extern void safe_hs_init();"
- ,"extern VALUE Exports;"
- ,"void Init_" ++ zmoduleName ++ "(){"
- ," eprintf(\"loading " ++ zmoduleName ++ "\\n\");"
- ," VALUE Fake = Qnil;"
- ," safe_hs_init();"
- ," Fake = rb_define_module_under(Exports, \"" ++ zmoduleName ++ "\");"
- ] ++ map cDef exports ++ ["}"]
+genC exports (Zname zmoduleName) = [qq|
+#include <stdio.h>
+#include <stdlib.h>
+#define HAVE_STRUCT_TIMESPEC 1
+#include <ruby.h>
+#ifdef DEBUG
+#define eprintf printf
+#else
+int eprintf(const char *f, ...)\{\}
+#endif
+{concatMap cWrapper exports}
+extern void safe_hs_init();
+extern VALUE Exports;
+void Init_{zmoduleName}()\{
+ eprintf("loading $zmoduleName\n");
+ VALUE Fake = Qnil;
+ safe_hs_init();
+ Fake = rb_define_module_under(Exports, "$zmoduleName");
+ {concatMap cDef exports}
+\}
+|]
where
cWrapper :: (String,Int) -> String
- cWrapper (f,arity) =
- let res = unlines
- ["VALUE hubrish_" ++ f ++ "("++ (intercalate "," . take arity $ repeat "VALUE") ++ ");",
- "VALUE " ++ f ++ "(VALUE mod, VALUE v){"
- ," eprintf(\""++f++" has been called\\n\");"
- -- also needs to curry on the ruby side
-
- -- v is actually an array now, so we need to stash each element in
- -- a nested haskell tuple. for the moment, let's just take the first one.
-
- ," unsigned long res = hubrish_" ++ f ++ "(" ++ intercalate "," ["rb_ary_entry(v," ++ show i ++ ")"| i<- [0..(arity-1)]] ++ ");"
- ," eprintf(\"hubrish "++f++" has been called\\n\");"
- ," eprintf(\"result is %p\\n\",res);"
- -- ," res = res | 0x100000000;"
- ," if (rb_obj_is_kind_of(res,rb_eException)) {"
- ," eprintf(\""++f++" has provoked an exception\\n\");"
- ," rb_exc_raise(res);"
- ," } else {"
- ," eprintf(\"returning from "++f++"\\n\");"
- ," return res;"
- ," }"
- ,"}"]
- in res
+ cWrapper (f,arity) = [qq|
+VALUE hubrish_{f}({intercalate "," . take arity $ repeat "VALUE"});
+VALUE {f}(VALUE mod, VALUE v)\{
+ eprintf("{f} has been called\\n");
+ unsigned long res = hubrish_$f({intercalate "," ["rb_ary_entry(v," ++ show i ++ ")"| i<- [0..(arity-1)]]});
+ eprintf("hubrish $f has been called\\n");
+ eprintf("result is %p\\n",res);
+
+ if (rb_obj_is_kind_of(res,rb_eException)) \{
+ eprintf("$f has provoked an exception\\n");
+ rb_exc_raise(res);
+ \} else \{
+ eprintf("returning from $f\\n");
+ return res;
+ \}
+\}
+|]
cDef :: (String,Int) -> String
- -- adef f = " eprintf(\"Defining |" ++ f ++ "|\\n\");\n" ++ "rb_define_method(Fake, \"" ++ f ++"\","++ f++", 1);"
- cDef (f,_arity) = " eprintf(\"Defining |" ++ f ++ "|\\n\");\n" ++ "rb_define_method(Fake, \"" ++ f ++"\","++ f++", -2);"
+ cDef (f,_arity) = [qq|
+eprintf("Defining |$f|\\n");
+rb_define_method(Fake, "$f", $f, -2);|]
-haskellBoilerplate moduleName = unlines ["{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}",
- "module Language.Ruby.Hubris.Exports." ++ moduleName ++ " where",
- "import Language.Ruby.Hubris",
- "import Language.Ruby.Hubris.Binding",
- "import System.IO.Unsafe (unsafePerformIO)",
- "import Control.Monad",
- "import Control.Exception",
- "import Data.Either",
- "import Data.Function(($))",
- "import qualified Prelude as P(show,putStrLn)",
- "import Data.Tuple (uncurry)",
- "import Foreign.C.Types",
- "import qualified " ++ moduleName]
+haskellBoilerplate :: String -> String
+haskellBoilerplate moduleName = [qq|
+\{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-\}
+module Language.Ruby.Hubris.Exports.$moduleName where
+import Language.Ruby.Hubris
+import Language.Ruby.Hubris.Binding
+import System.IO.Unsafe (unsafePerformIO)
+import Control.Monad
+import Control.Exception
+import Data.Either
+import Data.Function(($))
+import qualified Prelude as P(show,putStrLn)
+import Data.Tuple (uncurry)
+import Foreign.C.Types
+import qualified $moduleName
+|]
+genWrapper :: (String, Int) -> String -> String
genWrapper (func,arity) mod = unlines [func ++ " :: " ++ myType
,func ++ " " ++ unwords symbolArgs ++ " = " ++ defHask
,"foreign export ccall \"hubrish_" ++ func ++ "\" " ++ func ++ " :: " ++ myType]
where myType = intercalate "->" (replicate (1+arity) " CULong ")
-- mark's patented gensyms. just awful.
symbolArgs = take arity $ map ( \ x -> "fake_arg_symbol_"++[x]) ['a' .. 'z']
- defHask = "unsafePerformIO $ do\n r <- try $ evaluate $ toRuby $" ++ mod ++"."++ func ++ " " ++ unwords (map (\ x -> "(toHaskell " ++ x ++ ")") symbolArgs) ++ "\n case r of\n" ++
--- unlines [" Left (e::SomeException) -> createException (P.show e) `traces` (\"died in haskell wrapper\" P.++ P.show e) ",
- unlines [" Left (e::SomeException) -> createException (P.show e)" ,
- " Right a -> return a"]
+ defHask = [qq|unsafePerformIO $ do
+ r <- try $ evaluate $ toRuby $ $mod.$func { unwords (map (\\x -> "(toHaskell " ++ x ++ ")") symbolArgs) }
+ case r of
+ Left (e::SomeException) -> createException (P.show e)
+ Right a -> return a
+|]
say :: String -> InterpreterT IO ()
-- say = liftIO . putStrLn
View
@@ -41,7 +41,8 @@ Library
--extra-include-dirs=/opt/local/include/ruby-1.9.1/
--extra-lib-dirs: /opt/local/lib
extra-libraries: ruby
- build-depends: ghc, Cabal>=1.7.4 && < 2.0, base, containers, bytestring, array, mtl, old-time, ghc-paths, hint >= 0.3.3.2, HUnit, process
+ build-depends: ghc, Cabal>=1.7.4 && < 2.0, base, containers, bytestring, array, mtl, old-time, ghc-paths, hint >= 0.3.3.2, HUnit, process,
+ interpolatedstring-perl6
Executable Hubrify
Main-is: Hubrify.hs

0 comments on commit a5bf5ce

Please sign in to comment.