Skip to content

Commit 46fa554

Browse files
vbfoxvbfox
committed
Add colorprintf function
1 parent 9827067 commit 46fa554

File tree

5 files changed

+186
-119
lines changed

5 files changed

+186
-119
lines changed

‎src/BlackFox.ColoredPrintf/BlackFox.ColoredPrintf.fsproj‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -57,9 +57,10 @@
5757
<ItemGroup>
5858
<Compile Include="AssemblyInfo.fs" />
5959
<Compile Include="ColorStrings.fs" />
60-
<Compile Include="ColoredPrintf.fs" />
60+
<Compile Include="ColoredWriter.fs" />
6161
<None Include="paket.references" />
6262
<None Include="paket.template" />
63+
<Compile Include="ColoredPrintf.fs" />
6364
</ItemGroup>
6465
<ItemGroup>
6566
<Reference Include="mscorlib" />

‎src/BlackFox.ColoredPrintf/ColoredPrintf.fs‎

Lines changed: 56 additions & 115 deletions
Original file line numberDiff line numberDiff line change
@@ -1,120 +1,61 @@
1-
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
2-
module BlackFox.ColoredPrintf.ColoredWriter
1+
[<AutoOpen>]
2+
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
3+
module BlackFox.ColoredPrintf.ColoredPrintf
34

45
open System
5-
open System.Text
6-
7-
type IColoredPrinterEnv =
8-
abstract Write : string -> unit
9-
abstract Foreground : ConsoleColor with get,set
10-
abstract Background : ConsoleColor with get,set
11-
12-
type WriterStatus = | Normal | Foreground | Background | Escaping
13-
type WriterState = {
14-
mutable Colors: (ConsoleColor * ConsoleColor) list
15-
mutable Status: WriterStatus
16-
CurrentText: StringBuilder
17-
mutable WipForeground: ConsoleColor option
18-
}
19-
20-
let getEmptyState (foreground: ConsoleColor) (background: ConsoleColor) = {
21-
Colors = [foreground, background]
22-
Status = WriterStatus.Normal
23-
CurrentText = StringBuilder()
24-
WipForeground = None
25-
}
26-
27-
module private StateHelpers =
28-
open ColorStrings
29-
let inline clearText (state: WriterState) = ignore(state.CurrentText.Clear())
30-
let inline appendChar (c: char) (state: WriterState) = ignore(state.CurrentText.Append(c))
31-
32-
let inline writeCurrentTextToEnv (env: IColoredPrinterEnv) (state: WriterState) =
33-
if state.CurrentText.Length > 0 then
34-
env.Write (state.CurrentText.ToString())
35-
state |> clearText
36-
37-
let inline getColor (state: WriterState) =
38-
let colorText = state.CurrentText.ToString()
39-
state |> clearText
40-
colorNameToColor colorText
41-
42-
open StateHelpers
43-
44-
let inline writeChar (env: IColoredPrinterEnv) (c: char) (state: WriterState) =
45-
match state.Status with
46-
| WriterStatus.Normal when c = '$' ->
47-
writeCurrentTextToEnv env state
48-
state.Status <- WriterStatus.Foreground
49-
| WriterStatus.Normal when c = ']' ->
50-
match state.Colors with
51-
| [] -> failwith "Unexpected, no colors in stack"
52-
| [_] -> state |> appendChar c
53-
| (currentFg, currentBg) :: (previousFg, previousBg) :: rest ->
54-
writeCurrentTextToEnv env state
55-
state.Colors <- (previousFg, previousBg) :: rest
56-
if currentFg <> previousFg then env.Foreground <- previousFg
57-
if currentBg <> previousBg then env.Background <- previousBg
58-
| WriterStatus.Normal when c = '\\' -> state.Status <- WriterStatus.Escaping
59-
| WriterStatus.Normal -> state |> appendChar c
60-
| WriterStatus.Escaping when c = '$' || c = ']' ->
61-
state |> appendChar c
62-
state.Status <- WriterStatus.Normal
63-
| WriterStatus.Escaping ->
64-
state |> appendChar '\\'
65-
state |> appendChar c
66-
state.Status <- WriterStatus.Normal
67-
| WriterStatus.Foreground when c = ';' ->
68-
match getColor state with
69-
| Some c -> state.WipForeground <- Some c
70-
| None -> ()
71-
state.Status <- WriterStatus.Background
72-
| WriterStatus.Foreground when c = '[' ->
73-
let (currentFg, currentBg) = state.Colors.Head
74-
match getColor state with
75-
| Some c ->
76-
if currentFg <> c then env.Foreground <- c
77-
state.Colors <- (c, currentBg) :: state.Colors
78-
| None ->
79-
state.Colors <- state.Colors.Head :: state.Colors
80-
state.Status <- WriterStatus.Normal
81-
| WriterStatus.Foreground -> state |> appendChar c
82-
| WriterStatus.Background when c = '[' ->
83-
let (currentFg, currentBg) = state.Colors.Head
84-
85-
let fg = defaultArg state.WipForeground currentFg
86-
let bg = defaultArg (getColor state) currentBg
87-
88-
state.WipForeground <- None
6+
open BlackFox.MasterOfFoo
7+
open BlackFox.ColoredPrintf.ColoredWriter
8+
9+
type private ConsoleColoredPrinterEnv() =
10+
let mutable fg = ConsoleColor.White
11+
let mutable bg = ConsoleColor.Black
12+
let mutable colorDisabled = false
13+
let wrap f =
14+
if not colorDisabled then
15+
try f()
16+
with | _ -> colorDisabled <- true
17+
18+
do
19+
wrap (fun _ ->
20+
fg <- Console.ForegroundColor
21+
bg <- Console.BackgroundColor)
22+
23+
interface ColoredWriter.IColoredPrinterEnv with
24+
member __.Write (s: string) = Console.Write(s)
25+
member __.Foreground
26+
with get () = fg
27+
and set c =
28+
fg <- c
29+
wrap(fun _ -> Console.ForegroundColor <- c)
30+
member __.Background
31+
with get () = bg
32+
and set c =
33+
bg <- c
34+
wrap(fun _ -> Console.BackgroundColor <- c)
35+
36+
type private ColoredConsolePrintEnv<'Result>(k) =
37+
inherit PrintfEnv<unit, string, 'Result>()
38+
39+
let env = ConsoleColoredPrinterEnv() :> ColoredWriter.IColoredPrinterEnv
40+
let state = getEmptyState env.Foreground env.Background
41+
42+
override __.Finalize() : 'Result =
43+
state |> finish env
44+
k()
45+
46+
override __.Write(s : PrintableElement) =
47+
match s.ElementType with
48+
| PrintableElementType.FromFormatSpecifier -> env.Write(s.FormatAsPrintF())
49+
| _ -> state |> writeString env (s.FormatAsPrintF())
50+
51+
override __.WriteT(s : string) =
52+
env.Write(s)
8953

90-
if currentFg <> fg then env.Foreground <- fg
91-
if currentBg <> bg then env.Background <- bg
54+
type ColorPrintFormat<'T> = Format<'T, unit, string, unit>
9255

93-
state.Colors <- (fg, bg) :: state.Colors
94-
state.Status <- WriterStatus.Normal
95-
| WriterStatus.Background -> state |> appendChar c
96-
97-
let inline writeString (env: IColoredPrinterEnv) (s: string) (state: WriterState) =
98-
for i in 0..s.Length-1 do
99-
state |> writeChar env (s.[i])
56+
let colorprintf<'T> (format: ColorPrintFormat<'T>) =
57+
doPrintfFromEnv format (ColoredConsolePrintEnv(id))
10058

101-
let inline finish (env: IColoredPrinterEnv) (state: WriterState) =
102-
match state.Status with
103-
| WriterStatus.Normal ->
104-
writeCurrentTextToEnv env state
105-
| WriterStatus.Escaping ->
106-
state |> appendChar '\\'
107-
writeCurrentTextToEnv env state
108-
| WriterStatus.Foreground -> ()
109-
| WriterStatus.Background -> ()
110-
111-
let writeCompleteString (env: IColoredPrinterEnv) (s: string) =
112-
let initialFg = env.Foreground
113-
let initialBg = env.Background
114-
115-
let state = getEmptyState initialFg initialBg
116-
state |> writeString env s
117-
118-
state |> finish env
119-
if initialFg <> env.Foreground then env.Foreground <- initialFg
120-
if initialBg <> env.Background then env.Background <- initialBg
59+
let colorprintfn<'T> (format: ColorPrintFormat<'T>) =
60+
let writeLine () = Console.WriteLine()
61+
doPrintfFromEnv format (ColoredConsolePrintEnv(writeLine))

‎src/BlackFox.ColoredPrintf/ColoredWriter.fs‎

Lines changed: 117 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,117 @@
1+
module BlackFox.ColoredPrintf.ColoredWriter
2+
3+
open System
4+
open System.Text
5+
6+
type IColoredPrinterEnv =
7+
abstract Write : string -> unit
8+
abstract Foreground : ConsoleColor with get,set
9+
abstract Background : ConsoleColor with get,set
10+
11+
type WriterStatus = | Normal | Foreground | Background | Escaping
12+
type WriterState = {
13+
mutable Colors: (ConsoleColor * ConsoleColor) list
14+
mutable Status: WriterStatus
15+
CurrentText: StringBuilder
16+
mutable WipForeground: ConsoleColor option
17+
}
18+
19+
let getEmptyState (foreground: ConsoleColor) (background: ConsoleColor) = {
20+
Colors = [foreground, background]
21+
Status = WriterStatus.Normal
22+
CurrentText = StringBuilder()
23+
WipForeground = None
24+
}
25+
26+
module private StateHelpers =
27+
open ColorStrings
28+
let inline clearText (state: WriterState) = ignore(state.CurrentText.Clear())
29+
let inline appendChar (c: char) (state: WriterState) = ignore(state.CurrentText.Append(c))
30+
31+
let inline writeCurrentTextToEnv (env: IColoredPrinterEnv) (state: WriterState) =
32+
if state.CurrentText.Length > 0 then
33+
env.Write (state.CurrentText.ToString())
34+
state |> clearText
35+
36+
let inline getColor (state: WriterState) =
37+
let colorText = state.CurrentText.ToString()
38+
state |> clearText
39+
colorNameToColor colorText
40+
41+
open StateHelpers
42+
43+
let inline writeChar (env: IColoredPrinterEnv) (c: char) (state: WriterState) =
44+
match state.Status with
45+
| WriterStatus.Normal when c = '$' ->
46+
writeCurrentTextToEnv env state
47+
state.Status <- WriterStatus.Foreground
48+
| WriterStatus.Normal when c = ']' ->
49+
match state.Colors with
50+
| [] -> failwith "Unexpected, no colors in stack"
51+
| [_] -> state |> appendChar c
52+
| (currentFg, currentBg) :: (previousFg, previousBg) :: rest ->
53+
writeCurrentTextToEnv env state
54+
state.Colors <- (previousFg, previousBg) :: rest
55+
if currentFg <> previousFg then env.Foreground <- previousFg
56+
if currentBg <> previousBg then env.Background <- previousBg
57+
| WriterStatus.Normal when c = '\\' -> state.Status <- WriterStatus.Escaping
58+
| WriterStatus.Normal -> state |> appendChar c
59+
| WriterStatus.Escaping when c = '$' || c = ']' ->
60+
state |> appendChar c
61+
state.Status <- WriterStatus.Normal
62+
| WriterStatus.Escaping ->
63+
state |> appendChar '\\'
64+
state |> appendChar c
65+
state.Status <- WriterStatus.Normal
66+
| WriterStatus.Foreground when c = ';' ->
67+
match getColor state with
68+
| Some c -> state.WipForeground <- Some c
69+
| None -> ()
70+
state.Status <- WriterStatus.Background
71+
| WriterStatus.Foreground when c = '[' ->
72+
let (currentFg, currentBg) = state.Colors.Head
73+
match getColor state with
74+
| Some c ->
75+
if currentFg <> c then env.Foreground <- c
76+
state.Colors <- (c, currentBg) :: state.Colors
77+
| None ->
78+
state.Colors <- state.Colors.Head :: state.Colors
79+
state.Status <- WriterStatus.Normal
80+
| WriterStatus.Foreground -> state |> appendChar c
81+
| WriterStatus.Background when c = '[' ->
82+
let (currentFg, currentBg) = state.Colors.Head
83+
84+
let fg = defaultArg state.WipForeground currentFg
85+
let bg = defaultArg (getColor state) currentBg
86+
87+
state.WipForeground <- None
88+
89+
if currentFg <> fg then env.Foreground <- fg
90+
if currentBg <> bg then env.Background <- bg
91+
92+
state.Colors <- (fg, bg) :: state.Colors
93+
state.Status <- WriterStatus.Normal
94+
| WriterStatus.Background -> state |> appendChar c
95+
96+
let inline writeString (env: IColoredPrinterEnv) (s: string) (state: WriterState) =
97+
for i in 0..s.Length-1 do
98+
state |> writeChar env (s.[i])
99+
100+
let inline finish (env: IColoredPrinterEnv) (state: WriterState) =
101+
match state.Status with
102+
| WriterStatus.Normal ->
103+
writeCurrentTextToEnv env state
104+
| WriterStatus.Escaping ->
105+
state |> appendChar '\\'
106+
writeCurrentTextToEnv env state
107+
| WriterStatus.Foreground -> ()
108+
| WriterStatus.Background -> ()
109+
110+
let (initialFg, initialBg) = state.Colors |> List.last
111+
if initialFg <> env.Foreground then env.Foreground <- initialFg
112+
if initialBg <> env.Background then env.Background <- initialBg
113+
114+
let writeCompleteString (env: IColoredPrinterEnv) (s: string) =
115+
let state = getEmptyState (env.Foreground) (env.Background)
116+
state |> writeString env s
117+
state |> finish env

‎src/TestApp/Program.fs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,8 @@
1-
// Learn more about F# at http://fsharp.org
2-
// See the 'F# Tutorial' project for more help.
1+
open System
2+
open BlackFox.ColoredPrintf
33

44
[<EntryPoint>]
55
let main argv =
6-
printfn "%A" argv
6+
colorprintfn "$white;blue[%s ]$black;white[%s ]$white;red[%s]" "La vie" "est" "belle"
7+
ignore(Console.ReadLine())
78
0 // return an integer exit code

‎src/TestApp/TestApp.fsproj‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,13 @@
5252
<None Include="App.config" />
5353
<None Include="paket.references" />
5454
</ItemGroup>
55+
<ItemGroup>
56+
<ProjectReference Include="..\BlackFox.ColoredPrintf\BlackFox.ColoredPrintf.fsproj">
57+
<Name>BlackFox.ColoredPrintf</Name>
58+
<Project>{860e1cc6-a7f8-4bc2-9a6c-ebe93360ece1}</Project>
59+
<Private>True</Private>
60+
</ProjectReference>
61+
</ItemGroup>
5562
<PropertyGroup>
5663
<MinimumVisualStudioVersion Condition="'$(MinimumVisualStudioVersion)' == ''">11</MinimumVisualStudioVersion>
5764
</PropertyGroup>

0 commit comments

Comments
 (0)