feat(third_party/bazel): Check in rules_haskell from Tweag r/17

1 files changed, 342 insertions, 0 deletions

diff --git a/third_party/bazel/rules_haskell/examples/primitive/test/main.hs b/third_party/bazel/rules_haskell/examples/primitive/test/main.hs
new file mode 100644
index 000000000000..abec96df032d
--- /dev/null
+++ b/third_party/bazel/rules_haskell/examples/primitive/test/main.hs
@@ -0,0 +1,342 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Fix (fix)
+import Control.Monad.Primitive
+import Control.Monad.ST
+import Data.Monoid
+import Data.Primitive
+import Data.Primitive.Array
+import Data.Primitive.ByteArray
+import Data.Primitive.Types
+import Data.Primitive.SmallArray
+import Data.Primitive.PrimArray
+import Data.Word
+import Data.Proxy (Proxy(..))
+import GHC.Int
+import GHC.IO
+import GHC.Prim
+import Data.Function (on)
+#if MIN_VERSION_base(4,9,0)
+import Data.Semigroup (stimes)
+#endif
+
+import Test.Tasty (defaultMain,testGroup,TestTree)
+import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,(===),CoArbitrary,Function)
+import qualified Test.Tasty.QuickCheck as TQC
+import qualified Test.QuickCheck as QC
+import qualified Test.QuickCheck.Classes as QCC
+import qualified Test.QuickCheck.Classes.IsList as QCCL
+import qualified Data.List as L
+
+main :: IO ()
+main = do
+  testArray
+  testByteArray
+  defaultMain $ testGroup "properties"
+    [ testGroup "Array"
+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int)))
+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int)))
+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int)))
+      , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
+      , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 Array))
+      , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 Array))
+      , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 Array))
+      , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 Array))
+      , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 Array))
+#endif
+#if MIN_VERSION_base(4,7,0)
+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int)))
+      , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray')
+#endif
+      ]
+    , testGroup "SmallArray"
+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SmallArray Int)))
+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SmallArray Int)))
+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SmallArray Int)))
+      , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))
+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
+      , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 SmallArray))
+      , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 SmallArray))
+      , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 SmallArray))
+      , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 SmallArray))
+      , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 SmallArray))
+#endif
+#if MIN_VERSION_base(4,7,0)
+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int)))
+      , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray')
+#endif
+      ]
+    , testGroup "ByteArray"
+      [ testGroup "Ordering"
+        [ TQC.testProperty "equality" byteArrayEqProp
+        , TQC.testProperty "compare" byteArrayCompareProp
+        ]
+      , testGroup "Resize"
+        [ TQC.testProperty "shrink" byteArrayShrinkProp
+        , TQC.testProperty "grow" byteArrayGrowProp
+        ]
+      , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray))
+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray))
+      , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))
+#if MIN_VERSION_base(4,7,0)
+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray))
+#endif
+      ]
+    , testGroup "PrimArray"
+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16)))
+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16)))
+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16)))
+#if MIN_VERSION_base(4,7,0)
+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16)))
+      , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray)
+      , TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray')
+      , TQC.testProperty "foldlPrimArray" (QCCL.foldlProp int16 foldlPrimArray)
+      , TQC.testProperty "foldlPrimArray'" (QCCL.foldlProp int16 foldlPrimArray')
+      , TQC.testProperty "foldlPrimArrayM'" (QCCL.foldlMProp int16 foldlPrimArrayM')
+      , TQC.testProperty "mapPrimArray" (QCCL.mapProp int16 int32 mapPrimArray)
+      , TQC.testProperty "traversePrimArray" (QCCL.traverseProp int16 int32 traversePrimArray)
+      , TQC.testProperty "traversePrimArrayP" (QCCL.traverseProp int16 int32 traversePrimArrayP)
+      , TQC.testProperty "imapPrimArray" (QCCL.imapProp int16 int32 imapPrimArray)
+      , TQC.testProperty "itraversePrimArray" (QCCL.imapMProp int16 int32 itraversePrimArray)
+      , TQC.testProperty "itraversePrimArrayP" (QCCL.imapMProp int16 int32 itraversePrimArrayP)
+      , TQC.testProperty "generatePrimArray" (QCCL.generateProp int16 generatePrimArray)
+      , TQC.testProperty "generatePrimArrayA" (QCCL.generateMProp int16 generatePrimArrayA)
+      , TQC.testProperty "generatePrimArrayP" (QCCL.generateMProp int16 generatePrimArrayP)
+      , TQC.testProperty "replicatePrimArray" (QCCL.replicateProp int16 replicatePrimArray)
+      , TQC.testProperty "replicatePrimArrayA" (QCCL.replicateMProp int16 replicatePrimArrayA)
+      , TQC.testProperty "replicatePrimArrayP" (QCCL.replicateMProp int16 replicatePrimArrayP)
+      , TQC.testProperty "filterPrimArray" (QCCL.filterProp int16 filterPrimArray)
+      , TQC.testProperty "filterPrimArrayA" (QCCL.filterMProp int16 filterPrimArrayA)
+      , TQC.testProperty "filterPrimArrayP" (QCCL.filterMProp int16 filterPrimArrayP)
+      , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray)
+      , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA)
+      , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP)
+#endif
+      ]
+    , testGroup "UnliftedArray"
+      [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))
+      , lawsToTest (QCC.ordLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))
+      , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))
+#if MIN_VERSION_base(4,7,0)
+      , lawsToTest (QCC.isListLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16))))
+      , TQC.testProperty "mapUnliftedArray" (QCCL.mapProp arrInt16 arrInt32 mapUnliftedArray)
+      , TQC.testProperty "foldrUnliftedArray" (QCCL.foldrProp arrInt16 foldrUnliftedArray)
+      , TQC.testProperty "foldrUnliftedArray'" (QCCL.foldrProp arrInt16 foldrUnliftedArray')
+      , TQC.testProperty "foldlUnliftedArray" (QCCL.foldlProp arrInt16 foldlUnliftedArray)
+      , TQC.testProperty "foldlUnliftedArray'" (QCCL.foldlProp arrInt16 foldlUnliftedArray')
+#endif
+      ]
+    , testGroup "DefaultSetMethod"
+      [ lawsToTest (QCC.primLaws (Proxy :: Proxy DefaultSetMethod))
+      ]
+    -- , testGroup "PrimStorable"
+    --   [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived))
+    --   ]
+    ]
+
+int16 :: Proxy Int16
+int16 = Proxy
+
+int32 :: Proxy Int32
+int32 = Proxy
+
+arrInt16 :: Proxy (PrimArray Int16)
+arrInt16 = Proxy
+
+arrInt32 :: Proxy (PrimArray Int16)
+arrInt32 = Proxy
+
+-- Tests that using resizeByteArray to shrink a byte array produces
+-- the same results as calling Data.List.take on the list that the
+-- byte array corresponds to.
+byteArrayShrinkProp :: QC.Property
+byteArrayShrinkProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->
+  let large = max n m
+      small = min n m
+      xs = intsLessThan large
+      ys = byteArrayFromList xs
+      largeBytes = large * sizeOf (undefined :: Int)
+      smallBytes = small * sizeOf (undefined :: Int)
+      expected = byteArrayFromList (L.take small xs)
+      actual = runST $ do
+        mzs0 <- newByteArray largeBytes
+        copyByteArray mzs0 0 ys 0 largeBytes
+        mzs1 <- resizeMutableByteArray mzs0 smallBytes
+        unsafeFreezeByteArray mzs1
+   in expected === actual
+
+-- Tests that using resizeByteArray with copyByteArray (to fill in the
+-- new empty space) to grow a byte array produces the same results as
+-- calling Data.List.++ on the lists corresponding to the original
+-- byte array and the appended byte array.
+byteArrayGrowProp :: QC.Property
+byteArrayGrowProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->
+  let large = max n m
+      small = min n m
+      xs1 = intsLessThan small
+      xs2 = intsLessThan (large - small)
+      ys1 = byteArrayFromList xs1
+      ys2 = byteArrayFromList xs2
+      largeBytes = large * sizeOf (undefined :: Int)
+      smallBytes = small * sizeOf (undefined :: Int)
+      expected = byteArrayFromList (xs1 ++ xs2)
+      actual = runST $ do
+        mzs0 <- newByteArray smallBytes
+        copyByteArray mzs0 0 ys1 0 smallBytes
+        mzs1 <- resizeMutableByteArray mzs0 largeBytes
+        copyByteArray mzs1 smallBytes ys2 0 ((large - small) * sizeOf (undefined :: Int))
+        unsafeFreezeByteArray mzs1
+   in expected === actual
+
+-- Provide the non-negative integers up to the bound. For example:
+--
+-- >>> intsLessThan 5
+-- [0,1,2,3,4]
+intsLessThan :: Int -> [Int]
+intsLessThan i = if i < 1
+  then []
+  else (i - 1) : intsLessThan (i - 1)
+  
+byteArrayCompareProp :: QC.Property
+byteArrayCompareProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->
+  compareLengthFirst xs ys === compare (byteArrayFromList xs) (byteArrayFromList ys)
+
+byteArrayEqProp :: QC.Property
+byteArrayEqProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->
+  (compareLengthFirst xs ys == EQ) === (byteArrayFromList xs == byteArrayFromList ys)
+
+compareLengthFirst :: [Word8] -> [Word8] -> Ordering
+compareLengthFirst xs ys = (compare `on` length) xs ys <> compare xs ys
+
+-- on GHC 7.4, Proxy is not polykinded, so we need this instead.
+data Proxy1 (f :: * -> *) = Proxy1
+
+lawsToTest :: QCC.Laws -> TestTree
+lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)
+
+testArray :: IO ()
+testArray = do
+    arr <- newArray 1 'A'
+    let unit =
+            case writeArray arr 0 'B' of
+                IO f ->
+                    case f realWorld# of
+                        (# _, _ #) -> ()
+    c1 <- readArray arr 0
+    return $! unit
+    c2 <- readArray arr 0
+    if c1 == 'A' && c2 == 'B'
+        then return ()
+        else error $ "Expected AB, got: " ++ show (c1, c2)
+
+testByteArray :: IO ()
+testByteArray = do
+    let arr1 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])
+        arr2 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])
+        arr3 = mkByteArray ([0xde, 0xad, 0xbe, 0xee] :: [Word8])
+        arr4 = mkByteArray ([0xde, 0xad, 0xbe, 0xdd] :: [Word8])
+        arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [Word8])
+    when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $
+        fail $ "ByteArray Show incorrect: "++show arr1
+    unless (arr1 > arr3) $
+        fail $ "ByteArray Ord incorrect"
+    unless (arr1 == arr2) $
+        fail $ "ByteArray Eq incorrect"
+    unless (mappend arr1 arr4 == arr5) $
+        fail $ "ByteArray Monoid mappend incorrect"
+    unless (mappend arr1 (mappend arr3 arr4) == mappend (mappend arr1 arr3) arr4) $
+        fail $ "ByteArray Monoid mappend not associative"
+    unless (mconcat [arr1,arr2,arr3,arr4,arr5] == (arr1 <> arr2 <> arr3 <> arr4 <> arr5)) $
+        fail $ "ByteArray Monoid mconcat incorrect"
+#if MIN_VERSION_base(4,9,0)
+    unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $
+        fail $ "ByteArray Semigroup stimes incorrect"
+#endif
+
+mkByteArray :: Prim a => [a] -> ByteArray
+mkByteArray xs = runST $ do
+    marr <- newByteArray (length xs * sizeOf (head xs))
+    sequence $ zipWith (writeByteArray marr) [0..] xs
+    unsafeFreezeByteArray marr
+
+instance Arbitrary1 Array where
+  liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen)
+
+instance Arbitrary a => Arbitrary (Array a) where
+  arbitrary = fmap fromList QC.arbitrary
+
+instance Arbitrary1 SmallArray where
+  liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen)
+
+instance Arbitrary a => Arbitrary (SmallArray a) where
+  arbitrary = fmap smallArrayFromList QC.arbitrary
+
+instance Arbitrary ByteArray where
+  arbitrary = do
+    xs <- QC.arbitrary :: Gen [Word8]
+    return $ runST $ do
+      a <- newByteArray (L.length xs)
+      iforM_ xs $ \ix x -> do
+        writeByteArray a ix x
+      unsafeFreezeByteArray a
+
+instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where
+  arbitrary = do
+    xs <- QC.arbitrary :: Gen [a]
+    return $ runST $ do
+      a <- newPrimArray (L.length xs)
+      iforM_ xs $ \ix x -> do
+        writePrimArray a ix x
+      unsafeFreezePrimArray a
+
+instance (Arbitrary a, PrimUnlifted a) => Arbitrary (UnliftedArray a) where
+  arbitrary = do
+    xs <- QC.vector =<< QC.choose (0,3)
+    return (unliftedArrayFromList xs)
+
+instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where
+  coarbitrary x = QC.coarbitrary (primArrayToList x)
+
+instance (Prim a, Function a) => Function (PrimArray a) where
+  function = QC.functionMap primArrayToList primArrayFromList
+
+iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m ()
+iforM_ xs0 f = go 0 xs0 where
+  go !_ [] = return ()
+  go !ix (x : xs) = f ix x >> go (ix + 1) xs
+
+newtype DefaultSetMethod = DefaultSetMethod Int16
+  deriving (Eq,Show,Arbitrary)
+
+instance Prim DefaultSetMethod where
+  sizeOf# _ = sizeOf# (undefined :: Int16)
+  alignment# _ = alignment# (undefined :: Int16)
+  indexByteArray# arr ix = DefaultSetMethod (indexByteArray# arr ix)
+  readByteArray# arr ix s0 = case readByteArray# arr ix s0 of
+    (# s1, n #) -> (# s1, DefaultSetMethod n #)
+  writeByteArray# arr ix (DefaultSetMethod n) s0 = writeByteArray# arr ix n s0
+  setByteArray# = defaultSetByteArray#
+  indexOffAddr# addr off = DefaultSetMethod (indexOffAddr# addr off)
+  readOffAddr# addr off s0 = case readOffAddr# addr off s0 of
+    (# s1, n #) -> (# s1, DefaultSetMethod n #)
+  writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0
+  setOffAddr# = defaultSetOffAddr#
+
+-- TODO: Uncomment this out when GHC 8.6 is release. Also, uncomment
+-- the corresponding PrimStorable test group above.
+--
+-- newtype Derived = Derived Int16
+--   deriving newtype (Prim)
+--   deriving Storable via (PrimStorable Derived)
+
+
+