├── lib ├── dune ├── Fmt.ml ├── Ansi │ ├── Attributes.mli │ ├── Attributes.ml │ ├── Ansi.mli │ ├── Color.mli │ ├── Ansi.ml │ └── Color.ml └── Fmt.mli ├── test ├── Test_ansi │ ├── dune │ ├── Test_attributes.ml │ ├── Test_ansi.ml │ └── Test_color.ml └── Test_fmt │ ├── dune │ └── Test_fmt.ml ├── .ocamlformat ├── .gitignore ├── README.md ├── dune-project ├── docs └── index.md ├── .github ├── FUNDING.yml └── workflows │ ├── pages.yml │ └── CI.yml ├── ansifmt.opam ├── LICENSE ├── CODE_OF_CONDUCT.md └── CHANGES.md /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name ansifmt) 3 | (name ansifmt) 4 | (libraries re rich-string)) 5 | 6 | (include_subdirs qualified) 7 | -------------------------------------------------------------------------------- /test/Test_ansi/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_ansi) 3 | (inline_tests) 4 | (libraries ansifmt) 5 | (preprocess 6 | (pps ppx_expect))) 7 | -------------------------------------------------------------------------------- /test/Test_fmt/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_fmt) 3 | (inline_tests) 4 | (libraries ansifmt) 5 | (preprocess 6 | (pps ppx_expect)) 7 | (modules test_fmt)) 8 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | 3 | # custom settings 4 | margin=64 5 | parens-tuple=always 6 | parens-tuple-patterns=always 7 | 8 | # to avoid formatting changes too often 9 | version=0.28.1 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | 22 | # Merlin configuring file for Vim and Emacs 23 | .merlin 24 | 25 | # Dune generated files 26 | *.install 27 | 28 | # Local OPAM switch 29 | _opam/ 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ansifmt 2 | 3 | A simple, lightweight library for ANSI styling. 4 | 5 | ## Useful links 6 | 7 | - User documentation: [link on GitHub](docs/index.md) 8 | - API documentation: 9 | - Demo project: 10 | 11 | --- 12 | 13 | ansifmt's development does not involve any large language model. 14 | 15 | [![ansifmt is entirely brain-made.](https://brainmade.org/black-logo.svg)](https://brainmade.org) 16 | -------------------------------------------------------------------------------- /test/Test_ansi/Test_attributes.ml: -------------------------------------------------------------------------------- 1 | open Ansifmt.Ansi.Attributes 2 | 3 | module Fixtures = struct 4 | let bold = create 1 5 | let fg_yellow = create ~parameters:[ 5; 3 ] 38 6 | let italic_bg_blue = create ~parameters:[ 48; 2; 0; 0; 255 ] 3 7 | end 8 | 9 | module Test_serialize = struct 10 | let%test "serialize bold" = 11 | serialize Fixtures.bold = "{ code = 1 ; parameters = [] }" 12 | ;; 13 | 14 | let%test "serialize fg_yellow" = 15 | serialize Fixtures.fg_yellow 16 | = "{ code = 38 ; parameters = [5; 3] }" 17 | ;; 18 | 19 | let%test "serialize italic_bg_blue" = 20 | serialize Fixtures.italic_bg_blue 21 | = "{ code = 3 ; parameters = [48; 2; 0; 0; 255] }" 22 | ;; 23 | end 24 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | 3 | (name ansifmt) 4 | 5 | (version 2.0.0) 6 | 7 | (generate_opam_files true) 8 | 9 | (source 10 | (github qexat/ansifmt)) 11 | 12 | (authors "lexa ") 13 | 14 | (maintainers "lexa ") 15 | 16 | (license MIT) 17 | 18 | (package 19 | (name ansifmt) 20 | (synopsis "A simple, lightweight library for ANSI styling") 21 | (description "A simple, lightweight library for ANSI styling.") 22 | (depends 23 | (ocaml 24 | (>= "5.1")) 25 | (ppx_inline_test :with-test) 26 | (ppx_expect :with-test) 27 | (re 28 | (= "1.12.0")) 29 | (rich-string 30 | (>= "1.0.0"))) 31 | (tags 32 | ("ansi" "formatting" "styling" "pretty-printing" "terminal"))) 33 | -------------------------------------------------------------------------------- /lib/Fmt.ml: -------------------------------------------------------------------------------- 1 | include Rich_string.Make (Ansi) 2 | 3 | let stylize = enrich 4 | 5 | let rec prune_styled rs = 6 | match rs with 7 | | Empty | String _ -> rs 8 | | Enriched (_, rs) -> prune_styled rs 9 | | Join (sep, rss) -> 10 | Join (prune_styled sep, List.map prune_styled rss) 11 | ;; 12 | 13 | let render ~with_styles rs = 14 | let rs' = if with_styles then rs else prune_styled rs in 15 | render rs' 16 | ;; 17 | 18 | let print 19 | ?(out = stdout) 20 | ?(ending = Some (String "\n")) 21 | ?with_styles:(color_strategy = `Auto) 22 | rs 23 | = 24 | let with_styles = 25 | match color_strategy with 26 | | `Always -> true 27 | | `Never -> false 28 | | `Auto -> Out_channel.isatty out 29 | in 30 | let rs' = if with_styles then rs else prune_styled rs in 31 | print ~out ~ending rs' 32 | ;; 33 | -------------------------------------------------------------------------------- /docs/index.md: -------------------------------------------------------------------------------- 1 | 2 | # ansifmt 3 | 4 | ansifmt is a simple, lightweight library for ANSI formatting and styling. 5 | 6 | It provides a convenient API for [SGR escape sequences](https://en.wikipedia.org/wiki/ANSI_escape_code#Select_Graphic_Rendition_parameters), as well as a string-like data type where parts of it can be stylized in different ways. 7 | 8 | ## Structure 9 | 10 | The library is comprised of two modules: `Ansi` ([documentation](https://qexat.github.io/ansifmt/Ansifmt/Ansi/)), which provides the aforementioned interface over escape sequences, and `Fmt` ([documentation](https://qexat.github.io/ansifmt/Ansifmt/Ansi/)) for dealing with that pretty-printable stylized string data type. 11 | 12 | > [!TIP] 13 | > For simple usage, you probably want to stick to `Fmt`. 14 | > `Ansi` exists for more granular control, or if you want to build your own library using it. 15 | -------------------------------------------------------------------------------- /lib/Ansi/Attributes.mli: -------------------------------------------------------------------------------- 1 | (** Represents the attributes of an ANSI SGR escape sequence. *) 2 | type t 3 | 4 | (** [create ?parameters code] produces a new attribute record 5 | given a SGR code and its parameters. 6 | If parameters are not provided, the default is an empty 7 | list. *) 8 | val create : ?parameters:int list -> int -> t 9 | 10 | (** [compose left right] combines two attribute records into 11 | one, with [left] being the primary one. *) 12 | val compose : t -> t -> t 13 | 14 | (** [serialize record] produces a serialized representation of 15 | the [record]. *) 16 | val serialize : t -> string 17 | 18 | (** [show record] renders the [record] such that it can be used 19 | to construct a full ANSI SGR escape sequence. *) 20 | val show : t -> string 21 | 22 | (** [left & right] is the same as [compose left right]. *) 23 | val ( & ) : t -> t -> t 24 | -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # Leave the other fields empty in case we want to fill them in the future 2 | github: [qexat, chshersh] 3 | patreon: # Replace with a single Patreon username 4 | open_collective: # Replace with a single Open Collective username 5 | ko_fi: # Replace with a single Ko-fi username 6 | tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel 7 | community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry 8 | liberapay: # Replace with a single Liberapay username 9 | issuehunt: # Replace with a single IssueHunt username 10 | lfx_crowdfunding: # Replace with a single LFX Crowdfunding project-name e.g., cloud-foundry 11 | polar: # Replace with a single Polar username 12 | buy_me_a_coffee: # Replace with a single Buy Me a Coffee username 13 | thanks_dev: # Replace with a single thanks.dev username 14 | custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2'] 15 | -------------------------------------------------------------------------------- /lib/Ansi/Attributes.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { code : int 3 | ; parameters : int list 4 | } 5 | 6 | let create ?(parameters = []) (code : int) : t = 7 | { code; parameters } 8 | ;; 9 | 10 | let compose (left : t) (right : t) : t = 11 | let { code = code_left; parameters = parameters_left } : t = 12 | left 13 | in 14 | let { code = code_right; parameters = parameters_right } = 15 | right 16 | in 17 | { code = code_left 18 | ; parameters = 19 | parameters_left @ (code_right :: parameters_right) 20 | } 21 | ;; 22 | 23 | let serialize ({ code; parameters } : t) : string = 24 | Printf.sprintf 25 | "{ code = %s ; parameters = %s }" 26 | (Int.to_string code) 27 | (parameters 28 | |> List.map Int.to_string 29 | |> String.concat "; " 30 | |> Printf.sprintf "[%s]") 31 | ;; 32 | 33 | let show ({ code; parameters } : t) : string = 34 | code :: parameters 35 | |> List.map Int.to_string 36 | |> String.concat ";" 37 | ;; 38 | 39 | let ( & ) = compose 40 | -------------------------------------------------------------------------------- /ansifmt.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "2.0.0" 4 | synopsis: "A simple, lightweight library for ANSI styling" 5 | description: "A simple, lightweight library for ANSI styling." 6 | maintainer: ["lexa "] 7 | authors: ["lexa "] 8 | license: "MIT" 9 | tags: ["ansi" "formatting" "styling" "pretty-printing" "terminal"] 10 | homepage: "https://github.com/qexat/ansifmt" 11 | bug-reports: "https://github.com/qexat/ansifmt/issues" 12 | depends: [ 13 | "dune" {>= "3.17"} 14 | "ocaml" {>= "5.1"} 15 | "ppx_inline_test" {with-test} 16 | "ppx_expect" {with-test} 17 | "re" {= "1.12.0"} 18 | "rich-string" {>= "1.0.0"} 19 | "odoc" {with-doc} 20 | ] 21 | build: [ 22 | ["dune" "subst"] {dev} 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ] 35 | dev-repo: "git+https://github.com/qexat/ansifmt.git" 36 | -------------------------------------------------------------------------------- /lib/Fmt.mli: -------------------------------------------------------------------------------- 1 | (** A string which components can be styled with ANSI escape 2 | sequences. *) 3 | 4 | include Rich_string.TYPE with type Enricher.t = Ansi.t 5 | 6 | (** [stylize ansi rs] adds the [ansi] escape sequence to the 7 | rich string [rs]. Synonym of [enrich]. *) 8 | val stylize : Ansi.t -> t -> t 9 | 10 | (** [prune_styled rs] removes every ANSI escape sequence from 11 | the rich string [rs]. *) 12 | val prune_styled : t -> t 13 | 14 | (** [render ~with_styles rs] generates a built-in string from 15 | the rich string [rs] that includes ANSI escape sequences if 16 | [with_styles] is [true]. *) 17 | val render : with_styles:bool -> t -> string 18 | 19 | (** [print ?out ?ending ?with_styles rs] writes the rich string 20 | [rs] to the [out] channel (defaults to [stdout]), 21 | optionally appending [ending] (defaults to a newline), 22 | optionally including ANSI escape sequences (defaults to 23 | doing it if [out] is a TTY). *) 24 | val print 25 | : ?out:out_channel 26 | -> ?ending:t option 27 | -> ?with_styles:[< `Always | `Auto | `Never > `Auto ] 28 | -> t 29 | -> unit 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2025 Qexat 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /.github/workflows/pages.yml: -------------------------------------------------------------------------------- 1 | name: Deploy odoc to GitHub Pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | workflow_dispatch: 8 | 9 | permissions: read-all 10 | 11 | concurrency: 12 | group: deploy-odoc 13 | cancel-in-progress: true 14 | 15 | jobs: 16 | deploy-odoc: 17 | name: Deploy odoc to GitHub Pages 18 | 19 | environment: 20 | name: github-pages 21 | url: ${{ steps.deployment.outputs.page_url }} 22 | 23 | permissions: 24 | contents: read 25 | id-token: write 26 | pages: write 27 | 28 | runs-on: ubuntu-latest 29 | 30 | steps: 31 | - name: Checkout tree 32 | uses: actions/checkout@v4 33 | 34 | - name: Set-up OCaml 35 | uses: ocaml/setup-ocaml@v3 36 | with: 37 | ocaml-compiler: 5 38 | 39 | - name: Install dependencies 40 | run: opam install . --deps-only --with-doc 41 | 42 | - name: Build documentation 43 | run: opam exec -- dune build @doc 44 | 45 | - name: Set-up Pages 46 | uses: actions/configure-pages@v5 47 | 48 | - name: Upload artifact 49 | uses: actions/upload-pages-artifact@v3 50 | with: 51 | path: _build/default/_doc/_html 52 | 53 | - name: Deploy odoc to GitHub Pages 54 | id: deployment 55 | uses: actions/deploy-pages@v4 56 | -------------------------------------------------------------------------------- /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | # Based on the example workflow of the Set Up OCaml action 2 | # 3 | 4 | name: CI 5 | 6 | on: 7 | - pull_request 8 | - workflow_dispatch 9 | 10 | permissions: read-all 11 | 12 | jobs: 13 | build: 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | os: 18 | - ubuntu-latest 19 | - macos-latest 20 | - windows-latest 21 | 22 | runs-on: ${{ matrix.os }} 23 | 24 | steps: 25 | - name: Checkout tree 26 | uses: actions/checkout@v4 27 | 28 | - name: Set-up OCaml 29 | uses: ocaml/setup-ocaml@v3 30 | with: 31 | ocaml-compiler: 5 32 | 33 | - run: opam install . --deps-only --with-test 34 | 35 | - run: opam exec -- dune build 36 | 37 | - run: opam exec -- dune runtest 38 | 39 | lint-doc: 40 | runs-on: ubuntu-latest 41 | steps: 42 | - name: Checkout tree 43 | uses: actions/checkout@v4 44 | - name: Set-up OCaml 45 | uses: ocaml/setup-ocaml@v3 46 | with: 47 | ocaml-compiler: 5 48 | - uses: ocaml/setup-ocaml/lint-doc@v3 49 | 50 | lint-fmt: 51 | runs-on: ubuntu-latest 52 | steps: 53 | - name: Checkout tree 54 | uses: actions/checkout@v4 55 | - name: Set-up OCaml 56 | uses: ocaml/setup-ocaml@v3 57 | with: 58 | ocaml-compiler: 5 59 | - uses: ocaml/setup-ocaml/lint-fmt@v3 60 | -------------------------------------------------------------------------------- /test/Test_fmt/Test_fmt.ml: -------------------------------------------------------------------------------- 1 | open Ansifmt 2 | 3 | module Fixtures = struct 4 | open Fmt 5 | 6 | let raw = string "hello world" 7 | 8 | let stylized = 9 | stylize 10 | Ansi.(`Bold & `Foreground Color.green) 11 | (string "beans") 12 | ;; 13 | 14 | let composed = 15 | stylize 16 | (`Foreground Ansi.Color.blue) 17 | (string "blue" ++ stylize `Italic (string "+italic")) 18 | ++ stylize `Italic (string "-blue") 19 | ;; 20 | end 21 | 22 | module Test_render = struct 23 | let ( = ) = String.equal 24 | 25 | let%test "render raw with styling" = 26 | Fmt.render ~with_styles:true Fixtures.raw = "hello world" 27 | ;; 28 | 29 | let%test "render raw without styling" = 30 | Fmt.render ~with_styles:false Fixtures.raw = "hello world" 31 | ;; 32 | 33 | let%test "render stylized with styling" = 34 | Fmt.render ~with_styles:true Fixtures.stylized 35 | = "\x1b[1;38;5;2mbeans\x1b[22;39m" 36 | ;; 37 | 38 | let%test "render stylized without styling" = 39 | Fmt.render ~with_styles:false Fixtures.stylized = "beans" 40 | ;; 41 | 42 | let%test "render composed with styling" = 43 | Fmt.render ~with_styles:true Fixtures.composed 44 | = "\x1b[38;5;4mblue\x1b[3m+italic\x1b[23m\x1b[39m\x1b[3m-blue\x1b[23m" 45 | ;; 46 | 47 | let%test "render composed without styling" = 48 | Fmt.render ~with_styles:false Fixtures.composed 49 | = "blue+italic-blue" 50 | ;; 51 | end 52 | 53 | module Test_print = struct 54 | let%expect_test 55 | "print composed with always styling, default ending, \ 56 | default out" 57 | = 58 | Fmt.print ~with_styles:`Always Fixtures.composed; 59 | [%expect_exact 60 | "\x1b[38;5;4mblue\x1b[3m+italic\x1b[23m\x1b[39m\x1b[3m-blue\x1b[23m\n"] 61 | ;; 62 | 63 | let%expect_test 64 | "print composed with never styling, default ending, \ 65 | default out" 66 | = 67 | Fmt.print ~with_styles:`Never Fixtures.composed; 68 | [%expect_exact "blue+italic-blue\n"] 69 | ;; 70 | 71 | let%expect_test 72 | "print stylized with always styling, no ending, default \ 73 | out" 74 | = 75 | Fmt.print 76 | ~with_styles:`Always 77 | ~ending:None 78 | Fixtures.stylized; 79 | [%expect_exact "\x1b[1;38;5;2mbeans\x1b[22;39m"] 80 | ;; 81 | 82 | let%expect_test 83 | "print stylized with never styling, custom ending, \ 84 | default out" 85 | = 86 | Fmt.( 87 | print 88 | ~with_styles:`Never 89 | ~ending:(Some (string "arecool")) 90 | Fixtures.stylized); 91 | [%expect_exact "beansarecool"] 92 | ;; 93 | end 94 | -------------------------------------------------------------------------------- /test/Test_ansi/Test_ansi.ml: -------------------------------------------------------------------------------- 1 | open Ansifmt 2 | 3 | module Fixtures = struct 4 | open Ansi 5 | 6 | let simple_styling : t = `Blink 7 | 8 | (* orang *) 9 | let simple_color : t = `Background (`Rgb (255, 127, 0)) 10 | let styling_and_color = `Bold & `Foreground Color.red 11 | 12 | let complex_composition = 13 | `Italic 14 | & `Reverse 15 | & `Foreground (`Basic 42) 16 | & `Background (`Rgb (0, 0, 0)) 17 | ;; 18 | end 19 | 20 | module Test_serialize = struct 21 | let%test "serialize simple styling" = 22 | Ansi.serialize Fixtures.simple_styling = "blink" 23 | ;; 24 | 25 | let%test "serialize simple color" = 26 | Ansi.serialize Fixtures.simple_color 27 | = "background(rgb(255, 127, 0))" 28 | ;; 29 | 30 | let%test "serialize styling and color" = 31 | Ansi.serialize Fixtures.styling_and_color 32 | = "bold & foreground(basic(1))" 33 | ;; 34 | 35 | let%test "serialize complex composition" = 36 | Ansi.serialize Fixtures.complex_composition 37 | = "italic & reverse & foreground(basic(42)) & \ 38 | background(rgb(0, 0, 0))" 39 | ;; 40 | end 41 | 42 | module Test_deserialize = struct 43 | let%test "deserialize simple styling" = 44 | Ansi.deserialize "blink" = Some Fixtures.simple_styling 45 | ;; 46 | 47 | let%test "deserialize simple color" = 48 | Ansi.deserialize "background(rgb(255, 127, 0))" 49 | = Some Fixtures.simple_color 50 | ;; 51 | 52 | let%test "deserialize styling and color" = 53 | Ansi.deserialize "bold & fg(basic(1))" 54 | = Some Fixtures.styling_and_color 55 | ;; 56 | 57 | let%test "deserialize complex composition" = 58 | Ansi.deserialize 59 | "italic & REVERSE& foreground ( basic(42)) &background \ 60 | (rgb(0, 0, 0) )" 61 | = Some Fixtures.complex_composition 62 | ;; 63 | end 64 | 65 | module Test_show = struct 66 | let%test "show simple styling" = 67 | Ansi.show Fixtures.simple_styling = "\x1b[5m" 68 | ;; 69 | 70 | let%test "show simple color" = 71 | Ansi.show Fixtures.simple_color = "\x1b[48;2;255;127;0m" 72 | ;; 73 | 74 | let%test "show styling and color" = 75 | Ansi.show Fixtures.styling_and_color = "\x1b[1;38;5;1m" 76 | ;; 77 | 78 | let%test "show complex composition" = 79 | Ansi.show Fixtures.complex_composition 80 | = "\x1b[3;7;38;5;42;48;2;0;0;0m" 81 | ;; 82 | end 83 | 84 | module Test_unshow = struct 85 | let%test "unshow simple styling" = 86 | Ansi.unshow Fixtures.simple_styling = "\x1b[25m" 87 | ;; 88 | 89 | let%test "unshow simple color" = 90 | Ansi.unshow Fixtures.simple_color = "\x1b[49m" 91 | ;; 92 | 93 | let%test "unshow styling and color" = 94 | Ansi.unshow Fixtures.styling_and_color = "\x1b[22;39m" 95 | ;; 96 | 97 | let%test "unshow complex composition" = 98 | Ansi.unshow Fixtures.complex_composition 99 | = "\x1b[23;27;39;49m" 100 | ;; 101 | end 102 | 103 | module Test_wrap = struct 104 | let%test "wrap empty string" = 105 | Ansi.wrap Fixtures.complex_composition "" 106 | = "\x1b[23;27;39;49m" 107 | ;; 108 | 109 | let%test "wrap contentful string" = 110 | Ansi.wrap Fixtures.complex_composition "I love beans 🫘" 111 | = "\x1b[3;7;38;5;42;48;2;0;0;0mI love beans \ 112 | 🫘\x1b[23;27;39;49m" 113 | ;; 114 | end 115 | -------------------------------------------------------------------------------- /lib/Ansi/Ansi.mli: -------------------------------------------------------------------------------- 1 | (** This module defines the escape sequence data type. 2 | 3 | Every value of this type is one styling ([`Bold], 4 | [`Reverse], [`Foreground] {!Color.red}) or the composition 5 | of two of them ([`Bold]{{!(&)}[&]}[`Reverse]), which can be chained 6 | ([`Dim] {{!(&)}[&]} [`Italic] {{!(&)}[&]} [`Blink] {{!(&)}[&]} [`Background] {!Color.magenta}). 7 | 8 | {[ 9 | open Ansifmt 10 | 11 | let chesnay = `Italic 12 | let rocquencout = Ansi.(`Bold & `Reverse & `Foreground Color.red) 13 | 14 | (* compose to infinity! *) 15 | let inria = Ansi.(chesnay & rocquencourt) 16 | ]} 17 | 18 | {i [chesnay], [rocquencourt] and [inria] all have the same 19 | type {!t}.} 20 | 21 | In a composition chain, if two stylings are overlapping 22 | (for example, [`Foreground Color.blue & `Foreground Color.red]), 23 | the rightmost takes precedence. 24 | *) 25 | 26 | (** Represents an ANSI SGR escape sequence. *) 27 | type t = 28 | [ `Bold 29 | | `Dim 30 | | `Italic 31 | | `Underline 32 | | `Blink 33 | | `Reverse 34 | | `Foreground of Color.t 35 | | `Background of Color.t 36 | | `Composed of t * t 37 | ] 38 | 39 | (** [compose left right] combines the [left] and right 40 | sequences into one. 41 | 42 | See also: {{!(&)}[( & )]} *) 43 | val compose : t -> t -> t 44 | 45 | (** [ansi1 = ansi2] determines whether two escape sequences are 46 | equal. *) 47 | val ( = ) : t -> t -> bool 48 | 49 | (** [serialize ansi] produces a serialized representation of 50 | the [ansi] escape sequence. 51 | 52 | {b Example} 53 | 54 | {[ 55 | open Ansifmt 56 | 57 | let styling = Ansi.(`Dim & `Background (`Rgb (0, 0, 0))) 58 | let () = Printf.printf "%s\n" (Ansi.serialize styling) 59 | ]} 60 | 61 | {i [dim & background(rgb(0, 0, 0))] will be printed.} 62 | 63 | See also: {!deserialize}. 64 | *) 65 | val serialize : t -> string 66 | 67 | (** [deserialize string] produces an escape sequence from a 68 | serialization [string]. If it fails to parse, returns 69 | [None]. 70 | 71 | {b Example} 72 | 73 | {[ 74 | open Ansifmt 75 | 76 | let serialized = "blink & BOLD & foreground(rgb(255, 0, 0))" 77 | 78 | let () = 79 | match Ansi.deserialize serialized with 80 | | None -> Printf.eprintf "oh nothing don't worry\n" 81 | | Some ansi -> 82 | Printf.printf "%sHACKED!\n" (Ansi.show ansi) 83 | ;; 84 | ]} 85 | 86 | {i A blinking bold [HACKED!] will be printed in red.} 87 | 88 | See also: {!serialize}. 89 | *) 90 | val deserialize : string -> t option 91 | 92 | (** [show ansi] renders the [ansi] escape sequence into a 93 | string. 94 | 95 | {b Example} 96 | 97 | {[ 98 | open Ansifmt 99 | 100 | let versailles = Ansi.(`Underline & `Background Color.green) 101 | let () = Printf.printf "%s hello!\n" (Ansi.show versailles) 102 | ]} 103 | 104 | {i [hello!] will be printed with an underline and a green 105 | background.} 106 | 107 | See also: {!Ansifmt.Fmt}, {!wrap}, {!unshow}. 108 | *) 109 | val show : t -> string 110 | 111 | (** [unshow ansi] renders the ANSI escape sequence that cancels 112 | [ansi] into a string. 113 | 114 | {b Example} 115 | 116 | {[ 117 | open Ansifmt 118 | 119 | let cergy = Ansi.(`Blink & `Dim & `Foreground Color.blue) 120 | 121 | let () = 122 | Printf.printf 123 | "%s hello! %s bye.\n" 124 | (Ansi.show cergy) 125 | (Ansi.unshow cergy) 126 | ;; 127 | ]} 128 | 129 | {i While [hello!] will be printed dim, blinking and in 130 | blue, [bye.] will be unstylized.} 131 | 132 | See also: {!Ansifmt.Fmt}, {!wrap}, {!show}. 133 | *) 134 | val unshow : t -> string 135 | 136 | (** [wrap ansi string] wraps [string] with the rendered [ansi] 137 | escape sequence and its cancelling counterpart. 138 | 139 | For example, if [string] is ["Hello"] and [ansi] is 140 | [`Bold], the result will be ["\x1b\[1mHello\x1b\[22m"], 141 | which makes the string appear bold but not what comes 142 | after. 143 | 144 | {b Example} 145 | 146 | {[ 147 | open Ansifmt 148 | 149 | let styling = `Foreground (`Rgb (255, 127, 0)) 150 | let text = "I love OCaml" 151 | 152 | let () = Printf.printf "%s\n" (Ansi.wrap styling text) 153 | ]} 154 | 155 | {i [I love OCaml] will be printed in a beautiful orange 156 | color.} 157 | 158 | See also: {!Ansifmt.Fmt}, {!show}, {!unshow}. 159 | *) 160 | val wrap : t -> string -> string 161 | 162 | (** [enrich] is a synonym of [wrap]. *) 163 | val enrich : t -> string -> string 164 | 165 | (** [left & right] is the same as {!compose} [left right]. 166 | 167 | {b NOTE:} [&] is associative but not commutative. 168 | 169 | {b Example} 170 | 171 | {[ 172 | open Ansifmt 173 | 174 | let styling = Ansi.(`Bold & `Foreground Color.yellow) 175 | ]} 176 | *) 177 | val ( & ) : t -> t -> t 178 | 179 | module Attributes : module type of Attributes 180 | module Color : module type of Color 181 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | We as members, contributors, and leaders pledge to make participation in our 6 | community a harassment-free experience for everyone, regardless of age, body 7 | size, visible or invisible disability, ethnicity, sex characteristics, gender 8 | identity and expression, level of experience, education, socio-economic status, 9 | nationality, personal appearance, race, religion, or sexual identity 10 | and orientation. 11 | 12 | We pledge to act and interact in ways that contribute to an open, welcoming, 13 | diverse, inclusive, and healthy community. 14 | 15 | ## Our Standards 16 | 17 | Examples of behavior that contributes to a positive environment for our 18 | community include: 19 | 20 | * Demonstrating empathy and kindness toward other people 21 | * Being respectful of differing opinions, viewpoints, and experiences 22 | * Giving and gracefully accepting constructive feedback 23 | * Accepting responsibility and apologizing to those affected by our mistakes, 24 | and learning from the experience 25 | * Focusing on what is best not just for us as individuals, but for the 26 | overall community 27 | 28 | Examples of unacceptable behavior include: 29 | 30 | * The use of sexualized language or imagery, and sexual attention or 31 | advances of any kind 32 | * Trolling, insulting or derogatory comments, and personal or political attacks 33 | * Public or private harassment 34 | * Publishing others' private information, such as a physical or email 35 | address, without their explicit permission 36 | * Other conduct which could reasonably be considered inappropriate in a 37 | professional setting 38 | 39 | ## Enforcement Responsibilities 40 | 41 | Community leaders are responsible for clarifying and enforcing our standards of 42 | acceptable behavior and will take appropriate and fair corrective action in 43 | response to any behavior that they deem inappropriate, threatening, offensive, 44 | or harmful. 45 | 46 | Community leaders have the right and responsibility to remove, edit, or reject 47 | comments, commits, code, wiki edits, issues, and other contributions that are 48 | not aligned to this Code of Conduct, and will communicate reasons for moderation 49 | decisions when appropriate. 50 | 51 | ## Scope 52 | 53 | This Code of Conduct applies within all community spaces, and also applies when 54 | an individual is officially representing the community in public spaces. 55 | Examples of representing our community include using an official e-mail address, 56 | posting via an official social media account, or acting as an appointed 57 | representative at an online or offline event. 58 | 59 | ## Enforcement 60 | 61 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 62 | reported to the community leaders responsible for enforcement at 63 | contact@qexat.com. 64 | All complaints will be reviewed and investigated promptly and fairly. 65 | 66 | All community leaders are obligated to respect the privacy and security of the 67 | reporter of any incident. 68 | 69 | ## Enforcement Guidelines 70 | 71 | Community leaders will follow these Community Impact Guidelines in determining 72 | the consequences for any action they deem in violation of this Code of Conduct: 73 | 74 | ### 1. Correction 75 | 76 | **Community Impact**: Use of inappropriate language or other behavior deemed 77 | unprofessional or unwelcome in the community. 78 | 79 | **Consequence**: A private, written warning from community leaders, providing 80 | clarity around the nature of the violation and an explanation of why the 81 | behavior was inappropriate. A public apology may be requested. 82 | 83 | ### 2. Warning 84 | 85 | **Community Impact**: A violation through a single incident or series 86 | of actions. 87 | 88 | **Consequence**: A warning with consequences for continued behavior. No 89 | interaction with the people involved, including unsolicited interaction with 90 | those enforcing the Code of Conduct, for a specified period of time. This 91 | includes avoiding interactions in community spaces as well as external channels 92 | like social media. Violating these terms may lead to a temporary or 93 | permanent ban. 94 | 95 | ### 3. Temporary Ban 96 | 97 | **Community Impact**: A serious violation of community standards, including 98 | sustained inappropriate behavior. 99 | 100 | **Consequence**: A temporary ban from any sort of interaction or public 101 | communication with the community for a specified period of time. No public or 102 | private interaction with the people involved, including unsolicited interaction 103 | with those enforcing the Code of Conduct, is allowed during this period. 104 | Violating these terms may lead to a permanent ban. 105 | 106 | ### 4. Permanent Ban 107 | 108 | **Community Impact**: Demonstrating a pattern of violation of community 109 | standards, including sustained inappropriate behavior, harassment of an 110 | individual, or aggression toward or disparagement of classes of individuals. 111 | 112 | **Consequence**: A permanent ban from any sort of public interaction within 113 | the community. 114 | 115 | ## Attribution 116 | 117 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], 118 | version 2.0, available at 119 | https://www.contributor-covenant.org/version/2/0/code_of_conduct.html. 120 | 121 | Community Impact Guidelines were inspired by [Mozilla's code of conduct 122 | enforcement ladder](https://github.com/mozilla/diversity). 123 | 124 | [homepage]: https://www.contributor-covenant.org 125 | 126 | For answers to common questions about this code of conduct, see the FAQ at 127 | https://www.contributor-covenant.org/faq. Translations are available at 128 | https://www.contributor-covenant.org/translations. 129 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # 2.0.0 2 | 3 | ## Changes 4 | 5 | - `Fmt` has been rewritten from scratch to use my own library called `rich-string`. As such, a lot of tests have been dropped as they already exist upstream. The interface is mostly the same, besides the type itself and a few parameters that got renamed. 6 | - `Fmt.print`'s `ending` parameter now takes a `Fmt.t option` instead of a `string option`. 7 | 8 | ## Features 9 | 10 | - `Ansi` and `Color` now implement their own dedicated equality. No need to use the built-in polymorphic equality anymore. 11 | 12 | ## Removed 13 | 14 | - `Fmt`'s serialization feature is now dependent on `rich-string`. Since the latter does not provide it yet, serialization was dropped for now. 15 | - `Fmt.show` was also removed. On top of not being provided by `rich-string` and being the identity function, it was not all that useful. 16 | 17 | # 1.0.0 18 | 19 | **1.0.0 is a complete rewrite of ansifmt**. 20 | 21 | At this stage, ansifmt has been fully rewritten. It now includes a test suite. This version is entirely incompatible with ansifmt 0.3.0 and older. Notably, some of its features were purposefully lost in this rewrite. 22 | Users should expect a new library on top of this one to replace them in the future. 23 | 24 | ## Changes 25 | 26 | - `ansifmt` is now split in two modules: `Ansi`, which provides APIs for escape sequences (in `Ansi`), attributes as a low-level representation (in `Ansi.Attribute`) and terminal-compatible colors (in `Ansi.Color`), and `Fmt`, which provides a pretty-printable string API built on top of `Ansi`. 27 | - The `Color` API has been simplified. Colors can now be constructed using built-in integers ; they will be normalized-on-demand. `Advanced` is now called `Basic`. `Minimal` has been dropped as it is already covered by `Basic`, assuming that modern terminal emulators support 8-bit colors. 28 | - The `Styling` API (now called `Ansi`) has been tremendously simplified and is now based on a choice type instead of a record type. 29 | - `parse_hex` is now `of_hex_repr`. 30 | - Luminance calculation now linearizes properly the color. 31 | 32 | ## Features 33 | 34 | - A new `Fmt` API is available, which allows to construct strings with specific parts stylized using `Ansi`. This includes a convenient function, `Fmt.print`, to print in the terminal, stripping escape sequences when the output channel is not a TTY (by default -- this is configurable). 35 | - Color parsing now supports deserialization of strings of the form `rgb(r, g, b)`. 36 | - `Ansi`, `Attributes`, `Color` and `Fmt` objects are serializable. 37 | - `Ansi` objects are now deserializable. 38 | 39 | ## Removed 40 | 41 | - The `Formatting` API has been fully dropped. We estimate that `ansifmt` is not the right place to put this in. Instead, we are working on another library, built on top of `ansifmt`, that will provide these features in an improved manner. 42 | - The `IO` API has been removed following `Formatting`. 43 | 44 | ## Performance 45 | 46 | No benchmark has been done, so this should be taken with a grain of salt, but it is likely that the new version exhibits better performance, due to simplification of implementation and lightening of the library overall. 47 | 48 | # 0.3.0 49 | 50 | ## Features 51 | 52 | - Add `Custom` token type variant which takes a styling, for tokens without particular semantics. 53 | - Add `Formatting.Element` that supersedes `Formatting.Tree`. 54 | - Add `Formatting.Interfaces.TO_ELEMENT` interface which establishes the contract to convert to a formatting element that is used by formatting and printing utilitary functions such as `format` and `IO.print_formatted`. 55 | - Expose the `Int8` module that is used by `Color`. 56 | - Add `Token.number` to easily construct a number literal token. 57 | 58 | ## Removed 59 | 60 | - Remove `Formatting.Tree`, `Formatting.TOKENIZABLE` and its associated functions. Use `Formatting.Element` instead. 61 | - Remove the `Prelude` module. It has merged with the core `Ansifmt` module. 62 | - Remove `print_formatted` alias from the prelude. The function can still be found as `IO.print_formatted`. 63 | - Remove `make_styling` alias from the prelude. The function can still be found as `Styling.create`. 64 | 65 | ## Internal 66 | 67 | - Renamed `Utils` to `Internal`. 68 | - `Formatting` is now a directory instead of a file containing all its submodules. 69 | - Added `List.intersperse` and `List.singleton` (used in `Formatting.Element`). 70 | - Added `Bool.tautology` (used in `Formatting.Element`). 71 | 72 | # 0.2.0 73 | 74 | ## Features 75 | 76 | - Add color functions `luminance` and `best_for_contrast`. (by @chshersh in #5) 77 | - Add styling functions `fg`, `bg`, `bold`, `dim`, `italic`, `underlined`. (by @chshersh in #6) 78 | - Add styling composition with `&`. (by @chshersh in #6) 79 | - Add function `make_rgb_hex` to parse hexadecimal codes into RGB colors. (by @chshersh in #7) 80 | 81 | ## Breaking Changes 82 | 83 | - `Color.t` and `Color.Ground.t` are now polymorphic variants. (by @chshersh in #5) 84 | 85 | ## Removed 86 | 87 | - `Util.parenthesize_if` which is deemed unuseful and is kind of a duplicate of `Tree.parenthesize_if` in `Formatting`. 88 | 89 | # 0.1.3 90 | 91 | ## Fixes 92 | 93 | - Fixed a bug where unwanted `m` characters would appear in the output before every colored token 94 | 95 | # 0.1.2 96 | 97 | ## Fixes 98 | 99 | - Moved `Formatting.tokenize` and `Formatting.format` to a dedicated `Formatting.Util` submodule - it is common for users who wish to implement `TOKENIZABLE` to `open Formatting`, and `Formatting.tokenize` would then shadow the user's own function, making it cumbersome if the latter was recursive. 100 | This does not affect the `Ansifmt` prelude - `format` stays available. 101 | 102 | # 0.1.1 103 | 104 | ## Features 105 | 106 | - Added `print_formatted` and the `IO` submodule. 107 | 108 | # 0.1.0 109 | 110 | First pre-release. 111 | -------------------------------------------------------------------------------- /lib/Ansi/Color.mli: -------------------------------------------------------------------------------- 1 | (** {1 Color} *) 2 | 3 | (** Represents a ANSI color. It can be either 8-bit, which 4 | provides a portable palette of 256 colors, or 24-bit (RGB), 5 | which gives more granularity. 6 | 7 | The 256-color palette can be found on the Wikipedia article 8 | on ANSI escape sequences: 9 | {:https://en.wikipedia.org/wiki/ANSI_escape_code#8-bit} 10 | 11 | NOTE: Each constructor would normally expect integers 12 | between 0 and 255 - for convenience, they operate with the 13 | built-in [int] type which is technically too permissive, 14 | but allows direct use of numeric literals. To prevent 15 | generating invalid escape sequences, the integers get 16 | therefore normalized by taking their absolute value modulo 17 | 256. *) 18 | type t = 19 | [ `Basic of int 20 | | `Rgb of int * int * int 21 | ] 22 | 23 | (** [to_attributes ground color] produces the attribute record 24 | of the [color]. 25 | 26 | Since the code depends on whether the color is applied to 27 | the foreground or the background, this latter piece of 28 | information must also be provided via [ground]. *) 29 | val to_attributes 30 | : [ `Foreground | `Background ] 31 | -> t 32 | -> Attributes.t 33 | 34 | (** {2 Comparison} *) 35 | 36 | (** [color1 = color2] determines whether two colors are equal. 37 | 38 | {b Note:} [`Basic] colors are never equal to [`Rgb] ones 39 | even if your terminal renders them identically. *) 40 | val ( = ) : t -> t -> bool 41 | 42 | (** {2 Constants} *) 43 | 44 | (** These constants are provided for convenience. They 45 | correspond to the 4-bit ANSI colors. *) 46 | 47 | (** {3 Base colors} *) 48 | 49 | val black : t 50 | val red : t 51 | val green : t 52 | val yellow : t 53 | val blue : t 54 | val magenta : t 55 | val cyan : t 56 | val white : t 57 | 58 | (** {3 Bright variants} *) 59 | 60 | val bright_black : t 61 | val bright_red : t 62 | val bright_green : t 63 | val bright_yellow : t 64 | val bright_blue : t 65 | val bright_magenta : t 66 | val bright_cyan : t 67 | val bright_white : t 68 | 69 | (** {2 Checked constructors} *) 70 | 71 | (** These functions are equivalent to the type's constructors 72 | but check the integer values instead of normalizing them. *) 73 | 74 | (** [basic index] constructs a 8-bit color. [index] must be 75 | between 0 and 255 (both included) ; otherwise, it returns 76 | [None]. *) 77 | val basic : int -> [ `Basic of int ] option 78 | 79 | (** [rgb (r, g, b)] constructs an RGB color. All channels must 80 | be between 0 and 255 (both included) ; otherwise, it 81 | returns [None]. *) 82 | val rgb : int * int * int -> [ `Rgb of int * int * int ] option 83 | 84 | (** {2 Serialization/Deserialization} *) 85 | 86 | (** [serialize color] produces a serialized representation of 87 | the [color]. 88 | 89 | {b Tip:} the serialized color can be retreived back using 90 | {!parse}. 91 | 92 | {b Note:} colors are normalized before serialization. *) 93 | val serialize : t -> string 94 | 95 | (** These functions parse strings to get a color from them. *) 96 | 97 | (** [of_hex_repr string] attempts to parse the [string] as the 98 | representation of an hexadecimal number. 99 | 100 | It allows: 101 | - Leading hash ([#f864a0], optional) 102 | - Implicitly doubled digits ([#ddd]) *) 103 | val of_hex_repr : string -> [ `Rgb of int * int * int ] option 104 | 105 | (** [parse string] attempts to find a serialized color in the 106 | [string]. 107 | 108 | It supports [rgb(r, g, b)] and [basic(n)], ignoring spaces 109 | and case. Numbers greater than 255 are allowed, but not 110 | less than 0. *) 111 | val parse : string -> t option 112 | 113 | (** {2 Utility functions} *) 114 | 115 | (** [luminance color] returns the luminance of the [color] as 116 | a floating-point number between 0 and 1. 117 | 118 | {b Important:} This is {b NOT} a function to estimate 119 | perceived lightness. For that, see {!perceived_lightness}. 120 | 121 | {b Note:} the color is normalized before calculation. 122 | 123 | {b Note:} this function is only available for RGB colors. *) 124 | val luminance : [ `Rgb of int * int * int ] -> float 125 | 126 | (** [perceived_lightness color] returns the perceived lightness 127 | of the [color] as an integer between 0 and 100. 128 | 129 | {b Note:} the color is normalized before calculation. 130 | 131 | {b Note:} this function is only available for RGB colors. *) 132 | val perceived_lightness : [ `Rgb of int * int * int ] -> int 133 | 134 | (** [best_for_contrast color] determines whether a light or 135 | dark opposite color is best. 136 | 137 | For example, if [color] is a background color, this 138 | function will tell whether the text written on top of it 139 | should be light or dark for the best readability. 140 | 141 | {b Note:} the calculation is based on 142 | {{!perceived_lightness}perceived lightness}. 143 | 144 | {b Note:} the color is normalized before calculation. 145 | 146 | {b Note:} this function is only available for RGB colors. *) 147 | val best_for_contrast 148 | : [ `Rgb of int * int * int ] 149 | -> [ `Light | `Dark ] 150 | 151 | module Basic : sig 152 | (** Functions to deal with basic colors. *) 153 | 154 | (** The regular expression used to parse basic colors. *) 155 | val regular_expression : Re.re 156 | 157 | (** [parse string] attempts to find a serialized basic color 158 | in the [string]. *) 159 | val parse : string -> [> `Basic of int ] option 160 | end 161 | 162 | module Rgb : sig 163 | (** Functions to deal with RGB colors. *) 164 | 165 | (** The regular expression used to parse RGB colors. *) 166 | val regular_expression : Re.re 167 | 168 | (** [parse string] attempts to find a serialized RGB color in 169 | the [string]. *) 170 | val parse : string -> [> `Rgb of int * int * int ] option 171 | end 172 | -------------------------------------------------------------------------------- /lib/Ansi/Ansi.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | [ `Bold 3 | | `Dim 4 | | `Italic 5 | | `Underline 6 | | `Blink 7 | | `Reverse 8 | | `Foreground of Color.t 9 | | `Background of Color.t 10 | | `Composed of t * t 11 | ] 12 | 13 | let rec ( = ) (left : t) (right : t) = 14 | match (left, right) with 15 | | (`Bold, `Bold) 16 | | (`Dim, `Dim) 17 | | (`Italic, `Italic) 18 | | (`Underline, `Underline) 19 | | (`Blink, `Blink) 20 | | (`Reverse, `Reverse) -> true 21 | | (`Foreground left_color, `Foreground right_color) -> 22 | Color.(left_color = right_color) 23 | | (`Background left_color, `Background right_color) -> 24 | Color.(left_color = right_color) 25 | | (`Composed (left1, left2), `Composed (right1, right2)) -> 26 | left1 = right1 && left2 = right2 27 | | (_, _) -> false 28 | ;; 29 | 30 | let foreground color = `Foreground color 31 | let background color = `Background color 32 | let compose (left : t) (right : t) : t = `Composed (left, right) 33 | 34 | let rec to_attributes (ansi : t) : Attributes.t = 35 | match ansi with 36 | | `Bold -> Attributes.create 1 37 | | `Dim -> Attributes.create 2 38 | | `Italic -> Attributes.create 3 39 | | `Underline -> Attributes.create 4 40 | | `Blink -> Attributes.create 5 41 | | `Reverse -> Attributes.create 7 42 | | `Foreground color -> Color.to_attributes `Foreground color 43 | | `Background color -> Color.to_attributes `Background color 44 | | `Composed (left, right) -> 45 | Attributes.(to_attributes left & to_attributes right) 46 | ;; 47 | 48 | let rec to_cancelling_attributes (ansi : t) : Attributes.t = 49 | match ansi with 50 | | `Bold -> Attributes.create 22 51 | | `Dim -> Attributes.create 22 52 | | `Italic -> Attributes.create 23 53 | | `Underline -> Attributes.create 24 54 | | `Blink -> Attributes.create 25 55 | | `Reverse -> Attributes.create 27 56 | | `Foreground _ -> Attributes.create 39 57 | | `Background _ -> Attributes.create 49 58 | | `Composed (left, right) -> 59 | Attributes.( 60 | to_cancelling_attributes left 61 | & to_cancelling_attributes right) 62 | ;; 63 | 64 | let rec serialize (ansi : t) : string = 65 | match ansi with 66 | | `Bold -> "bold" 67 | | `Dim -> "dim" 68 | | `Italic -> "italic" 69 | | `Underline -> "underline" 70 | | `Blink -> "blink" 71 | | `Reverse -> "reverse" 72 | | `Foreground color -> 73 | Printf.sprintf "foreground(%s)" (Color.serialize color) 74 | | `Background color -> 75 | Printf.sprintf "background(%s)" (Color.serialize color) 76 | | `Composed (left, right) -> 77 | Printf.sprintf "%s & %s" (serialize left) (serialize right) 78 | ;; 79 | 80 | module Option = struct 81 | include Option 82 | 83 | let ( let+ ) = bind 84 | 85 | let rec all = function 86 | | [] -> None 87 | | Some item :: [] -> Some [ item ] 88 | | None :: _ -> None 89 | | Some item :: rest -> 90 | let+ rest' = all rest in 91 | Some (item :: rest') 92 | ;; 93 | end 94 | 95 | let ( let+ ) = Option.bind 96 | 97 | let rec list_to_composed = function 98 | | [] -> None 99 | | first :: [] -> Some first 100 | | first :: rest -> 101 | let+ right = list_to_composed rest in 102 | Some (compose first right) 103 | ;; 104 | 105 | module Deserialization = struct 106 | let try_remove_xground source ~x = 107 | let xground = x ^ "ground" in 108 | let xg = String.sub x 0 1 ^ "g" in 109 | if String.starts_with ~prefix:xground source 110 | then ( 111 | let xground_length = String.length xground in 112 | Some 113 | (String.sub 114 | source 115 | xground_length 116 | (String.length source - xground_length) 117 | |> String.trim)) 118 | else if String.starts_with ~prefix:xg source 119 | then 120 | Some 121 | (String.sub source 2 (String.length source - 2) 122 | |> String.trim) 123 | else None 124 | ;; 125 | 126 | let try_remove_paren_left source = 127 | if String.starts_with ~prefix:"(" source 128 | then Some (String.sub source 1 (String.length source - 1)) 129 | else None 130 | ;; 131 | 132 | let try_remove_paren_right source = 133 | if String.ends_with ~suffix:")" source 134 | then Some (String.sub source 0 (String.length source - 1)) 135 | else None 136 | ;; 137 | 138 | let try_parse_xground source ~f ~x = 139 | let+ source = try_remove_xground source ~x in 140 | let+ source = try_remove_paren_left source in 141 | let+ source = try_remove_paren_right source in 142 | let+ color = Color.parse source in 143 | Some (f color) 144 | ;; 145 | 146 | let parse_single source = 147 | match source with 148 | | "bold" -> Some `Bold 149 | | "dim" -> Some `Dim 150 | | "italic" -> Some `Italic 151 | | "underline" -> Some `Underline 152 | | "blink" -> Some `Blink 153 | | "reverse" -> Some `Reverse 154 | | _ when String.starts_with ~prefix:"background" source -> 155 | try_parse_xground source ~x:"back" ~f:background 156 | | _ -> try_parse_xground source ~x:"fore" ~f:foreground 157 | ;; 158 | end 159 | 160 | let deserialize (source : string) : t option = 161 | let+ parts = 162 | source 163 | |> String.split_on_char '&' 164 | |> List.map String.trim 165 | |> List.map String.lowercase_ascii 166 | |> List.map Deserialization.parse_single 167 | |> Option.all 168 | in 169 | list_to_composed parts 170 | ;; 171 | 172 | let show (ansi : t) : string = 173 | Printf.sprintf 174 | "\x1b[%sm" 175 | (Attributes.show (to_attributes ansi)) 176 | ;; 177 | 178 | let unshow (ansi : t) : string = 179 | Printf.sprintf 180 | "\x1b[%sm" 181 | (Attributes.show (to_cancelling_attributes ansi)) 182 | ;; 183 | 184 | let wrap (ansi : t) (string : string) : string = 185 | let cancelling_ansi_string = unshow ansi in 186 | if String.(equal string empty) 187 | then 188 | (* As the string is empty, the [ansi] escape sequence will 189 | not affect anything, meaning we can safely drop it. 190 | However, we cannot do the same for the cancelling part, 191 | as there might be outer active escape sequences still 192 | running. *) 193 | cancelling_ansi_string 194 | else 195 | Printf.sprintf 196 | "%s%s%s" 197 | (show ansi) 198 | string 199 | cancelling_ansi_string 200 | ;; 201 | 202 | let enrich = wrap 203 | let ( & ) = compose 204 | 205 | module Attributes = Attributes 206 | module Color = Color 207 | -------------------------------------------------------------------------------- /lib/Ansi/Color.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | [ `Basic of int 3 | | `Rgb of int * int * int 4 | ] 5 | 6 | let ( = ) (left : t) (right : t) = 7 | match (left, right) with 8 | | (`Basic i, `Basic j) -> Int.equal i j 9 | | (`Rgb (r1, g1, b1), `Rgb (r2, g2, b2)) -> 10 | Int.equal r1 r2 && Int.equal g1 g2 && Int.equal b1 b2 11 | | (_, _) -> false 12 | ;; 13 | 14 | let normalize_value (value : int) : int = abs value mod 256 15 | 16 | let normalize_rgb (color : [ `Rgb of int * int * int ]) 17 | : [> `Rgb of int * int * int ] 18 | = 19 | match color with 20 | | `Rgb (r, g, b) -> 21 | `Rgb 22 | (normalize_value r, normalize_value g, normalize_value b) 23 | ;; 24 | 25 | let normalize (color : t) : t = 26 | match color with 27 | | `Basic index -> `Basic (normalize_value index) 28 | | `Rgb _ as color -> normalize_rgb color 29 | ;; 30 | 31 | let to_attributes 32 | (ground : [ `Foreground | `Background ]) 33 | (color : t) 34 | : Attributes.t 35 | = 36 | let code = 37 | match ground with 38 | | `Foreground -> 38 39 | | `Background -> 48 40 | in 41 | let parameters = 42 | match normalize color with 43 | | `Basic index -> [ 5; index ] 44 | | `Rgb (r, g, b) -> [ 2; r; g; b ] 45 | in 46 | Attributes.create ~parameters code 47 | ;; 48 | 49 | let black : t = `Basic 0 50 | let red : t = `Basic 1 51 | let green : t = `Basic 2 52 | let yellow : t = `Basic 3 53 | let blue : t = `Basic 4 54 | let magenta : t = `Basic 5 55 | let cyan : t = `Basic 6 56 | let white : t = `Basic 7 57 | let bright_black : t = `Basic 8 58 | let bright_red : t = `Basic 9 59 | let bright_green : t = `Basic 10 60 | let bright_yellow : t = `Basic 11 61 | let bright_blue : t = `Basic 12 62 | let bright_magenta : t = `Basic 13 63 | let bright_cyan : t = `Basic 14 64 | let bright_white : t = `Basic 15 65 | 66 | let basic : int -> [ `Basic of int ] option = 67 | fun index -> 68 | if Int.(equal index (normalize_value index)) 69 | then Some (`Basic index) 70 | else None 71 | ;; 72 | 73 | let rgb : int * int * int -> [ `Rgb of int * int * int ] option = 74 | fun (r, g, b) -> 75 | if 76 | Int.(equal r (normalize_value r)) 77 | && Int.(equal g (normalize_value g)) 78 | && Int.(equal b (normalize_value b)) 79 | then Some (`Rgb (r, g, b)) 80 | else None 81 | ;; 82 | 83 | let ( let+ ) = Option.bind 84 | 85 | let of_hex_repr : string -> [ `Rgb of int * int * int ] option = 86 | let parse_hex_digit (char : char) : int option = 87 | match char with 88 | | '0' .. '9' -> Some (Char.code char - Char.code '0') 89 | | 'A' .. 'F' -> Some (Char.code char - Char.code 'A' + 10) 90 | | 'a' .. 'f' -> Some (Char.code char - Char.code 'a' + 10) 91 | | _ -> None 92 | in 93 | let parse_channel (char0 : char) (char1 : char) : int option = 94 | let+ digit0 = parse_hex_digit char0 in 95 | let+ digit1 = parse_hex_digit char1 in 96 | Some ((digit0 * 0x10) + digit1) 97 | in 98 | let rec try_parse_hex = function 99 | | [ r; g; b ] -> try_parse_hex [ r; r; g; g; b; b ] 100 | | [ r0; r1; g0; g1; b0; b1 ] -> 101 | let+ red = parse_channel r0 r1 in 102 | let+ green = parse_channel g0 g1 in 103 | let+ blue = parse_channel b0 b1 in 104 | rgb (red, green, blue) 105 | | _ -> None 106 | in 107 | fun string -> 108 | string 109 | |> String.trim 110 | |> String.to_seq 111 | |> List.of_seq 112 | |> function 113 | | '#' :: rest -> try_parse_hex rest 114 | | rest -> try_parse_hex rest 115 | ;; 116 | 117 | module Basic = struct 118 | let regular_expression = 119 | Re.compile 120 | @@ Re.Pcre.re 121 | ~flags:[ `CASELESS ] 122 | {|^\s*basic\s*\(\s*(0|[1-9][0-9]*)\s*\)\s*$|} 123 | ;; 124 | 125 | let parse : string -> [> `Basic of int ] option = 126 | fun string -> 127 | let+ match' = Re.exec_opt regular_expression string in 128 | let+ group = Re.Group.get_opt match' 1 in 129 | let+ index = int_of_string_opt group in 130 | Some (`Basic index) 131 | ;; 132 | end 133 | 134 | module Rgb = struct 135 | let regular_expression = 136 | Re.compile 137 | @@ Re.Pcre.re 138 | ~flags:[ `CASELESS ] 139 | {|^\s*rgb\s*\(\s*(0|[1-9][0-9]*)\s*,\s*(0|[1-9][0-9]*)\s*,\s*(0|[1-9][0-9]*)\s*(,\s*)?\)\s*$|} 140 | ;; 141 | 142 | let parse : string -> [> `Rgb of int * int * int ] option = 143 | fun string -> 144 | let+ match' = Re.exec_opt regular_expression string in 145 | let+ red_group = Re.Group.get_opt match' 1 in 146 | let+ green_group = Re.Group.get_opt match' 2 in 147 | let+ blue_group = Re.Group.get_opt match' 3 in 148 | let+ red = int_of_string_opt red_group in 149 | let+ green = int_of_string_opt green_group in 150 | let+ blue = int_of_string_opt blue_group in 151 | Some (`Rgb (red, green, blue)) 152 | ;; 153 | end 154 | 155 | let parse : string -> t option = 156 | let ( let- ) 157 | : type a. a option -> (unit -> a option) -> a option 158 | = 159 | fun option func -> 160 | match option with 161 | | None -> func () 162 | | Some _ -> option 163 | in 164 | fun string -> 165 | let- () = Basic.parse string in 166 | Rgb.parse string 167 | ;; 168 | 169 | (* Linearization, luminance and perceived lightness algorithms 170 | are mostly based on the following StackOverflow comment: 171 | , with some 172 | adjustements. *) 173 | 174 | let linearize 175 | : [ `Rgb of int * int * int ] -> float * float * float 176 | = 177 | let linearize_channel channel = 178 | let channel_srgb = Int.to_float channel /. 255. in 179 | if channel_srgb <= 0.04045 180 | then channel_srgb /. 12.92 181 | else ((channel_srgb +. 0.055) /. 1.055) ** 2.4 182 | in 183 | fun rgb -> 184 | match rgb with 185 | | `Rgb (r, g, b) -> 186 | ( linearize_channel r 187 | , linearize_channel g 188 | , linearize_channel b ) 189 | ;; 190 | 191 | let luminance : [ `Rgb of int * int * int ] -> float = 192 | fun rgb -> 193 | let (r, g, b) = linearize (normalize_rgb rgb) in 194 | (0.2126 *. r) +. (0.7152 *. g) +. (0.0722 *. b) 195 | ;; 196 | 197 | let perceived_lightness : [ `Rgb of int * int * int ] -> int = 198 | fun rgb -> 199 | let luminance = luminance rgb in 200 | (if luminance <= 216. /. 24389. 201 | then luminance *. 903.3 202 | else ((luminance ** (1. /. 3.)) *. 116.) -. 16.) 203 | |> Float.to_int 204 | ;; 205 | 206 | let best_for_contrast 207 | : [ `Rgb of int * int * int ] -> [ `Light | `Dark ] 208 | = 209 | fun rgb -> 210 | if perceived_lightness rgb < 50 then `Light else `Dark 211 | ;; 212 | 213 | let serialize : t -> string = 214 | fun color -> 215 | match normalize color with 216 | | `Basic n -> Printf.sprintf "basic(%d)" n 217 | | `Rgb (r, g, b) -> Printf.sprintf "rgb(%d, %d, %d)" r g b 218 | ;; 219 | -------------------------------------------------------------------------------- /test/Test_ansi/Test_color.ml: -------------------------------------------------------------------------------- 1 | open Ansifmt.Ansi 2 | 3 | module Fixtures = struct 4 | open Color 5 | 6 | let bright_magenta = bright_magenta 7 | let salmon = `Basic 173 8 | let middle_gray = `Basic 244 9 | let blue_by_modulo = `Basic 260 10 | let bright_red_by_abs = `Basic ~-9 11 | let rgb_pink = `Rgb (255, 140, 185) 12 | let rgb_brown = `Rgb (133, 66, 33) 13 | let rgb_green_by_normalization = `Rgb (~-127, 511, ~-1024) 14 | end 15 | 16 | module Test_basic = struct 17 | let ( = ) = Option.equal Color.( = ) 18 | 19 | let%test "basic valid integer" = 20 | (Color.basic 244 :> Color.t option) 21 | = Some Fixtures.middle_gray 22 | ;; 23 | 24 | let%test "basic integer too large" = 25 | (Color.basic 432 :> Color.t option) = None 26 | ;; 27 | 28 | let%test "basic negative integer" = 29 | (Color.basic ~-17 :> Color.t option) = None 30 | ;; 31 | end 32 | 33 | module Test_rgb = struct 34 | let ( = ) = Option.equal Color.( = ) 35 | 36 | let%test "rgb valid integers" = 37 | (Color.rgb (255, 140, 185) :> Color.t option) 38 | = Some Fixtures.rgb_pink 39 | ;; 40 | 41 | let%test "rgb one integer is not valid" = 42 | (Color.rgb (47, ~-5, 210) :> Color.t option) = None 43 | ;; 44 | 45 | let%test "rgb all integers are invalid" = 46 | (Color.rgb (~-21, 476, 298) :> Color.t option) = None 47 | ;; 48 | end 49 | 50 | module Test_of_hex_repr = struct 51 | let ( = ) = Option.equal Color.( = ) 52 | 53 | let%test 54 | "of hex repr valid hexadecimal, 6 characters, with hash" 55 | = 56 | (Color.of_hex_repr "#FF8CB9" :> Color.t option) 57 | = Some Fixtures.rgb_pink 58 | ;; 59 | 60 | let%test 61 | "of hex repr valid hexadecimal, 3 characters, with hash" 62 | = 63 | (Color.of_hex_repr "#888" :> Color.t option) 64 | = Some (`Rgb (136, 136, 136)) 65 | ;; 66 | 67 | let%test 68 | "of hex repr valid hexadecimal, 6 characters, no hash" 69 | = 70 | (Color.of_hex_repr "854221" :> Color.t option) 71 | = Some Fixtures.rgb_brown 72 | ;; 73 | 74 | let%test 75 | "of hex repr valid hexadecimal, 3 characters, no hash" 76 | = 77 | (Color.of_hex_repr "fff" :> Color.t option) 78 | = Some (`Rgb (255, 255, 255)) 79 | ;; 80 | 81 | let%test "of hex repr invalid hexadecimal (4 characters)" = 82 | (Color.of_hex_repr "#d0d0" :> Color.t option) = None 83 | ;; 84 | 85 | let%test 86 | "of hex repr invalid hexadecimal (characters outside of \ 87 | [0-9A-F])" 88 | = 89 | (Color.of_hex_repr "#3g4zME" :> Color.t option) = None 90 | ;; 91 | 92 | let%test "of_hex_repr invalid hexadecimal (empty)" = 93 | (Color.of_hex_repr "" :> Color.t option) = None 94 | ;; 95 | end 96 | 97 | module Test_basic_parse = struct 98 | let ( = ) = Option.equal Color.( = ) 99 | 100 | let%test "parse valid basic in bounds 0-255" = 101 | Color.Basic.parse "basic(173)" = Some Fixtures.salmon 102 | ;; 103 | 104 | let%test 105 | "parse valid basic in bounds 0-255, different formatting" 106 | = 107 | Color.Basic.parse " BaSiC ( 244) " 108 | = Some Fixtures.middle_gray 109 | ;; 110 | 111 | let%test "parse valid basic out of bounds >255" = 112 | Color.Basic.parse "basic(260)" 113 | = Some Fixtures.blue_by_modulo 114 | ;; 115 | 116 | let%test "parse invalid basic out of bounds <0" = 117 | Color.Basic.parse "basic(-9)" = None 118 | ;; 119 | 120 | let%test "parse invalid basic starting with #" = 121 | Color.Basic.parse "#basic(42)" = None 122 | ;; 123 | 124 | let%test "parse invalid basic with 3 arguments" = 125 | Color.Basic.parse "basic(255, 140, 185)" = None 126 | ;; 127 | 128 | let%test "parse invalid empty string" = 129 | Color.Basic.parse "" = None 130 | ;; 131 | end 132 | 133 | module Test_rgb_parse = struct 134 | let ( = ) = Option.equal Color.( = ) 135 | 136 | let%test "parse valid rgb in bounds 0-255" = 137 | Color.Rgb.parse "rgb(255, 140, 185)" 138 | = Some Fixtures.rgb_pink 139 | ;; 140 | 141 | let%test 142 | "parse valid rgb in bounds 0-255, different formatting" 143 | = 144 | Color.Rgb.parse " RGb ( 133 ,66 ,33) " 145 | = Some Fixtures.rgb_brown 146 | ;; 147 | 148 | let%test "parse valid rgb out of bounds >255" = 149 | Color.Rgb.parse "rgb(511, 383, 256)" 150 | = Some (`Rgb (511, 383, 256)) 151 | ;; 152 | 153 | let%test "parse invalid rgb out of bounds <0" = 154 | Color.Rgb.parse "rgb(-21, 476, 298)" = None 155 | ;; 156 | 157 | let%test "parse invalid rgb starting with #" = 158 | Color.Rgb.parse "#rgb(57, 189, 43)" = None 159 | ;; 160 | 161 | let%test "parse invalid rgba with alpha channel" = 162 | Color.Rgb.parse "rgba(100, 50, 0, 0.5)" = None 163 | ;; 164 | 165 | let%test "parse invalid rgb with ratios" = 166 | Color.Rgb.parse "rgb(0.6, 0.3, 0.47)" = None 167 | ;; 168 | 169 | let%test "parse invalid rgb with one argument" = 170 | Color.Rgb.parse "rgb(23)" = None 171 | ;; 172 | 173 | let%test "parse invalid empty string" = 174 | Color.Rgb.parse "" = None 175 | ;; 176 | end 177 | 178 | module Test_parse = struct 179 | let ( = ) = Option.equal Color.( = ) 180 | 181 | (* NOTE: These tests are copies of Test_parse_basic and 182 | Test_parse_rgb, because we want to be sure that their 183 | behaviors are matched without introducing functor logic *) 184 | 185 | let%test "parse valid basic in bounds 0-255" = 186 | Color.parse "basic(173)" = Some Fixtures.salmon 187 | ;; 188 | 189 | let%test 190 | "parse valid basic in bounds 0-255, different formatting" 191 | = 192 | Color.parse " BaSiC ( 244) " = Some Fixtures.middle_gray 193 | ;; 194 | 195 | let%test "parse valid basic out of bounds >255" = 196 | Color.parse "basic(260)" = Some Fixtures.blue_by_modulo 197 | ;; 198 | 199 | let%test "parse invalid basic out of bounds <0" = 200 | Color.parse "basic(-9)" = None 201 | ;; 202 | 203 | let%test "parse invalid basic starting with #" = 204 | Color.parse "#basic(42)" = None 205 | ;; 206 | 207 | let%test "parse invalid basic with 3 arguments" = 208 | Color.parse "basic(255, 140, 185)" = None 209 | ;; 210 | 211 | let%test "parse valid rgb in bounds 0-255" = 212 | Color.parse "rgb(255, 140, 185)" = Some Fixtures.rgb_pink 213 | ;; 214 | 215 | let%test 216 | "parse valid rgb in bounds 0-255, different formatting" 217 | = 218 | Color.parse " RGb ( 133 ,66 ,33) " 219 | = Some Fixtures.rgb_brown 220 | ;; 221 | 222 | let%test "parse valid rgb out of bounds >255" = 223 | Color.parse "rgb(511, 383, 256)" 224 | = Some (`Rgb (511, 383, 256)) 225 | ;; 226 | 227 | let%test "parse invalid rgb out of bounds <0" = 228 | Color.parse "rgb(-21, 476, 298)" = None 229 | ;; 230 | 231 | let%test "parse invalid rgb starting with #" = 232 | Color.parse "#rgb(57, 189, 43)" = None 233 | ;; 234 | 235 | let%test "parse invalid rgba with alpha channel" = 236 | Color.parse "rgba(100, 50, 0, 0.5)" = None 237 | ;; 238 | 239 | let%test "parse invalid rgb with ratios" = 240 | Color.parse "rgb(0.6, 0.3, 0.47)" = None 241 | ;; 242 | 243 | let%test "parse invalid rgb with one argument" = 244 | Color.parse "rgb(23)" = None 245 | ;; 246 | 247 | let%test "parse invalid empty string" = Color.parse "" = None 248 | end 249 | 250 | module Test_luminance = struct 251 | (* IDEA: property testing that values always fall between 0 252 | and 1? *) 253 | 254 | let ( =~ ) float1 float2 = 255 | Float.(abs (sub float1 float2)) <= 0.0001 256 | ;; 257 | 258 | module Expected = struct 259 | (* FROZEN 2025-10-30 *) 260 | 261 | let pink = 0.4351894959372870 262 | let brown = 0.0899278022203988 263 | let green_by_normalization = 0.7603202590262281 264 | end 265 | 266 | let%test "luminance pink" = 267 | Color.luminance Fixtures.rgb_pink =~ Expected.pink 268 | ;; 269 | 270 | let%test "luminance brown" = 271 | Color.luminance Fixtures.rgb_brown =~ Expected.brown 272 | ;; 273 | 274 | let%test "luminance green by normalization" = 275 | Color.luminance Fixtures.rgb_green_by_normalization 276 | =~ Expected.green_by_normalization 277 | ;; 278 | end 279 | 280 | module Test_perceived_lightness = struct 281 | let ( = ) = Int.equal 282 | 283 | (* IDEA: property testing that values always fall between 0 284 | and 100? *) 285 | 286 | module Expected = struct 287 | (* FROZEN 2025-06-27 *) 288 | 289 | let pink = 71 290 | let brown = 35 291 | let green_by_normalization = 89 292 | end 293 | 294 | let%test "perceived lightness pink" = 295 | Color.perceived_lightness Fixtures.rgb_pink = Expected.pink 296 | ;; 297 | 298 | let%test "perceived lightness brown" = 299 | Color.perceived_lightness Fixtures.rgb_brown 300 | = Expected.brown 301 | ;; 302 | 303 | let%test "perceived lightness green by normalization" = 304 | Color.perceived_lightness 305 | Fixtures.rgb_green_by_normalization 306 | = Expected.green_by_normalization 307 | ;; 308 | end 309 | 310 | module Test_best_for_contrast = struct 311 | (* the compared type is just two tags so it's not too 312 | horrible to use [=] here. *) 313 | let ( = ) = Stdlib.( = ) 314 | 315 | let%test "best for contrast pink" = 316 | Color.best_for_contrast Fixtures.rgb_pink = `Dark 317 | ;; 318 | 319 | let%test "best for contrast brown" = 320 | Color.best_for_contrast Fixtures.rgb_brown = `Light 321 | ;; 322 | end 323 | 324 | module Test_serialize = struct 325 | let ( = ) = String.equal 326 | 327 | let%test "serialize basic bright magenta" = 328 | Color.serialize Fixtures.bright_magenta = "basic(13)" 329 | ;; 330 | 331 | let%test "serialize basic salmon" = 332 | Color.serialize Fixtures.salmon = "basic(173)" 333 | ;; 334 | 335 | let%test "serialize basic blue by modulo" = 336 | Color.serialize Fixtures.blue_by_modulo = "basic(4)" 337 | ;; 338 | 339 | let%test "serialize basic bright red by abs" = 340 | Color.serialize Fixtures.bright_red_by_abs = "basic(9)" 341 | ;; 342 | 343 | let%test "serialize rgb pink" = 344 | Color.serialize Fixtures.rgb_pink = "rgb(255, 140, 185)" 345 | ;; 346 | 347 | let%test "serialize rgb green by normalization" = 348 | Color.serialize Fixtures.rgb_green_by_normalization 349 | = "rgb(127, 255, 0)" 350 | ;; 351 | end 352 | --------------------------------------------------------------------------------