diff --git a/CHANGELOG.md b/CHANGELOG.md index d65fecc..6e3f323 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # CHANGELOG +## [Unreleased] + +* Fix `displayList` by making it lazier (https://github.com/haskell-text/text-display/pull/27) + ## [v0.0.3.0] - 21/08/2022 This is an experimental release. diff --git a/src/Data/Text/Display.hs b/src/Data/Text/Display.hs index cefaf98..77ffb70 100644 --- a/src/Data/Text/Display.hs +++ b/src/Data/Text/Display.hs @@ -94,11 +94,10 @@ class Display a where -- > → Custom `displayList` displayList :: [a] -> Builder displayList [] = "[]" - displayList (x : xs) = displayList' xs ("[" <> displayBuilder x) + displayList (x : xs) = "[" <> displayBuilder x <> foldMap go xs <> "]" where - displayList' :: [a] -> Builder -> Builder - displayList' [] acc = acc <> "]" - displayList' (y : ys) acc = displayList' ys (acc <> "," <> displayBuilder y) + go :: a -> Builder + go y = "," <> displayBuilder y -- | The method 'displayPrec' allows you to write instances that -- require nesting. The precedence parameter can be thought of as a diff --git a/test/Main.hs b/test/Main.hs index b400c91..09e4f31 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -6,11 +6,18 @@ module Main where +import Control.DeepSeq +import Control.Exception +import Control.Monad import Data.ByteString import Data.List.NonEmpty import qualified Data.List.NonEmpty as NE +import Data.Maybe import qualified Data.Text as T import Data.Text.Arbitrary +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import System.Timeout import Test.Hspec import Test.Hspec.QuickCheck import Test.ShouldNotTypecheck (shouldNotTypecheck) @@ -34,6 +41,14 @@ data OpaqueType = OpaqueType Int (Display) via (OpaqueInstance "" OpaqueType) +-- | @v \`shouldEvaluateWithin\` n@ sets the expectation that evaluating @v@ +-- should take no longer than @n@ microseconds. +shouldEvaluateWithin :: (HasCallStack, NFData a) => a -> Int -> Expectation +shouldEvaluateWithin a n = do + res <- timeout n (evaluate $ force a) + when (isNothing res) $ do + expectationFailure ("evaluation timed out in " <> show n <> " microseconds") + spec :: Spec spec = do describe "Display Tests:" $ do @@ -51,6 +66,9 @@ spec = do it "Single-element List instance is equivalent to Show" $ do let list = [1] :: [Int] T.unpack (display list) `shouldBe` show list + it "List instance is streamed lazily" $ do + let list = [1 ..] :: [Int] + TL.take 20 (TB.toLazyText $ displayBuilder list) `shouldEvaluateWithin` 100000 it "NonEmpty instance is equivalent to Show" $ do let ne = NE.fromList [1 .. 5] :: NonEmpty Int T.unpack (display ne) `shouldBe` show ne diff --git a/text-display.cabal b/text-display.cabal index 728019b..4aeb717 100644 --- a/text-display.cabal +++ b/text-display.cabal @@ -55,6 +55,7 @@ test-suite text-display-test build-depends: , base , bytestring + , deepseq , hspec , quickcheck-text , should-not-typecheck