-
Notifications
You must be signed in to change notification settings - Fork 3
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
5 changed files
with
186 additions
and
119 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,120 +1,61 @@ | ||
| [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>] | ||
| module BlackFox.ColoredPrintf.ColoredWriter | ||
| [<AutoOpen>] | ||
| [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>] | ||
| module BlackFox.ColoredPrintf.ColoredPrintf | ||
|
|
||
| open System | ||
| open System.Text | ||
|
|
||
| type IColoredPrinterEnv = | ||
| abstract Write : string -> unit | ||
| abstract Foreground : ConsoleColor with get,set | ||
| abstract Background : ConsoleColor with get,set | ||
|
|
||
| type WriterStatus = | Normal | Foreground | Background | Escaping | ||
| type WriterState = { | ||
| mutable Colors: (ConsoleColor * ConsoleColor) list | ||
| mutable Status: WriterStatus | ||
| CurrentText: StringBuilder | ||
| mutable WipForeground: ConsoleColor option | ||
| } | ||
|
|
||
| let getEmptyState (foreground: ConsoleColor) (background: ConsoleColor) = { | ||
| Colors = [foreground, background] | ||
| Status = WriterStatus.Normal | ||
| CurrentText = StringBuilder() | ||
| WipForeground = None | ||
| } | ||
|
|
||
| module private StateHelpers = | ||
| open ColorStrings | ||
| let inline clearText (state: WriterState) = ignore(state.CurrentText.Clear()) | ||
| let inline appendChar (c: char) (state: WriterState) = ignore(state.CurrentText.Append(c)) | ||
|
|
||
| let inline writeCurrentTextToEnv (env: IColoredPrinterEnv) (state: WriterState) = | ||
| if state.CurrentText.Length > 0 then | ||
| env.Write (state.CurrentText.ToString()) | ||
| state |> clearText | ||
|
|
||
| let inline getColor (state: WriterState) = | ||
| let colorText = state.CurrentText.ToString() | ||
| state |> clearText | ||
| colorNameToColor colorText | ||
|
|
||
| open StateHelpers | ||
|
|
||
| let inline writeChar (env: IColoredPrinterEnv) (c: char) (state: WriterState) = | ||
| match state.Status with | ||
| | WriterStatus.Normal when c = '$' -> | ||
| writeCurrentTextToEnv env state | ||
| state.Status <- WriterStatus.Foreground | ||
| | WriterStatus.Normal when c = ']' -> | ||
| match state.Colors with | ||
| | [] -> failwith "Unexpected, no colors in stack" | ||
| | [_] -> state |> appendChar c | ||
| | (currentFg, currentBg) :: (previousFg, previousBg) :: rest -> | ||
| writeCurrentTextToEnv env state | ||
| state.Colors <- (previousFg, previousBg) :: rest | ||
| if currentFg <> previousFg then env.Foreground <- previousFg | ||
| if currentBg <> previousBg then env.Background <- previousBg | ||
| | WriterStatus.Normal when c = '\\' -> state.Status <- WriterStatus.Escaping | ||
| | WriterStatus.Normal -> state |> appendChar c | ||
| | WriterStatus.Escaping when c = '$' || c = ']' -> | ||
| state |> appendChar c | ||
| state.Status <- WriterStatus.Normal | ||
| | WriterStatus.Escaping -> | ||
| state |> appendChar '\\' | ||
| state |> appendChar c | ||
| state.Status <- WriterStatus.Normal | ||
| | WriterStatus.Foreground when c = ';' -> | ||
| match getColor state with | ||
| | Some c -> state.WipForeground <- Some c | ||
| | None -> () | ||
| state.Status <- WriterStatus.Background | ||
| | WriterStatus.Foreground when c = '[' -> | ||
| let (currentFg, currentBg) = state.Colors.Head | ||
| match getColor state with | ||
| | Some c -> | ||
| if currentFg <> c then env.Foreground <- c | ||
| state.Colors <- (c, currentBg) :: state.Colors | ||
| | None -> | ||
| state.Colors <- state.Colors.Head :: state.Colors | ||
| state.Status <- WriterStatus.Normal | ||
| | WriterStatus.Foreground -> state |> appendChar c | ||
| | WriterStatus.Background when c = '[' -> | ||
| let (currentFg, currentBg) = state.Colors.Head | ||
|
|
||
| let fg = defaultArg state.WipForeground currentFg | ||
| let bg = defaultArg (getColor state) currentBg | ||
|
|
||
| state.WipForeground <- None | ||
| open BlackFox.MasterOfFoo | ||
| open BlackFox.ColoredPrintf.ColoredWriter | ||
|
|
||
| type private ConsoleColoredPrinterEnv() = | ||
| let mutable fg = ConsoleColor.White | ||
| let mutable bg = ConsoleColor.Black | ||
| let mutable colorDisabled = false | ||
| let wrap f = | ||
| if not colorDisabled then | ||
| try f() | ||
| with | _ -> colorDisabled <- true | ||
|
|
||
| do | ||
| wrap (fun _ -> | ||
| fg <- Console.ForegroundColor | ||
| bg <- Console.BackgroundColor) | ||
|
|
||
| interface ColoredWriter.IColoredPrinterEnv with | ||
| member __.Write (s: string) = Console.Write(s) | ||
| member __.Foreground | ||
| with get () = fg | ||
| and set c = | ||
| fg <- c | ||
| wrap(fun _ -> Console.ForegroundColor <- c) | ||
| member __.Background | ||
| with get () = bg | ||
| and set c = | ||
| bg <- c | ||
| wrap(fun _ -> Console.BackgroundColor <- c) | ||
|
|
||
| type private ColoredConsolePrintEnv<'Result>(k) = | ||
| inherit PrintfEnv<unit, string, 'Result>() | ||
|
|
||
| let env = ConsoleColoredPrinterEnv() :> ColoredWriter.IColoredPrinterEnv | ||
| let state = getEmptyState env.Foreground env.Background | ||
|
|
||
| override __.Finalize() : 'Result = | ||
| state |> finish env | ||
| k() | ||
|
|
||
| override __.Write(s : PrintableElement) = | ||
| match s.ElementType with | ||
| | PrintableElementType.FromFormatSpecifier -> env.Write(s.FormatAsPrintF()) | ||
| | _ -> state |> writeString env (s.FormatAsPrintF()) | ||
|
|
||
| override __.WriteT(s : string) = | ||
| env.Write(s) | ||
|
|
||
| if currentFg <> fg then env.Foreground <- fg | ||
| if currentBg <> bg then env.Background <- bg | ||
| type ColorPrintFormat<'T> = Format<'T, unit, string, unit> | ||
|
|
||
| state.Colors <- (fg, bg) :: state.Colors | ||
| state.Status <- WriterStatus.Normal | ||
| | WriterStatus.Background -> state |> appendChar c | ||
|
|
||
| let inline writeString (env: IColoredPrinterEnv) (s: string) (state: WriterState) = | ||
| for i in 0..s.Length-1 do | ||
| state |> writeChar env (s.[i]) | ||
| let colorprintf<'T> (format: ColorPrintFormat<'T>) = | ||
| doPrintfFromEnv format (ColoredConsolePrintEnv(id)) | ||
|
|
||
| let inline finish (env: IColoredPrinterEnv) (state: WriterState) = | ||
| match state.Status with | ||
| | WriterStatus.Normal -> | ||
| writeCurrentTextToEnv env state | ||
| | WriterStatus.Escaping -> | ||
| state |> appendChar '\\' | ||
| writeCurrentTextToEnv env state | ||
| | WriterStatus.Foreground -> () | ||
| | WriterStatus.Background -> () | ||
|
|
||
| let writeCompleteString (env: IColoredPrinterEnv) (s: string) = | ||
| let initialFg = env.Foreground | ||
| let initialBg = env.Background | ||
|
|
||
| let state = getEmptyState initialFg initialBg | ||
| state |> writeString env s | ||
|
|
||
| state |> finish env | ||
| if initialFg <> env.Foreground then env.Foreground <- initialFg | ||
| if initialBg <> env.Background then env.Background <- initialBg | ||
| let colorprintfn<'T> (format: ColorPrintFormat<'T>) = | ||
| let writeLine () = Console.WriteLine() | ||
| doPrintfFromEnv format (ColoredConsolePrintEnv(writeLine)) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,117 @@ | ||
| module BlackFox.ColoredPrintf.ColoredWriter | ||
|
|
||
| open System | ||
| open System.Text | ||
|
|
||
| type IColoredPrinterEnv = | ||
| abstract Write : string -> unit | ||
| abstract Foreground : ConsoleColor with get,set | ||
| abstract Background : ConsoleColor with get,set | ||
|
|
||
| type WriterStatus = | Normal | Foreground | Background | Escaping | ||
| type WriterState = { | ||
| mutable Colors: (ConsoleColor * ConsoleColor) list | ||
| mutable Status: WriterStatus | ||
| CurrentText: StringBuilder | ||
| mutable WipForeground: ConsoleColor option | ||
| } | ||
|
|
||
| let getEmptyState (foreground: ConsoleColor) (background: ConsoleColor) = { | ||
| Colors = [foreground, background] | ||
| Status = WriterStatus.Normal | ||
| CurrentText = StringBuilder() | ||
| WipForeground = None | ||
| } | ||
|
|
||
| module private StateHelpers = | ||
| open ColorStrings | ||
| let inline clearText (state: WriterState) = ignore(state.CurrentText.Clear()) | ||
| let inline appendChar (c: char) (state: WriterState) = ignore(state.CurrentText.Append(c)) | ||
|
|
||
| let inline writeCurrentTextToEnv (env: IColoredPrinterEnv) (state: WriterState) = | ||
| if state.CurrentText.Length > 0 then | ||
| env.Write (state.CurrentText.ToString()) | ||
| state |> clearText | ||
|
|
||
| let inline getColor (state: WriterState) = | ||
| let colorText = state.CurrentText.ToString() | ||
| state |> clearText | ||
| colorNameToColor colorText | ||
|
|
||
| open StateHelpers | ||
|
|
||
| let inline writeChar (env: IColoredPrinterEnv) (c: char) (state: WriterState) = | ||
| match state.Status with | ||
| | WriterStatus.Normal when c = '$' -> | ||
| writeCurrentTextToEnv env state | ||
| state.Status <- WriterStatus.Foreground | ||
| | WriterStatus.Normal when c = ']' -> | ||
| match state.Colors with | ||
| | [] -> failwith "Unexpected, no colors in stack" | ||
| | [_] -> state |> appendChar c | ||
| | (currentFg, currentBg) :: (previousFg, previousBg) :: rest -> | ||
| writeCurrentTextToEnv env state | ||
| state.Colors <- (previousFg, previousBg) :: rest | ||
| if currentFg <> previousFg then env.Foreground <- previousFg | ||
| if currentBg <> previousBg then env.Background <- previousBg | ||
| | WriterStatus.Normal when c = '\\' -> state.Status <- WriterStatus.Escaping | ||
| | WriterStatus.Normal -> state |> appendChar c | ||
| | WriterStatus.Escaping when c = '$' || c = ']' -> | ||
| state |> appendChar c | ||
| state.Status <- WriterStatus.Normal | ||
| | WriterStatus.Escaping -> | ||
| state |> appendChar '\\' | ||
| state |> appendChar c | ||
| state.Status <- WriterStatus.Normal | ||
| | WriterStatus.Foreground when c = ';' -> | ||
| match getColor state with | ||
| | Some c -> state.WipForeground <- Some c | ||
| | None -> () | ||
| state.Status <- WriterStatus.Background | ||
| | WriterStatus.Foreground when c = '[' -> | ||
| let (currentFg, currentBg) = state.Colors.Head | ||
| match getColor state with | ||
| | Some c -> | ||
| if currentFg <> c then env.Foreground <- c | ||
| state.Colors <- (c, currentBg) :: state.Colors | ||
| | None -> | ||
| state.Colors <- state.Colors.Head :: state.Colors | ||
| state.Status <- WriterStatus.Normal | ||
| | WriterStatus.Foreground -> state |> appendChar c | ||
| | WriterStatus.Background when c = '[' -> | ||
| let (currentFg, currentBg) = state.Colors.Head | ||
|
|
||
| let fg = defaultArg state.WipForeground currentFg | ||
| let bg = defaultArg (getColor state) currentBg | ||
|
|
||
| state.WipForeground <- None | ||
|
|
||
| if currentFg <> fg then env.Foreground <- fg | ||
| if currentBg <> bg then env.Background <- bg | ||
|
|
||
| state.Colors <- (fg, bg) :: state.Colors | ||
| state.Status <- WriterStatus.Normal | ||
| | WriterStatus.Background -> state |> appendChar c | ||
|
|
||
| let inline writeString (env: IColoredPrinterEnv) (s: string) (state: WriterState) = | ||
| for i in 0..s.Length-1 do | ||
| state |> writeChar env (s.[i]) | ||
|
|
||
| let inline finish (env: IColoredPrinterEnv) (state: WriterState) = | ||
| match state.Status with | ||
| | WriterStatus.Normal -> | ||
| writeCurrentTextToEnv env state | ||
| | WriterStatus.Escaping -> | ||
| state |> appendChar '\\' | ||
| writeCurrentTextToEnv env state | ||
| | WriterStatus.Foreground -> () | ||
| | WriterStatus.Background -> () | ||
|
|
||
| let (initialFg, initialBg) = state.Colors |> List.last | ||
| if initialFg <> env.Foreground then env.Foreground <- initialFg | ||
| if initialBg <> env.Background then env.Background <- initialBg | ||
|
|
||
| let writeCompleteString (env: IColoredPrinterEnv) (s: string) = | ||
| let state = getEmptyState (env.Foreground) (env.Background) | ||
| state |> writeString env s | ||
| state |> finish env |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,7 +1,8 @@ | ||
| // Learn more about F# at http://fsharp.org | ||
| // See the 'F# Tutorial' project for more help. | ||
| open System | ||
| open BlackFox.ColoredPrintf | ||
|
|
||
| [<EntryPoint>] | ||
| let main argv = | ||
| printfn "%A" argv | ||
| colorprintfn "$white;blue[%s ]$black;white[%s ]$white;red[%s]" "La vie" "est" "belle" | ||
| ignore(Console.ReadLine()) | ||
| 0 // return an integer exit code |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters