Compatability fixes

recursion-ninja · May 21, 2019 · 229c7fe · 229c7fe
1 parent c5bdb2b
commit 229c7fe
Show file tree

Hide file tree

Showing 4 changed files with 68 additions and 22 deletions.
diff --git a/.travis.yml b/.travis.yml
@@ -11,8 +11,8 @@ matrix:
       env: GHCVER=8.2.2
       os: osx
 
-    - compiler: "ghc-8.4.4"
-      env: GHCVER=8.4.4
+    - compiler: "ghc-8.6.5"
+      env: GHCVER=8.6.5
       os: osx
 
     # Linux builds
@@ -53,14 +53,15 @@ matrix:
       addons: {apt: {packages: [cabal-install-head, ghc-head], sources: [hvr-ghc]}}
 
   allow_failures:
+    - compiler: "ghc-8.8.1"
     - compiler: "ghc-head"
 
 before_install:
   # MacOS setups
   # Install specific GHC version
   - if [[ "$TRAVIS_OS_NAME" == "osx" && "$GHCVER" == "8.0.2" ]]; then brew install ghc@8.0 cabal-install && export PATH=/usr/local/opt/ghc@8.0/bin:$PATH; fi
   - if [[ "$TRAVIS_OS_NAME" == "osx" && "$GHCVER" == "8.2.2" ]]; then brew install ghc@8.2 cabal-install && export PATH=/usr/local/opt/ghc@8.2/bin:$PATH; fi
-  - if [[ "$TRAVIS_OS_NAME" == "osx" && "$GHCVER" == "8.4.4" ]]; then brew install ghc     cabal-install && export PATH=/usr/local/opt/ghc/bin:$PATH; fi
+  - if [[ "$TRAVIS_OS_NAME" == "osx" && "$GHCVER" == "8.6.5" ]]; then brew install ghc     cabal-install && export PATH=/usr/local/opt/ghc/bin:$PATH; fi
 
   # Linux setups initial setup
   # Export PATH to specific GHC & Cabal version specific programs
@@ -95,7 +96,12 @@ install:
     fi
 
   # Install dependencies and utility programs
-  - cabal install --enable-benchmarks --enable-documentation --enable-tests --only-dependencies
+  - |
+    if $GHCHEAD; then
+      cabal install --enable-benchmarks --enable-documentation --enable-tests --only-dependencies --allow-newer
+    else
+      cabal install --enable-benchmarks --enable-documentation --enable-tests --only-dependencies
+    fi
   - cabal install hpc
 
 script:

diff --git a/bv-little.cabal b/bv-little.cabal
@@ -51,7 +51,7 @@ library
 
   if !impl(ghc >= 8.0)
 
-    build-depends:    semigroups
+    build-depends:    semigroups       >= 0.18  && < 0.19
 
   default-language: Haskell2010
 
@@ -104,7 +104,7 @@ Test-Suite test-suite
 
   main-is:          TestSuite.hs
 
-  build-depends:      base             >= 4.5.1 && < 4.13
+  build-depends:      base             >= 4.5.1 && < 5
                     , bv-little
                     , deepseq
                     , hashable
@@ -120,7 +120,7 @@ Test-Suite test-suite
 
   if !impl(ghc >= 8.0)
 
-    build-depends:    semigroups
+    build-depends:    semigroups       >= 0.18  && < 0.19
                     , transformers
 
   default-language: Haskell2010
@@ -139,7 +139,7 @@ benchmark benchmark-suite
 
   main-is:          Benchmarks.hs
 
-  build-depends:      base             >= 4.5.1 && < 4.13
+  build-depends:      base             >= 4.5.1 && < 5
                     , bv-little
                     , criterion
                     , deepseq
@@ -150,7 +150,7 @@ benchmark benchmark-suite
 
   if !impl(ghc >= 8.0)
 
-    build-depends:    semigroups
+    build-depends:    semigroups       >= 0.18  && < 0.19
 
   default-language: Haskell2010
 

diff --git a/src/Data/BitVector/LittleEndian.hs b/src/Data/BitVector/LittleEndian.hs
@@ -64,7 +64,6 @@ module Data.BitVector.LittleEndian
   , dimension
   , isZeroVector
   , subRange
-  , showNatural
   ) where
 
 
@@ -88,7 +87,7 @@ import GHC.Generics
 import GHC.Integer.GMP.Internals
 import GHC.Integer.Logarithms
 import GHC.Natural
-import Test.QuickCheck           (Arbitrary(..), CoArbitrary(..), NonNegative(..), suchThat, variant)
+import Test.QuickCheck           (Arbitrary(..), CoArbitrary(..), NonNegative(..), choose, suchThat, variant)
 import TextShow                  (TextShow(showb))
 
 
@@ -118,11 +117,50 @@ type instance MonoKey BitVector = Word
 -- @since 0.1.0
 instance Arbitrary BitVector where
 
+    -- Arbitrary instance distribution weighting:
+    --  -  2% = (maxBound :: Word)
+    --  -  2% = (maxBound :: Word) + 1
+    --  -  8% = all bits on
+    --  -  8% = all bits off
+    --  - 80% = any bit configuration
     arbitrary = do
-        dimVal <- getNonNegative <$> arbitrary
-        let upperBound = shiftL 1 dimVal
-        intVal <- (getNonNegative <$> arbitrary) `suchThat` (< upperBound)
-        pure . BV (toEnum dimVal) $ intToNat intVal
+        -- 1/25 chance of generating the boundary value at which the natural number
+        -- must use different Natural constructors: NatS# & NatJ# 
+        n <- choose (0, 25 :: Word)
+        case n of
+          0 -> boundaryValue
+          1 -> allBitsOn
+          2 -> allBitsOn
+          3 -> allBitsOff
+          4 -> allBitsOff
+          _ -> anyBitValue
+      where
+        allBitsOn     = genBitVector $ Just True
+        allBitsOff    = genBitVector $ Just False
+        anyBitValue   = genBitVector $ Nothing
+
+        boundaryValue = do
+            let wrdVal = maxBound :: Word
+            let dimVal = toEnum $ popCount wrdVal
+            let numVal = wordToNatural wrdVal
+            -- 50/50 change to generate above or below the constructor boundary
+            underBoundary <- arbitrary
+            let (lowerBound, naturalVal)
+                  | underBoundary = (dimVal    , numVal    )
+                  | otherwise     = (dimVal + 1, numVal + 1)
+            widthVal <- (getNonNegative <$> arbitrary) `suchThat` (>= lowerBound)
+            pure $ BV widthVal naturalVal
+
+        genBitVector spec = do
+            dimVal <- getNonNegative <$> arbitrary 
+            let upperBound = shiftL 1 dimVal
+            -- 1/5 chance all bits on or all bits off
+            natVal <- case spec of
+                        Just False -> pure $ intToNat 0
+                        Just True  -> pure . intToNat $ upperBound - 1
+                        Nothing    -> fmap intToNat $
+                                        (getNonNegative <$> arbitrary) `suchThat` (< upperBound)
+            pure $ BV (toEnum dimVal) natVal
 
 
 -- |
@@ -158,14 +196,14 @@ instance Bits BitVector where
         in  BV w $ n .&. mask
 
     {-# INLINE setBit #-}
-    setBit bv@(BV w n) i@(I# v)
+    setBit bv@(BV w n) i
       | i < 0 = bv
-      | otherwise = BV (max w j) $ (n `orNatural` (bitNatural v :: Natural) :: Natural)
+      | otherwise = BV (max w j) $ n `setBit` i
       where
         !j = toEnum i + 1
 
     {-# INLINE testBit #-}
-    testBit (BV w n) i = i >= 0 && toEnum i < w && n `testBitNatural` i
+    testBit (BV w n) i = i >= 0 && toEnum i < w && n `testBit` i
 
     bitSize (BV w _) = fromEnum w
 
@@ -1116,10 +1154,12 @@ toInt w
 -- this function does not throw an exception when an negative valued 'Integer'
 -- is supplied and is also compatible with base < 4.10.0.0.
 {-# INLINE intToNat #-}
+-- {-# NOINLINE intToNat #-}
 intToNat :: Integer -> Natural
-intToNat (S# i#) | I# i# >= 0  = NatS# (int2Word# i#)
-intToNat (Jp# bn)              = NatJ# bn
-intToNat _                     = NatS# (int2Word# 0#)
+intToNat (S#  i#) | isTrue# (i# >=# 0#)               = NatS# (int2Word# i#)
+intToNat (Jp# bn) | isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn)
+                  | otherwise                         = NatJ# bn
+intToNat _                                            = NatS# (int2Word# 0#)
 
 
 -- |

diff --git a/test/TestSuite.hs b/test/TestSuite.hs
@@ -34,7 +34,7 @@ import           TextShow (TextShow(showb), toString)
 
 infix 0 -=>
 (-=>) :: QC.Testable p => Bool -> p -> Property 
-(-=>) p q = (not p) .||. q
+(-=>) p q = not p .||. q
 
 
 main :: IO ()