Infrastructure for generating test data.

generation/generation.cabal

@@ -18,13 +18,14 @@ extra-source-files:  CHANGELOG.md
 
 executable generation
   main-is:             Main.hs
-  other-modules:       Base, BinaryOps, Compare, Conversions, CryptoNum, File, Gen
+  other-modules:       Base, BinaryOps, Compare, Conversions, CryptoNum, File, Gen, Testing
   -- other-extensions:
   build-depends:       base ^>=4.12.0.0,
                        containers,
                        directory,
                        filepath,
-                       mtl
+                       mtl,
+                       random
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall

generation/src/BinaryOps.hs

@@ -3,16 +3,20 @@ module BinaryOps(
   )
  where
 
-import Control.Monad(forM_)
+import Control.Monad(forM_,replicateM_)
+import Data.Bits((.&.), (.|.), shiftL, xor)
 import File
 import Gen
 
+binaryTestCount :: Int
+binaryTestCount = 3000
+
 binaryOps :: File
 binaryOps = File {
     predicate = \ _ _ -> True,
     outputName = "binary",
     generator = declareBinaryOperators,
-    testGenerator = Nothing
+    testGenerator = Just testVectors
 }
 
 declareBinaryOperators :: Word -> Gen ()
@@ -52,7 +56,7 @@ declareBinaryOperators bitsize =
                  out ("output.value[" ++ show i ++ "] = !self.value[" ++ show i ++ "];")
                out "output"
      blank
-     addBinaryLaws name
+     addBinaryLaws name entries
 
 generateBinOps :: String -> String -> String -> String -> Word -> Gen ()
 generateBinOps trait name fun op entries =
@@ -99,8 +103,8 @@ generateBinOpsFromAssigns trait name fun op =
                out ("output " ++ op ++ " rhs;")
                out "output"
 
-addBinaryLaws :: String -> Gen ()
-addBinaryLaws name =
+addBinaryLaws :: String -> Word -> Gen ()
+addBinaryLaws name entries =
   do let args3 = "(a: " ++ name ++ ", b: " ++ name ++ ", c: " ++ name ++ ")"
          args2 = "(a: " ++ name ++ ", b: " ++ name ++ ")"
      out "#[cfg(test)]"
@@ -143,4 +147,25 @@ addBinaryLaws name =
                out ("(&a & &ones) == a")
           blank
           wrapIndent ("fn or_ident(a: " ++ name ++ ") -> bool") $
-            out ("(&a | " ++ name ++ "::zero()) == a")
+            out ("(&a | " ++ name ++ "::zero()) == a")
+          wrapIndent ("fn neg_as_xor(a: " ++ name ++ ") -> bool") $
+            do out ("let ones = " ++ name ++ "{ value: [0xFFFFFFFFFFFFFFFFu64; "
+                    ++ show entries ++ "] };")
+               out ("!&a == (&ones ^ &a)")
+
+
+testVectors :: Word -> Gen ()
+testVectors bitsize = replicateM_ binaryTestCount $
+  do a <- newNum False bitsize
+     b <- newNum False bitsize
+     let o = a .|. b
+         c = a .&. b
+         n = a `xor` ((1 `shiftL` fromIntegral bitsize) - 1)
+         x = a `xor` b
+     emitTestVariable 'a' a
+     emitTestVariable 'b' b
+     emitTestVariable 'c' c
+     emitTestVariable 'o' o
+     emitTestVariable 'n' n
+     emitTestVariable 'x' x
+  

generation/src/File.hs

@@ -8,6 +8,7 @@ module File(
 
 import Control.Monad(forM_)
 import Data.Char(toUpper)
+import Data.List(isPrefixOf)
 import qualified Data.Map.Strict as Map
 import Gen(Gen,blank,out)
 import System.FilePath(takeBaseName,takeDirectory,takeFileName,(</>))
@@ -41,9 +42,12 @@ addModuleTasks :: FilePath -> [Task] -> [Task]
 addModuleTasks base baseTasks = unsignedTask : (baseTasks ++ moduleTasks)
  where
   moduleMap = foldr addModuleInfo Map.empty baseTasks
-  addModuleInfo task =
-    Map.insertWith (++) (takeDirectory (outputFile task))
-                        [takeBaseName (outputFile task)]
+  addModuleInfo task map
+    | base `isPrefixOf` outputFile task =
+        Map.insertWith (++) (takeDirectory (outputFile task))
+                            [takeBaseName (outputFile task)]
+                            map
+    | otherwise = map
   moduleTasks = Map.foldrWithKey generateModuleTask [] moduleMap
   generateModuleTask directory mods acc = acc ++ [Task {
       outputFile = directory </> "mod.rs",

generation/src/Gen.hs

@@ -10,14 +10,19 @@ module Gen(
     implFor,
     implFor',
     implFor'',
+    newNum,
+    TestVariable(..),
     )
  where
 
 import Control.Monad.RWS.Strict(RWS,evalRWS)
 import Control.Monad.State.Class(MonadState,get,put)
 import Control.Monad.Writer.Class(MonadWriter,tell)
+import Data.Bits(shiftL)
 import Data.List(replicate)
 import Data.Word(Word)
+import Numeric(showHex)
+import System.Random(StdGen, newStdGen, random, randomR)
 
 newtype Gen a = Gen { unGen :: RWS () String GenState a}
  deriving (Applicative, Functor, Monad, MonadState GenState, MonadWriter String)
@@ -27,15 +32,19 @@ tabAmount = 4
 
 data GenState = GenState {
     indentAmount :: Word,
-    gensymIndex  :: Word
+    gensymIndex  :: Word,
+    rng          :: StdGen
 }
 
-initGenState :: GenState
-initGenState =  GenState { indentAmount = 0, gensymIndex = 0 }
+initGenState :: IO GenState
+initGenState =
+    do rng0 <- newStdGen
+       return GenState { indentAmount = 0, gensymIndex = 0, rng = rng0 }
 
 runGen :: FilePath -> Gen a -> IO a
 runGen path action =
-    do let (res, contents) = evalRWS (unGen action) () initGenState
+    do state0 <- initGenState
+       let (res, contents) = evalRWS (unGen action) () state0
        writeFile path contents
        return res
 
@@ -85,4 +94,22 @@ implFor' trait name middle =
 
 implFor'' :: String -> String -> Gen a -> Gen a
 implFor'' trait name middle =
-    wrapIndent ("impl<'a,'b> " ++ trait ++ " for " ++ name) middle
+    wrapIndent ("impl<'a,'b> " ++ trait ++ " for " ++ name) middle
+
+newNum :: Bool -> Word -> Gen Integer
+newNum signed bits =
+    do gs <- get
+       let rng0 = rng gs
+       let high = (1 `shiftL` fromIntegral bits) - 1
+       let (v, rng1) = randomR (0, high) rng0
+       let (sign, rng2) = random rng1
+       let v' = if signed && sign then -v else v
+       put gs{ rng = rng2 }
+       return v'
+
+class TestVariable a where
+    emitTestVariable :: Char -> a -> Gen ()
+
+instance TestVariable Integer where
+    emitTestVariable c v =
+        out ([c] ++ ": " ++ showHex v "")

generation/src/Testing.hs

@@ -0,0 +1,4 @@
+module Testing(
+       )
+ where
+