[hoc-cvs] [hoc commit] r346 - in trunk/hoc: . InterfaceGenerator2 Tests

[<cod...@go...>]

Author: wol...@gm...
Date: Wed Oct 29 15:54:06 2008
New Revision: 346

Added:
    trunk/hoc/Tests/Test.hs
    trunk/hoc/Tests/TestFFI.hs
    trunk/hoc/Tests/TestPreprocessor.hs
Modified:
    trunk/hoc/HOC.cabal
    trunk/hoc/InterfaceGenerator2/Preprocessor.hs
    trunk/hoc/Setup.hs
    trunk/hoc/Tests/TestFoundation.hs

Log:
Build some unit tests for both the core library and the interface generator  
from the
main HOC.cabal file.

Enable them using
runhaskell Setup.hs configure -f Tests



Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal	(original)
+++ trunk/hoc/HOC.cabal	Wed Oct 29 15:54:06 2008
@@ -10,6 +10,10 @@
      description: write HOC interface generator files in binary format
                   (requires binary package)

+Flag Tests
+    description: build test cases
+    default: False
+
  Library
      build-depends: base, template-haskell, unix

@@ -73,3 +77,30 @@
      if flag(BinaryInterfaces)
          build-depends: binary >= 0.2
          cpp-options: -DBINARY_INTERFACES
+
+Executable hoc-test
+    main-is: Test.hs
+    hs-source-dirs: HOC, InterfaceGenerator2, Tests
+
+    cpp-options: -DTEST
+
+    build-depends: HUnit
+
+    if !flag(Tests)
+        buildable: False
+
+    extensions: MagicHash, TemplateHaskell,
+                ForeignFunctionInterface, GeneralizedNewtypeDeriving,
+                EmptyDataDecls, MultiParamTypeClasses,  
FunctionalDependencies,
+                ScopedTypeVariables, RecursiveDo, FlexibleContexts,
+                FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable
+
+
+    extra-libraries: objc, ffi
+    if os(darwin)
+        frameworks: Foundation
+        cpp-options: -DMACOSX
+    else
+        extra-lib-dirs: /usr/lib/gcc/i486-linux-gnu/4.1.3/,  
/usr/lib/GNUstep/System/Library/Libraries
+        extra-libraries: gnustep-base
+        cpp-options: -DGNUSTEP

Modified: trunk/hoc/InterfaceGenerator2/Preprocessor.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Preprocessor.hs	(original)
+++ trunk/hoc/InterfaceGenerator2/Preprocessor.hs	Wed Oct 29 15:54:06 2008
@@ -44,7 +44,7 @@
      <|> (reserved cpp "ifndef" >> definedMacroCondition >>= \e -> return $  
If (negateExpr e))
      <|> (reserved cpp "endif" >> return Endif)
      <|> (reserved cpp "else" >> return Else)
-    <|> (plainLine >>= \p -> return $ Text ("//# " ++ p))
+    <|> (plainLine >>= \p -> return $ Text ("//#" ++ p))

  definedMacroCondition = do
      macro <- identifier cpp
@@ -69,7 +69,11 @@
              <|> do x <- identifier cpp
                     return (get >>= return . maybe 0 id . Map.lookup x)

-        optable = [ [Infix (bop "<" (<)) AssocLeft,
+        optable = [ [Infix (op "*" (*)) AssocLeft,
+        			 Infix (op "/" div) AssocLeft],
+        			[Infix (op "+" (+)) AssocLeft,
+        			 Infix (op "-" (-)) AssocLeft],
+        			[Infix (bop "<" (<)) AssocLeft,
                       Infix (bop "<=" (<=)) AssocLeft,
                       Infix (bop "==" (==)) AssocLeft,
                       Infix (bop "!=" (/=)) AssocLeft,
@@ -157,29 +161,7 @@
                              (l2 : ls') -> (l ++ '\n' : l2) : ls'
                              ls' -> ls'
      | otherwise = l : handleBackslashes ls
-
-preprocess fn f = execute fn $ parseDirectives f

-{-
-test = putStrLn $ execute "test" $ parseDirectives
-   "#include <foo>\n\
-    \blah\n\
-    \foo bar\n\
-    \#if 1\n\
-    \baz\n\
-    \#else\n\
-    \quux\n\
-    \#endif\n"
-
-test2 fn = do
---    f <- readFile  
$ "/System/Library/Frameworks/Foundation.framework/Versions/C/Headers/" ++  
fn
-    f <- readFile $ "/usr/lib/GNUstep/System/Library/Headers/" ++ fn
-    putStrLn $ execute fn $ parseDirectives f
-
+preprocess :: String -> String -> String
+preprocess fn f = execute fn $ parseDirectives f

-test3 fn = do
-    f <- readFile  
$ "/System/Library/Frameworks/Foundation.framework/Versions/C/Headers/" ++  
fn
-    -- putStrLn $
-    putStrLn fn
-    print $ length $ execute fn $ parseDirectives f
--}

Modified: trunk/hoc/Setup.hs
==============================================================================
--- trunk/hoc/Setup.hs	(original)
+++ trunk/hoc/Setup.hs	Wed Oct 29 15:54:06 2008
@@ -62,6 +62,7 @@
          _ -> fail "Failed in C compilation."

      -- system "cp dist/build/HOC_cbits.o dist/build/HOC_cbits.dyn_o"
+    system "cp dist/build/HOC_cbits.o dist/build/hoc-test/hoc-test-tmp/"

      let buildInfo = emptyBuildInfo {
              options = [ (GHC, ["dist/build/HOC_cbits.o" ]
@@ -71,6 +72,14 @@
                                ++ extralibs) ],
              cSources = ["HOC_cbits.o"]
          }
+        buildInfo2 = emptyBuildInfo {
+            options = [ (GHC,  
["dist/build/hoc-test/hoc-test-tmp/HOC_cbits.o" ]
+                              ++ paths ++
+                              ["-lobjc",
+                               "-lffi"]
+                              ++ extralibs) ]{-,
+            cSources = ["HOC_cbits.o"]-}
+        }

-    return (Just buildInfo, [])
+    return (Just buildInfo, [("hoc-test", buildInfo2)])


Added: trunk/hoc/Tests/Test.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/Tests/Test.hs	Wed Oct 29 15:54:06 2008
@@ -0,0 +1,11 @@
+module Main where
+
+import qualified TestFFI
+import qualified TestPreprocessor
+
+import Test.HUnit
+
+main = runTestTT $ test [
+        TestFFI.tests,
+        TestPreprocessor.tests
+    ]

Added: trunk/hoc/Tests/TestFFI.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/Tests/TestFFI.hs	Wed Oct 29 15:54:06 2008
@@ -0,0 +1,88 @@
+{-# LANGUAGE RankNTypes #-}
+module TestFFI where
+
+import HOC.FFICallInterface
+import HOC.Invocation
+
+
+import Foreign
+import Foreign.C
+import Data.Int
+import Test.HUnit
+
+import HOC.Arguments
+import HOC.StdArgumentTypes
+
+foreign import ccall "ffi.h ffi_call"
+    ffi_call :: FFICif -> FunPtr a -> Ptr b -> Ptr (Ptr ()) -> IO Int
+
+
+fficallDirectly cif fp args
+    = allocaRetval $ \ret -> do
+        ffi_call cif fp ret args
+        peekRetval ret
+
+type Invoker = forall a b c d.
+    (ObjCArgument a a, ObjCArgument b b) =>
+    FFICif -> FunPtr (a -> b) -> Ptr (Ptr ()) -> IO b
+
+testArgAndResult :: (Num a, Num b, ObjCArgument a a, ObjCArgument b b)
+                 => Invoker -> FunPtr (a -> b) -> IO ()
+
+
+testArgAndResult invoker fp
+    = do
+        fixTypes fp theArg theResult
+
+        argType <- makeFFIType theArg
+        retType <- makeFFIType theResult
+        cif <- ffiPrepCif retType [argType]
+        x <- with theArg $ \arg -> withArray [arg] $ \args -> invoker cif  
fp (castPtr args)
+        x @?= theResult
+        return ()
+    where
+        theArg = 23
+        theResult = 19
+
+        fixTypes :: FunPtr (a -> b) -> a -> b -> IO ()
+        fixTypes f a b = return ()
+
+
+
+subtractFrom42 x = 42 - x
+
+foreign export ccall "funIntToInt" subtractFrom42 :: CInt -> CInt
+foreign import ccall "&funIntToInt" funIntToInt :: FunPtr (CInt -> CInt)
+
+foreign export ccall "funCharToChar" subtractFrom42 :: CChar -> CChar
+foreign import ccall "&funCharToChar" funCharToChar :: FunPtr (CChar ->  
CChar)
+
+foreign export ccall "funFloatToFloat" subtractFrom42 :: CFloat -> CFloat
+foreign import ccall "&funFloatToFloat" funFloatToFloat :: FunPtr (CFloat  
-> CFloat)
+
+foreign export ccall "funDoubleToDouble" subtractFrom42 :: CDouble ->  
CDouble
+foreign import ccall "&funDoubleToDouble" funDoubleToDouble :: FunPtr  
(CDouble -> CDouble)
+
+foreign export ccall "funLLongToLLong" subtractFrom42 :: CLLong -> CLLong
+foreign import ccall "&funLLongToLLong" funLLongToLLong :: FunPtr (CLLong  
-> CLLong)
+
+testArgsAndResults :: Invoker -> Test
+
+
+testArgsAndResults invoker
+    = test [
+        testArgAndResult invoker funIntToInt,
+        testArgAndResult invoker funCharToChar,
+        testArgAndResult invoker funLLongToLLong,
+        testArgAndResult invoker funFloatToFloat,
+        testArgAndResult invoker funDoubleToDouble
+    ]
+
+tests = "TestFFI" ~: test [
+        "peekRetval" ~: test $ with (42 :: Int) $ \p -> do
+                ret <- peekRetval (castPtr p :: Ptr CChar)
+                ret @?= (42 :: CChar)
+            ,
+        "Plain FFI" ~: testArgsAndResults fficallDirectly,
+        "callWithRetval" ~: testArgsAndResults callWithRetval
+    ]

Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs	(original)
+++ trunk/hoc/Tests/TestFoundation.hs	Wed Oct 29 15:54:06 2008
@@ -12,6 +12,10 @@
  import Control.Exception    ( try, finally )
  import qualified System.Info( os )

+deriving instance Show NSRect
+deriving instance Show NSPoint
+deriving instance Show NSSize
+
        -- garbage collect and make really sure that finalizers have time to  
run
  performGCAndWait targetCount time maxRepeat = do
      performGC

Added: trunk/hoc/Tests/TestPreprocessor.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/Tests/TestPreprocessor.hs	Wed Oct 29 15:54:06 2008
@@ -0,0 +1,141 @@
+module TestPreprocessor where
+
+import Preprocessor
+
+import Test.HUnit
+import Data.Char
+
+rstrip = reverse . dropWhile isSpace . reverse
+
+a ==> b = rstrip (preprocess "test" a) ~?= rstrip b
+
+success a = (filter interesting $ lines $ preprocess "test" a) ~?=  
["success"]
+	where
+		interesting ('/' : '/' : _ ) = False
+		interesting other | all isSpace other = False
+						  | otherwise = True
+
+tests = "TestPreprocessor" ~: test [
+		"empty" ~: "" ==> "",
+		
+		"plainLines" ~:
+			let txt = "asfljkaslf\nasjfhaslkhf\naskfhaskjf\n"
+			in txt ==> txt,
+			
+		"comment1" ~:
+			"/* abc */\ndef\n/*ghi*/\n" ==> "/* abc */\ndef\n/*ghi*/\n",
+		"comment2" ~:
+			"/* abc\ndef */\nghi\n" ==> "/* abc*/\n/*def */\nghi\n",
+			
+		"ifthenelse1" ~:
+			"#include <foo>\n\
+			\blah\n\
+			\foo bar\n\
+			\#if 42\n\
+			\baz\n\
+			\#else\n\
+			\quux\n\
+			\#endif\n"
+			==>
+			"//#include <foo>\n\
+			\blah\n\
+			\foo bar\n\
+			\//#if 1\n\
+			\baz\n\
+			\//#else\n\
+			\//T quux\n\
+			\//#endif",
+			
+		"elif1" ~: success
+			"#if 1\n\
+			\success\n\
+			\#elif 1\n\
+			\failure2\n\
+			\#else\n\
+			\failure3\n\
+			\#endif",
+			
+		"elif2" ~: success
+			"#if 0\n\
+			\failure1\n\
+			\#elif 1\n\
+			\success\n\
+			\#else\n\
+			\failure2\n\
+			\#endif",
+
+		"elif3" ~: success
+			"#if 0\n\
+			\failure1\n\
+			\#elif 0\n\
+			\failure2\n\
+			\#else\n\
+			\success\n\
+			\#endif",
+		
+		"elif4" ~: success
+			"#if 6 * 9 == 42\n\
+			\No, that is not the question.\n\
+			\#elif 2 + 2 == 5\n\
+			\We love Big Brother!\n\
+			\#else\n\
+			\success\n\
+			\#endif",
+			
+		"elif5" ~: success
+			"#if 6 * 7 == 42\n\
+			\success\n\
+			\#elif 2 + 2 == 5\n\
+			\We love Big Brother!\n\
+			\#else\n\
+			\wrong, too.\n\
+			\#endif",
+
+		"elif6" ~: success
+			"#if 6 * 9 == 42\n\
+			\no.\n\
+			\#elif MAC_OS_X_VERSION_10_5 == 1050\n\
+			\success\n\
+			\#else\n\
+			\wrong, too.\n\
+			\#endif",
+			
+		"nest1" ~: success
+			"#if 1\n\
+			\#if 1\n\
+			\success\n\
+			\#else\n\
+			\failure1\n\
+			\#endif\n\
+			\#else\n\
+			\failure2\n\
+			\#if 1\n\
+			\failure3\n\
+			\#else\n\
+			\failure4\n\
+			\#endif\n\
+			\failure5\n\
+			\#endif",
+
+		"nest2" ~: success
+			"#if 0\n\
+			\failure0\n\
+			\#if 1\n\
+			\failure1\n\
+			\#else\n\
+			\failure2\n\
+			\#endif\n\
+			\failure3\n\
+			\#else\n\
+			\#if 0\n\
+			\failure4\n\
+			\#else\n\
+			\success\n\
+			\#endif\n\
+			\#endif",
+			
+		"defineBackslash" ~: success
+			"#define FOO bar\n\\\
+			\			 baz\n\
+			\success"
+	]