├── fake.cmd ├── nuget.config ├── src ├── FSharp.CommandLine │ ├── exceptions.fs │ ├── extensions.fs │ ├── FSharp.CommandLine.fsproj │ ├── abstraction.fs │ ├── optionValues.fs │ ├── basictypes.fs │ ├── commands.fs │ ├── generators.fs │ └── options.fs ├── common │ ├── Version.fs │ └── prelude.fs └── FSharp.Scanf │ ├── FSharp.Scanf.fsproj │ └── scanf.fs ├── RELEASE_NOTES.md ├── fake.sh ├── .gitattributes ├── .github └── ISSUE_TEMPLATE.md ├── FSharp.CommandLine.sln ├── README.md ├── .gitignore ├── test.fsx └── LICENSE.txt /fake.cmd: -------------------------------------------------------------------------------- 1 | SET TOOL_PATH=.fake 2 | 3 | IF NOT EXIST "%TOOL_PATH%\fake.exe" ( 4 | dotnet tool install fake-cli --tool-path ./%TOOL_PATH% 5 | ) 6 | 7 | "%TOOL_PATH%/fake.exe" %* -------------------------------------------------------------------------------- /nuget.config: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /src/FSharp.CommandLine/exceptions.fs: -------------------------------------------------------------------------------- 1 | namespace FSharp.CommandLine 2 | 3 | exception OptionParseFailed of summary:CommandOptionSummary * msg: string with 4 | override this.Message = this.msg 5 | exception CommandExecutionFailed of msg: string with 6 | override this.Message = this.msg 7 | 8 | exception RequestExit of int 9 | exception RequestShowHelp of msg: string with 10 | override this.Message = this.msg 11 | -------------------------------------------------------------------------------- /src/common/Version.fs: -------------------------------------------------------------------------------- 1 | // Auto-Generated by FAKE; do not edit 2 | namespace System 3 | open System.Reflection 4 | 5 | [] 6 | [] 7 | do () 8 | 9 | module internal AssemblyVersionInformation = 10 | let [] AssemblyVersion = "3.3.3805.29705" 11 | let [] AssemblyFileVersion = "3.3.3805.29705" 12 | -------------------------------------------------------------------------------- /RELEASE_NOTES.md: -------------------------------------------------------------------------------- 1 | * 3.4.* - Indent multiline command descriptions 2 | * 3.3.* - Fixed scanf parser. 3 | * 3.2.* - Fixed scanf parser. 4 | * 3.1.* - Improve comments. Some refactoring. 5 | * 3.0.* - Breaking API changes. Use FAKE again. Refactor Scanf. 6 | * 2.2.* - Fix broken NuGet dependency 7 | * 2.1.* - Separated scanf module 8 | * 2.0.* - Breaking API changes: no more internal side effects 9 | * 1.2.* - Get rid of FAKE 10 | * 1.1.* - Support .NET Standard 2.0 11 | * 1.0.* - Initial release 12 | 13 | -------------------------------------------------------------------------------- /fake.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | export DOTNET_SYSTEM_NET_HTTP_USESOCKETSHTTPHANDLER=0 3 | 4 | set -eu 5 | set -o pipefail 6 | 7 | # liberated from https://stackoverflow.com/a/18443300/433393 8 | realpath() { 9 | OURPWD=$PWD 10 | cd "$(dirname "$1")" 11 | LINK=$(readlink "$(basename "$1")") 12 | while [ "$LINK" ]; do 13 | cd "$(dirname "$LINK")" 14 | LINK=$(readlink "$(basename "$1")") 15 | done 16 | REALPATH="$PWD/$(basename "$1")" 17 | cd "$OURPWD" 18 | echo "$REALPATH" 19 | } 20 | 21 | TOOL_PATH=$(realpath .fake) 22 | FAKE="$TOOL_PATH"/fake 23 | 24 | if ! [ -e "$FAKE" ] 25 | then 26 | dotnet tool install fake-cli --tool-path "$TOOL_PATH" 27 | fi 28 | "$FAKE" "$@" 29 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp text=auto eol=lf 6 | *.vb diff=csharp text=auto eol=lf 7 | *.fs diff=csharp text=auto eol=lf 8 | *.fsi diff=csharp text=auto eol=lf 9 | *.fsx diff=csharp text=auto eol=lf 10 | *.sln text eol=crlf merge=union 11 | *.csproj merge=union 12 | *.vbproj merge=union 13 | *.fsproj merge=union 14 | *.dbproj merge=union 15 | 16 | # Standard to msysgit 17 | *.doc diff=astextplain 18 | *.DOC diff=astextplain 19 | *.docx diff=astextplain 20 | *.DOCX diff=astextplain 21 | *.dot diff=astextplain 22 | *.DOT diff=astextplain 23 | *.pdf diff=astextplain 24 | *.PDF diff=astextplain 25 | *.rtf diff=astextplain 26 | *.RTF diff=astextplain 27 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | ### Description 2 | 3 | Please provide a succinct description of your issue. 4 | 5 | ### Repro steps 6 | 7 | Please provide the steps required to reproduce the problem 8 | 9 | 1. Step A 10 | 11 | 2. Step B 12 | 13 | ### Expected behavior 14 | 15 | Please provide a description of the behavior you expect. 16 | 17 | ### Actual behavior 18 | 19 | Please provide a description of the actual behavior you observe. 20 | 21 | ### Known workarounds 22 | 23 | Please provide a description of any known workarounds. 24 | 25 | ### Related information 26 | 27 | * Operating system 28 | * Branch 29 | * .NET Runtime, CoreCLR or Mono Version 30 | * Performance information, links to performance testing scripts 31 | -------------------------------------------------------------------------------- /src/FSharp.CommandLine/extensions.fs: -------------------------------------------------------------------------------- 1 | namespace FSharp.CommandLine 2 | 3 | [] 4 | module InternalExtensions = 5 | open Microsoft.FSharp.Quotations 6 | open Microsoft.FSharp.Quotations.Patterns 7 | open Microsoft.FSharp.Linq.RuntimeHelpers 8 | 9 | type FuncHelper = private | FuncHelper with 10 | static member compileFunc (x: Expr<'a -> 'b>) = 11 | LeafExpressionConverter.EvaluateQuotation x :?> ('a -> 'b) 12 | 13 | static member getFirstArgumentName (x: Expr<'a -> 'b>) = 14 | let rec gn tupleArgName = function 15 | | Let (v, TupleGet(Var tn, index), body) when (tupleArgName = tn.Name) -> 16 | (index, v.Name) :: gn tupleArgName body 17 | | _ -> [] 18 | in 19 | match x with 20 | | Lambda (v, e) -> 21 | match (gn v.Name e) with 22 | | [] -> Some [v.Name] 23 | | xs -> xs |> List.sortBy fst |> List.map snd |> Some 24 | | _ -> None 25 | 26 | -------------------------------------------------------------------------------- /src/FSharp.Scanf/FSharp.Scanf.fsproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | netstandard2.0;netstandard1.6;net46;net45 6 | Type-safe scanf for F# 7 | cannorin 8 | 9 | (c) cannorin 2017-2019 10 | https://github.com/cannorin/FSharp.CommandLine/tree/master/src/FSharp.Scanf 11 | MIT 12 | fsharp commandline console scanf 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /src/FSharp.CommandLine/FSharp.CommandLine.fsproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | netstandard2.0;net46 6 | A framework for building command line application in F#. Supports command line option parsing, type-safe scanf, monadic command construction, automatic help & shell completion generation, and so on. 7 | cannorin 8 | 9 | (c) cannorin 2017-2019 10 | https://github.com/cannorin/FSharp.CommandLine 11 | https://github.com/cannorin/FSharp.CommandLine/blob/master/LICENSE.txt 12 | fsharp commandline parsing framework 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /src/FSharp.CommandLine/abstraction.fs: -------------------------------------------------------------------------------- 1 | namespace FSharp.CommandLine.Internals 2 | 3 | module Abstraction = 4 | type State<'Args, 'a> = 'Args -> ('a * 'Args) 5 | 6 | type StateConfig<'Config, 'Args, 'a> = { 7 | config: 'Config -> 'Config 8 | func: State<'Args, 'a> 9 | } 10 | 11 | module StateConfig = 12 | let inline scbind (f: 'a -> StateConfig<'Config, 'Args, 'b>) (g: 'Config -> 'Config) (m: StateConfig<'Config, 'Args, 'a>) = 13 | { 14 | config = m.config >> g 15 | func = 16 | fun args -> 17 | let (a, args) = m.func args 18 | (f a).func args 19 | } 20 | 21 | let inline returnValue (a: 'a) : StateConfig<_, _, 'a> = 22 | { 23 | config = id 24 | func = fun args -> (a, args) 25 | } 26 | 27 | let inline returnWith (f: unit -> 'a) : StateConfig<_, _, 'a> = 28 | { 29 | config = id 30 | func = fun args -> (f(), args) 31 | } 32 | 33 | let inline bind f m = m |> scbind f id 34 | 35 | let inline mapConfig g m = m |> scbind returnValue g 36 | 37 | let inline map f m = m |> bind (f >> returnValue) 38 | 39 | let inline zip (m: StateConfig<_, _, 'a>) (n: StateConfig<_, _, 'b>) (f: 'a -> 'b -> 'c) = 40 | scbind (fun a -> 41 | { 42 | config = id 43 | func = fun args -> let (b, args) = n.func args in (f a b, args) 44 | }) 45 | n.config 46 | m 47 | 48 | let inline combine (a: StateConfig<_,_,_>) (b: StateConfig<_,_,_>) = zip a b (fun _ b -> b) 49 | 50 | let args = 51 | { 52 | config = id 53 | func = fun args -> (args, args) 54 | } 55 | -------------------------------------------------------------------------------- /FSharp.CommandLine.sln: -------------------------------------------------------------------------------- 1 | 2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio 15 4 | VisualStudioVersion = 15.0.27428.2011 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "FSharp.CommandLine", "src\FSharp.CommandLine\FSharp.CommandLine.fsproj", "{32A93182-5504-4C36-98E0-D2486AA6B361}" 7 | EndProject 8 | Project("{f2a71f9b-5d33-465a-a702-920d77279786}") = "FSharp.Scanf", "src\FSharp.Scanf\FSharp.Scanf.fsproj", "{9540C26A-B0A5-4E78-A596-C62F036A2DF1}" 9 | EndProject 10 | Global 11 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 12 | Debug|Any CPU = Debug|Any CPU 13 | Release|Any CPU = Release|Any CPU 14 | EndGlobalSection 15 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 16 | {32A93182-5504-4C36-98E0-D2486AA6B361}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 17 | {32A93182-5504-4C36-98E0-D2486AA6B361}.Debug|Any CPU.Build.0 = Debug|Any CPU 18 | {32A93182-5504-4C36-98E0-D2486AA6B361}.Release|Any CPU.ActiveCfg = Release|Any CPU 19 | {32A93182-5504-4C36-98E0-D2486AA6B361}.Release|Any CPU.Build.0 = Release|Any CPU 20 | {9540C26A-B0A5-4E78-A596-C62F036A2DF1}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 21 | {9540C26A-B0A5-4E78-A596-C62F036A2DF1}.Debug|Any CPU.Build.0 = Debug|Any CPU 22 | {9540C26A-B0A5-4E78-A596-C62F036A2DF1}.Release|Any CPU.ActiveCfg = Release|Any CPU 23 | {9540C26A-B0A5-4E78-A596-C62F036A2DF1}.Release|Any CPU.Build.0 = Release|Any CPU 24 | EndGlobalSection 25 | GlobalSection(SolutionProperties) = preSolution 26 | HideSolutionNode = FALSE 27 | EndGlobalSection 28 | GlobalSection(ExtensibilityGlobals) = postSolution 29 | SolutionGuid = {80272E67-BBF7-47F2-A615-C56E4B39D7D6} 30 | EndGlobalSection 31 | EndGlobal 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | FSharp.CommandLine 2 | ====================== 3 | 4 | The FSharp.CommandLine library can be [installed from NuGet](https://nuget.org/packages/FSharp.CommandLine) 5 | 6 | ``` 7 | PM> Install-Package FSharp.CommandLine 8 | ``` 9 | 10 | FSharp.CommandLine is a monadic commandline application framework that automatically generates both help texts and shell suggestions. 11 | 12 | This library also contains type-safe scanf and type-safe commandline option parser. 13 | 14 | Example 15 | ------- 16 | 17 | ```fsharp 18 | open System 19 | open FSharp.CommandLine 20 | 21 | let fileOption = 22 | commandOption { 23 | names ["f"; "file"] 24 | description "Name of a file to use (Default index: 0)" 25 | takes (format("%s:%i").withNames ["filename"; "index"]) 26 | takes (format("%s").map (fun filename -> (filename, 0))) 27 | suggests (fun _ -> [CommandSuggestion.Files None]) 28 | } 29 | 30 | type Verbosity = Quiet | Normal | Full | Custom of int 31 | 32 | let verbosityOption = 33 | commandOption { 34 | names ["v"; "verbosity"] 35 | description "Display this amount of information in the log." 36 | takes (regex @"q(uiet)?$" |> asConst Quiet) 37 | takes (regex @"n(ormal)?$" |> asConst Quiet) 38 | takes (regex @"f(ull)?$" |> asConst Full) 39 | takes (format("custom:%i").map (fun level -> Custom level)) 40 | takes (format("c:%i").map (fun level -> Custom level)) 41 | } 42 | 43 | let mainCommand () = 44 | command { 45 | name "main" 46 | description "The main command." 47 | opt files in fileOption |> CommandOption.zeroOrMore 48 | opt verbosity in verbosityOption |> CommandOption.zeroOrExactlyOne 49 | |> CommandOption.whenMissingUse Normal 50 | do printfn "%A, %A" files verbosity 51 | return 0 52 | } 53 | 54 | [] 55 | let main argv = 56 | mainCommand() |> Command.runAsEntryPoint argv 57 | ``` 58 | 59 | ## License 60 | 61 | Apache 2. See LICENSE.txt for details. 62 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ## Ignore Visual Studio temporary files, build results, and 2 | ## files generated by popular Visual Studio add-ons. 3 | 4 | # User-specific files 5 | *.suo 6 | *.user 7 | *.sln.docstates 8 | 9 | # Xamarin Studio / monodevelop user-specific 10 | *.userprefs 11 | *.dll.mdb 12 | *.exe.mdb 13 | 14 | # Build results 15 | 16 | [Dd]ebug/ 17 | [Rr]elease/ 18 | x64/ 19 | build/ 20 | [Bb]in/ 21 | [Oo]bj/ 22 | 23 | # MSTest test Results 24 | [Tt]est[Rr]esult*/ 25 | [Bb]uild[Ll]og.* 26 | 27 | *_i.c 28 | *_p.c 29 | *.ilk 30 | *.meta 31 | *.obj 32 | *.pch 33 | *.pdb 34 | *.pgc 35 | *.pgd 36 | *.rsp 37 | *.sbr 38 | *.tlb 39 | *.tli 40 | *.tlh 41 | *.tmp 42 | *.tmp_proj 43 | *.log 44 | *.vspscc 45 | *.vssscc 46 | .builds 47 | *.pidb 48 | *.log 49 | *.scc 50 | 51 | # Visual C++ cache files 52 | ipch/ 53 | *.aps 54 | *.ncb 55 | *.opensdf 56 | *.sdf 57 | *.cachefile 58 | 59 | # Visual Studio profiler 60 | *.psess 61 | *.vsp 62 | *.vspx 63 | 64 | # Other Visual Studio data 65 | .vs/ 66 | 67 | # Guidance Automation Toolkit 68 | *.gpState 69 | 70 | # ReSharper is a .NET coding add-in 71 | _ReSharper*/ 72 | *.[Rr]e[Ss]harper 73 | 74 | # TeamCity is a build add-in 75 | _TeamCity* 76 | 77 | # DotCover is a Code Coverage Tool 78 | *.dotCover 79 | 80 | # NCrunch 81 | *.ncrunch* 82 | .*crunch*.local.xml 83 | 84 | # Installshield output folder 85 | [Ee]xpress/ 86 | 87 | # DocProject is a documentation generator add-in 88 | DocProject/buildhelp/ 89 | DocProject/Help/*.HxT 90 | DocProject/Help/*.HxC 91 | DocProject/Help/*.hhc 92 | DocProject/Help/*.hhk 93 | DocProject/Help/*.hhp 94 | DocProject/Help/Html2 95 | DocProject/Help/html 96 | 97 | # Click-Once directory 98 | publish/ 99 | 100 | # Publish Web Output 101 | *.Publish.xml 102 | 103 | # Enable nuget.exe in the .nuget folder (though normally executables are not tracked) 104 | !.nuget/NuGet.exe 105 | 106 | # Windows Azure Build Output 107 | csx 108 | *.build.csdef 109 | 110 | # Windows Store app package directory 111 | AppPackages/ 112 | 113 | # VSCode 114 | .vscode/ 115 | 116 | # Others 117 | sql/ 118 | *.Cache 119 | ClientBin/ 120 | [Ss]tyle[Cc]op.* 121 | ~$* 122 | *~ 123 | *.dbmdl 124 | *.[Pp]ublish.xml 125 | *.pfx 126 | *.publishsettings 127 | 128 | # RIA/Silverlight projects 129 | Generated_Code/ 130 | 131 | # Backup & report files from converting an old project file to a newer 132 | # Visual Studio version. Backup files are not needed, because we have git ;-) 133 | _UpgradeReport_Files/ 134 | Backup*/ 135 | UpgradeLog*.XML 136 | UpgradeLog*.htm 137 | 138 | # SQL Server files 139 | App_Data/*.mdf 140 | App_Data/*.ldf 141 | 142 | 143 | #LightSwitch generated files 144 | GeneratedArtifacts/ 145 | _Pvt_Extensions/ 146 | ModelManifest.xml 147 | 148 | # ========================= 149 | # Windows detritus 150 | # ========================= 151 | 152 | # Windows image file caches 153 | Thumbs.db 154 | ehthumbs.db 155 | 156 | # Folder config file 157 | Desktop.ini 158 | 159 | # Recycle Bin used on file shares 160 | $RECYCLE.BIN/ 161 | 162 | # Mac desktop service store files 163 | .DS_Store 164 | 165 | # =================================================== 166 | # Exclude F# project specific directories and files 167 | # =================================================== 168 | 169 | # NuGet Packages Directory 170 | packages/ 171 | 172 | # Test results produced by build 173 | TestResults.xml 174 | 175 | # Nuget outputs 176 | nuget/*.nupkg 177 | release.cmd 178 | release.sh 179 | localpackages/ 180 | paket-files 181 | *.orig 182 | .paket/paket.exe 183 | docsrc/content/license.md 184 | docsrc/content/release-notes.md 185 | .fake 186 | .paket 187 | docsrc/tools/FSharp.Formatting.svclog 188 | .ionide 189 | -------------------------------------------------------------------------------- /test.fsx: -------------------------------------------------------------------------------- 1 | #r "src/FSharp.CommandLine/bin/Debug/net46/FSharp.Scanf.dll" 2 | #r "src/FSharp.CommandLine/bin/Debug/net46/FSharp.CommandLine.dll" 3 | 4 | #load "src/common/prelude.fs" 5 | open System 6 | open FSharp.CommandLine 7 | 8 | let fileOption = 9 | commandOption { 10 | names ["f"; "file"] 11 | description "Name of a file to use (Default index: 0)" 12 | takes (format("%s:%i").withNames ["filename"; "index"]) 13 | takes (format("%s").map (fun filename -> (filename, 0))) 14 | suggests (fun _ -> [CommandSuggestion.Files None]) 15 | } 16 | 17 | type Verbosity = Quiet | Normal | Full | Custom of int 18 | 19 | let verbosityOption = 20 | commandOption { 21 | names ["v"; "verbosity"] 22 | description "Display this amount of information in the log." 23 | takes (regex @"q(uiet)?$" |> asConst Quiet) 24 | takes (regex @"n(ormal)?$" |> asConst Normal) 25 | takes (regex @"f(ull)?$" |> asConst Full) 26 | takes (format("custom:%i").map (fun level -> Custom level)) 27 | takes (format("c:%i").map (fun level -> Custom level)) 28 | } 29 | 30 | let inline nearest r g b = 31 | let brb = if r>128 || g>128 || b>128 then 8 else 0 32 | let rb = if r>64 then 4 else 0 33 | let gb = if g>64 then 2 else 0 34 | let bb = if b>64 then 1 else 0 35 | (brb + rb + gb + bb) |> enum 36 | 37 | let colorOption = 38 | commandOption { 39 | names ["color"; "c"]; description "Colorize the output." 40 | takes (format "red" |> asConst ConsoleColor.Red) 41 | takes (format "green" |> asConst ConsoleColor.Green) 42 | takes (format "blue" |> asConst ConsoleColor.Blue) 43 | takes (format("%i,%i,%i").map (fun (r,g,b) -> nearest r g b)) 44 | suggests (fun _ -> [CommandSuggestion.Values["red"; "green"; "blue"]]) 45 | } 46 | 47 | let echoCommand = 48 | command { 49 | name "echo" 50 | displayName "main echo" 51 | description "Echo the input." 52 | opt color in colorOption |> CommandOption.zeroOrExactlyOne 53 | do! Command.failOnUnknownOptions() 54 | let! args = Command.args 55 | if args |> List.contains "help" then 56 | do! Command.failShowingHelp "showing help." 57 | do 58 | let s = args |> String.concat " " 59 | match color with 60 | | Some c -> cprintfn c "%s" s 61 | | None -> printfn "%s" s 62 | return 0 63 | } 64 | 65 | let plus1 = 66 | command { 67 | opt number in 68 | commandOption { 69 | names ["n"; "number"]; description "integer number." 70 | takes (format("%i").withNames["num"]) 71 | } |> CommandOption.whenMissingUse 0 72 | do printfn "num: %i" number 73 | return number 74 | } 75 | 76 | let x = 77 | command { 78 | do! Command.failOnUnknownOptions() 79 | do! Command.failOnUnknownOptions() 80 | } 81 | 82 | let mainCommand = 83 | command { 84 | name "main" 85 | description "The main command." 86 | opt files in fileOption |> CommandOption.zeroOrMore 87 | opt verbosity in verbosityOption |> CommandOption.zeroOrExactlyOne 88 | |> CommandOption.whenMissingUse Normal 89 | import num in plus1 90 | subcommands [echoCommand] 91 | do! Command.failOnUnknownOptions() 92 | let! args = Command.args 93 | if args |> List.contains "help" then 94 | do! Command.failShowingHelp "showing help." 95 | do printfn "%A, %A" files verbosity 96 | return 0 97 | } 98 | 99 | while true do 100 | printf "test> " 101 | let inputs = Console.ReadLine() |> String.split ' ' |> String.removeEmptyEntries 102 | let mc = mainCommand 103 | try 104 | mc |> Command.runAsEntryPointDebug inputs ||> (fun code args -> printfn "(exited with %i, unused args:%A)\n" code args) 105 | with 106 | | RequestExit code -> printfn "(exited with %i)\n" code 107 | | RequestShowHelp msg -> 108 | cprintfn ConsoleColor.Red "error: %s\n" msg 109 | for line in Help.generate (inputs |> List.ofArray) mc do 110 | printfn "%s" line 111 | | OptionParseFailed (_, msg) 112 | | CommandExecutionFailed msg -> cprintfn ConsoleColor.Red "error: %s\n" msg 113 | | e -> reraise' e 114 | 115 | -------------------------------------------------------------------------------- /src/FSharp.CommandLine/optionValues.fs: -------------------------------------------------------------------------------- 1 | namespace FSharp.CommandLine 2 | 3 | [] 4 | module OptionValues = 5 | open System 6 | open FSharp.Scanf 7 | open FSharp.Scanf.Optimized 8 | open Microsoft.FSharp.Quotations 9 | open System.Text.RegularExpressions 10 | 11 | type ValueFormat<'p,'st,'rd,'rl,'t,'a> = { 12 | format: PrintfFormat<'p,'st,'rd,'rl,'t> 13 | paramNames: (string list) option 14 | handler: 't -> 'a 15 | } 16 | with 17 | static member inline construct (this: ValueFormat<_,_,_,_,_,_>) = 18 | let parser s = 19 | s |> tryKsscanf this.format this.handler 20 | |> function Ok x -> Some x | _ -> None 21 | in 22 | let formatTokens = 23 | let defaultNames = 24 | this.format.GetFormatterNames() 25 | |> List.map (String.replace ' ' '_' >> String.toUpperInvariant) 26 | |> List.map (sprintf "%s_VALUE") 27 | in 28 | let names = (this.paramNames ?| defaultNames) |> List.map (sprintf "<%s>") in 29 | this.format.PrettyTokenize names 30 | in 31 | (parser, formatTokens) 32 | 33 | member this.map ([]mapper: Expr<'a -> 'b>) = 34 | let mf x = (FuncHelper.compileFunc mapper) x in 35 | let pns = FuncHelper.getFirstArgumentName mapper in 36 | { format = this.format; handler = this.handler >> mf; paramNames = pns } 37 | 38 | member this.withNames names = 39 | { this with paramNames = Some names } 40 | 41 | member this.asConst value = 42 | { format = this.format; handler = (fun _ -> value); paramNames = this.paramNames } 43 | 44 | let inline format (fmt: PrintfFormat<_,_,_,_,'t>) : ValueFormat<_,_,_,_,'t,'t> = 45 | { format = fmt; handler = id; paramNames = None } 46 | 47 | type ValueRegex<'a> = { 48 | regex: Regex 49 | handler: string list -> 'a 50 | } 51 | with 52 | static member construct (this: ValueRegex<_>) = 53 | let parser (str: string) = 54 | let m: Match = this.regex.Match(str) 55 | if m.Success then 56 | m.Groups 57 | |> Seq.cast 58 | |> List.ofSeq 59 | |> List.zip (this.regex.GetGroupNames() |> List.ofArray) 60 | |> List.filter (fun (name, _) -> name |> String.forall Char.IsDigit |> not) 61 | |> List.map (fun (_, x) -> x.Value) 62 | |> this.handler |> Some 63 | else None 64 | let tokens = [to_s this.regex] 65 | (parser, tokens) 66 | 67 | member this.map mapper = 68 | { regex = this.regex; handler = this.handler >> mapper } 69 | 70 | member this.asConst value = 71 | { regex = this.regex; handler = fun _ -> value } 72 | 73 | let inline regex r = 74 | { regex = Regex(r); handler = id } 75 | 76 | type ValueTypedRegex<'a, '_Regex, '_Match > = { 77 | typedRegex: '_Regex 78 | handler: '_Match -> 'a 79 | } 80 | with 81 | static member inline construct (this: ValueTypedRegex<_, ^Regex, ^Match>) : _ 82 | when ^Match :> Match = 83 | let parser str = 84 | let m = (^Regex: (member TypedMatch: string -> ^Match) this.typedRegex,str) 85 | if m.Success then 86 | this.handler m |> Some 87 | else None 88 | let tokens = [to_s this.typedRegex] 89 | (parser, tokens) 90 | 91 | member inline this.map mapper = 92 | { typedRegex = this.typedRegex; handler = this.handler >> mapper } 93 | 94 | member inline this.asConst value = 95 | { typedRegex = this.typedRegex; handler = fun _ -> value } 96 | 97 | let inline typedRegex< ^Regex, ^Match when ^Regex: (new: unit -> ^Regex) and ^Regex: (member TypedMatch: string -> ^Match) > : ValueTypedRegex< ^Match, ^Regex, ^Match > = 98 | { typedRegex = new ^Regex(); handler = id } 99 | 100 | let inline asConst value (optionValue: ^X) = 101 | (^X: (member asConst: _ -> _) optionValue,value) 102 | 103 | let inline internal construct (optionValue: ^X) = 104 | (^X: (static member construct: _ -> _) optionValue) 105 | 106 | -------------------------------------------------------------------------------- /src/FSharp.CommandLine/basictypes.fs: -------------------------------------------------------------------------------- 1 | namespace FSharp.CommandLine 2 | 3 | [] 4 | module BasicTypes = 5 | open FSharp.CommandLine.Internals.Abstraction 6 | open System.Runtime.CompilerServices 7 | 8 | type Args = string list 9 | 10 | type HelpElement = 11 | /// prints `usage: $(command name) $(args)`. 12 | | HelpUsage 13 | /// prints `usage: $(command name) $(args)` of which `args` can be customized. 14 | | HelpUsageCustomArgs of args: string list 15 | /// prints a string. 16 | | HelpRawString of text: string 17 | /// prints the infomation of all the subcommands. 18 | | HelpAllSubcommands 19 | /// prints the infomation of the specified subcommands. 20 | | HelpSpecificSubcommands of names: string list 21 | /// prints the infomation of all the command options. 22 | | HelpAllOptions 23 | /// prints the infomation of the specified command options. 24 | | HelpSpecificOptions of namesWithoutHyphen: string list 25 | /// prints elements as a section. the content will be indented. 26 | /// nested sections make the indentation deeper. 27 | | HelpSection of sectionName: string * sectionBody: seq 28 | /// prints an empty line. 29 | | HelpEmptyLine 30 | 31 | module internal Seq = 32 | let inline snoc x xs = seq { yield! xs; yield x } 33 | 34 | [] 35 | type HelpBuilder = 36 | member inline __.For (_, _) = failwith "Not supported" 37 | member inline __.Yield _ : HelpElement seq = Seq.empty 38 | /// prints `usage: $(command name) $(args)`. 39 | [] 40 | member inline __.Usage xs = xs |> Seq.snoc HelpUsage 41 | /// prints `usage: $(command name) $(args)` of which `args` can be customized. 42 | [] 43 | member inline __.UsageWithCustomArgs (xs, argNames) = xs |> Seq.snoc (HelpUsageCustomArgs argNames) 44 | /// prints a string. 45 | [] 46 | member inline __.RawText (xs, str) = xs |> Seq.snoc (HelpRawString str) 47 | /// prints the infomation of all the subcommands. 48 | [] 49 | member inline __.Subcommands xs = xs |> Seq.snoc HelpAllSubcommands 50 | /// prints the infomation of the specified subcommands. 51 | [] 52 | member inline __.SpecificSubcommands (xs, cmds) = xs |> Seq.snoc (HelpSpecificSubcommands cmds) 53 | /// prints the infomation of all the command options. 54 | [] 55 | member inline __.Options xs = xs |> Seq.snoc HelpAllOptions 56 | /// prints the infomation of the specified command options. 57 | [] 58 | member inline __.SpecificOptions (xs, opts) = xs |> Seq.snoc (HelpSpecificOptions opts) 59 | /// prints elements as a section. the content will be indented. 60 | /// nested sections make the indentation deeper. 61 | [] 62 | member inline __.Section (xs, sectionName, section) = xs |> Seq.snoc (HelpSection(sectionName, section)) 63 | /// prints elements as a section when the condition holds. the content will be indented. 64 | /// nested sections make the indentation deeper. 65 | [] 66 | member inline __.ConditionalSection (xs, sectionName, cond, section) = 67 | if cond() then 68 | xs |> Seq.snoc (HelpSection(sectionName, section)) 69 | else 70 | xs 71 | /// prints an empty line. 72 | [] 73 | member inline __.EmptyLine xs = xs |> Seq.snoc HelpEmptyLine 74 | 75 | let helpText = HelpBuilder () 76 | 77 | type CommandSuggestion = 78 | /// suggests a set of string. 79 | | Values of string list 80 | /// suggests a set of string with description. 81 | | ValuesWithDescription of (string * string) list 82 | /// suggests files optionally with pattern. 83 | | Files of pattern: string option 84 | /// suggests directories. 85 | | Directories of pattern: string option 86 | /// suggests a command option. 87 | | OptionSuggestion of (string list) * string 88 | /// prints a message. 89 | | Message of string 90 | 91 | type CommandOptionSummary = { 92 | names: string list; 93 | description: string; 94 | isFlag: bool; 95 | paramNames: (string list) list 96 | isMatch: string list -> string list option 97 | genSuggestions: string option -> CommandSuggestion list 98 | } 99 | with 100 | member this.Param = 101 | let rec print eq xss = 102 | let heads = xss |> List.map List.tryHead 103 | if heads |> List.exists Option.isSome then 104 | let isOptional = heads |> List.exists Option.isNone 105 | let groups = xss |> List.filter (List.isEmpty >> not) 106 | |> List.groupBy List.head 107 | |> List.map (fun (g, xs) -> sprintf "%s%s" g (xs |> List.map List.tail |> print "")) 108 | let s = 109 | if List.length groups > 1 then 110 | let s = groups |> String.concat "|" 111 | if isOptional then s else sprintf "{%s}" s 112 | else 113 | groups |> String.concat "" 114 | if isOptional then sprintf "[%s%s]" eq s else sprintf "%s%s"eq s 115 | else 116 | "" 117 | in print "=" (this.paramNames |> List.rev) 118 | 119 | member this.NameRepresentations = 120 | this.names |> List.collect (function 121 | | x when x.Length = 1 -> 122 | [ "-"; "/" ] |> List.map (fun prefix -> sprintf "%s%s" prefix x) 123 | | x -> 124 | [ "--"; "/" ] |> List.map (fun prefix -> sprintf "%s%s" prefix x)) 125 | 126 | member this.Print () = 127 | let o x = if this.isFlag then sprintf "%s[+|-]" x else sprintf "%s%s" x this.Param 128 | ((this.NameRepresentations |> List.filter (String.startsWith "-") |> String.concat ", " |> o), this.description) 129 | 130 | [] 131 | type CommandSummary = { 132 | name: string; 133 | displayName: string option; 134 | description: string; 135 | paramNames: (string list) option 136 | help: HelpElement seq option 137 | genSuggestions: Args -> CommandSuggestion list 138 | } 139 | 140 | [] 141 | type CommandInfo = { 142 | summary: CommandSummary 143 | options: CommandOptionSummary list 144 | subcommands: Command list 145 | } 146 | and Command<'a> = StateConfig 147 | 148 | type CommandInfo with 149 | static member empty = 150 | { 151 | summary = Unchecked.defaultof 152 | options = [] 153 | subcommands = [] 154 | } 155 | 156 | [] 157 | type ICommandExt() = 158 | [] 159 | static member inline Summary(x: Command<_>) = 160 | (x.config CommandInfo.empty).summary 161 | -------------------------------------------------------------------------------- /src/FSharp.CommandLine/commands.fs: -------------------------------------------------------------------------------- 1 | namespace FSharp.CommandLine 2 | 3 | [] 4 | module Commands = 5 | open System 6 | open FSharp.CommandLine.Options 7 | open FSharp.CommandLine.Generators 8 | open FSharp.CommandLine.Internals.Abstraction 9 | 10 | let inline private mapSummary f co = 11 | co |> StateConfig.mapConfig (fun cfg -> { cfg with summary = f cfg.summary }) 12 | 13 | type CommandBuilder() = 14 | member inline __.Bind (c, f) : Command<_> = StateConfig.bind f c 15 | member inline __.Return x = StateConfig.returnValue x 16 | member inline __.For (c, f) : Command<_> = StateConfig.bind f c 17 | member inline __.Yield x = StateConfig.returnValue x 18 | member inline __.ReturnFrom (x: Command<_>) = x 19 | member inline __.Combine (a, b) : Command<_> = StateConfig.combine a b 20 | member inline __.Combine (f: unit -> _, b: Command<_>) : Command<_> = StateConfig.combine (f()) b 21 | member inline __.Combine (a: Command<_>, f: unit -> _) : Command<_> = StateConfig.combine a (f()) 22 | member inline __.Zero () = StateConfig.returnValue () 23 | member inline __.Delay (f: unit -> Command<_>) = f 24 | member inline __.Undelay x : Command<_> = x() 25 | member inline __.Run f : Command<_> = f() 26 | member inline __.TryWith (f, h) = try f() with exn -> h exn 27 | member inline __.TryFinally (f, h) = try f() finally h() 28 | member inline this.Using (disp: #System.IDisposable, m) = 29 | this.TryFinally( 30 | this.Delay(fun () -> m disp), 31 | fun () -> dispose disp 32 | ) 33 | member inline this.While (cond, m: unit -> Command<_>) = 34 | let rec loop cond m : Command<_> = 35 | if cond () then this.Combine(this.Undelay m, loop cond m) 36 | else this.Zero () 37 | loop cond m 38 | member inline this.For (xs: #seq<_>, exec) = 39 | this.Using( 40 | (xs :> seq<_>).GetEnumerator(), 41 | fun en -> 42 | this.While( 43 | en.MoveNext, 44 | this.Delay(fun () -> exec en.Current)) 45 | ) 46 | /// uses a command option. 47 | [] 48 | member inline __.UseOption (co: Command<'a>, opt: #ICommandOption<'b>, f: 'a -> 'b -> 'c) = 49 | { 50 | config = co.config >> opt.Config 51 | func = 52 | fun args -> 53 | let (a, args) = co.func args 54 | let (b, args) = opt.Parse args 55 | (f a b, args) 56 | } 57 | /// imports a command to this command. will inherit options and other metadatas. 58 | [] 59 | member inline __.ImportCommand (c1, c2, f) : Command<_> = StateConfig.zip c1 c2 f 60 | /// required. sets the name of the command. will also be used when this command is 61 | /// a subcommand of the other one. 62 | [] 63 | member inline __.Name (co, x) = 64 | co |> mapSummary (fun s -> { s with name = x }) 65 | /// optional. sets the name of the command that will be displayed in the help text. 66 | /// the one speficied by `name` will be used if not specified. 67 | [] 68 | member inline __.DisplayName (co, n) = 69 | co |> mapSummary (fun s -> { s with displayName = Some n }) 70 | /// required. sets the description of the command. 71 | [] 72 | member inline __.Description (co, x) = 73 | co |> mapSummary (fun s -> { s with description = x }) 74 | /// optional. speficies the suggestions it will generate. 75 | [] 76 | member inline __.Suggests (co: Command<_>, f) = 77 | co |> mapSummary (fun s -> { s with genSuggestions = f }) 78 | /// optional. customizes the help text. 79 | [] 80 | member inline __.Help (co: Command<_>, xs: HelpElement seq) = 81 | co |> mapSummary (fun s -> { s with help = Some xs }) 82 | [] 83 | [] 84 | member inline __.Preprocess xs = xs 85 | /// optional. specifies the subcommands. 86 | [] 87 | member inline __.Subcommands (co, xs) = 88 | { 89 | config = 90 | fun cfg -> 91 | let cfg = co.config cfg 92 | { cfg with subcommands = cfg.subcommands @ xs } 93 | func = 94 | fun args -> 95 | let sc = 96 | match args with 97 | | h :: _ -> 98 | List.tryFind (fun (x:Command<_>) -> x.Summary().name = h) xs 99 | | _ -> None 100 | if sc.IsSome then 101 | let (code, _) = sc.Value.func (List.tail args) 102 | RequestExit code |> raise 103 | else 104 | co.func args 105 | } 106 | 107 | let command = CommandBuilder () 108 | 109 | module Command = 110 | let args : Command = StateConfig.args 111 | let inline bind f m : Command<_> = StateConfig.bind f m 112 | let inline returnValue x : Command<_> = StateConfig.returnValue x 113 | let inline returnWith f : Command<_> = StateConfig.returnWith f 114 | let inline map f m : Command<_> = StateConfig.map f m 115 | let inline mapInfo f m : Command<_> = StateConfig.mapConfig f m 116 | let inline zip a b f : Command<_> = StateConfig.zip a b f 117 | let inline combine a b : Command<_> = StateConfig.combine a b 118 | 119 | let private runMain args (cmd: Command) = 120 | match args |> List.ofArray with 121 | | OptionParse ReservedCommandOptions.suggestOption (sug, rest) -> 122 | Suggestions.generate rest cmd 123 | |> Suggestions.print (SuggestionBackends.findByName sug) 124 | |> printfn "%A" 125 | (0, []) 126 | | OptionParse ReservedCommandOptions.helpOption (true, rest) -> 127 | for line in Help.generate rest cmd do 128 | printfn "%s" line 129 | (0, []) 130 | | args -> 131 | cmd.func args 132 | 133 | #if DEBUG 134 | let runAsEntryPointDebug args (cmd: Command) = runMain args cmd 135 | #endif 136 | 137 | /// executes the command as an entry point: 138 | /// 139 | /// ``` 140 | /// [] 141 | /// let main argv = 142 | /// Command.runAsEntryPoint argv command 143 | /// ``` 144 | let runAsEntryPoint args (cmd: Command) = 145 | try 146 | runMain args cmd |> fst 147 | with 148 | | RequestExit code -> code 149 | | RequestShowHelp msg -> 150 | cprintfn ConsoleColor.Red "error: %s\n" msg 151 | for line in Help.generate (args |> List.ofArray) cmd do 152 | printfn "%s" line 153 | -1 154 | | OptionParseFailed (_, msg) 155 | | CommandExecutionFailed msg -> cprintfn ConsoleColor.Red "error: %s\n" msg; -1 156 | | e -> reraise' e 157 | 158 | /// stops the execution immediately and then exits with the specified code. 159 | let inline exit code = 160 | RequestExit code |> raise 161 | 162 | /// stops the execution immediately and then exits with the specified error message and code `-1`. 163 | let inline fail msg = 164 | CommandExecutionFailed msg |> raise 165 | 166 | /// stops the execution immediately and then exits with the specified error message and code `-1`. 167 | let inline failf fmt = 168 | Printf.kprintf (fun msg -> CommandExecutionFailed msg |> raise ) fmt 169 | 170 | /// if there are remaining unknown options, then stops the execution 171 | /// immediately and then exits with code `-1`. 172 | let failOnUnknownOptions () = 173 | command { 174 | let! argv = StateConfig.args in 175 | let uks = argv |> CommandOption.getRemainingOptions in 176 | if uks |> List.isEmpty then 177 | return () 178 | else 179 | sprintf "unknown option: '%s'" (List.head uks) |> CommandExecutionFailed |> raise 180 | } 181 | 182 | /// shows the error message and the help of the current (sub)command, then exits with code `-1`. 183 | let inline failShowingHelp message = 184 | RequestShowHelp message |> raise 185 | 186 | -------------------------------------------------------------------------------- /src/FSharp.CommandLine/generators.fs: -------------------------------------------------------------------------------- 1 | namespace FSharp.CommandLine 2 | 3 | [] 4 | module Generators = 5 | let rec private dig argv (cmd: Command) = 6 | let config = (cmd.config CommandInfo.empty) 7 | match argv with 8 | | [] -> (cmd, []) 9 | | args -> 10 | match config.options |> List.choose (fun o -> o.isMatch args) 11 | |> List.tryHead with 12 | | Some rest -> dig rest cmd 13 | | None -> 14 | match config.subcommands |> List.tryFind (fun sc -> sc.Summary().name = List.head args) with 15 | | Some sc -> dig (List.tail args) sc 16 | | None -> (cmd, args) 17 | 18 | let private getCommandInfo (cmd: Command<_>) = 19 | let config = (cmd.config CommandInfo.empty) 20 | (config.summary, config.subcommands, config.options) 21 | 22 | module Help = 23 | let private prettySprint a b = 24 | let indent = " " 25 | let indentLen = String.length indent 26 | let aLen = String.length a 27 | let bLines = String.replace "\r" "" b |> String.split "\n" |> List.ofArray 28 | if List.isEmpty bLines then 29 | seq { 30 | yield sprintf "%s" a 31 | } 32 | elif aLen > indentLen then 33 | seq { 34 | yield sprintf "%s" a 35 | yield! (bLines |> List.map (sprintf "%s %s" indent)) 36 | } 37 | else 38 | seq { 39 | yield sprintf "%s %s" a (String.replicate (indentLen - aLen) " " |> sprintf "%s%s" <| bLines.Head) 40 | yield! (bLines.Tail |> List.map (sprintf "%s %s" indent)) 41 | } 42 | 43 | let private genParamNames pns subs options = 44 | match pns with 45 | | Some xs -> xs |> String.concat " " 46 | | None -> 47 | match (List.isEmpty subs, List.isEmpty options) with 48 | | (true, true) -> "" 49 | | (true, false) -> "[options]" 50 | | (false, true) -> "" 51 | | (false, false) -> "[options] " 52 | 53 | /// given a help generator and a command, generates the help text. 54 | let interpret (generator: Command<_> -> #seq) (cmd: Command<_>) = 55 | let (smry, scs, opts) = getCommandInfo cmd 56 | let dn = smry.displayName ?| smry.name 57 | let rec print elems = 58 | seq { 59 | for elem in elems do 60 | yield! 61 | match elem with 62 | | HelpUsage -> seq [sprintf "usage: %s %s" dn (genParamNames smry.paramNames scs opts)] 63 | | HelpUsageCustomArgs args -> seq [sprintf "usage: %s %s" dn (args |> String.concat " ")] 64 | | HelpRawString txt -> seq [txt] 65 | | HelpAllSubcommands -> 66 | seq { 67 | if List.isEmpty scs |> not then 68 | for sc in scs do 69 | let (scsmry, scsubs, scopts) = getCommandInfo sc 70 | yield! prettySprint (sprintf "%s %s" scsmry.name (genParamNames scsmry.paramNames scsubs scopts)) scsmry.description 71 | } 72 | | HelpSpecificSubcommands names -> 73 | let scs' = scs |> List.filter (fun sc -> names |> List.contains ((sc.config CommandInfo.empty).summary.name)) 74 | seq { 75 | if scs' |> List.isEmpty |> not then 76 | for sc in scs' do 77 | let (scsmry, scsubs, scopts) = getCommandInfo sc 78 | yield! prettySprint (sprintf "%s %s" scsmry.name (genParamNames scsmry.paramNames scsubs scopts)) scsmry.description 79 | } 80 | | HelpAllOptions -> 81 | seq { 82 | if List.isEmpty opts |> not then 83 | for opt in opts do 84 | let (pr, desc) = opt.Print() 85 | yield! prettySprint pr desc 86 | } 87 | | HelpSpecificOptions names -> 88 | let opts' = opts |> List.filter (fun opt -> names |> List.exists (fun name -> opt.names |> List.contains name)) 89 | seq { 90 | if List.isEmpty opts' |> not then 91 | for opt in opts' do 92 | let (pr, desc) = opt.Print() 93 | yield! prettySprint pr desc 94 | } 95 | | HelpSection (name, bodies) -> 96 | seq { 97 | yield sprintf "%s:" name 98 | yield! print bodies |> Seq.map (fun line -> sprintf " %s" line) 99 | } 100 | | HelpEmptyLine -> seq [""] 101 | 102 | } 103 | generator cmd |> print 104 | 105 | /// a default help generator for the command. 106 | let defaultGenerator (cmd: Command<_>) = 107 | let (smry, scs, opts) = getCommandInfo cmd 108 | helpText { 109 | defaultUsage 110 | emptyLine 111 | text smry.description 112 | emptyLine 113 | conditionalSection "commands" (fun () -> scs |> List.isEmpty |> not) ( 114 | helpText { 115 | allSubcommands 116 | emptyLine 117 | } 118 | ) 119 | conditionalSection "options" (fun () -> opts |> List.isEmpty |> not) ( 120 | helpText { 121 | allOptions 122 | } 123 | ) 124 | } 125 | 126 | /// generates a help text from the arguments and the command. 127 | let generate args cmd = 128 | let (cmd, _) = dig args cmd 129 | let (smry, _, _) = getCommandInfo cmd 130 | match smry.help with 131 | | Some help -> interpret (fun _ -> help) cmd 132 | | None -> interpret defaultGenerator cmd 133 | 134 | type ISuggestionBackend = 135 | abstract print: CommandSuggestion list -> string 136 | 137 | module Suggestions = 138 | /// prints the suggestions to the backend. 139 | let print (backend: #ISuggestionBackend) css = 140 | backend.print css 141 | 142 | /// generates suggestions from the arguments and the command. 143 | let generate args (cmd: Command) = 144 | List.ofSeq <| 145 | try 146 | let ((cmdsum, cmdsubs, cmdopts), remArgs) = 147 | let (cmd, rem) = dig args cmd 148 | (getCommandInfo cmd, rem) 149 | seq { 150 | for sub in cmdsubs do 151 | let (scsum, _, _) = getCommandInfo sub 152 | yield ValuesWithDescription [(scsum.name, scsum.description)] 153 | for opt in cmdopts do 154 | yield OptionSuggestion(opt.NameRepresentations, opt.description) 155 | yield! 156 | if (box cmdsum.genSuggestions <> null) then 157 | cmdsum.genSuggestions remArgs |> Seq.ofList 158 | else Seq.empty 159 | } 160 | with 161 | | OptionParseFailed (opsum, _) -> 162 | seq { 163 | yield! 164 | if (box opsum.genSuggestions <> null) then 165 | args |> List.tryLast 166 | |> Option.filter (String.startsWith "-" >> not) 167 | |> Option.filter (String.startsWith "/" >> not) 168 | |> Option.map (Some >> opsum.genSuggestions) 169 | |> Option.defaultWith (fun () -> opsum.genSuggestions None) 170 | |> Seq.ofList 171 | else Seq.empty 172 | } 173 | | CommandExecutionFailed msg -> seq { yield Message msg } 174 | 175 | module SuggestionBackends = 176 | open FSharp.Collections 177 | 178 | /// a suggestion backend for zsh. 179 | let zsh = 180 | let quote str = sprintf "'%s'" str 181 | let escape str = 182 | str |> String.replace "'" "'\"'\"'" 183 | |> String.replace ":" "\\:" 184 | |> String.replace "\\" "\\\\" 185 | let conv = function 186 | | Values [] | ValuesWithDescription [] -> [] 187 | | Values xs -> 188 | "_values" :: "-w" :: "'values'" :: (xs |> List.map (escape >> quote)) 189 | | ValuesWithDescription xs -> 190 | "_values" :: "-w" :: "'values'" :: (xs |> List.map (fun (v, descr) -> sprintf "%s[%s]" v descr) 191 | |> List.map (escape >> quote)) 192 | | Files (Some pattern) -> "_files" :: "-g" :: [pattern |> quote] 193 | | Files None -> ["_files"] 194 | | Directories (Some pattern) -> "_files" :: "-/" :: "-g" :: [pattern |> quote] 195 | | Directories None -> "_files" :: "-/" :: [] 196 | | OptionSuggestion ([name], desc) -> 197 | "_arguments" :: (sprintf "'%s[%s]'" name (desc |> escape)) :: ["\"*: :->hoge\""] 198 | | OptionSuggestion (names, desc) when List.length names > 1 -> 199 | let names = names |> List.filter (String.startsWith "-") 200 | "_arguments" :: (sprintf "{%s}'[%s]'" (names |> String.concat ",") (desc |> escape)) :: ["\"*: :->hoge\""] 201 | | Message msg -> "_message" :: "-r" :: (msg |> escape |> quote) :: [] 202 | | _ -> [] 203 | { 204 | new ISuggestionBackend with 205 | member __.print css = 206 | css |> List.map conv 207 | |> List.filter (List.isEmpty >> not) 208 | |> List.groupBy List.head 209 | |> List.map (fun (gn, xss) -> 210 | if gn = "_arguments" then 211 | gn :: (xss |> List.map (fun xs -> xs.[1 .. List.length xs - 2]) |> List.concat) @ ["\"*: :->hoge\""] 212 | else 213 | gn :: (xss |> List.map (fun xs -> xs.[1 .. List.length xs - 1]) |> List.concat) 214 | ) 215 | |> List.map (String.concat " ") 216 | |> String.concat "; " 217 | } 218 | 219 | let mutable impls = 220 | Map.ofList [ 221 | ("zsh", zsh) 222 | ] 223 | 224 | /// given a backend name, gets the backend object. 225 | let findByName name = 226 | impls |> Map.tryFind name 227 | |> Option.defaultWith (fun () -> sprintf "suggestion backend not exist: %s" name |> CommandExecutionFailed |> raise) 228 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /src/FSharp.CommandLine/options.fs: -------------------------------------------------------------------------------- 1 | namespace FSharp.CommandLine 2 | 3 | [] 4 | module rec Options = 5 | open FSharp.Scanf.Optimized 6 | open Microsoft.FSharp.Quotations 7 | 8 | open CommandOption 9 | 10 | /// specify how to treat options like ```-abcd``` 11 | type SingleHyphenStyle = 12 | /// treat ```-abcd``` as ```--abcd``` 13 | | SingleLong 14 | /// treat ```-abcd``` as ```-a bcd``` 15 | | SingleShort 16 | /// treat ```-abcd``` as ```-a -b -c -d``` 17 | | MergedShort 18 | 19 | [] 20 | type CommandOptionNoArgProvided<'a> = 21 | | UseDefault of 'a 22 | | JustFail 23 | 24 | [] 25 | type CommandOptionKind<'a> = 26 | | Flag of (bool -> 'a) 27 | | TakingValueWith of CommandOptionNoArgProvided<'a> * (string -> 'a option) list 28 | 29 | type ICommandOption<'a> = 30 | abstract member Parse: string list -> ('a * string list) 31 | abstract member Config: CommandInfo -> CommandInfo 32 | abstract member Summary: CommandOptionSummary 33 | 34 | /// represents a command option parser that tries to parse the arguments 35 | /// and returns an optional result value. 36 | [] 37 | type CommandOption<'a> = { 38 | baseSummary: CommandOptionSummary 39 | kind: CommandOptionKind<'a> 40 | style: SingleHyphenStyle 41 | } 42 | with 43 | member this.Summary = 44 | let self = this 45 | { 46 | this.baseSummary with 47 | isMatch = 48 | fun argv -> 49 | match (parseImpl self argv) with 50 | | (Some _, rem) -> Some rem 51 | | (None, _) -> None 52 | } 53 | member this.Parse argv = parseImpl this argv 54 | interface ICommandOption<'a option> with 55 | member this.Summary = this.Summary 56 | member this.Parse argv = parseImpl this argv 57 | member this.Config cfg = 58 | { 59 | cfg with 60 | options = this.Summary :: cfg.options 61 | } 62 | 63 | /// represents a command option of which behavior and/or functionality are augmented. 64 | /// (e.g. can parse multiple occurrence of the option at once) 65 | [] 66 | type AugmentedCommandOption<'a, 'b> = { 67 | orig: ICommandOption<'a> 68 | augmenter: ICommandOption<'a> -> Args -> ('b * Args) 69 | } 70 | with 71 | interface ICommandOption<'b> with 72 | member this.Summary = this.orig.Summary 73 | member this.Parse argv = this.augmenter this.orig argv 74 | member this.Config cfg = (this.orig :> ICommandOption<_>).Config cfg 75 | 76 | let inline private defaultCO () = 77 | { 78 | baseSummary = 79 | { 80 | names = []; 81 | description = ""; 82 | isFlag = false; 83 | paramNames = []; 84 | isMatch = fun _ -> None 85 | genSuggestions = (fun _ -> []) 86 | }; 87 | kind = TakingValueWith (JustFail, []); 88 | style = MergedShort 89 | } 90 | 91 | let inline private defaultCF () = 92 | { 93 | baseSummary = 94 | { 95 | names = []; 96 | description = ""; 97 | isFlag = true; 98 | paramNames = []; 99 | isMatch = fun _ -> None 100 | genSuggestions = (fun _ -> []) 101 | }; 102 | kind = Flag id; 103 | style = MergedShort 104 | } 105 | 106 | 107 | module ReservedCommandOptions = 108 | let helpOption = 109 | { 110 | baseSummary = 111 | { 112 | names = ["?"; "h"; "help"] 113 | description = "display this help usage." 114 | isFlag = false 115 | paramNames = [] 116 | isMatch = fun _ -> None 117 | genSuggestions = (fun _ -> []) 118 | } 119 | kind = Flag id 120 | style = MergedShort 121 | } 122 | 123 | let suggestOption = 124 | { 125 | baseSummary = 126 | { 127 | names = ["generate-suggestions"; "generate-suggestions-incomplete"] 128 | description = "" 129 | isFlag = false 130 | paramNames = [["name"]] 131 | isMatch = fun _ -> None 132 | genSuggestions = (fun _ -> []) 133 | } 134 | kind = TakingValueWith (UseDefault "zsh", [Some]) 135 | style = MergedShort 136 | } 137 | 138 | [] 139 | type CommandOptionBuilder<'a>(dc: unit -> CommandOption<'a>) = 140 | member __.For (_, _) = failwith "Not supported" 141 | member __.Yield _ = dc () 142 | /// required. 143 | /// specifies the option's names. hyphens should not be included, 144 | /// as they will automatically be handled depending on 145 | /// the length of the name and optionally the `style` command. 146 | [] 147 | member __.Names (co, x) = { co with baseSummary = { co.baseSummary with names = x } } 148 | [] 149 | member __.Description (co, x) = { co with baseSummary = { co.baseSummary with description = x } } 150 | /// required for command option. 151 | /// specifies the format of the argument. for example: 152 | /// `takes (format("%s").map(fun str -> someFunc str))` 153 | [] 154 | member inline __.Takes (co: CommandOption<'a>, x) = 155 | let (f, ts) = construct x in 156 | { co with 157 | kind = 158 | match co.kind with 159 | | TakingValueWith (d, xs) -> TakingValueWith (d, List.append xs [f]) 160 | | _ -> TakingValueWith (JustFail, [f]); 161 | baseSummary = 162 | { co.baseSummary with 163 | paramNames = ts :: co.baseSummary.paramNames 164 | } 165 | } 166 | /// `takesFormat fmt (fun .. -> ..)` is a shorthand for 167 | /// `takes (format(fmt).map(fun .. -> ..))`. 168 | [] 169 | member inline __.TakesFormat (co: CommandOption<_>, fmt: PrintfFormat<_,_,_,_,_>, []mapper: Expr<_ -> _>) = 170 | let mf x = (FuncHelper.compileFunc mapper) x in 171 | let pns = FuncHelper.getFirstArgumentName mapper in 172 | let x = 173 | { format = fmt; handler = mf; paramNames = pns } 174 | let (f, ts) = construct x in 175 | { co with 176 | kind = 177 | match co.kind with 178 | | TakingValueWith (d, xs) -> TakingValueWith (d, List.append xs [f]) 179 | | _ -> TakingValueWith (JustFail, [f]); 180 | baseSummary = 181 | { co.baseSummary with 182 | paramNames = ts :: co.baseSummary.paramNames 183 | } 184 | } 185 | /// optional. 186 | /// makes the option's argument optional, and specifies the default value 187 | /// that will be used when the argument is not provided. 188 | [] 189 | member __.DefaultValue (co: CommandOption<'a>, value: 'a) = 190 | { co with 191 | kind = 192 | match co.kind with 193 | | TakingValueWith (_, xs) -> TakingValueWith (UseDefault value, xs) 194 | | x -> x 195 | } 196 | /// optional. 197 | /// specifies the command suggestions this option will generate. 198 | [] 199 | member __.Suggests (co, f) = { co with baseSummary = { co.baseSummary with genSuggestions=f } } 200 | /// optional. 201 | /// specify how to treat options like ```-abcd```. 202 | /// the default value is `MergedShort`. 203 | [] 204 | member __.Style (co, st) = { co with style = st } 205 | 206 | let commandOption<'a> = CommandOptionBuilder<'a> defaultCO 207 | let commandFlag = CommandOptionBuilder defaultCF 208 | 209 | type Command = 210 | /// short-form definition of command option 211 | static member inline option (_names, _format, ?_descr, ?defVal, ?_style) = 212 | let mutable co = 213 | commandOption { 214 | names _names 215 | takes (format _format) 216 | description (_descr ?| "") 217 | style (_style ?| SingleHyphenStyle.MergedShort) 218 | } 219 | defVal |> Option.iter (fun x -> co <- commandOption<_>.DefaultValue(co, x)) 220 | co 221 | 222 | /// short-form definition of command flag 223 | static member inline flag (_names, ?_descr, ?_style) = 224 | commandFlag { 225 | names _names 226 | description (_descr ?| "") 227 | style (_style ?| SingleHyphenStyle.MergedShort) 228 | } 229 | 230 | type private RefinedToken = 231 | | RFlag of string 232 | | RFlagDisable of string 233 | | RFlagAndValue of string * string 234 | | RMaybeCombinedFlag of string 235 | | RMaybeCombinedFlagAndValue of string * string 236 | | RValue of string 237 | | RIgnoreAfter 238 | with 239 | override this.ToString() = 240 | match this with 241 | | RFlag s -> sprintf "--%s" s 242 | | RFlagDisable s -> sprintf "-%s-" s 243 | | RFlagAndValue (s, v) -> sprintf "--%s=%s" s v 244 | | RMaybeCombinedFlag s -> sprintf "-%s" s 245 | | RMaybeCombinedFlagAndValue (s, v) -> sprintf "-%s=%s" s v 246 | | RValue s -> s 247 | | RIgnoreAfter -> "--" 248 | 249 | let private optionForms = [ 250 | tryKsscanf "--" (fun () -> RIgnoreAfter) 251 | tryKsscanf "-%c" (RFlag << to_s); 252 | tryKsscanf "-%c=%s" (Tuple.map2 to_s id >> RFlagAndValue); 253 | tryKsscanf "--%s=%s" RFlagAndValue; 254 | tryKsscanf "/%s=%s" RFlagAndValue; 255 | tryKsscanf "--%s" RFlag; 256 | tryKsscanf "-%c+" (RFlag << to_s); 257 | tryKsscanf "-%c-" (RFlagDisable << to_s); 258 | tryKsscanf "-%s=%s" RMaybeCombinedFlagAndValue; 259 | tryKsscanf "-%s" RMaybeCombinedFlag; 260 | tryKsscanf "/%s" RFlag; 261 | tryKsscanf "%s" RValue 262 | ] 263 | 264 | let rec private tokenize argv = 265 | seq { 266 | if List.isEmpty argv then 267 | yield! Seq.empty 268 | else 269 | let (h, t) = (List.head argv, List.tail argv) 270 | let ro = optionForms |> List.map (fun f -> f h) 271 | |> List.choose (function Ok x -> Some x | _ -> None) 272 | |> List.tryHead 273 | if Option.isSome ro then 274 | yield ro.Value; 275 | yield! 276 | match ro.Value with 277 | | RIgnoreAfter -> t |> Seq.map RValue 278 | | _ -> tokenize t 279 | else 280 | yield! Seq.empty 281 | } 282 | 283 | module CommandOption = 284 | /// gets the arguments which look like (will potentially be recognized by the parser as) 285 | /// a command option. 286 | let getRemainingOptions argv = 287 | argv |> tokenize |> List.ofSeq 288 | |> List.choose (function RIgnoreAfter | RValue _ -> None | x -> Some x) 289 | |> List.map to_s 290 | 291 | let internal parseImpl (opt: CommandOption<'a>) argv = 292 | let inline isSingle s = String.length s = 1 293 | let inline matches x = opt.baseSummary.names |> List.contains x 294 | let shortNames = opt.baseSummary.names |> List.filter isSingle 295 | let opf msg = OptionParseFailed(opt.baseSummary, msg) 296 | 297 | let tokens = tokenize argv |> List.ofSeq 298 | let rec find ts = 299 | match opt.kind with 300 | | Flag f -> 301 | let inline f x = f x |> Some 302 | match ts with 303 | | RFlag x :: rest when matches x -> (f true, rest) 304 | | RFlagDisable x :: rest when matches x -> (f false, rest) 305 | | RFlagAndValue (x, _) :: _ when matches x -> 306 | sprintf "'%s' is a flag and does not take an argument" x |> opf |> raise 307 | | RMaybeCombinedFlag xs :: rest & x :: _ -> 308 | match opt.style with 309 | | MergedShort when shortNames |> List.exists xs.Contains -> 310 | let c = shortNames |> List.find xs.Contains 311 | (f true, RMaybeCombinedFlag (xs.Replace(c, "")) :: rest) 312 | | SingleLong when matches xs -> (f true, rest) 313 | | SingleShort when shortNames |> List.exists xs.StartsWith -> 314 | sprintf "'%c' is a flag and does not take an argument" (xs.[0]) |> opf |> raise 315 | | _ -> find rest |> Tuple.map2 id (fun rest' -> x :: rest') 316 | | RMaybeCombinedFlagAndValue (xs, v) :: rest & x :: _ -> 317 | match opt.style with 318 | | MergedShort when shortNames |> List.exists xs.Contains -> 319 | let c = shortNames |> List.find xs.Contains 320 | if shortNames |> List.exists xs.EndsWith then 321 | sprintf "'%s' is a flag and does not take an argument" c |> opf |> raise 322 | else 323 | (f true, RMaybeCombinedFlagAndValue(xs.Replace(c, ""), v) :: rest) 324 | | SingleLong when matches xs -> 325 | sprintf "'%s' is a flag and does not take an argument" xs |> opf |> raise 326 | | SingleShort -> sprintf "invalid option: '-%s=%s'" xs v |> opf |> raise 327 | | _ -> find rest |> Tuple.map2 id (fun rest' -> x :: rest') 328 | | x :: rest -> find rest |> Tuple.map2 id (fun rest' -> x :: rest') 329 | | [] -> (None, []) 330 | | TakingValueWith (na, fs) -> 331 | let inline tryReturn v name = 332 | match (fs |> List.map (fun f -> f v) |> List.choose id |> List.tryHead) with 333 | | Some x -> Some x 334 | | None -> 335 | sprintf "the value '%s' is invalid for the option '%s'" v name |> opf |> raise 336 | let inline tryDefault name = 337 | match na with 338 | | UseDefault x -> Some x 339 | | JustFail -> 340 | sprintf "a value is missing for the option '%s'" name |> opf |> raise 341 | match ts with 342 | | RFlag x :: RValue v :: rest 343 | | RFlagAndValue (x, v) :: rest when matches x -> (tryReturn v x, rest) 344 | | RFlag x :: rest when matches x -> (tryDefault x, rest) 345 | | RFlagDisable x :: _ when matches x -> 346 | sprintf "a value is missing for the option '%s'" x |> opf |> raise 347 | | RMaybeCombinedFlag xs :: RValue v :: rest & x :: _ :: _-> 348 | match opt.style with 349 | | MergedShort when shortNames |> List.exists xs.EndsWith -> 350 | let c = shortNames |> List.find xs.EndsWith 351 | (tryReturn v c, RMaybeCombinedFlag (xs.Replace(c, "")) :: rest) 352 | | MergedShort when shortNames |> List.exists xs.Contains -> 353 | let c = shortNames |> List.find xs.Contains 354 | (tryDefault c, RMaybeCombinedFlag (xs.Replace(c, "")) :: RValue v :: rest) 355 | | SingleShort when shortNames |> List.exists xs.StartsWith -> 356 | let c = shortNames |> List.find xs.StartsWith 357 | let v' = xs.Substring(1) 358 | (tryReturn v' c, RValue v :: rest) 359 | | SingleLong when matches xs -> 360 | (tryReturn v xs, rest) 361 | | _ -> find rest |> Tuple.map2 id (fun rest' -> x :: RValue v :: rest') 362 | | RMaybeCombinedFlagAndValue (xs, v) :: rest & x :: _ -> 363 | match opt.style with 364 | | MergedShort when shortNames |> List.exists xs.EndsWith -> 365 | let c = shortNames |> List.find xs.EndsWith 366 | (tryReturn v c, RMaybeCombinedFlag (xs.Replace(c, "")) :: rest) 367 | | MergedShort when shortNames |> List.exists xs.Contains -> 368 | let c = shortNames |> List.find xs.Contains 369 | (tryDefault c, RMaybeCombinedFlagAndValue (xs.Replace(c, ""), v) :: rest) 370 | | SingleLong when matches xs -> 371 | (tryReturn v xs, rest) 372 | | SingleShort -> sprintf "invalid option: '-%s=%s'" xs v |> opf |> raise 373 | | _ -> find rest |> Tuple.map2 id (fun rest' -> x :: rest') 374 | | x :: rest -> find rest |> Tuple.map2 id (fun rest' -> x :: rest') 375 | | [] -> (None, []) 376 | find tokens |> Tuple.map2 id (List.map to_s) 377 | 378 | /// given a command option and arguments, applies the parser to the arguments 379 | /// and returns the parsed result and the remaining arguments. 380 | let inline parse (opt: #ICommandOption<_>) argv = opt.Parse argv 381 | 382 | /// given a command option and arguments, applies the parser to the arguments until it fails 383 | /// and returns the results and the remaining arguments. 384 | let parseMany (opt: #ICommandOption<_>) argv = 385 | let rec p xs = 386 | seq { 387 | yield! 388 | match (opt.Parse xs) with 389 | | (Some x, rest) -> 390 | seq { yield (x, rest); yield! p rest } 391 | | (None, _) -> 392 | Seq.empty 393 | } 394 | let x = p argv 395 | (x |> Seq.map fst |> List.ofSeq, x |> Seq.map snd |> Seq.tryLast ?| argv) 396 | 397 | /// given a command option, augments its functionality by modifying 398 | /// its behavior. both the original command option and the arguments which 399 | /// will be passed at the execution time are available. 400 | let inline augment f c = { orig=c; augmenter=f } 401 | let inline map f c = 402 | let ac = augment (fun c args -> c.Parse args) c 403 | { 404 | orig=ac.orig; 405 | augmenter=(fun o x -> ac.augmenter o x |> Tuple.map2 f id) 406 | } 407 | 408 | /// given a command option, returns a new command option that parses 409 | /// zero or more occurrence of that command option. 410 | let inline zeroOrMore co = 411 | co |> augment parseMany 412 | 413 | /// given a command option, returns a new command option that fails 414 | /// if there are more than one occurrence of that command option. 415 | let inline zeroOrExactlyOne co = 416 | co |> zeroOrMore 417 | |> map (function 418 | | [] -> None 419 | | x :: [] -> Some x 420 | | _ -> 421 | let msg = sprintf "the option '%s' should be provided only once" 422 | (co.Summary.NameRepresentations |> List.head) 423 | OptionParseFailed (co.Summary, msg) |> raise 424 | ) 425 | 426 | /// given a command option, returns a new command option that returns 427 | /// the specified default value if there is no occurence. 428 | let inline whenMissingUse defaultValue co = 429 | co |> map (function Some x -> x | None -> defaultValue) 430 | 431 | /// an active pattern to parse the arguments using the command option 432 | /// and gets the result and the remaining arguments. 433 | let inline (|OptionParse|_|) opt argv = 434 | let (reso, argv') = parse opt argv 435 | reso |> Option.map (fun x -> (x, argv')) -------------------------------------------------------------------------------- /src/FSharp.Scanf/scanf.fs: -------------------------------------------------------------------------------- 1 | (* 2 | The MIT License 3 | Scanf.fs - type safe scanf 4 | Copyright(c) 2018-2019 cannorin 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 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | *) 21 | 22 | // original: http://www.fssnip.net/4I/title/sscanf-parsing-with-format-strings 23 | 24 | /// Scanf functions. 25 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 26 | module FSharp.Scanf 27 | 28 | open System 29 | open System.IO 30 | open Microsoft.FSharp.Reflection 31 | 32 | let inline internal to_s x = x.ToString() 33 | 34 | let inline internal check f x = if f x then x else failwithf "format failure \"%s\"" x 35 | 36 | let inline internal parseDecimal x = Decimal.Parse(x, System.Globalization.CultureInfo.InvariantCulture) 37 | 38 | module Internal = 39 | // type wrapper 40 | [] 41 | type ScanfTypeMarker<'t> = | ScanfTypeMarker 42 | 43 | [] 44 | let parserChars = "bdisuxXoeEfFgGMcA" 45 | 46 | let inline internal formatIntegerStr str fmt = 47 | match fmt with 48 | | 'i' | 'd' | 'u' -> str 49 | | 'x' -> str |> check (String.forall (fun c -> Char.IsLower c || Char.IsDigit c)) |> ((+) "0x") 50 | | 'X' -> str |> check (String.forall (fun c -> Char.IsUpper c || Char.IsDigit c)) |> ((+) "0x") 51 | | 'o' -> "0o" + str 52 | | _ -> str 53 | 54 | let inline internal convertUnsafe fmt targetType str = 55 | let str = formatIntegerStr str fmt 56 | if targetType = typeof then box str 57 | else if targetType = typeof then int32 str |> box 58 | else if targetType = typeof then float str |> box 59 | else if targetType = typeof then char str |> box 60 | else if targetType = typeof then Boolean.Parse(str) |> box 61 | else if targetType = typeof then int8 str |> box 62 | else if targetType = typeof then uint8 str |> box 63 | else if targetType = typeof then int16 str |> box 64 | else if targetType = typeof then uint16 str |> box 65 | else if targetType = typeof then uint32 str |> box 66 | else if targetType = typeof then int64 str |> box 67 | else if targetType = typeof then uint64 str |> box 68 | else if targetType = typeof then float32 str |> box 69 | else if targetType = typeof then parseDecimal str |> box 70 | else if targetType = typeof then box () 71 | else if targetType = typeof then bigint.Parse str |> box 72 | else failwithf "Unsupported type '%s'" targetType.Name 73 | 74 | let inline internal typemarker<'t> : ScanfTypeMarker<'t> = ScanfTypeMarker 75 | 76 | // Compile-time resolved string-to-value parsers 77 | type OptimizedConverter = 78 | static member inline Convert (_: ScanfTypeMarker, _, _) = () 79 | static member inline Convert (_: ScanfTypeMarker, s: string list, _) = Boolean.Parse(s.Head) 80 | static member inline Convert (_: ScanfTypeMarker, s: string list, _) = s.Head 81 | static member inline Convert (_: ScanfTypeMarker, s:string list, _) = char s.Head 82 | static member inline Convert (_: ScanfTypeMarker, s: string list, formatters: char list) = 83 | formatIntegerStr s.Head formatters.Head |> int8 84 | static member inline Convert (_: ScanfTypeMarker, s: string list, formatters: char list) = 85 | formatIntegerStr s.Head formatters.Head |> uint8 86 | static member inline Convert (_: ScanfTypeMarker, s: string list, formatters: char list) = 87 | formatIntegerStr s.Head formatters.Head |> int16 88 | static member inline Convert (_: ScanfTypeMarker, s: string list, formatters: char list) = 89 | formatIntegerStr s.Head formatters.Head |> uint16 90 | static member inline Convert (_: ScanfTypeMarker, s: string list, formatters: char list) = 91 | formatIntegerStr s.Head formatters.Head |> int32 92 | static member inline Convert (_: ScanfTypeMarker, s: string list, formatters: char list) = 93 | formatIntegerStr s.Head formatters.Head |> uint32 94 | static member inline Convert (_: ScanfTypeMarker, s: string list, formatters: char list) = 95 | formatIntegerStr s.Head formatters.Head |> int64 96 | static member inline Convert (_: ScanfTypeMarker, s: string list, formatters: char list) = 97 | formatIntegerStr s.Head formatters.Head |> uint64 98 | static member inline Convert (_: ScanfTypeMarker, s: string list, formatters: char list) = 99 | formatIntegerStr s.Head formatters.Head |> bigint.Parse 100 | static member inline Convert (_: ScanfTypeMarker, s:string list, _) = float s.Head 101 | static member inline Convert (_: ScanfTypeMarker, s:string list, _) = float32 s.Head 102 | static member inline Convert (_: ScanfTypeMarker, s:string list, _) = parseDecimal s.Head 103 | 104 | let inline internal convertFast (typ: ScanfTypeMarker< ^t >) (s: string list) (formatter:char list) = 105 | let inline call_2 (_: ScanfTypeMarker< ^Converter >, _: ScanfTypeMarker< ^x >) = 106 | ((^Converter or ^x): (static member Convert: _*_*_ -> ^t) typ,s,formatter) 107 | let inline call (a: ScanfTypeMarker<'a>, b: ScanfTypeMarker<'b>) = call_2 (a, b) 108 | call (typemarker, typ) 109 | 110 | // 8-tuples or more are reprensented as `System.Tuple'7<_,_,_,_,_,_,_,System.Tuple<...>>` 111 | // but it is impossible to handle them generically 112 | type OptimizedConverter with 113 | static member inline Convert (_: ScanfTypeMarker<'t1*'t2>, s: string list, fs: char list) = 114 | convertFast typemarker<'t1> s fs, 115 | convertFast typemarker<'t2> s.Tail fs.Tail 116 | static member inline Convert (_: ScanfTypeMarker<'t1*'t2*'t3>, s: string list, fs: char list) = 117 | convertFast typemarker<'t1> s fs, 118 | convertFast typemarker<'t2> s.Tail fs.Tail, 119 | convertFast typemarker<'t3> s.Tail.Tail fs.Tail.Tail 120 | static member inline Convert (_: ScanfTypeMarker<'t1*'t2*'t3*'t4>, s: string list, fs: char list) = 121 | convertFast typemarker<'t1> s fs, 122 | convertFast typemarker<'t2> s.Tail fs.Tail, 123 | convertFast typemarker<'t3> s.Tail.Tail fs.Tail.Tail, 124 | convertFast typemarker<'t4> s.Tail.Tail.Tail fs.Tail.Tail.Tail 125 | static member inline Convert (_: ScanfTypeMarker<'t1*'t2*'t3*'t4*'t5>, s: string list, fs: char list) = 126 | convertFast typemarker<'t1> s fs, 127 | convertFast typemarker<'t2> s.Tail fs.Tail, 128 | convertFast typemarker<'t3> s.Tail.Tail fs.Tail.Tail, 129 | convertFast typemarker<'t4> s.Tail.Tail.Tail fs.Tail.Tail.Tail, 130 | convertFast typemarker<'t5> s.Tail.Tail.Tail.Tail fs.Tail.Tail.Tail.Tail 131 | static member inline Convert (_: ScanfTypeMarker<'t1*'t2*'t3*'t4*'t5*'t6>, s: string list, fs: char list) = 132 | convertFast typemarker<'t1> s fs, 133 | convertFast typemarker<'t2> s.Tail fs.Tail, 134 | convertFast typemarker<'t3> s.Tail.Tail fs.Tail.Tail, 135 | convertFast typemarker<'t4> s.Tail.Tail.Tail fs.Tail.Tail.Tail, 136 | convertFast typemarker<'t5> s.Tail.Tail.Tail.Tail fs.Tail.Tail.Tail.Tail, 137 | convertFast typemarker<'t6> s.Tail.Tail.Tail.Tail.Tail fs.Tail.Tail.Tail.Tail.Tail 138 | static member inline Convert (_: ScanfTypeMarker<'t1*'t2*'t3*'t4*'t5*'t6*'t7>, s: string list, fs: char list) = 139 | convertFast typemarker<'t1> s fs, 140 | convertFast typemarker<'t2> s.Tail fs.Tail, 141 | convertFast typemarker<'t3> s.Tail.Tail fs.Tail.Tail, 142 | convertFast typemarker<'t4> s.Tail.Tail.Tail fs.Tail.Tail.Tail, 143 | convertFast typemarker<'t5> s.Tail.Tail.Tail.Tail fs.Tail.Tail.Tail.Tail, 144 | convertFast typemarker<'t6> s.Tail.Tail.Tail.Tail.Tail fs.Tail.Tail.Tail.Tail.Tail, 145 | convertFast typemarker<'t7> s.Tail.Tail.Tail.Tail.Tail.Tail fs.Tail.Tail.Tail.Tail.Tail.Tail 146 | 147 | // Creates a list of formatter characters from a format string, 148 | // for example "(%s,%d)" -> ['s', 'd'] 149 | let rec internal getFormatters xs = 150 | match xs with 151 | | '%' :: '%' :: xr -> getFormatters xr 152 | | '%' :: x :: xr -> 153 | if parserChars |> Seq.contains x then x :: getFormatters xr 154 | else failwithf "Unsupported formatter '%%%c'" x 155 | | _ :: xr -> getFormatters xr 156 | | [] -> [] 157 | 158 | [] 159 | type FormatStringPart = 160 | | Placeholder of typ:char 161 | | Literal of string 162 | | Space 163 | static member getFormatters(fmt: FormatStringPart list) = 164 | let rec get = function 165 | | Placeholder c :: rest -> c :: get rest 166 | | _ :: rest -> get rest 167 | | [] -> [] 168 | get fmt 169 | 170 | let inline internal (<+>) h t = 171 | match h, t with 172 | | FormatStringPart.Literal s, FormatStringPart.Literal t :: rest -> 173 | FormatStringPart.Literal (s+t) :: rest 174 | | _ -> h :: t 175 | 176 | let rec internal parsePlaceholderImpl currentPos (str: string) = 177 | let c = str.[currentPos] 178 | let nextPos = currentPos + 1 179 | if Char.IsLetter c then 180 | FormatStringPart.Placeholder c :: parseFormatImpl nextPos nextPos str 181 | else if c = '%' then 182 | FormatStringPart.Literal "%" <+> parseFormatImpl nextPos nextPos str 183 | else failwithf "Unsupported formatter '%%%c'" c 184 | 185 | and internal parseFormatImpl startPos currentPos (str: string) = 186 | if currentPos >= str.Length then 187 | if currentPos = startPos then [] 188 | else 189 | let s = str.Substring(startPos, currentPos - startPos) 190 | FormatStringPart.Literal s :: [] 191 | else 192 | let c = str.[currentPos] 193 | if c = '%' then 194 | let nextPos = currentPos + 1 195 | if currentPos = startPos then 196 | parsePlaceholderImpl nextPos str 197 | else 198 | let s = str.Substring(startPos, currentPos - startPos) 199 | FormatStringPart.Literal s <+> parsePlaceholderImpl nextPos str 200 | else if c = ' ' || c = '\n' || c = '\r' || c = '\t' then 201 | let mutable i = 1 202 | while currentPos + i < str.Length 203 | && let c = str.[currentPos + i] in 204 | c = ' ' || c = '\n' || c = '\r' || c = '\t' do i <- i+1 205 | let nextPos = currentPos + i 206 | if currentPos = startPos then 207 | FormatStringPart.Space :: parseFormatImpl nextPos nextPos str 208 | else 209 | let s = str.Substring(startPos, currentPos - startPos) 210 | FormatStringPart.Literal s :: FormatStringPart.Space :: parseFormatImpl nextPos nextPos str 211 | else 212 | parseFormatImpl startPos (currentPos + 1) str 213 | 214 | let inline internal parseFormat (str: string) = 215 | parseFormatImpl 0 0 str 216 | 217 | open FParsec 218 | let inline (<++>) p1 p2 = p1 .>>. p2 |>> List.Cons 219 | let inline strOf p = withSkippedString (fun s _ -> s) p 220 | 221 | let rec internal buildParser = function 222 | | [] -> eof >>% [] 223 | | FormatStringPart.Space :: rest -> 224 | spaces1 >>. buildParser rest 225 | | FormatStringPart.Literal lit :: rest -> 226 | skipString lit >>. buildParser rest 227 | | FormatStringPart.Placeholder c :: rest-> 228 | let cont = buildParser rest 229 | match c with 230 | | 'b' -> (pstring "true" <|> pstring "false") <++> cont 231 | | 'd' | 'i' -> many1Satisfy isDigit <++> cont 232 | | 's' | 'A' -> 233 | manyCharsTill anyChar (followedBy cont) .>>.? cont |>> List.Cons 234 | | 'u' -> strOf puint64 <++> cont 235 | | 'x' | 'X' -> manySatisfy isHex <++> cont 236 | | 'o' -> manySatisfy isOctal <++> cont 237 | | 'e' | 'E' | 'f' | 'F' | 'g' | 'G' -> 238 | (skipStringCI "nan" >>% "NaN") 239 | <|> (skipStringCI "infinity" <|> skipStringCI "inf" >>% "Infinity") 240 | <|> (strOf pfloat) 241 | <++> cont 242 | | 'M' -> 243 | many1Satisfy isDigit .>>.? opt (skipChar '.' >>? many1Satisfy isDigit) 244 | |>> (fun (i, j) -> i + Option.defaultValue "" j) 245 | <++> cont 246 | | 'c' -> anyChar |>> string <++> cont 247 | | c -> failwithf "Unsupported formatter '%%%c'" c 248 | 249 | let inline internal matchFormat fmt fmtStr str = 250 | match run (buildParser fmt) str with 251 | | Success (xs, _, _) -> xs 252 | | Failure (msg, _, _) -> 253 | failwithf "the input does not match the format '%s': %s" fmtStr msg 254 | 255 | // Extracts string matches and the format from a format string and a given string. 256 | let getMatchesAndFormat (pf: PrintfFormat<_, _, _, _, _>) s = 257 | let formatStr = pf.Value 258 | let fmt = parseFormat formatStr 259 | let groups = matchFormat fmt formatStr s 260 | let formatters = FormatStringPart.getFormatters fmt 261 | groups, formatStr, formatters 262 | 263 | open Internal 264 | 265 | type PrintfFormat<'a,'b,'c,'d,'e> with 266 | member this.GetFormatterNames () = 267 | let fs = this.Value.ToCharArray() 268 | |> Array.toList |> getFormatters in 269 | let print = function 270 | | 's' -> "string" 271 | | 'c' -> "char" 272 | | 'b' -> "bool" 273 | | 'i' | 'd' -> "int" 274 | | 'u' -> "uint" 275 | | 'x' -> "lowercase hex" 276 | | 'X' -> "uppercase hex" 277 | | 'o' -> "octal" 278 | | 'f' | 'e' | 'E' | 'g' | 'G' -> "double" 279 | | 'M' -> "decimal" 280 | | 'A' -> "any type" 281 | | x -> failwithf "Unsupported formatter '%%%c'" x 282 | in 283 | fs |> List.map print 284 | 285 | member this.PrettyTokenize names = 286 | let fcs = this.Value.ToCharArray() |> Array.toList in 287 | if (List.length names) < (fcs |> getFormatters |> List.length) then 288 | failwith "Parameter count does not match to the format" 289 | else 290 | let rec replace = function 291 | | [], _ -> [] 292 | | cs, [] -> 293 | cs |> List.map to_s 294 | | '%' :: '%' :: cs, ns -> 295 | replace (cs, ns) 296 | | '%' :: c :: cs, n :: ns when parserChars |> Seq.contains c -> 297 | n :: replace (cs, ns) 298 | | c :: cs, ns -> 299 | to_s c :: replace (cs, ns) 300 | in 301 | replace (fcs, names) 302 | 303 | member this.PrettyPrint names = this.PrettyTokenize names |> String.concat "" 304 | 305 | type ScanfTypeMarker<'t> = Internal.ScanfTypeMarker<'t> 306 | 307 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 308 | let ksscanf (pf: PrintfFormat<_,_,_,_,'t>) (cont: 't -> 'u) s : 'u = 309 | let matches, formatStr, formatters = getMatchesAndFormat pf s 310 | let value = 311 | if typeof<'t> = typeof then 312 | if s = formatStr then 313 | box () :?> 't 314 | else 315 | failwith "Match failed" 316 | else 317 | if matches.Length = 1 then 318 | convertUnsafe formatters.[0] typeof<'t> matches.[0] :?> 't 319 | else 320 | let targetTypes = FSharpType.GetTupleElements(typeof<'t>) 321 | let values = 322 | (formatters, targetTypes, matches) 323 | |||> Seq.map3 convertUnsafe 324 | |> Seq.toArray 325 | FSharpValue.MakeTuple(values, typeof<'t>) :?> 't 326 | cont value 327 | 328 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 329 | let inline tryKsscanf pf cont s = 330 | try 331 | ksscanf pf cont s |> Ok 332 | with 333 | | ex -> Error ex 334 | 335 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 336 | let inline sscanf pf s = 337 | ksscanf pf id s 338 | 339 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 340 | let inline trySscanf pf s = 341 | tryKsscanf pf id s 342 | 343 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 344 | let inline scanfn pf = 345 | Console.ReadLine() |> sscanf pf 346 | 347 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 348 | let inline tryScanfn pf = 349 | Console.ReadLine() |> trySscanf pf 350 | 351 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 352 | let inline kscanfn pf cont = 353 | ksscanf pf cont <| Console.ReadLine() 354 | 355 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 356 | let inline tryKscanfn pf cont = 357 | tryKsscanf pf cont <| Console.ReadLine() 358 | 359 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 360 | let inline fscanfn pf (tr: TextReader) = 361 | tr.ReadLine() |> sscanf pf 362 | 363 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 364 | let inline tryFscanfn pf (tr: TextReader) = 365 | tr.ReadLine() |> trySscanf pf 366 | 367 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 368 | let inline kfscanfn pf cont (tr: TextReader) = 369 | ksscanf pf cont <| tr.ReadLine() 370 | 371 | /// If the result type is 7-tuple or less, consider using `FSharp.Scanf.Optimized` module instead. 372 | let inline tryKfscanfn pf cont (tr: TextReader) = 373 | tryKsscanf pf cont <| tr.ReadLine() 374 | 375 | // active pattern 376 | let (|Sscanf|_|) (format:PrintfFormat<_,_,_,_,'t>) input = 377 | trySscanf format input |> function | Ok x -> Some x | Error _ -> None 378 | 379 | /// Scanf functions, no reflection/boxing. About 6x-7x faster than unoptimized ones. 380 | /// 381 | /// Can only be used with up to 7 captures (i.e. the result type must be up to 7-tuples). 382 | /// 383 | /// If you implement a static member with signature `Convert: ScanfTypeMarker * string list * char list -> YourType`, 384 | /// you can directly parse the string into that type by using `%A`. 385 | /// 386 | /// ``` 387 | /// type A = A of string with 388 | /// static member Convert (_: ScanfTypeMarker, ss: string list, _) = ss.[0] 389 | /// 390 | /// let a: A = sscanf "%A" "foo" 391 | /// // val a : A = A "foo" 392 | /// ``` 393 | module Optimized = 394 | type ScanfTypeMarker<'t> = Internal.ScanfTypeMarker<'t> 395 | 396 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 397 | let inline ksscanf (pf: PrintfFormat<_,_,_,_,^t>) (cont: ^t -> 'u) s : 'u = 398 | let matches, _, formatters = getMatchesAndFormat pf s 399 | let strings = matches |> Seq.toList 400 | convertFast typemarker< ^t > strings formatters |> cont 401 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 402 | let inline tryKsscanf pf cont s = 403 | try 404 | ksscanf pf cont s |> Ok 405 | with 406 | | ex -> Error ex 407 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 408 | let inline sscanf pf s = 409 | ksscanf pf id s 410 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 411 | let inline trySscanf pf s = 412 | tryKsscanf pf id s 413 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 414 | let inline scanfn pf = 415 | Console.ReadLine() |> sscanf pf 416 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 417 | let inline tryScanfn pf = 418 | Console.ReadLine() |> trySscanf pf 419 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 420 | let inline kscanfn pf cont = 421 | ksscanf pf cont <| Console.ReadLine() 422 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 423 | let inline tryKscanfn pf cont = 424 | tryKsscanf pf cont <| Console.ReadLine() 425 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 426 | let inline fscanfn pf (tr: TextReader) = 427 | tr.ReadLine() |> sscanf pf 428 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 429 | let inline tryFscanfn pf (tr: TextReader) = 430 | tr.ReadLine() |> trySscanf pf 431 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 432 | let inline kfscanfn pf cont (tr: TextReader) = 433 | ksscanf pf cont <| tr.ReadLine() 434 | /// If the result type is 8-tuple or more, it fails to typecheck. Use `FSharp.Scanf` module instead or try reducing the captures by applying `scanf` to the result string. 435 | let inline tryKfscanfn pf cont (tr: TextReader) = 436 | tryKsscanf pf cont <| tr.ReadLine() 437 | -------------------------------------------------------------------------------- /src/common/prelude.fs: -------------------------------------------------------------------------------- 1 | (* 2 | The MIT License 3 | prelude.fs - my prelude 4 | Copyright(c) 2018 cannorin 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 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | *) 21 | 22 | // this file is automatically generated by build.fsx. 23 | // do not edit this directly. 24 | 25 | [] 26 | module internal Prelude 27 | 28 | // from: ToplevelOperators.fs 29 | [] 30 | module ToplevelOperators = 31 | open System 32 | let inline to_s x = x.ToString() 33 | 34 | let inline (?|) opt df = defaultArg opt df 35 | 36 | let inline (!!) (x: Lazy<'a>) = x.Value 37 | 38 | let inline undefined (x: 'a) : 'b = NotImplementedException(to_s x) |> raise 39 | 40 | let inline reraise' ex = System.Runtime.ExceptionServices.ExceptionDispatchInfo.Capture(ex).Throw(); failwith "impossible" 41 | 42 | let inline private ccl (fc: ConsoleColor) = 43 | Console.ForegroundColor <- fc; 44 | { new IDisposable with 45 | member x.Dispose() = Console.ResetColor() } 46 | 47 | let inline cprintf color format = 48 | Printf.kprintf (fun s -> use c = ccl color in printf "%s" s) format 49 | 50 | let inline cprintfn color format = 51 | Printf.kprintf (fun s -> use c = ccl color in printfn "%s" s) format 52 | 53 | let inline dispose (disp: #System.IDisposable) = 54 | match disp with null -> () | x -> x.Dispose() 55 | 56 | let inline succ (n: ^number) = 57 | n + LanguagePrimitives.GenericOne< ^number > 58 | 59 | let inline pred (n: ^number) = 60 | n - LanguagePrimitives.GenericOne< ^number > 61 | 62 | // from: Interop.fs 63 | open System 64 | 65 | module Func = 66 | let inline ofFSharp0 f = new Func<_>(f) 67 | let inline ofFSharp1 f = new Func<_, _>(f) 68 | let inline ofFSharp2 f = new Func<_, _, _>(f) 69 | let inline ofFSharp3 f = new Func<_, _, _, _>(f) 70 | let inline toFSharp0 (f: Func<_>) () = f.Invoke() 71 | let inline toFSharp1 (f: Func<_, _>) x = f.Invoke(x) 72 | let inline toFSharp2 (f: Func<_, _, _>) x y = f.Invoke(x, y) 73 | let inline toFSharp3 (f: Func<_, _, _, _>) x y z = f.Invoke(x, y, z) 74 | 75 | module Action = 76 | let inline ofFSharp0 a = new Action(a) 77 | let inline ofFSharp1 a = new Action<_>(a) 78 | let inline ofFSharp2 a = new Action<_, _>(a) 79 | let inline ofFSharp3 a = new Action<_, _, _>(a) 80 | let inline toFSharp0 (f: Action) () = f.Invoke() 81 | let inline toFSharp1 (f: Action<_>) x = f.Invoke(x) 82 | let inline toFSharp2 (f: Action<_, _>) x y = f.Invoke(x, y) 83 | let inline toFSharp3 (f: Action<_, _, _>) x y z = f.Invoke(x, y, z) 84 | 85 | module Flag = 86 | let inline combine (xs: ^flag seq) : ^flag 87 | when ^flag: enum = 88 | xs |> Seq.fold (|||) (Unchecked.defaultof< ^flag >) 89 | let inline contains (x: ^flag) (flags: ^flag) : bool 90 | when ^flag: enum = 91 | (x &&& flags) = x 92 | 93 | module Number = 94 | open System.Globalization 95 | 96 | let inline tryParse< ^T when ^T: (static member TryParse: string -> ^T byref -> bool) > str : ^T option = 97 | let mutable ret = Unchecked.defaultof<_> in 98 | if (^T: (static member TryParse: string -> ^T byref -> bool) (str, &ret)) then 99 | Some ret 100 | else 101 | None 102 | 103 | let inline tryParseWith< ^T when ^T: (static member TryParse: string -> NumberStyles -> IFormatProvider -> ^T byref -> bool) > str styleo formato : ^T option = 104 | let mutable ret = Unchecked.defaultof<_> in 105 | let style = styleo ?| NumberStyles.None in 106 | let format = formato ?| CultureInfo.InvariantCulture in 107 | if (^T: (static member TryParse: string -> NumberStyles -> IFormatProvider -> ^T byref -> bool) (str, style, format, &ret)) then 108 | Some ret 109 | else 110 | None 111 | 112 | // from: Patterns.fs 113 | [] 114 | module Patterns = 115 | open System.Text.RegularExpressions 116 | 117 | let (|Regex|_|) pattern input = 118 | let m = Regex.Match(input, pattern) 119 | if m.Success then Some(List.tail [ for g in m.Groups -> g.Value ]) 120 | else None 121 | 122 | let (|DefaultValue|) dv x = 123 | match x with 124 | | Some v -> v 125 | | None -> dv 126 | 127 | [] 128 | module Kvp = 129 | open System.Collections.Generic 130 | type kvp<'a, 'b> = KeyValuePair<'a, 'b> 131 | let inline KVP (a, b) = kvp(a, b) 132 | let (|KVP|) (x: kvp<_, _>) = (x.Key, x.Value) 133 | 134 | [] 135 | module Nat = 136 | type nat = uint32 137 | let inline S i = i + 1u 138 | [] 139 | let Z = 0u 140 | let (|S|Z|) i = if i = 0u then Z else S (i-1u) 141 | 142 | // from: String.fs 143 | module String = 144 | open System 145 | open System.Text 146 | open System.Globalization 147 | 148 | let inline startsWith (s: ^a) (str: ^String) : bool = (^String: (member StartsWith: ^a -> bool) str, s) 149 | 150 | let inline endsWith (s: ^a) (str: ^String) : bool = (^String: (member EndsWith: ^a -> bool) str, s) 151 | 152 | let inline contains (s: ^a) (str: ^String) : bool = (^String: (member IndexOf: ^a -> int) str, s) <> -1 153 | 154 | let inline findIndex (q: ^T) (str: ^String) = 155 | (^String: (member IndexOf: ^T -> int) (str, q)) 156 | 157 | let inline findIndexAfter (q: ^T) i (str: ^String) = 158 | (^String: (member IndexOf: ^T -> int -> int) (str, q, i)) 159 | 160 | let inline findLastIndex (q: ^T) (str: ^String) = 161 | (^String: (member LastIndexOf: ^T -> int) (str, q)) 162 | 163 | let inline findLastIndexAfter (q: ^T) i (str: ^String) = 164 | (^String: (member LastIndexOf: ^T -> int -> int) (str, q, i)) 165 | 166 | let inline insertAt s i (str: string) = str.Insert(i, s) 167 | 168 | let inline removeAfter i (str: string) = str.Remove i 169 | 170 | let inline remove startIndex endIndex (str: string) = str.Remove(startIndex, endIndex) 171 | 172 | let inline substringAfter i (str: string) = str.Substring i 173 | 174 | let inline substring startIndex endIndex (str: string) = str.Substring(startIndex, endIndex) 175 | 176 | let inline normalize (nfo: NormalizationForm option) (str: string) = 177 | match nfo with Some nf -> str.Normalize nf | None -> str.Normalize() 178 | 179 | let inline toLower (ci: CultureInfo) (str: string) = str.ToLower ci 180 | 181 | let inline toLowerInvariant (str: string) = str.ToLowerInvariant() 182 | 183 | let inline toUpper (ci: CultureInfo) (str: string) = str.ToUpper ci 184 | 185 | let inline toUpperInvariant (str: string) = str.ToUpperInvariant() 186 | 187 | let inline padLeft i (str: string) = str.PadLeft i 188 | 189 | let inline padLeftBy i c (str: string) = str.PadLeft(i, c) 190 | 191 | let inline padRight i (str: string) = str.PadRight i 192 | 193 | let inline padRightBy i c (str: string) = str.PadRight(i, c) 194 | 195 | let inline trim (str: string) = str.Trim() 196 | 197 | let inline trimStart (str: string) = str.TrimStart() 198 | 199 | let inline trimEnd (str: string) = str.TrimEnd() 200 | 201 | let inline trimBy (trimChar: char) (str: string) = str.Trim(trimChar) 202 | 203 | let inline trimBySeq (trimChars: char seq) (str: string) = str.Trim(trimChars |> Seq.toArray) 204 | 205 | let inline trimStartBy (trimChar: char) (str: string) = str.TrimStart(trimChar) 206 | 207 | let inline trimStartBySeq (trimChars: char seq) (str: string) = str.TrimStart(trimChars |> Seq.toArray) 208 | 209 | let inline trimEndBy (trimChar: char) (str: string) = str.TrimEnd(trimChar) 210 | 211 | let inline trimEndBySeq (trimChars: char seq) (str: string) = str.TrimEnd(trimChars |> Seq.toArray) 212 | 213 | let inline replace (before: ^T) (after: ^T) (s: ^String) = 214 | (^String: (member Replace: ^T -> ^T -> ^String) (s, before, after)) 215 | 216 | let inline split (sp: ^T) (s: ^String) = 217 | (^String: (member Split: ^T array -> StringSplitOptions -> ^String array) (s, [|sp|], StringSplitOptions.None)) 218 | 219 | let inline splitSeq (sp: ^T seq) (s: ^String) = 220 | (^String: (member Split: ^T array -> StringSplitOptions -> ^String array) (s, Seq.toArray sp, StringSplitOptions.None)) 221 | 222 | let inline removeEmptyEntries (sp: string array) = sp |> Array.filter (String.IsNullOrEmpty >> not) 223 | 224 | let inline toChars (s: string) = s.ToCharArray() 225 | 226 | let inline ofChars (chars: #seq) = System.String.Concat chars 227 | 228 | let inline nth i (str: string) = str.[i] 229 | 230 | let inline rev (str: string) = 231 | new String(str.ToCharArray() |> Array.rev) 232 | 233 | let inline private whileBase pred act str = 234 | if String.IsNullOrEmpty str then 235 | "" 236 | else 237 | let mutable i = 0 238 | while i < String.length str && str |> nth i |> pred do i <- i + 1 done 239 | if i = 0 then "" 240 | else str |> act i 241 | 242 | let inline take i str = 243 | if i = 0 then "" 244 | else if i >= String.length str then str 245 | else removeAfter i str 246 | 247 | let inline skip i str = 248 | if i = 0 then str 249 | else if i >= String.length str then "" 250 | else substringAfter i str 251 | 252 | let inline takeWhile predicate (str: string) = 253 | whileBase predicate take str 254 | 255 | let inline skipWhile predicate (str: string) = 256 | whileBase predicate skip str 257 | 258 | let inline build (builder: StringBuilder -> unit) = 259 | let sb = new StringBuilder() 260 | builder sb 261 | sb.ToString() 262 | 263 | [] 264 | module StringExtensions = 265 | open System.Text 266 | 267 | type StringBuilder with 268 | member inline this.printf format = 269 | Printf.kprintf (fun s -> this.Append s |> ignore) format 270 | 271 | member inline this.printfn format = 272 | Printf.kprintf (fun s -> this.AppendLine s |> ignore) format 273 | 274 | // from: Collections.fs 275 | open System.Collections.Generic 276 | 277 | type array2d<'t> = 't[,] 278 | type array3d<'t> = 't[,,] 279 | 280 | module List = 281 | let inline splitWith predicate xs = 282 | List.foldBack (fun x state -> 283 | if predicate x then 284 | [] :: state 285 | else 286 | match state with 287 | | [] -> [[x]] 288 | | h :: t -> (x :: h) :: t 289 | ) xs [] 290 | 291 | let inline split separator xs = splitWith ((=) separator) xs 292 | 293 | let inline tryTake length xs = 294 | if List.length xs >= length then 295 | List.take length xs |> Some 296 | else None 297 | 298 | let inline skipSafe length xs = 299 | if List.length xs > length then 300 | List.skip length xs 301 | else List.empty 302 | 303 | let inline foldi folder state xs = 304 | List.fold (fun (i, state) x -> (i + 1, folder i state x)) (0, state) xs |> snd 305 | 306 | module Seq = 307 | let inline splitWith predicate xs = 308 | let i = ref 1 309 | xs |> Seq.groupBy (fun x -> if predicate x then incr i; 0 else !i) 310 | |> Seq.filter (fst >> ((<>) 0)) 311 | |> Seq.map snd 312 | 313 | let inline split separator xs = splitWith ((=) separator) xs 314 | 315 | let inline skipSafe length xs = 316 | xs |> Seq.indexed 317 | |> Seq.skipWhile (fst >> ((>) length)) 318 | |> Seq.map snd 319 | 320 | let inline tryTake length xs = 321 | let xs' = xs |> Seq.indexed |> Seq.cache 322 | if xs' |> Seq.exists (fst >> ((=) (length - 1))) then 323 | xs' |> Seq.take length |> Seq.map snd |> Some 324 | else None 325 | 326 | let inline foldi folder state xs = 327 | Seq.fold (fun (i, state) x -> (i + 1, folder i state x)) (0, state) xs |> snd 328 | 329 | module Array = 330 | let inline skipSafe length xs = 331 | if Array.length xs > length then 332 | Array.skip length xs 333 | else Array.empty 334 | 335 | let inline tryTake length xs = 336 | if Array.length xs > length then 337 | Array.take length xs |> Some 338 | else if Array.length xs = length then Some xs 339 | else None 340 | 341 | let inline foldi folder state xs = 342 | Array.fold (fun (i, state) x -> (i + 1, folder i state x)) (0, state) xs |> snd 343 | 344 | module Map = 345 | open FSharp.Collections 346 | let inline choose c m = 347 | m |> Map.fold ( 348 | fun newMap k v -> 349 | match c k v with 350 | | Some x -> newMap |> Map.add k x 351 | | None -> newMap 352 | ) Map.empty 353 | 354 | /// Appends two maps. If there is a duplicate key, 355 | /// the value in the latter map (`m2`) will be used. 356 | let inline append m1 m2 = 357 | Map.fold (fun m k v -> Map.add k v m) m1 m2 358 | 359 | /// Concats multiple maps. If there is a duplicate key, 360 | /// the value in the last map containing that key will be used. 361 | let inline concat ms = 362 | ms |> Seq.fold (fun state m -> append state m) Map.empty 363 | 364 | /// Merges two maps. If there is a duplicate key, the `merger` function 365 | /// will be called: the first parameter is the key, the second is the value 366 | /// found in the formar map `m1`, and the third is the one found in `m2`. 367 | let inline merge merger m1 m2 = 368 | Map.fold (fun m k v1 -> 369 | match m |> Map.tryFind k with 370 | | Some v2 -> Map.add k (merger k v1 v2) m 371 | | None -> Map.add k v1 m 372 | ) m1 m2 373 | 374 | /// Merges multiple maps. If there is a duplicate key, the `merger` function 375 | /// will be called: the first parameter is the key, the second is the value 376 | /// already found in the earlier maps, and the third is the value newly found. 377 | let inline mergeMany merger ms = 378 | ms |> Seq.fold (fun state m -> merge merger state m) Map.empty 379 | 380 | type dict<'a, 'b> = IDictionary<'a, 'b> 381 | 382 | module Dict = 383 | let inline empty<'a, 'b when 'a: comparison> = Map.empty :> dict<'a, 'b> 384 | let inline map f (d: #dict<_, _>) = 385 | dict <| seq { 386 | for KVP(k, v) in d do 387 | yield k, f k v 388 | } 389 | let inline filter p (d: #dict<_, _>) = 390 | dict <| seq { 391 | for KVP(k, v) in d do 392 | if p k v then yield k,v 393 | } 394 | let inline choose c (d: #dict<_, _>) = 395 | dict <| seq { 396 | for KVP(k, v) in d do 397 | match c k v with 398 | | Some x -> yield k, x 399 | | None -> () 400 | } 401 | let inline fold f init (d: #dict<_, _>) = 402 | Seq.fold (fun state (KVP(k, v)) -> f state k v) init d 403 | let inline count (xs: #dict<_, _>) = xs.Count 404 | let inline exists pred (xs: #dict<_, _>) = 405 | xs :> seq<_> |> Seq.exists (function KVP(k, v) -> pred k v) 406 | let inline containsKey x (xs: #dict<_, _>) = xs.ContainsKey x 407 | let inline find key (xs: #dict<_, _>) = xs.[key] 408 | let inline tryFind key (xs: #dict<_, _>) = 409 | if xs.ContainsKey key then xs.[key] |> Some else None 410 | let inline toMap (xs: #dict<_, _>) = 411 | let mutable m = Map.empty 412 | for KVP(k, v) in xs do 413 | m <- m |> Map.add k v 414 | m 415 | let inline toMutable (xs: #dict<'a, 'b>) = new Dictionary<'a, 'b>(xs :> IDictionary<_, _>) 416 | let inline toSeq (xs: #dict<_, _>) = xs :> seq> 417 | 418 | // from: DataTypes.fs 419 | module Lazy = 420 | let inline run (x: Lazy<_>) = x.Value 421 | 422 | let inline force (x: Lazy<_>) = x.Force() 423 | 424 | let inline bind (f: 'a -> Lazy<'b>) (x: Lazy<'a>) : Lazy<'b> = 425 | Lazy<_>.Create (fun () -> x |> force |> f |> force) 426 | 427 | let inline returnValue x = 428 | Lazy<_>.CreateFromValue x 429 | 430 | let inline returnThunk thunk = 431 | Lazy<_>.Create thunk 432 | 433 | let inline map (f: 'a -> 'b) (x: Lazy<'a>) = 434 | lazy (f x.Value) 435 | 436 | let inline flatten (x: Lazy>) = lazy (!!(!!x)) 437 | 438 | module Tuple = 439 | let inline map2 f g (x, y) = (f x, g y) 440 | let inline map3 f g h (x, y, z) = (f x, g y, h z) 441 | let inline map4 f g h i (x, y, z, w) = (f x, g y, h z, i w) 442 | let inline map5 f g h i j (x, y, z, w, v) = (f x, g y, h z, i w, j v) 443 | 444 | module Result = 445 | let inline bimap f g res = 446 | match res with 447 | | Ok x -> Ok (f x) 448 | | Error e -> Error (g e) 449 | 450 | let inline toOption res = 451 | match res with 452 | | Ok x -> Some x 453 | | Error _ -> None 454 | 455 | let inline toChoice res = 456 | match res with 457 | | Ok x -> Choice1Of2 x 458 | | Error e -> Choice2Of2 e 459 | 460 | let inline ofOption opt = 461 | match opt with 462 | | Some x -> Ok x 463 | | None -> Error () 464 | 465 | let inline ofChoice cic = 466 | match cic with 467 | | Choice1Of2 x -> Ok x 468 | | Choice2Of2 e -> Error e 469 | 470 | let inline get res = 471 | match res with 472 | | Ok x -> x 473 | | Error e -> reraise' e 474 | 475 | let inline catch f res = 476 | match res with 477 | | Ok x -> x 478 | | Error e -> f e 479 | 480 | let inline defaultValue y res = 481 | match res with 482 | | Ok x -> x 483 | | Error _ -> y 484 | 485 | module Async = 486 | open System 487 | open Microsoft.FSharp.Control 488 | 489 | let inline run x = Async.RunSynchronously x 490 | let inline returnValue x = async { return x } 491 | let inline bind f m = async { let! x = m in return! f x } 492 | 493 | let timeout (timeout : TimeSpan) a = 494 | async { 495 | try 496 | let! child = Async.StartChild(a, int timeout.TotalMilliseconds) in 497 | let! result = child in 498 | return Some result 499 | with 500 | | :? TimeoutException -> return None 501 | } 502 | 503 | // from: ComputationExpressions.fs 504 | [] 505 | module ComputationExpressions = 506 | open System.Linq 507 | 508 | (* 509 | // boilerplate for strict monads to add delay/try 510 | 511 | member inline this.Delay f = f 512 | member inline this.Undelay f = f() 513 | member inline this.TryWith (f, h) = try f() with exn -> h exn 514 | member inline this.TryFinally (f, h) = try f() finally h() 515 | 516 | 517 | // boilerplate for any monad to add for/while 518 | 519 | member inline this.Zero () = this.Return () 520 | member inline this.Using (disp: #System.IDisposable, m) = 521 | this.TryFinally( 522 | this.Delay(fun () -> m disp), 523 | fun () -> dispose disp 524 | ) 525 | member inline this.Combine (a, b) = this.Bind (a, fun () -> b) 526 | member inline this.While (cond, m) = 527 | let rec loop cond m = 528 | if cond () then this.Combine(this.Undelay m, loop cond m) 529 | else this.Zero () 530 | loop cond m 531 | member inline this.For (xs: #seq<_>, exec) = 532 | this.Using( 533 | (xs :> seq<_>).GetEnumerator(), 534 | fun en -> 535 | this.While( 536 | en.MoveNext, 537 | this.Delay(fun () -> exec en.Current)) 538 | ) 539 | *) 540 | 541 | type OptionBuilder() = 542 | member inline this.Bind(m, f) = Option.bind f m 543 | member inline this.Return x = Some x 544 | member inline this.ReturnFrom x = x 545 | 546 | member inline this.Delay f = f 547 | member inline this.Undelay f = f() 548 | member inline this.TryWith (f, h) = try f() with exn -> h exn 549 | member inline this.TryFinally (f, h) = try f() finally h() 550 | 551 | member inline this.Zero () = this.Return () 552 | member inline this.Using (disp: #System.IDisposable, m) = 553 | this.TryFinally( 554 | this.Delay(fun () -> m disp), 555 | fun () -> dispose disp 556 | ) 557 | member inline this.Combine (a, b) = this.Bind (a, fun () -> b) 558 | member inline this.While (cond, m) = 559 | let rec loop cond m = 560 | if cond () then this.Combine(this.Undelay m, loop cond m) 561 | else this.Zero () 562 | loop cond m 563 | member inline this.For (xs: #seq<_>, exec) = 564 | this.Using( 565 | (xs :> seq<_>).GetEnumerator(), 566 | fun en -> 567 | this.While( 568 | en.MoveNext, 569 | this.Delay(fun () -> exec en.Current)) 570 | ) 571 | 572 | type ResultBuilder() = 573 | member inline this.Bind(m, f) = Result.bind f m 574 | member inline this.Return x = Ok x 575 | member inline this.ReturnFrom x = x 576 | 577 | member inline this.Delay f = f 578 | member inline this.Undelay f = f() 579 | member inline this.TryWith (f, h) = try f() with exn -> h exn 580 | member inline this.TryFinally (f, h) = try f() finally h() 581 | 582 | member inline this.Zero () = this.Return () 583 | member inline this.Using (disp: #System.IDisposable, m) = 584 | this.TryFinally( 585 | this.Delay(fun () -> m disp), 586 | fun () -> dispose disp 587 | ) 588 | member inline this.Combine (a, b) = this.Bind (a, fun () -> b) 589 | member inline this.While (cond, m) = 590 | let rec loop cond m = 591 | if cond () then this.Combine(this.Undelay m, loop cond m) 592 | else this.Zero () 593 | loop cond m 594 | member inline this.For (xs: #seq<_>, exec) = 595 | this.Using( 596 | (xs :> seq<_>).GetEnumerator(), 597 | fun en -> 598 | this.While( 599 | en.MoveNext, 600 | this.Delay(fun () -> exec en.Current)) 601 | ) 602 | 603 | 604 | type LazyBuilder() = 605 | member inline this.Bind(m, f) = Lazy.bind f m 606 | member inline this.Return x = lazy x 607 | member inline this.ReturnFrom m = m 608 | 609 | member inline this.Delay f = this.Bind(this.Return (), f) 610 | member inline this.Undelay x = x 611 | member inline this.TryWith (m, f) = 612 | lazy (try Lazy.force m with exn -> f exn) 613 | member inline this.TryFinally (m, f) = 614 | lazy (try Lazy.force m finally f() ) 615 | 616 | member inline this.Zero () = this.Return () 617 | member inline this.Using (disp: #System.IDisposable, m) = 618 | this.TryFinally( 619 | this.Delay(fun () -> m disp), 620 | fun () -> dispose disp 621 | ) 622 | member inline this.Combine (a, b) = this.Bind (a, fun () -> b) 623 | member inline this.While (cond, m) = 624 | let rec loop cond m = 625 | if cond () then this.Combine(this.Undelay m, loop cond m) 626 | else this.Zero () 627 | loop cond m 628 | member inline this.For (xs: #seq<_>, exec) = 629 | this.Using( 630 | (xs :> seq<_>).GetEnumerator(), 631 | fun en -> 632 | this.While( 633 | en.MoveNext, 634 | this.Delay(fun () -> exec en.Current)) 635 | ) 636 | 637 | open System.Threading.Tasks 638 | type AsyncBuilder with 639 | member inline this.Bind(t:Task<'T>, f:'T -> Async<'R>) : Async<'R> = 640 | async.Bind(Async.AwaitTask t, f) 641 | member inline this.Bind(t:Task, f:unit -> Async<'R>) : Async<'R> = 642 | async.Bind(Async.AwaitTask t, f) 643 | 644 | [] 645 | module Do = 646 | let option = OptionBuilder() 647 | let result = ResultBuilder() 648 | let lazy' = LazyBuilder() 649 | 650 | 651 | // from: IO.fs 652 | open System 653 | open System.IO 654 | 655 | module Path = 656 | 657 | let combine x y = Path.Combine(x, y) 658 | 659 | let combineMany xs = Path.Combine <| Seq.toArray xs 660 | 661 | let makeRelativeTo parentDir file = 662 | let filePath = new Uri(file) 663 | let path = 664 | new Uri ( 665 | if (parentDir |> String.endsWith (to_s Path.DirectorySeparatorChar) |> not) then 666 | sprintf "%s%c" parentDir Path.DirectorySeparatorChar 667 | else 668 | parentDir 669 | ) 670 | Uri.UnescapeDataString( 671 | path.MakeRelativeUri(filePath) 672 | |> to_s 673 | |> String.replace '/' Path.DirectorySeparatorChar) 674 | 675 | module File = 676 | let inline isHidden path = 677 | File.GetAttributes(path).HasFlag(FileAttributes.Hidden) 678 | 679 | module Directory = 680 | let inline isHidden dir = 681 | DirectoryInfo(dir).Attributes.HasFlag(FileAttributes.Hidden) 682 | 683 | let rec enumerateFilesRecursively includeHidden dir = 684 | seq { 685 | for x in Directory.EnumerateFiles dir do 686 | if includeHidden || not (File.isHidden x) then 687 | yield x 688 | for subdir in Directory.EnumerateDirectories dir do 689 | if includeHidden || not (isHidden subdir) then 690 | yield! enumerateFilesRecursively includeHidden subdir 691 | } 692 | 693 | // from: Task.fs 694 | open System.Threading.Tasks 695 | 696 | type task<'t> = Task<'t> 697 | type plaintask = Task 698 | 699 | module Task = 700 | let inline run (t: _ task) = t.Result 701 | 702 | let inline runThunked (thunk: unit -> _ task) =thunk().Result 703 | 704 | let inline tryRun (t: _ task) = 705 | try Ok <| run t with e -> Error e 706 | 707 | let inline tryRunThunked (thunk: unit -> _ task) = 708 | try Ok <| runThunked thunk with e -> Error e 709 | 710 | let inline bind (f: 'a -> 'b task) (t: 'a task) : 'b task = 711 | t.ContinueWith(fun (x: _ task) -> f x.Result).Unwrap() 712 | 713 | let inline returnValue x : _ task= 714 | let s = TaskCompletionSource() 715 | s.SetResult x 716 | s.Task 717 | 718 | let inline returnThunk thunk = new Task<_>(fun () -> thunk ()) 719 | 720 | let inline map (f: 'a -> 'b) (t: 'a task) : 'b task = 721 | t.ContinueWith(fun (x: _ task) -> f x.Result) 722 | 723 | let inline catch (t: _ task) : _ task = 724 | returnThunk (fun () -> try Ok t.Result with e -> Error e) 725 | 726 | let inline ofAsync (a: Async<_>) = a |> Async.StartAsTask 727 | 728 | let inline ofAsyncThunked (a: Async<_>) () = a |> Async.StartAsTask 729 | 730 | let inline toAsync (t: _ task) = Async.AwaitTask t 731 | 732 | let inline toAsyncThunked (thunk: unit -> _ task) = async { return runThunked thunk } 733 | 734 | let inline ignore (t: _ task) : unit task = t |> map ignore 735 | 736 | let inline ignorePlain (t: _ task) : plaintask = t :> plaintask 737 | 738 | let inline isCompleted (t: #plaintask) = t.IsCompleted 739 | let inline isCanceled (t: #plaintask) = t.IsCanceled 740 | let inline isFaulted (t: #plaintask) = t.IsFaulted 741 | let inline exn (t: #plaintask) = match t.Exception with null -> None | exn -> Some exn 742 | 743 | // from: Utilities.fs 744 | module Convert = 745 | let inline hexsToInt (hexs: #seq) = 746 | let len = Seq.length hexs - 1 747 | hexs |> Seq.foldi (fun i sum x -> 748 | let n = 749 | let n = int x - int '0' 750 | if n < 10 then n 751 | else if n < 23 then n - 7 752 | else n - 44 753 | sum + n * pown 16 (len - i)) 0 754 | 755 | let inline digitsToInt (digits: #seq) = 756 | let len = Seq.length digits - 1 757 | digits |> Seq.foldi (fun i sum x -> 758 | sum + (int x - int '0') * pown 10 (len - i)) 0 759 | 760 | module Shell = 761 | open System.Diagnostics 762 | 763 | let inline eval cmd args = 764 | use p = new Process() 765 | p.EnableRaisingEvents <- false 766 | p.StartInfo.UseShellExecute <- false 767 | p.StartInfo.FileName <- cmd 768 | p.StartInfo.Arguments <- args |> String.concat " " 769 | p.StartInfo.RedirectStandardInput <- true 770 | p.StartInfo.RedirectStandardOutput <- true 771 | p.Start() |> ignore 772 | p.WaitForExit() 773 | p.StandardOutput.ReadToEnd() 774 | 775 | let inline evalAsync cmd args = 776 | async { 777 | use p = new Process() 778 | do p.EnableRaisingEvents <- false 779 | do p.StartInfo.UseShellExecute <- false 780 | do p.StartInfo.FileName <- cmd 781 | do p.StartInfo.Arguments <- args |> String.concat " " 782 | do p.StartInfo.RedirectStandardInput <- true 783 | do p.StartInfo.RedirectStandardOutput <- true 784 | do p.Start() |> ignore 785 | do p.WaitForExit() 786 | return p.StandardOutput.ReadToEnd() 787 | } 788 | 789 | let inline pipe cmd args (stdin: string) = 790 | use p = new Process() 791 | p.EnableRaisingEvents <- false 792 | p.StartInfo.UseShellExecute <- false 793 | p.StartInfo.FileName <- cmd 794 | p.StartInfo.Arguments <- args |> String.concat " " 795 | p.StartInfo.RedirectStandardInput <- true 796 | p.StartInfo.RedirectStandardOutput <- true 797 | p.Start() |> ignore 798 | p.StandardInput.WriteLine stdin 799 | p.WaitForExit() 800 | p.StandardOutput.ReadToEnd() 801 | 802 | let inline pipeAsync cmd args (stdin: string) = 803 | async { 804 | use p = new Process() 805 | do p.EnableRaisingEvents <- false 806 | do p.StartInfo.UseShellExecute <- false 807 | do p.StartInfo.FileName <- cmd 808 | do p.StartInfo.Arguments <- args |> String.concat " " 809 | do p.StartInfo.RedirectStandardInput <- true 810 | do p.StartInfo.RedirectStandardOutput <- true 811 | do p.Start() |> ignore 812 | do! p.StandardInput.WriteLineAsync stdin 813 | do p.WaitForExit() 814 | return p.StandardOutput.ReadToEnd() 815 | } 816 | 817 | let inline run cmd args = 818 | use p = new Process() 819 | p.EnableRaisingEvents <- false 820 | p.StartInfo.UseShellExecute <- false 821 | p.StartInfo.FileName <- cmd 822 | p.StartInfo.Arguments <- args |> String.concat " " 823 | p.Start() |> ignore 824 | p.WaitForExit() 825 | p.ExitCode 826 | 827 | let inline runAsync cmd args = 828 | async { 829 | use p = new Process() 830 | do p.EnableRaisingEvents <- false 831 | do p.StartInfo.UseShellExecute <- false 832 | do p.StartInfo.FileName <- cmd 833 | do p.StartInfo.Arguments <- args |> String.concat " " 834 | do p.Start() |> ignore 835 | do p.WaitForExit() 836 | return p.ExitCode 837 | } 838 | 839 | --------------------------------------------------------------------------------