test operations on infinite structures

1 files changed, 31 insertions, 2 deletions

diff --git a/test/Spec.hs b/test/Spec.hs
index 351a517..f42712a 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,8 +1,18 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-import Test.QuickCheck
+import Blessings.Internal as B
+import Blessings.String
+import Control.Exception
+import System.IO.Unsafe
+import System.Timeout
 import Test.Hspec
-import Blessings
+import Test.QuickCheck
+
+unsafeTimeout :: Int -> a -> a
+unsafeTimeout n f =
+    case unsafePerformIO $ timeout n (evaluate f) of
+      Nothing -> error "timeout"
+      Just y -> y
 
 instance Arbitrary a => Arbitrary (Blessings a) where
   arbitrary =
@@ -24,3 +34,22 @@ main =
       it "obeys the Monoid laws" $
         property $ \(x :: Blessings String) ->
           x <> mempty == x && x == mempty <> x
+
+      let infx = mconcat (repeat (Plain "x" :: Blessings String))
+
+      it "can take from infinite structure" $
+        property $ \(n :: NonNegative Int) ->
+          unsafeTimeout 100000 $
+            let i = getNonNegative n in
+            B.length (B.take i infx) == i
+
+      it "can drop from infinite structure" $
+        property $ \(n :: NonNegative Int) ->
+          unsafeTimeout 100000 $
+            let i = getNonNegative n in
+            B.length (B.take i (B.drop i infx)) == i
+
+      it "can take concat of infinite structures" $
+        property $ \(x :: Blessings String) ->
+          unsafeTimeout 100000 $
+            B.length (B.take 1 $ infx <> x) <= 1