safe-coloured-text-gen (empty) → 0.0.0.0
raw patch · 6 files changed
+431/−0 lines, 6 filesdep +basedep +genvaliditydep +genvalidity-bytestring
Dependencies added: base, genvalidity, genvalidity-bytestring, genvalidity-sydtest, genvalidity-text, safe-coloured-text, safe-coloured-text-gen, sydtest, text
Files
- safe-coloured-text-gen.cabal +57/−0
- src/Text/Colour/Gen.hs +45/−0
- test/Spec.hs +1/−0
- test/Text/Colour/ChunkSpec.hs +240/−0
- test/Text/Colour/CodeSpec.hs +66/−0
- test/Text/ColourSpec.hs +22/−0
+ safe-coloured-text-gen.cabal view
@@ -0,0 +1,57 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: safe-coloured-text-gen+version: 0.0.0.0+description: Generators for types in safe-coloured-text+homepage: https://github.com/NorfairKing/safe-coloured-text#readme+bug-reports: https://github.com/NorfairKing/safe-coloured-text/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: Copyright (c) 2020 Tom Sydney Kerckhove+license: MIT+build-type: Simple++source-repository head+ type: git+ location: https://github.com/NorfairKing/safe-coloured-text++library+ exposed-modules:+ Text.Colour.Gen+ other-modules:+ Paths_safe_coloured_text_gen+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , genvalidity+ , genvalidity-bytestring+ , genvalidity-text+ , safe-coloured-text+ default-language: Haskell2010++test-suite safe-coloured-text-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Text.Colour.ChunkSpec+ Text.Colour.CodeSpec+ Text.ColourSpec+ Paths_safe_coloured_text_gen+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-tool-depends:+ sydtest-discover:sydtest-discover+ build-depends:+ base >=4.7 && <5+ , genvalidity-sydtest+ , safe-coloured-text+ , safe-coloured-text-gen+ , sydtest+ , text+ default-language: Haskell2010
+ src/Text/Colour/Gen.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.Colour.Gen where++import Data.GenValidity+import Data.GenValidity.ByteString ()+import Data.GenValidity.Text ()+import Text.Colour+import Text.Colour.Code++instance GenValid Chunk where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance GenValid CSI where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance GenValid SGR where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance GenValid Underlining where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance GenValid ColourIntensity where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance GenValid ConsoleIntensity where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance GenValid ConsoleLayer where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance GenValid TerminalColour where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering++instance GenValid Colour where+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
+ test/Text/Colour/ChunkSpec.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Text.Colour.ChunkSpec (spec) where++import Control.Monad+import Data.Char as Char+import Data.List+import qualified Data.Text as T+import Test.Syd+import Text.Colour.Capabilities+import Text.Colour.Chunk+import Text.Colour.Code++spec :: Spec+spec = do+ let gf = ("test_resources/chunk/" ++)+ describe "renderChunk" $ do+ it "outputs plain text if the terminal has no colours" $+ renderChunksBS WithoutColours [fore red "hello"] `shouldBe` "hello"+ it "outputs plain text if the terminal has no colours and 256 are needed" $+ renderChunksBS WithoutColours [fore (colour256 128) "hello"] `shouldBe` "hello"+ it "outputs plain text if the terminal has only 8 colours and 256 are needed" $+ renderChunksBS With8Colours [fore (colour256 128) "hello"] `shouldBe` "hello"+ it "outputs plain text if the terminal has no colours and 24bit colours are needed" $+ renderChunksBS WithoutColours [fore (colourRGB 128 128 128) "hello"] `shouldBe` "hello"+ it "outputs plain text if the terminal has only 8 colours and 24bit colours are needed" $+ renderChunksBS With8Colours [fore (colourRGB 128 128 128) "hello"] `shouldBe` "hello"+ it "outputs plain text if the terminal has only 8bit colours and 24bit colours are needed" $+ renderChunksBS With8BitColours [fore (colourRGB 128 128 128) "hello"] `shouldBe` "hello"+ it "outputs a plain chunk the same as before" $+ pureGoldenByteStringFile (gf "plain.dat") (renderChunkBS With24BitColours (chunk "ook"))+ describe "8 colours" $ do+ let gf8 = ("test_resources/chunk/8/" ++)+ let chunks string = justAFew $ do+ let colour = do+ terminalColour <- [minBound .. maxBound]+ intensity <- [minBound .. maxBound]+ pure $ Colour8 intensity terminalColour+ let mColour = Nothing : map Just colour+ chunkItalic <- Nothing : map Just [minBound .. maxBound]+ chunkConsoleIntensity <- Nothing : map Just [minBound .. maxBound]+ chunkUnderlining <- Nothing : map Just [minBound .. maxBound]+ chunkForeground <- mColour+ chunkBackground <- mColour+ let chunkText = T.pack string+ let italicName i = if i then "non-italic" else "italic"+ consoleIntensityName :: ConsoleIntensity -> String+ consoleIntensityName = \case+ BoldIntensity -> "bold"+ FaintIntensity -> "faint"+ NormalIntensity -> "non-bold"+ underliningName :: Underlining -> String+ underliningName = \case+ SingleUnderline -> "underline"+ DoubleUnderline -> "double underline"+ NoUnderline -> "no underline"+ name =+ unwords $+ filter+ (not . null)+ [ maybe "" italicName chunkItalic,+ maybe "" consoleIntensityName chunkConsoleIntensity,+ maybe "" underliningName chunkUnderlining,+ string,+ "with",+ mColourName chunkForeground,+ "foreground on",+ mColourName chunkBackground,+ "background"+ ]++ italicPath i = if i then "non-italic" else "italic"+ consoleIntensityPath :: ConsoleIntensity -> FilePath+ consoleIntensityPath = \case+ BoldIntensity -> "bold"+ FaintIntensity -> "faint"+ NormalIntensity -> "non-bold"+ underliningPath :: Underlining -> FilePath+ underliningPath = \case+ SingleUnderline -> "underline"+ DoubleUnderline -> "double-underline"+ NoUnderline -> "no-underline"+ path =+ intercalate+ "-"+ ( filter+ (not . null)+ [ maybe "" italicPath chunkItalic,+ maybe "" consoleIntensityPath chunkConsoleIntensity,+ maybe "" underliningPath chunkUnderlining,+ mColourPath chunkForeground,+ "fg",+ mColourPath chunkBackground,+ "bg"+ ]+ )+ <> ".dat"+ pure (name, path, Chunk {..})++ forM_ (chunks "ook") $ \(name, path, c) ->+ it (unwords ["outputs a", name, "the same way as before"]) $+ pureGoldenByteStringFile (gf8 path) (renderChunkBS With24BitColours c)+ describe "8bit colours" $ do+ let gf8bit = ("test_resources/chunk/8bit/" ++)+ let chunks string = justAFew $ do+ let colour = Colour8Bit <$> [minBound .. maxBound]+ let mColour = Nothing : map Just colour+ let chunkItalic = Nothing+ let chunkConsoleIntensity = Nothing+ let chunkUnderlining = Nothing+ chunkForeground <- mColour+ chunkBackground <- mColour+ let chunkText = T.pack string+ let name =+ unwords+ [ mColourName chunkForeground,+ "foreground on",+ mColourName chunkBackground,+ "background"+ ]+ path =+ intercalate+ "-"+ [ mColourPath chunkForeground,+ "fg",+ mColourPath chunkBackground,+ "bg"+ ]+ <> ".dat"+ pure (name, path, Chunk {..})++ forM_ (chunks "ook") $ \(name, path, c) ->+ it (unwords ["outputs a", name, "the same way as before"]) $+ pureGoldenByteStringFile (gf8bit path) (renderChunkBS With24BitColours c)+ describe "24bit colours" $ do+ let gf24bit = ("test_resources/chunk/24bit/" ++)+ let chunks string = justAFew $ do+ let colour = do+ let w = [0, 16 .. 255] -- Just a few colours, otherwise we end up with a boatload of files.+ r <- w+ g <- w+ b <- w+ pure $ Colour24Bit r g b+ let mColour = Nothing : map Just colour+ let chunkItalic = Nothing+ let chunkConsoleIntensity = Nothing+ let chunkUnderlining = Nothing+ chunkForeground <- mColour+ chunkBackground <- mColour+ let chunkText = T.pack string+ let name =+ unwords+ [ mColourName chunkForeground,+ "foreground on",+ mColourName chunkBackground,+ "background"+ ]+ path =+ intercalate+ "-"+ [ mColourPath chunkForeground,+ "fg",+ mColourPath chunkBackground,+ "bg"+ ]+ <> ".dat"+ pure (name, path, Chunk {..})++ forM_ (chunks "ook") $ \(name, path, c) ->+ it (unwords ["outputs a", name, "the same way as before"]) $+ pureGoldenByteStringFile (gf24bit path) (renderChunkBS With24BitColours c)+ describe "super fancy" $ do+ it "outputs this super fancy thing the same way as before" $+ let bc c = back c $ chunk " "++ colour8Bits = Colour8Bit <$> [16 .. maxBound]+ colour8Bitss = (Colour8Bit <$> [0 .. 7]) : (Colour8Bit <$> [8 .. 15]) : chunksOf 36 colour8Bits+ wsWithGaps = [0, 16 .. 255]+ colour24Bits = (Colour24Bit <$> wsWithGaps <*> wsWithGaps <*> wsWithGaps)+ colour24Bitss = chunksOf 64 colour24Bits+ cs =+ intercalate+ ["\n"]+ $ concat+ [ [ "Terminal colours (dull): " : map (bc . Colour8 Dull) [minBound .. maxBound],+ "Terminal colours (bright): " : map (bc . Colour8 Bright) [minBound .. maxBound]+ ],+ ["\n8 bit colours:"] : map (map bc) colour8Bitss,+ ["\n24 bit colours:"] : map (map bc) colour24Bitss+ ]+ in pureGoldenByteStringFile (gf "fancy.dat") (renderChunksBS With24BitColours cs)++chunksOf :: Int -> [a] -> [[a]]+chunksOf w l+ | length l > w = take w l : chunksOf w (drop w l)+ | otherwise = [l]++colourName :: Colour -> String+colourName =+ unwords . \case+ Colour8 intensity terminalColour ->+ [ show intensity,+ show terminalColour+ ]+ Colour8Bit w ->+ [ "8-bit colour",+ show w+ ]+ Colour24Bit r g b ->+ [ "8-bit colour",+ show (r, g, b)+ ]++mColourName :: Maybe Colour -> String+mColourName Nothing = "no"+mColourName (Just c) = "a(n) " <> colourName c++colourPath :: Colour -> FilePath+colourPath =+ map Char.toLower+ . intercalate "-"+ . \case+ Colour8 intensity terminalColour ->+ [ show intensity,+ show terminalColour+ ]+ Colour8Bit w -> [show w]+ Colour24Bit r g b -> [show r, show g, show b]++mColourPath :: Maybe Colour -> FilePath+mColourPath Nothing = "no"+mColourPath (Just c) = colourPath c++justAFew :: [a] -> [a]+justAFew = go 1+ where+ go _ [] = []+ go i (a : as) = a : go (2 * i) (drop i as)
+ test/Text/Colour/CodeSpec.hs view
@@ -0,0 +1,66 @@+module Text.Colour.CodeSpec (spec) where++import Control.Monad+import Data.Char as Char+import Data.List+import Test.Syd+import Text.Colour.Code++spec :: Spec+spec = do+ let gf = ("test_resources/csi/" ++)+ describe "renderCSI" $ do+ it "outputs a reset the same as before" $+ pureGoldenByteStringFile (gf "reset.dat") (renderCSIBS (SGR [Reset]))+ describe "SGR" $ do+ let gf8 = ("test_resources/csi/8/" ++)+ describe "8 colours" $ do+ describe "simple, exhaustive" $ do+ let sgrTests = do+ intensity <- [minBound .. maxBound]+ layer <- [minBound .. maxBound]+ colour <- [minBound .. maxBound]+ pure+ ( unwords [show intensity, show colour, show layer],+ map Char.toLower (intercalate "-" [show intensity, show colour, show layer]) ++ ".dat",+ SetColour intensity layer colour+ )+ forM_ sgrTests $ \(name, path, sgr) ->+ it (unwords ["outputs a", show name, "the same as before"]) $+ pureGoldenByteStringFile (gf8 path) (renderCSIBS (SGR [sgr]))+ it "outputs an dull red background with bright blue foreground the same as before" $ do+ pureGoldenByteStringFile+ (gf8 "two-colours.dat")+ ( renderCSIBS+ ( SGR+ [ SetColour Dull Background Red,+ SetColour Bright Foreground Blue+ ]+ )+ )+ it "outputs an bold, italic, underlined, dull yellow background with bright green foreground the same as before" $ do+ pureGoldenByteStringFile+ (gf8 "complex.dat")+ ( renderCSIBS+ ( SGR+ [ SetItalic True,+ SetUnderlining SingleUnderline,+ SetConsoleIntensity BoldIntensity,+ SetColour Dull Background Yellow,+ SetColour Bright Foreground Green+ ]+ )+ )+ let gf256 = ("test_resources/csi/256/" ++)+ describe "256 colours" $ do+ -- https://en.wikipedia.org/wiki/ANSI_escape_code#8-bit+ it "outputs a pink foreground colour with light blue background the same as before" $ do+ pureGoldenByteStringFile+ (gf256 "two-colours.dat")+ ( renderCSIBS+ ( SGR+ [ SetColour Dull Background Red,+ SetColour Bright Foreground Blue+ ]+ )+ )
+ test/Text/ColourSpec.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TypeApplications #-}++module Text.ColourSpec (spec) where++import Test.Syd+import Test.Syd.Validity+import Text.Colour+import Text.Colour.Code+import Text.Colour.Gen ()++spec :: Spec+spec = do+ genValidSpec @CSI+ genValidSpec @ColourIntensity+ genValidSpec @ConsoleIntensity+ genValidSpec @ConsoleLayer+ genValidSpec @SGR+ genValidSpec @TerminalColour+ genValidSpec @TerminalColour+ genValidSpec @Underlining+ genValidSpec @Colour+ genValidSpec @Chunk