CCall: Extend to test signed arguments and results

Closes #3.

src/CCall.hs

@@ -4,7 +4,6 @@ module CCall
     , testCCall
     ) where
 
-import Numeric.Natural
 import System.FilePath
 import System.IO.Temp
 import Test.QuickCheck
@@ -17,7 +16,8 @@ import Number
 
 data CCallDesc
     = CCallDesc { callRet :: SomeNumber
-                , callArgs :: [SomeNumber]
+                , callRetSignedness :: Signedness
+                , callArgs :: [(Signedness, SomeNumber)]
                 }
     deriving (Show)
 
@@ -30,9 +30,10 @@ mAX_ARGS = 32
 instance Arbitrary CCallDesc where
     arbitrary = do
         ret <- arbitrary
+        ret_signedness <- arbitrary
         n <- chooseInt (0, mAX_ARGS)
         args <- vectorOf n arbitrary
-        return $ CCallDesc ret args
+        return $ CCallDesc ret ret_signedness args
 
 testCCall
     :: Compiler
@@ -44,11 +45,11 @@ testCCall comp c =
         writeFile (tmpDir </> "test.cmm") (cCallCmm c)
         compile comp tmpDir ["test_c.c", "test.cmm"] soName ["-shared", "-dynamic"]
         out <- runIt comp (tmpDir </> soName)
-        let saw :: [Natural]
+        let saw :: [Integer]
             saw = map read (lines out)
-            expected :: [Natural]
-            expected = map (\(SomeNumber e) -> toUnsigned e) (callArgs c) ++ [ret]
-            ret = case callRet c of SomeNumber n -> toUnsigned n
+            expected :: [Integer]
+            expected = map (\(s, SomeNumber e) -> asInteger s e) (callArgs c) ++ [ret]
+            ret = case callRet c of SomeNumber n -> asInteger (callRetSignedness c) n
         return $ saw === expected
 
   where
@@ -65,11 +66,14 @@ cStub c
     ]
   where
     argBndrs = [ "arg"++show i | (i,_) <- zip [0::Int ..] (callArgs c) ]
-    argWidths = [ knownWidth @w | SomeNumber (_ :: Number w) <- callArgs c ]
+    argTypes =
+      [ (signedness, knownWidth @w)
+      | (signedness, SomeNumber (_ :: Number w)) <- callArgs c
+      ]
 
     funcDef = unlines $
-      [ cType (retWidth c) <> " test_c(" <> argList <> ") {" ] ++
-      zipWith printArg argWidths argBndrs ++
+      [ cType Unsigned (retWidth c) <> " test_c(" <> argList <> ") {" ] ++
+      zipWith printArg argTypes argBndrs ++
       [ "  fflush(stdout);"
       , "  return " ++ show (someNumberToUnsigned $ callRet c) ++ "ULL;"
       , "}"
@@ -77,39 +81,47 @@ cStub c
 
     argList =
         commaList
-        [ unwords [cType w, bndr]
-        | (w, bndr) <- zip argWidths argBndrs
+        [ unwords [ty, bndr]
+        | (ty, bndr) <- zip (map (uncurry cType) argTypes) argBndrs
         ]
-    printArg w bndr =
-        "  printf(" ++ quoted (formatStr w ++ "\\n") ++ ", " ++ bndr ++ ");"
+    printArg ty bndr =
+        "  printf(" ++ quoted (formatStr ty ++ "\\n") ++ ", " ++ bndr ++ ");"
 
 quoted :: String -> String
 quoted s = "\"" ++ s ++ "\""
 
-formatStr :: Width -> String
-formatStr w =
+formatStr :: (Signedness, Width) -> String
+formatStr (_signedness, w) =
     "0x%" ++ quoted ("PRIx"++show n)
   where
     n = widthBits w
 
-cType :: Width -> String
-cType W8  = "uint8_t"
-cType W16 = "uint16_t"
-cType W32 = "uint32_t"
-cType W64 = "uint64_t"
+cType :: Signedness -> Width -> String
+cType signedness width  = prefix ++ "int" ++ show n ++ "_t"
+  where
+    n = widthBits width
+    prefix = case signedness of
+      Signed   -> ""
+      Unsigned -> "u"
 
 cCallCmm :: CCallDesc -> String
 cCallCmm c = unlines
     [ "test("++cmmWordType ++" buffer) {"
     , "  "++cmmType (retWidth c)++" ret;"
-    , "  (ret) = foreign \"C\" test_c(" ++ argList ++ ");"
+    , "  (" ++ retHint ++ "ret) = foreign \"C\" test_c(" ++ argList ++ ");"
     , "  return ("++widenOp++"(ret));"
     , "}"
     ]
   where
+    retHint = case callRetSignedness c of
+                Signed   -> "\"signed\" "
+                Unsigned -> ""
     widenOp = "%zx" ++ show (widthBits wordSize)
     argList =
         commaList
-        [ exprToCmm $ ELit e
-        | SomeNumber e <- callArgs c
+        [ exprToCmm (ELit e) ++ hint
+        | (signedness, SomeNumber e) <- callArgs c
+        , let hint = case signedness of
+                       Signed -> " \"signed\""
+                       Unsigned -> ""
         ]