diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# Changelog for safe-coloured-text-parsing-gen + +## [0.0.0.0] - 2026-04-12 + +### Added + +* Initial release +* `GenValid` instance for `AnsiToken` +* Property and unit tests for ANSI parsing diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2021 Tom Sydney Kerckhove + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/safe-coloured-text-parsing-gen.cabal b/safe-coloured-text-parsing-gen.cabal new file mode 100644 --- /dev/null +++ b/safe-coloured-text-parsing-gen.cabal @@ -0,0 +1,62 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.3. +-- +-- see: https://github.com/sol/hpack + +name: safe-coloured-text-parsing-gen +version: 0.0.0.0 +synopsis: Generators for safe-coloured-text-parsing +category: User Interfaces +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) 2026 Tom Sydney Kerckhove +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + LICENSE + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/NorfairKing/safe-coloured-text + +library + exposed-modules: + Text.Colour.Chunk.Parsing.Gen + other-modules: + Paths_safe_coloured_text_parsing_gen + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , genvalidity + , safe-coloured-text-gen + , safe-coloured-text-parsing + default-language: Haskell2010 + +test-suite safe-coloured-text-parsing-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Text.Colour.Chunk.ParsingSpec + Paths_safe_coloured_text_parsing_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 + , genvalidity-text + , safe-coloured-text + , safe-coloured-text-gen + , safe-coloured-text-parsing + , safe-coloured-text-parsing-gen + , sydtest + , text + default-language: Haskell2010 diff --git a/src/Text/Colour/Chunk/Parsing/Gen.hs b/src/Text/Colour/Chunk/Parsing/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Text/Colour/Chunk/Parsing/Gen.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.Colour.Chunk.Parsing.Gen where + +import Data.GenValidity +import Text.Colour.Chunk.Parsing +import Text.Colour.Gen () + +instance GenValid OscCommand where + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering + +instance GenValid AnsiToken where + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/Text/Colour/Chunk/ParsingSpec.hs b/test/Text/Colour/Chunk/ParsingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Text/Colour/Chunk/ParsingSpec.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Text.Colour.Chunk.ParsingSpec (spec) where + +import Data.GenValidity.Text () +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import Test.Syd +import Test.Syd.Validity +import Text.Colour.Capabilities +import Text.Colour.Chunk +import Text.Colour.Chunk.Parsing +import Text.Colour.Chunk.Parsing.Gen () +import Text.Colour.Code +import Text.Colour.Gen () + +spec :: Spec +spec = do + genValidSpec @OscCommand + genValidSpec @AnsiToken + + describe "parseAnsiTokens" $ do + it "tokenizes plain text" $ + parseAnsiTokens "hello" `shouldBe` [PlainText "hello"] + + it "tokenizes an SGR sequence" $ + parseAnsiTokens "\ESC[31m" `shouldBe` [SgrSequence [31]] + + it "tokenizes mixed content" $ + parseAnsiTokens "hello\ESC[31mworld\ESC[0m!" + `shouldBe` [PlainText "hello", SgrSequence [31], PlainText "world", SgrSequence [0], PlainText "!"] + + it "tokenizes non-SGR CSI as OtherCsiSequence" $ + parseAnsiTokens "\ESC[2J" `shouldBe` [OtherCsiSequence] + + it "treats CSI with intermediate bytes as non-SGR" $ + parseAnsiTokens "\ESC[ 1m" `shouldBe` [OtherCsiSequence] + + it "tokenizes combined parameters" $ + parseAnsiTokens "\ESC[1;31m" `shouldBe` [SgrSequence [1, 31]] + + it "tokenizes 256-colour parameters" $ + parseAnsiTokens "\ESC[38;5;196m" `shouldBe` [SgrSequence [38, 5, 196]] + + it "tokenizes bare ESC as plain text" $ + parseAnsiTokens "before\ESCafter" + `shouldBe` [PlainText "before", PlainText "\ESC", PlainText "after"] + + it "keeps incomplete ESC[ together as single token" $ + parseAnsiTokens "hello\ESC[" `shouldBe` [PlainText "hello", PlainText "\ESC["] + + it "drops parameter values that overflow Word8" $ + parseAnsiTokens "\ESC[256m" `shouldBe` [SgrSequence []] + + it "tokenizes empty input" $ + parseAnsiTokens "" `shouldBe` [] + + it "tokenizes an OSC 8 hyperlink open with ST terminator" $ + parseAnsiTokens "\ESC]8;;https://example.com\ESC\\" + `shouldBe` [OscSequence (OscHyperlink "" "https://example.com")] + + it "tokenizes an OSC 8 hyperlink close with ST terminator" $ + parseAnsiTokens "\ESC]8;;\ESC\\" + `shouldBe` [OscSequence (OscHyperlink "" "")] + + it "tokenizes an OSC 0 window title with BEL terminator" $ + parseAnsiTokens "\ESC]0;My Title\BEL" + `shouldBe` [OscSequence (OscOther 0 "My Title")] + + it "tokenizes an OSC 8 hyperlink around text" $ + parseAnsiTokens "\ESC]8;;https://errors.haskell.org/messages/GHC-63394\ESC\\GHC-63394\ESC]8;;\ESC\\" + `shouldBe` [ OscSequence (OscHyperlink "" "https://errors.haskell.org/messages/GHC-63394"), + PlainText "GHC-63394", + OscSequence (OscHyperlink "" "") + ] + + describe "parseAnsiTokensLazy" $ do + it "produces the same tokens as strict parsing" $ + forAllValid $ \text -> + parseAnsiTokensLazy (Lazy.fromStrict text) `shouldBe` parseAnsiTokens text + + it "works with multi-chunk lazy text" $ + let lazyText = Lazy.fromChunks ["hello\ESC[31m", "world\ESC[0m!"] + tokens = parseAnsiTokensLazy lazyText + in tokens + `shouldBe` [PlainText "hello", SgrSequence [31], PlainText "world", SgrSequence [0], PlainText "!"] + + describe "parseAnsiChunks" $ do + it "returns plain text unchanged" $ + parseAnsiChunks noStyle "hello world" + `shouldBe` (noStyle, [chunk "hello world"]) + + it "parses a simple red foreground" $ + parseAnsiChunks noStyle "\ESC[31mhello\ESC[0m world" + `shouldBe` ( noStyle, + [ fore (Colour8 Dull Red) (chunk "hello"), + chunk " world" + ] + ) + + it "parses bold" $ + parseAnsiChunks noStyle "\ESC[1mbold\ESC[0m" + `shouldBe` (noStyle, [bold (chunk "bold")]) + + it "parses combined bold and colour" $ + parseAnsiChunks noStyle "\ESC[1;31mred bold\ESC[0m" + `shouldBe` (noStyle, [fore (Colour8 Dull Red) (bold (chunk "red bold"))]) + + it "parses bright colours" $ + parseAnsiChunks noStyle "\ESC[91mbright red\ESC[0m" + `shouldBe` (noStyle, [fore (Colour8 Bright Red) (chunk "bright red")]) + + it "parses 256-colour foreground" $ + parseAnsiChunks noStyle "\ESC[38;5;196mcolour\ESC[0m" + `shouldBe` (noStyle, [fore (Colour8Bit 196) (chunk "colour")]) + + it "parses 24-bit RGB foreground" $ + parseAnsiChunks noStyle "\ESC[38;2;255;128;0mcolour\ESC[0m" + `shouldBe` (noStyle, [fore (Colour24Bit 255 128 0) (chunk "colour")]) + + it "parses background colour" $ + parseAnsiChunks noStyle "\ESC[42mgreen bg\ESC[0m" + `shouldBe` (noStyle, [back (Colour8 Dull Green) (chunk "green bg")]) + + it "strips non-SGR CSI sequences" $ + parseAnsiChunks noStyle "before\ESC[2Jafter" + `shouldBe` (noStyle, [chunk "before", chunk "after"]) + + it "renders OSC 8 hyperlinks, keeping surrounding text" $ + parseAnsiChunks noStyle "warning: \ESC]8;;https://errors.haskell.org/messages/GHC-63394\ESC\\GHC-63394\ESC]8;;\ESC\\ [-Wx-partial]" + `shouldBe` ( noStyle, + [ chunk "warning: ", + (chunk "GHC-63394") {chunkStyle = noStyle {chunkStyleHyperlink = Just "https://errors.haskell.org/messages/GHC-63394"}}, + chunk " [-Wx-partial]" + ] + ) + + it "handles empty input" $ + parseAnsiChunks noStyle "" + `shouldBe` (noStyle, []) + + it "handles text with no visible content between escapes" $ + parseAnsiChunks noStyle "\ESC[31m\ESC[0m" + `shouldBe` (noStyle, []) + + it "threads state across calls" $ + let (style1, chunks1) = parseAnsiChunks noStyle "\ESC[31mhello" + result2 = parseAnsiChunks style1 "world\ESC[0m" + in do + chunks1 `shouldBe` [fore (Colour8 Dull Red) (chunk "hello")] + style1 `shouldBe` noStyle {chunkStyleForeground = Just (Colour8 Dull Red)} + result2 `shouldBe` (noStyle, [fore (Colour8 Dull Red) (chunk "world")]) + + it "handles incomplete sequence at end of text" $ + parseAnsiChunks noStyle "hello\ESC[" + `shouldBe` (noStyle, [chunk "hello", chunk "\ESC["]) + + it "never crashes on arbitrary input" $ + forAllValid $ \text -> + let (_, chunks) = parseAnsiChunks noStyle text + in seq (length chunks) (pure () :: IO ()) + + it "produces segment texts that concatenate to the input minus ANSI codes" $ + forAllValid $ \text -> + let (_, chunks) = parseAnsiChunks noStyle text + combined = Text.concat $ map chunkText chunks + in combined `shouldBe` stripAnsi text + + describe "parseAnsiChunksLazy" $ do + it "produces the same chunks as strict parsing" $ + forAllValid $ \text -> + let (styleS, chunksS) = parseAnsiChunks noStyle text + (styleL, chunksL) = parseAnsiChunksLazy noStyle (Lazy.fromStrict text) + in do + chunksL `shouldBe` chunksS + styleL `shouldBe` styleS + + describe "roundtrip" $ do + it "recovers chunk style from rendered output for non-empty chunks" $ + forAllValid $ \c -> + let c' = c {chunkText = if Text.null (chunkText c) then "x" else chunkText c} + rendered = renderChunkText With24BitColours c' + (_, parsed) = parseAnsiChunks noStyle rendered + in parsed `shouldBe` [c'] + +-- | Strip all ANSI escape sequences from text, keeping only plain text. +stripAnsi :: Text.Text -> Text.Text +stripAnsi = + Text.concat + . map (\case PlainText t -> t; _ -> "") + . parseAnsiTokens