Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
877 lines (813 sloc) 35.7 KB
namespace Fake.Core
exception DocoptException of string
with override x.Message = sprintf "%s" x.Data0
namespace Fake.Core.CommandLineParsing
open Fake.Core
open FParsec
open System
open System.Text
exception private InternalException of ErrorMessageList
exception UsageException of string
with override x.Message = sprintf "%s" x.Data0
module private Helpers =
let raiseArgvException errlist' =
let pos = Position(null, 0L, 0L, 0L) in
let perror = ParserError(pos, null, errlist') in
raise (DocoptException(perror.ToString()))
let improveErrorText (lnNr:int64) (colNr:int64) (arg:string) (oldText:string) =
oldText.Replace(
sprintf "argv: Ln: %d Col: %d" lnNr colNr,
sprintf "Argument %d ('%s')" (colNr + 1L) arg)
let unexpectedShort = string
>> ( + ) "short option -"
>> unexpected
let unexpectedLong = ( + ) "long option --"
>> unexpected
let expectedArg = ( + ) "argument "
>> expected
let unexpectedArg = ( + ) "argument "
>> unexpected
let raiseInternal exn' = raise (InternalException exn')
let raiseUnexpectedShort s' = raiseInternal (unexpectedShort s')
let raiseUnexpectedLong l' = raiseInternal (unexpectedLong l')
let raiseUnexpectedArg a' = raiseInternal (unexpectedArg a')
let inline printSOption s =
match s with
| None -> ""
| Some s -> s
let inline printReplyStatus (r:ReplyStatus) =
match r with
| ReplyStatus.Ok -> "Ok"
| ReplyStatus.Error -> "Error"
| ReplyStatus.FatalError -> "FatalError"
| _ -> sprintf "%d" (int r)
open Helpers
module ArgumentArray =
let isShortArgument (arg:string)=
arg.StartsWith "-" && not (arg.StartsWith "--") && arg <> "-"
type ArgumentStreamPosition =
// The position of the argument
| ArgumentPos of int
// For short options like -adf we iterate over every letter
| ShortArgumentPartialPos of int * int
override x.ToString () =
match x with
| ArgumentPos p -> sprintf "ArgumentPos(%d)" p
| ShortArgumentPartialPos (p, part) -> sprintf "ArgumentPos(%d, %d)" p part
member x.ArgIndex =
match x with
| ShortArgumentPartialPos (p, _)
| ArgumentPos p -> p
member x.InnerIndex =
match x with
| ShortArgumentPartialPos (_, i) -> i
| ArgumentPos _ -> 0
member x.IsEndOf (argv:string array) =
match x with
| ArgumentPos x -> x >= argv.Length
| ShortArgumentPartialPos (x, innerPos) ->
if x >= argv.Length then true
else
if x = argv.Length - 1 then
let arg = argv.[x]
innerPos >= arg.Length
else false
member x.Next (argv:string array) =
let res =
match x with
| ArgumentPos x ->
assert (x >= argv.Length || not (ArgumentArray.isShortArgument argv.[x]))
if x + 1 < argv.Length then
let next = argv.[x+1]
if not (ArgumentArray.isShortArgument next) then
ArgumentPos (x + 1)
else
ShortArgumentPartialPos(x + 1, 1)
else ArgumentPos (argv.Length)
| ShortArgumentPartialPos (x, i) ->
let c = argv.[x]
if i + 1 < c.Length then
ShortArgumentPartialPos (x, i + 1)
else
if x + 1 < argv.Length then
let next = argv.[x+1]
if not (ArgumentArray.isShortArgument next) then
ArgumentPos (x + 1)
else
ShortArgumentPartialPos(x + 1, 1)
else ArgumentPos (argv.Length)
//printfn "%A -> Next(%A) -> %A" x argv res
res
member x.NextArg (argv: string array) =
let res =
match x with
| ArgumentPos x
| ShortArgumentPartialPos (x, _) ->
if x + 1 < argv.Length then
let next = argv.[x+1]
if not (ArgumentArray.isShortArgument next) then
ArgumentPos (x + 1)
else
ShortArgumentPartialPos(x + 1, 1)
else ArgumentPos (argv.Length)
//printfn "%A -> NextArg(%A) -> %A" x argv res
res
type IArgumentStreamState<'TUserState> = interface end // { Pos : int; StateTag : int64; UserState : 'TUserState }
type IArgumentStream<'TUserState> =
abstract CurrentState : IArgumentStreamState<'TUserState>
abstract Position : ArgumentStreamPosition
abstract RestoreState : IArgumentStreamState<'TUserState> -> unit
abstract StateTag : int64
abstract UserState : 'TUserState with get, set
abstract UpdateStateTag : unit -> unit
abstract Seek : ArgumentStreamPosition -> unit
abstract Peek : unit -> string option
abstract PeekFull : unit -> string option
abstract IsEnd : bool
abstract Skip : unit -> unit
abstract SkipFull : unit -> unit
abstract SkipAndPeek : unit -> string option
abstract SkipAndPeekFull : unit -> string option
abstract Read : unit -> string option
abstract ReadFull : unit -> string option
abstract Argv : string array
type ArgumentStreamState<'TUserState> =
{ Pos : ArgumentStreamPosition; StateTag : int64; UserState : 'TUserState }
with interface IArgumentStreamState<'TUserState>
type ArgumentStream<'TUserState> private (argv:string array, initState:'TUserState) =
let mutable pos =
if argv.Length > 0 && ArgumentArray.isShortArgument argv.[0]
then ShortArgumentPartialPos(0, 1)
else ArgumentPos 0
let mutable stateTag = 0L
let mutable state = initState
let markChange () =
stateTag <- stateTag + 1L
let inc () =
markChange()
pos <- pos.Next(argv)
let incFull () =
markChange()
pos <- pos.NextArg(argv)
//if pos.ArgumentPosition < argv.Length then pos <- pos + 1
let current () =
match pos with
| ArgumentPos x ->
if x < argv.Length then Some argv.[x] else None
| ShortArgumentPartialPos (x, i) ->
if x < argv.Length then Some (sprintf "-%c" argv.[x].[i])
else None
let currentFull () =
match pos with
| ShortArgumentPartialPos (x, _)
| ArgumentPos x ->
if x < argv.Length then Some argv.[x] else None
interface IArgumentStream<'TUserState> with
member x.CurrentState = { Pos = pos; StateTag = stateTag; UserState = state} :> IArgumentStreamState<'TUserState>
member x.Position = pos
member x.RestoreState (oldState:IArgumentStreamState<'TUserState>) =
match oldState with
| :? ArgumentStreamState<'TUserState> as oldState ->
pos <- oldState.Pos
stateTag <- oldState.StateTag
state <- oldState.UserState
| _ -> failwithf "invalid state object"
member x.StateTag = stateTag
member x.UserState
with get () = state
and set v =
if not (obj.ReferenceEquals(v, state)) then
markChange (); state <- v
member x.UpdateStateTag () = markChange()
member x.Seek newPos =
markChange()
pos <- newPos
member x.Peek () = current()
member x.PeekFull () = currentFull()
member x.IsEnd = pos.IsEndOf argv
member x.Skip () = inc()
member x.SkipFull () = incFull()
member x.SkipAndPeek () =
let xx = x :> IArgumentStream<_>
xx.Skip(); xx.Peek()
member x.SkipAndPeekFull () =
let xx = x :> IArgumentStream<_>
xx.SkipFull(); xx.PeekFull()
member x.Read () =
let va = current()
inc()
va
member x.ReadFull () =
let va = currentFull()
incFull()
va
member x.Argv = argv
static member Create(argv:string array, initState:'TUserState) =
new ArgumentStream<'TUserState>(argv, initState)
override x.ToString() =
sprintf "Pos: %O, [|%s|], state: %O" pos (System.String.Join(";", argv)) state
module ArgumentStream =
let create (argv:string array) (initState:'TUserState) =
ArgumentStream<'TUserState>.Create(argv, initState) :> IArgumentStream<_>
let clone (stream:IArgumentStream<_>) =
let clone = ArgumentStream<'TUserState>.Create(stream.Argv, stream.UserState) :> IArgumentStream<_>
clone.RestoreState ({ Pos = stream.Position; StateTag = stream.StateTag; UserState = stream.UserState} :> IArgumentStreamState<'TUserState>)
clone
type MappingStreamState<'u, 't, 'tinner> =
{ Inner : IArgumentStreamState<'tinner>
State : 'u }
with interface IArgumentStreamState<'t>
let map (newState:'un) map (inner:IArgumentStream<'uo>) =
let mutable newState = newState
{ new IArgumentStream<'un> with
member x.CurrentState =
let innerState = inner.CurrentState
{ Inner = innerState; State = newState } :> IArgumentStreamState<'un>
member x.Position = inner.Position
member x.RestoreState (oldState:IArgumentStreamState<'un>) =
match oldState with
| :? MappingStreamState<'un, 'un, 'uo> as state ->
// let state = { Pos = oldState.Pos; StateTag = oldState.StateTag; UserState = map oldState.UserState }
inner.RestoreState state.Inner
newState <- state.State
| _ -> failwithf "Invalid state object"
member x.StateTag = inner.StateTag
member x.UserState
with get () = newState
and set v =
if not (obj.ReferenceEquals(v, newState)) then
newState <- v
inner.UserState <- map inner.UserState v
inner.UpdateStateTag()
member x.UpdateStateTag () = inner.UpdateStateTag()
member x.Seek newPos = inner.Seek newPos
member x.Peek () = inner.Peek ()
member x.PeekFull () = inner.PeekFull ()
member x.IsEnd = inner.IsEnd
member x.Skip () = inner.Skip()
member x.SkipFull () = inner.SkipFull()
member x.SkipAndPeek () = inner.SkipAndPeek()
member x.SkipAndPeekFull () = inner.SkipAndPeekFull()
member x.Read () = inner.Read()
member x.ReadFull () = inner.ReadFull()
member x.Argv = inner.Argv }
type ArgumentParser<'TUserState, 'TResult> = IArgumentStream<'TUserState> -> Reply<'TResult>
module ArgParser =
let preturn x : ArgumentParser<_,_> = fun stream -> Reply(x)
let pzero : ArgumentParser<_,_> = fun stream -> Reply(Error, FParsec.Error.NoErrorMessages)
let (>>=) (p: ArgumentParser<'u, 'a>) (f: 'a -> ArgumentParser<'u, 'b>) : ArgumentParser<_,_> =
fun stream ->
let reply1 = p stream
if reply1.Status = Ok then
let p2 = f reply1.Result
let stateTag = stream.StateTag
let mutable reply2 = p2 stream
if stateTag = stream.StateTag && reply2.Status = Error then
reply2.Error <- mergeErrors reply1.Error reply2.Error
reply2
else
Reply(reply1.Status, reply1.Error)
let (>>%) p x = p >>= fun _ -> preturn x
let (>>.) p1 p2 = p1 >>= fun _ -> p2
let (.>>) p1 p2 = p1 >>= fun x -> p2 >>% x
let (.>>.) p1 p2 = p1 >>= fun a -> p2 >>= fun b -> preturn (a, b)
let between (popen: ArgumentParser<_,'u>) (pclose: ArgumentParser<'u,_>) (p: ArgumentParser<'u,_>) =
popen >>. p .>> pclose
let (|>>) p f = p >>= fun x -> preturn (f x)
let (<?>) (p: ArgumentParser<'u,'a>) label : ArgumentParser<'u,'a> =
let error = expected label
fun stream ->
let stateTag = stream.StateTag
let mutable reply = p stream
if stateTag = stream.StateTag then
reply.Error <- error
reply
let choiceBest (ps : seq<ArgumentParser<'u, 'a>>) : ArgumentParser<_, _> =
fun (stream:IArgumentStream<_>) ->
let results =
ps
|> Seq.map (fun p -> async {
let cpStream = ArgumentStream.clone stream
let reply = p cpStream
return cpStream, reply
})
|> Async.Parallel
|> Async.RunSynchronously
let maxArgLength = (Seq.append stream.Argv [""] |> Seq.maxBy (fun (arg:string) -> arg.Length)).Length
let mutable (bestStream, bestResult) =
results
|> Seq.maxBy (fun (stream, reply) ->
if reply.Status <> Ok
then -stream.Argv.Length - 1 + stream.Position.ArgIndex, -maxArgLength - 1 + stream.Position.InnerIndex
else stream.Position.ArgIndex, stream.Position.InnerIndex)
let reply =
if bestResult.Status <> Ok then
let errors =
results
|> Seq.fold (fun (errors:ErrorMessageList) (_, reply) -> mergeErrors errors reply.Error) NoErrorMessages
bestResult.Error <- errors
bestResult
else
bestResult
while stream.Position <> bestStream.Position do stream.Read() |> ignore
stream.UserState <- bestStream.UserState
reply
let choice (ps : seq<ArgumentParser<'u, 'a>>) : ArgumentParser<_, _> =
fun (stream:IArgumentStream<_>) ->
use iter = ps.GetEnumerator()
if iter.MoveNext() then
let state = stream.CurrentState
let stateTag = stream.StateTag
let mutable error = NoErrorMessages
let mutable reply = iter.Current stream
while reply.Status = Error && iter.MoveNext() do
if stateTag <> stream.StateTag then
stream.RestoreState state
error <- mergeErrors error reply.Error
reply <- iter.Current stream
if stateTag = stream.StateTag && reply.Status = Error then
error <- mergeErrors error reply.Error
reply.Error <- error
reply
else Reply()
let (<|>) p1 p2 = choice [p1;p2]
[<Sealed>]
type Inline =
[<NoDynamicInvocation>]
static member inline
Many(stateFromFirstElement,
foldState,
resultFromState,
elementParser: ArgumentParser<_,_>,
?firstElementParser: ArgumentParser<_,_>,
?resultForEmptySequence) : ArgumentParser<_,_> =
fun stream ->
let mutable stateTag = stream.StateTag
let firstElementParser = match firstElementParser with Some p -> p | _ -> elementParser
let mutable reply = firstElementParser stream
if reply.Status = Ok then
let mutable xs = stateFromFirstElement reply.Result
let mutable error = reply.Error
stateTag <- stream.StateTag
reply <- elementParser stream
while reply.Status = Ok (*&& stateTag <> stream.StateTag*) do
if stateTag = stream.StateTag then
failwithf "infiniteLoopException %O" stream
xs <- foldState xs reply.Result
error <- reply.Error
stateTag <- stream.StateTag
reply <- elementParser stream
if reply.Status = Error && stateTag = stream.StateTag then
error <- mergeErrors error reply.Error
Reply(Ok, resultFromState xs, error)
else
error <- if stateTag <> stream.StateTag then reply.Error
else mergeErrors error reply.Error
Reply(reply.Status, error)
else
match resultForEmptySequence with
| Some _ (* if we bind f here, fsc won't be able to inline it *)
when reply.Status = Error && stateTag = stream.StateTag ->
Reply(Ok, (match resultForEmptySequence with Some f -> f() | _ -> Unchecked.defaultof<_>), reply.Error)
| _ ->
Reply(reply.Status, reply.Error)
let many p = Inline.Many((fun x -> [x]), (fun xs x -> x::xs), List.rev, p, resultForEmptySequence = fun () -> [])
let many1 p = Inline.Many((fun x -> [x]), (fun xs x -> x::xs), List.rev, p)
let pseq (ps : seq<ArgumentParser<_, _>>) : ArgumentParser<_, _> =
Seq.fold (>>.) (preturn Map.empty) ps
type internal UnorderedState<'u, 'a> =
{ InnerState : 'u
AppliedParsers : int list }
let internal mapParserToUnorderedState i (p:ArgumentParser<'u, _>) : ArgumentParser<UnorderedState<'u, _>, _> =
fun innerStream ->
let oldStream =
ArgumentStream.map
(innerStream.UserState.InnerState)
(fun unorderd s -> { unorderd with InnerState = s })
innerStream
let reply = p oldStream
if reply.Status = Ok then innerStream.UserState <- { innerStream.UserState with AppliedParsers = i :: innerStream.UserState.AppliedParsers }
reply
let punorderedseqWithMany allowEmpty allowMissing (ps : seq<bool * ArgumentParser<'u, 'a>>) : ArgumentParser<'u, _> =
fun (stream:IArgumentStream<_>) ->
let newStream =
ArgumentStream.map
{ InnerState = stream.UserState; AppliedParsers = [] }
(fun _ s -> s.InnerState)
stream
let allParsers =
ps
|> Seq.mapi (fun i (allowMultiple, p) -> allowMultiple, mapParserToUnorderedState i p)
|> Seq.toList
let mutable availableParsers = allParsers
let mutable reply = Reply(Unchecked.defaultof<'a>)
let mutable results = []
while reply.Status = ReplyStatus.Ok && availableParsers.Length > 0 do
reply <- choice (availableParsers |> Seq.map snd) newStream
if (reply.Status = ReplyStatus.Ok) then
results <- reply.Result :: results
availableParsers <-
allParsers
|> List.mapi (fun i p -> i, p)
|> List.filter(fun (i, (allowMultiple, _)) -> allowMultiple || not (List.exists (fun applied -> applied = i) newStream.UserState.AppliedParsers))
|> List.map snd
if reply.Status = Error && not allowMissing then
Reply(reply.Status, reply.Error)
else
if not allowEmpty && results = [] then
Reply(reply.Status, reply.Error)
else
Reply(results)
let punorderedseq allowEmpty allowMissing (ps : seq<ArgumentParser<'u, 'a>>) : ArgumentParser<'u, _> =
punorderedseqWithMany allowEmpty allowMissing (ps |> Seq.map (fun p -> false, p))
let chooseParser itemType chooser =
fun (stream:IArgumentStream<_>) ->
match chooser (stream.Peek()) with
| Some result ->
stream.Skip()
Reply(result)
| None ->
let e1 = expected itemType
let e2 = unexpected (sprintf "%s" (stream.PeekFull() |> printSOption))
let error = mergeErrors e1 e2
Reply(ReplyStatus.Error, error)
let chooseParserFull itemType chooser =
fun (stream:IArgumentStream<_>) ->
match chooser (stream.PeekFull()) with
| Some result ->
stream.SkipFull()
Reply(result)
| None ->
let e1 = expected itemType
let e2 = unexpected (sprintf "%s" (stream.PeekFull() |> printSOption))
let error = mergeErrors e1 e2
Reply(ReplyStatus.Error, error)
let chooseParser' itemType chooser =
let choose arg =
match arg with
| Some a -> chooser a
| None -> None
chooseParser itemType choose
let chooseParserFull' itemType chooser =
let choose arg =
match arg with
| Some a -> chooser a
| None -> None
chooseParserFull itemType choose
let pcmd cmd =
let chooseCmd arg =
if arg = cmd then Some cmd else None
chooseParserFull' (sprintf "Command '%s'" cmd) chooseCmd
let parg argName = chooseParserFull (sprintf "Argument for '%s'" argName) id
let updateUserState (map':'a -> DocoptMap -> DocoptMap) : 'a -> ArgumentParser<DocoptMap, DocoptMap> =
fun arg' ->
fun stream' ->
let res = map' arg' stream'.UserState
stream'.UserState <- res
Reply(res)
let debug (map':'a -> IArgumentStream<'state> -> unit) : 'a -> ArgumentParser<'state, 'a> =
fun arg' ->
fun stream' ->
map' arg' stream'
Reply(arg')
let updateMap key newItem map =
match Map.tryFind key map, newItem with
| None, _
| Some DocoptResult.NoResult, _ -> Map.add key newItem map
| _, DocoptResult.NoResult -> map
| Some (DocoptResult.Argument arg1), DocoptResult.Argument arg2 ->
Map.add key (DocoptResult.Arguments [arg1; arg2]) map
| Some (DocoptResult.Argument arg1), DocoptResult.Arguments argList ->
Map.add key (DocoptResult.Arguments (arg1 :: argList)) map
| Some (DocoptResult.Arguments argList1), DocoptResult.Argument arg2 ->
Map.add key (DocoptResult.Arguments (argList1 @ [arg2])) map
| Some (DocoptResult.Arguments argList1), DocoptResult.Arguments argList2 ->
Map.add key (DocoptResult.Arguments (argList1 @ argList2)) map
| Some (DocoptResult.Flag), DocoptResult.Flag ->
Map.add key (DocoptResult.Flags 2) map
| Some (DocoptResult.Flags n1), DocoptResult.Flag ->
Map.add key (DocoptResult.Flags (n1 + 1)) map
| Some (DocoptResult.Flag), DocoptResult.Flags n2 ->
Map.add key (DocoptResult.Flags (n2 + 1)) map
| Some (DocoptResult.Flags n1), DocoptResult.Flags n2 ->
Map.add key (DocoptResult.Flags (n1 + n2)) map
| Some v, _ -> failwithf "Cannot add value %O as %s -> %O already exists in the result map" newItem key v
let saveInMap key f =
updateUserState (fun item map ->
let newItem = f item
updateMap key newItem map)
let saveInMapM keys f =
updateUserState (fun item map ->
let newItem = f item
keys |> Seq.fold (fun map key -> updateMap key newItem map) map)
let multipleSaveInMap f =
updateUserState (fun item map ->
f item |> Seq.fold (fun map (key, newItem) -> updateMap key newItem map) map)
let mergeMap m1 m2 =
Map.fold (fun s k v -> Map.add k v s) m1 m2
let mergeMaps maps =
Seq.fold mergeMap Map.empty maps
let pLongFlag (flag:SafeOption) =
if not flag.IsLong then failwithf "Cannot parse empty short flag %O" flag
let keys =
[ if flag.IsShort then yield flag.FullShort
if flag.IsLong then yield flag.FullLong ]
let single =
let chooseCmd arg =
match arg with
| Some arg when arg = flag.FullLong -> Some arg
| _ -> None
chooseParserFull (sprintf "Flag '%s'" flag.FullLong) chooseCmd
if flag.HasArgument then
let chooseCmd arg =
match arg with
| Some (arg:string) when arg.StartsWith (flag.FullLong + "=") -> Some (arg.Substring (flag.FullLong.Length + 1))
| _ -> None
chooseParserFull (sprintf "Flag '%s='" flag.FullLong) chooseCmd <|> (single >>. parg flag.FullLong)
>>= saveInMapM keys (DocoptResult.Argument)
else
single
>>= saveInMapM keys (fun _ -> DocoptResult.Flag)
let pShortFlag (flag : SafeOption) =
if not flag.IsShort then failwithf "Cannot parse empty short flag %O" flag
let keys =
[ if flag.IsShort then yield flag.FullShort
if flag.IsLong then yield flag.FullLong ]
if flag.HasArgument then
// When we have a argument we know we can consume the complete argument
let chooseCmd (stream:IArgumentStream<_>) =
match stream.Peek(), stream.PeekFull() with
| Some (arg:string), Some (fullarg) when arg.StartsWith flag.FullShort ->
let oldPos = stream.Position
stream.SkipFull()
let result =
match oldPos with
| ShortArgumentPartialPos(_, i) when i + 1 < fullarg.Length ->
// Parameter for short switch is in current argument
Some (fullarg.Substring(i + 1))
| _ -> None
Reply(result)
| _ ->
let e1 = expected (sprintf "ShortFlag '%s'" flag.FullShort)
let e2 = unexpected (sprintf "%s" (stream.PeekFull() |> printSOption))
let error = mergeErrors e1 e2
Reply(ReplyStatus.Error, error)
//match arg with
//| Some (arg:string) when arg.StartsWith flag.FullShort ->
// if arg = flag.FullShort then
// Some (None)
// else Some (Some (arg.Substring (flag.FullShort.Length)))
//| _ -> None
chooseCmd
>>= (function
| Some arg -> preturn arg
| None -> parg flag.FullShort)
>>= saveInMapM keys (DocoptResult.Argument)
else
let chooseCmd arg =
match arg with
| Some (arg:string) when arg = flag.FullShort -> Some arg
| _ -> None
chooseParser (sprintf "ShortFlag '%s'" flag.FullShort) chooseCmd
>>= saveInMapM keys (fun _ -> DocoptResult.Flag)
let pOption includeShort (o' : SafeOption) =
let longArg =
if o'.IsLong then pLongFlag o'
else pzero
if includeShort && o'.IsShort then
//let short = pShortOptionsWithSave (SafeOptions [o'])
longArg <|> pShortFlag o'
else longArg
let pOptions allowMissing (flags : SafeOptions) =
let optionParsers = flags |> Seq.map (fun flag -> flag.AllowMultiple, pOption true flag) |> Seq.toList
optionParsers
|> punorderedseqWithMany false allowMissing
>>= updateUserState (fun _ state -> state)
let rec getParser (ast:UsageAst) : ArgumentParser<_, _> =
let p =
match ast with
| UsageAst.Eps -> preturn Map.empty
| UsageAst.Ano (_, o') ->
// Annotations are always optional
pOptions true o' <|> preturn Map.empty
//pzero <?> "Option annotation is not supported yet"
//CharParsers.
| UsageAst.Sop o' -> pOptions false o'
//o'.
//pzero <?> "Short options are not supported yet"
| UsageAst.Lop o' -> pOption true o'
| UsageAst.Sqb (UsageAst.Seq asts') when ast.ContainsOnlyOptions ->
asts'
|> Seq.map getParser
|> Seq.toList
|> punorderedseq false true
>>= updateUserState (fun _ state -> state)
| UsageAst.Sqb (UsageAst.Sop o') -> pOptions true o' <|> preturn Map.empty
| UsageAst.Sqb ast' ->
getParser ast' <|> preturn Map.empty
| UsageAst.Arg name' ->
parg name'
>>= saveInMap (name') (DocoptResult.Argument)
| UsageAst.XorEmpty -> preturn Map.empty
| UsageAst.Xor (l', r') ->
choiceBest [ getParser l'; getParser r' ]
| UsageAst.Seq asts' when ast.ContainsOnlyOptions ->
asts'
|> Seq.map getParser
|> Seq.toList
|> punorderedseq false false
>>= updateUserState (fun _ state -> state)
| UsageAst.Req ast' ->
getParser ast'
| UsageAst.Seq asts' ->
asts'
|> Seq.map getParser
|> pseq
| UsageAst.Cmd cmd' ->
pcmd cmd'
>>= saveInMap cmd' (fun _ -> DocoptResult.Flag)
| UsageAst.Ell (UsageAst.Sqb ast') ->
// Allow zero matches
many (getParser ast')
>>= updateUserState (fun _ state -> state)
| UsageAst.Ell ast' ->
// One or more
many1 (getParser ast')
>>= updateUserState (fun _ state -> state)
| UsageAst.Sdh ->
pcmd "-"
>>= saveInMap "-" (fun _ -> DocoptResult.Flag)
//(debug (fun _ stream ->
// printfn ">>>> STARTING ast %A, state: %A" ast stream) ())
//>>.
p
//>>= debug (fun result stream ->
// printfn ">>>> FINISHED ast %A, state: %A, result: %A" ast stream result)
type UsageParser(usageStrings':string array, sections:(string * SafeOptions) list) =
//let opts' = sections.["options"]
//let mutable isAno = false
//let toIAst obj' = (# "" obj' : UsageAst #) // maybe #IAst instead of IAst
let updateUserState (map':'a -> UsageAstCell -> UsageAstCell) : 'a -> Parser<UsageAstCell, UsageAstCell> =
fun arg' ->
fun stream' ->
let res = map' arg' stream'.UserState in
stream'.UserState <- res;
Reply(res)
let isLetterOrDigit c' = isLetter(c') || isDigit(c')
let opp = OperatorPrecedenceParser<UsageAstCell, _, UsageAstCell>()
let pupperArg =
let start c' = isUpper c' || isDigit c' in
let cont c' = start c' || c' = '-' in
identifier (IdentifierOptions(isAsciiIdStart=start,
isAsciiIdContinue=cont,
label="UPPER-CASE identifier"))
let plowerArg =
satisfyL (( = ) '<') "<lower-case> identifier"
>>. many1SatisfyL (( <> ) '>') "any character except '>'"
.>> skipChar '>'
|>> (fun name' -> String.Concat("<", name', ">"))
let parg =
let filterArg arg' (last':UsageAstCell) =
if obj.ReferenceEquals(null, last')
then UsageAstBuilder.Arg(arg')
elif (match last'.Content with Some (UsageAstBuilder.Sop opts) -> opts.Last.HasArgument | _ -> false)
|| (match last'.Content with Some(UsageAstBuilder.Lop opt) -> opt.HasArgument | _ -> false)
then UsageAstBuilder.Eps
else UsageAstBuilder.Arg(arg')
|> UsageAstCell.FromBuilder
in pupperArg <|> plowerArg
>>= updateUserState filterArg
let pano (title, so:SafeOptions) =
skipString (sprintf "[%s]" title)
>>= updateUserState (fun _ _ -> UsageAstBuilder.Ano(title, so) |> UsageAstBuilder.ToCell)
let psdh = skipString "[-]"
>>= updateUserState (fun _ _ -> UsageAstBuilder.Sqb (UsageAstBuilder.Sdh |> UsageAstBuilder.ToCell)|> UsageAstBuilder.ToCell)
let psop = let filterSops (sops':string) (last':UsageAstCell) =
let sops = ResizeArray<SafeOption>() in
let mutable i = -1 in
while (i <- i + 1; i < sops'.Length) do
//sops.Add({SafeOption.Empty with Short = Some sops'.[i] })
match sections |> Seq.tryPick (fun (_, opts) -> opts.Find(sops'.[i])) with
//match opts'.Find(sops'.[i]) with
| None -> sops.Add({SafeOption.Empty with Short = Some sops'.[i] })
| Some opt ->
(if opt.HasArgument && i + 1 < sops'.Length
then i <- sops'.Length);
sops.Add(opt)
done;
if sops.Count = 0
then UsageAstBuilder.Eps
else match last'.Content with
| Some (UsageAstBuilder.Sop list) ->
last'.Content <- Some (UsageAstBuilder.Sop (list.AddRange(sops |> List.ofSeq)))
UsageAstBuilder.Eps
| _ -> UsageAstBuilder.Sop(SafeOptions(sops |> Seq.toList))
|> UsageAstCell.FromBuilder
in skipChar '-'
>>. many1SatisfyL ( isLetterOrDigit ) "Short option(s)"
>>= updateUserState filterSops
let plop =
let filterLopt (lopt':string, arg':string Option) _ =
//UsageAstBuilder.Lop({SafeOption.Empty with Long = Some lopt'; ArgumentName = arg'})
match sections |> Seq.tryPick (fun (_, opts) -> opts.Find(lopt')) with
//match opts'.Find(lopt') with
| None -> UsageAstBuilder.Lop({SafeOption.Empty with Long = Some lopt'; ArgumentName = arg'})
| Some lopt -> UsageAstBuilder.Lop(lopt)
|> UsageAstCell.FromBuilder
in skipString "--"
>>. manySatisfy (fun c' -> Char.IsLetterOrDigit(c') || c' = '-')
.>>. opt (skipChar '=' >>. (plowerArg <|> pupperArg))
>>= updateUserState filterLopt
let psqb = between (skipChar '[' >>. spaces) (skipChar ']')
opp.ExpressionParser
>>= updateUserState (fun ast' _ -> UsageAstBuilder.Sqb(ast')|> UsageAstCell.FromBuilder)
let preq = between (skipChar '(' >>. spaces) (skipChar ')')
opp.ExpressionParser
>>= updateUserState (fun ast' _ -> UsageAstBuilder.Req(ast')|> UsageAstCell.FromBuilder)
let pcmd = many1Satisfy (fun c' -> isLetter(c') || isDigit(c') || c' = '-')
>>= updateUserState (fun cmd' _ -> UsageAstBuilder.Cmd(cmd')|> UsageAstCell.FromBuilder)
let panoParsers = sections |> List.map pano
let term = choice (Seq.append panoParsers [|
psdh;
plop;
psop;
psqb;
preq;
parg;
pcmd|])
let pxor = let afterStringParser =
spaces
.>> updateUserState (fun _ _ -> UsageAstBuilder.XorEmpty|> UsageAstCell.FromBuilder) ()
in InfixOperator("|", afterStringParser, 10, Associativity.Left,
fun x' y' -> UsageAstBuilder.Xor(x', y') |> UsageAstCell.FromBuilder)
let pell = let afterStringParser =
spaces .>> updateUserState (fun _ _ -> UsageAstBuilder.Ell(UsageAstBuilder.Eps|> UsageAstCell.FromBuilder)|> UsageAstCell.FromBuilder) ()
let makeEll (ast':UsageAstCell) =
match ast'.Content with
| Some (UsageAstBuilder.Seq seq) ->
let cell = seq |> List.last
cell.Content <-
match cell.Content with
| Some c ->
Some (UsageAstBuilder.Ell (UsageAstCell.FromBuilder c))
| None -> Some <| UsageAstBuilder.Ell(UsageAstBuilder.Eps|> UsageAstCell.FromBuilder)
ast'
| _ -> UsageAstBuilder.Ell(ast')|> UsageAstCell.FromBuilder
in PostfixOperator("...", afterStringParser, 20, false, makeEll)
let _ =
opp.TermParser <-
sepEndBy1 term spaces1
>>= updateUserState (fun ast' _ ->
match ast' |> List.filter (fun ast' -> ast'.Content.IsSome && ast'.Content.Value.UsageTag <> Tag.Eps) with
| [] -> UsageAstBuilder.Eps|> UsageAstCell.FromBuilder
| [ast] -> ast
| list -> UsageAstBuilder.Seq(list)|> UsageAstCell.FromBuilder
)
let _ = opp.AddOperator(pxor)
let _ = opp.AddOperator(pell)
let pusageLine = spaces >>. opp.ExpressionParser
let parseAsync = function
| "" -> async { return UsageAst.Eps }
| line -> async {
let line = line.TrimStart() in
let index = line.IndexOfAny([|' ';'\t'|]) in
return if index = -1 then UsageAst.Eps
else let line = line.Substring(index) in
match runParserOnString pusageLine { Content = None } "" line with
| Success(ast, _, _) -> ast.Build()
| Failure(err, _, _) -> raise (UsageException(err))
}
do if usageStrings'.Length = 0 || usageStrings' |> Seq.forall (String.IsNullOrWhiteSpace) then failwithf "Not given any usage-formats"
let asts =
usageStrings'
|> Array.map parseAsync
|> Async.Parallel
|> Async.RunSynchronously
let pAstParser =
let (>>.) = ArgParser.(>>.)
let (>>=) = ArgParser.(>>=)
asts
|> Seq.map ArgParser.getParser
|> ArgParser.choiceBest
>>= ArgParser.updateUserState (fun _ state -> state)
member __.ParseCommandLine (argv) =
let state = ArgumentStream.create argv Map.empty
let reply = pAstParser state
let errors = ErrorMessageList.ToSortedArray(reply.Error)
let argIdx = int64 state.Position.ArgIndex
let parseError = ParserError(Position("argv", argIdx,0L,argIdx), state.UserState, reply.Error)
let errorText =
use sw = new System.IO.StringWriter()
parseError.WriteTo(sw)
sw.ToString()
|> Helpers.improveErrorText 0L argIdx (if argIdx >= 0L && int argIdx < argv.Length then argv.[int argIdx] else "<>")
match reply.Status = ReplyStatus.Ok, errors, state.IsEnd with
| true, [||], true -> reply.Result
| _, _ , true -> raise <| DocoptException (sprintf "errors %s: %s" (printReplyStatus reply.Status) errorText)
| _, [||], false ->
let unparsed = argv.[state.Position.ArgIndex..argv.Length - 1]
raise <| DocoptException (sprintf "'[|%s|]' could not be parsed" (System.String.Join(";", unparsed :> _ seq)))
| _ ->
let unparsed = argv.[state.Position.ArgIndex..argv.Length - 1]
raise <| DocoptException (sprintf "errors: %s, ('[|%s|]' could not be parsed)" errorText (System.String.Join(";", unparsed :> _ seq)))
member __.Asts = asts
You can’t perform that action at this time.