Merge pull request #152 from github/remove-orphan-bytestring-listable

Remove orphan ByteString Listable instance.

Author: Patrick Thomson

semantic-core/semantic-core.cabal

@@ -71,9 +71,9 @@ test-suite spec
   other-modules:       Generators
   build-depends:       base
                      , semantic-core
-                     , hedgehog >= 0.6 && <1
+                     , hedgehog ^>= 1
                      , tasty >= 1.2 && <2
-                     , tasty-hedgehog >= 0.2 && <1
+                     , tasty-hedgehog ^>= 1.0.0.1
                      , tasty-hunit >= 0.10 && <1
                      , trifecta
   hs-source-dirs:      test

semantic.cabal

@@ -381,14 +381,17 @@ test-suite test
                      , Tags.Spec
                      , SpecHelpers
                      , Test.Hspec.LeanCheck
+                     , Generators
   build-depends:       semantic
                      , tree-sitter-json
                      , Glob ^>= 0.10.0
+                     , hedgehog ^>= 1
                      , hspec >= 2.6 && <3
                      , hspec-core >= 2.6 && <3
                      , hspec-expectations ^>= 0.8.2
                      , tasty ^>= 1.2.3
                      , tasty-golden ^>= 2.3.2
+                     , tasty-hedgehog ^>= 1.0.0.1
                      , tasty-hspec ^>= 1.1.5.1
                      , HUnit ^>= 1.6.0.0
                      , leancheck >= 0.8 && <1

test/Data/Functor/Listable.hs

@@ -566,20 +566,3 @@ instance Listable Pos where
 
 instance Listable Span where
   tiers = cons2 Span
-
-instance Listable Blob where
-  tiers = cons4 makeBlob
-
-instance Listable BlobPair where
-  tiers = liftTiers tiers
-
-instance Listable Source where
-  tiers = fromUTF8 `mapT` tiers
-
-instance Listable ByteString where
-  tiers = (T.encodeUtf8 . T.pack) `mapT` strings
-    where strings = foldr ((\\//) . listsOf . toTiers) []
-            [ ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9']
-            , [' '..'/'] <> [':'..'@'] <> ['['..'`'] <> ['{'..'~']
-            , [chr 0x00..chr 0x1f] <> [chr 127] -- Control characters.
-            , [chr 0xa0..chr 0x24f] ] -- Non-ASCII.

test/Data/Source/Spec.hs

@@ -1,53 +1,77 @@
-module Data.Source.Spec (spec) where
+{-# LANGUAGE NamedFieldPuns #-}
+module Data.Source.Spec (spec, testTree) where
 
-import Data.Char (chr)
-import Data.Functor.Listable
 import Data.Range
 import Data.Source
 import Data.Span
 import qualified Data.Text as Text
+
 import Test.Hspec
-import Test.Hspec.LeanCheck
-import Test.LeanCheck
+
+import qualified Generators as Gen
+import qualified Hedgehog.Gen as Gen
+import           Hedgehog ((===))
+import qualified Hedgehog.Range
+import           Hedgehog hiding (Range)
+import qualified Test.Tasty as Tasty
+import           Test.Tasty.Hedgehog (testProperty)
+
+prop :: HasCallStack => String -> (Source -> PropertyT IO ()) -> Tasty.TestTree
+prop desc f
+  = testProperty desc
+  . property
+  $ forAll (Gen.source (Hedgehog.Range.linear 0 100))
+  >>= f
+
+testTree :: Tasty.TestTree
+testTree = Tasty.testGroup "Data.Source"
+  [ Tasty.testGroup "sourceLineRanges"
+    [ prop "produces 1 more range than there are newlines" $
+      \ source -> length (sourceLineRanges source) === succ (Text.count "\n" (toText source))
+
+    , prop "produces exhaustive ranges" $
+      \ source -> foldMap (`slice` source) (sourceLineRanges source) === source
+    ]
+
+  , Tasty.testGroup "spanToRange"
+    [ prop "computes single-line ranges" $ \ source -> do
+        let ranges = sourceLineRanges source
+        let spans = zipWith (\ i Range {..} -> Span (Pos i 1) (Pos i (succ (end - start)))) [1..] ranges
+        fmap (spanToRange source) spans === ranges
+
+    , prop "computes multi-line ranges" $
+        \ source ->
+          spanToRange source (totalSpan source) === totalRange source
+
+    , prop "computes sub-line ranges" $
+        \ s -> let source = "*" <> s <> "*" in
+          spanToRange source (insetSpan (totalSpan source)) === insetRange (totalRange source)
+
+    , testProperty "inverse of rangeToSpan" . property $ do
+        a <- forAll . Gen.source $ Hedgehog.Range.linear 0 100
+        b <- forAll . Gen.source $ Hedgehog.Range.linear 0 100
+        let s = a <> "\n" <> b in spanToRange s (totalSpan s) === totalRange s
+    ]
+
+  ,  testProperty "rangeToSpan inverse of spanToRange" . property $ do
+      a <- forAll . Gen.source $ Hedgehog.Range.linear 0 100
+      b <- forAll . Gen.source $ Hedgehog.Range.linear 0 100
+      let s = a <> "\n" <> b in rangeToSpan s (totalRange s) === totalSpan s
+
+  , Tasty.testGroup "totalSpan"
+    [ testProperty "covers single lines" . property $ do
+        n <- forAll $ Gen.int (Hedgehog.Range.linear 0 100)
+        totalSpan (fromText (Text.replicate n "*")) === Span (Pos 1 1) (Pos 1 (max 1 (succ n)))
+
+    , testProperty "covers multiple lines" . property $ do
+        n <- forAll $ Gen.int (Hedgehog.Range.linear 0 100)
+        totalSpan (fromText (Text.intersperse '\n' (Text.replicate n "*"))) === Span (Pos 1 1) (Pos (max 1 n) (if n > 0 then 2 else 1))
+    ]
+
+  ]
 
 spec :: Spec
 spec = parallel $ do
-  describe "sourceLineRanges" $ do
-    prop "produces 1 more range than there are newlines" $
-      \ source -> length (sourceLineRanges source) `shouldBe` succ (Text.count "\n" (toText source))
-
-    prop "produces exhaustive ranges" $
-      \ source -> foldMap (`slice` source) (sourceLineRanges source) `shouldBe` source
-
-  describe "spanToRange" $ do
-    prop "computes single-line ranges" $
-      \ s -> let source = fromUTF8 s
-                 spans = zipWith (\ i Range {..} -> Span (Pos i 1) (Pos i (succ (end - start)))) [1..] ranges
-                 ranges = sourceLineRanges source in
-        spanToRange source <$> spans `shouldBe` ranges
-
-    prop "computes multi-line ranges" $
-      \ source ->
-        spanToRange source (totalSpan source) `shouldBe` totalRange source
-
-    prop "computes sub-line ranges" $
-      \ s -> let source = "*" <> s <> "*" in
-        spanToRange source (insetSpan (totalSpan source)) `shouldBe` insetRange (totalRange source)
-
-    prop "inverse of rangeToSpan" $
-      \ a b -> let s = a <> "\n" <> b in spanToRange s (totalSpan s) `shouldBe` totalRange s
-
-  describe "rangeToSpan" $ do
-    prop "inverse of spanToRange" $
-      \ a b -> let s = a <> "\n" <> b in rangeToSpan s (totalRange s) `shouldBe` totalSpan s
-
-  describe "totalSpan" $ do
-    prop "covers single lines" $
-      \ n -> totalSpan (fromText (Text.replicate n "*")) `shouldBe` Span (Pos 1 1) (Pos 1 (max 1 (succ n)))
-
-    prop "covers multiple lines" $
-      \ n -> totalSpan (fromText (Text.intersperse '\n' (Text.replicate n "*"))) `shouldBe` Span (Pos 1 1) (Pos (max 1 n) (if n > 0 then 2 else 1))
-
   describe "newlineIndices" $ do
     it "finds \\n" $
       let source = "a\nb" in
@@ -62,13 +86,6 @@ spec = parallel $ do
       let source = "hi\r}\r}\n xxx \r a" in
       newlineIndices source `shouldBe` [2, 4, 6, 12]
 
-  prop "preserves characters" . forAll (toTiers (list +| [chr 0xa0..chr 0x24f])) $
-    \ c -> Text.unpack (toText (fromText (Text.singleton c))) `shouldBe` [c]
-
-  prop "preserves strings" $
-    \ s -> fromText (toText s) `shouldBe` s
-
-
 insetSpan :: Span -> Span
 insetSpan sourceSpan = sourceSpan { spanStart = (spanStart sourceSpan) { posColumn = succ (posColumn (spanStart sourceSpan)) }
                                   , spanEnd = (spanEnd sourceSpan) { posColumn = pred (posColumn (spanEnd sourceSpan)) } }

test/Generators.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE TypeFamilies #-}
+module Generators
+  ( source
+  ) where
+
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Data.Source
+import Data.Functor.Identity
+
+source :: (GenBase m ~ Identity, MonadGen m) => Hedgehog.Range Int -> m Data.Source.Source
+source r = Data.Source.fromUTF8 <$> Gen.utf8 r Gen.unicode

test/Spec.hs

@@ -46,6 +46,7 @@ tests :: (?session :: TaskSession) => [TestTree]
 tests =
   [ Integration.Spec.spec
   , Semantic.CLI.Spec.spec
+  , Data.Source.Spec.testTree
   ]
 
 -- We can't bring this out of the IO monad until we divest