Say I have some text:
a = "foobarbaz"
b = "foobar"
c = "foo"
d = "rubbish"
e = "foobazbar"
and three parsers foo, bar, and baz for the strings 'foo', 'bar' and 'baz' respectively.
How would I create a parser that would give me the results:
a = ["foo", "bar", "baz"]
b = ["foo", "bar"]
c = ["foo"]
d = []
e = ["foo"]
when run against the inputs above? Basically attempt each possibility until failure whilst constructing a list. I could use user state but I would like to avoid if possible. (I would like to keep the individual parsers themselves ignorant of user state)
the closest I have gotten is something like fooseq below:
let foo = pstring "foo"
let bar = pstring "bar"
let baz = pstring "baz"
let foobar = pipe2 foo bar Seq.of2
let foobarbaz = pipe3 foo bar baz Seq.of3
let fooseq = choice (Seq.map attempt [foobarbaz; foobar; foo |>> Seq.of1 ;])
//(the Seq.ofx functions just take arguments and create a sequence of them)
It seems to me there must be a better way of doing this?
FParsec has no built-in sequence combinator that does exactly what you're looking for, but you could implement one yourself like in the following example:
let mySeq (parsers: seq<Parser<'t,'u>>) : Parser<'t[],'u> =
let ps = Array.ofSeq parsers
if ps.Length = 0 then preturn [||]
else
fun stream ->
let mutable stateTag = stream.StateTag
let mutable reply = ps.[0] stream
let mutable error = reply.Error
let mutable myReply = Reply()
if reply.Status <> Ok then myReply.Result <- [||]
else
// create array to hold results
let mutable xs = Array.zeroCreate ps.Length
xs.[0] <- reply.Result
let mutable i = 1
while i < ps.Length do
stateTag <- stream.StateTag
reply <- ps.[i] stream
error <- if stateTag <> stream.StateTag then reply.Error
else mergeErrors error reply.Error
if reply.Status = Ok then
xs.[i] <- reply.Result
i <- i + 1
else // truncate array and break loop
xs <- Array.sub xs 0 i
i <- ps.Length
myReply.Result <- xs
myReply.Status <- if reply.Status = Error && stateTag = stream.StateTag
then Ok
else reply.Status
myReply.Error <- error
myReply
With the mySeq combinator, you can express your fooSeq parser as
let fooSeq = mySeq [foo; bar; baz]
Related
I have a problem where during the parsing of a stream I get to point where the next N characters need to be parsed by applying a specfic parser multiple times (in sequence).
(stripped down toy) Example:
17<tag><anothertag><a42...
^
|- I'm here
Let's say the 17 indicates that the next N=17 characters make up tags, so I need to repetetively apply my "tagParser" but stop after 17 chars and not consume the rest even if it looks like a tag because that has a different meaning and will be parsed by another parser.
I cannot use many or many1 because that would eat the stream beyond those N characters.
Nor can I use parray because I do not know how many successful applications of that parser are there within the N characters.
I was looking into manyMinMaxSatisfy but could not figure out how to make use of it in this case.
Is there a way to cut N chars of a stream and feed them to some parser? Or is there a way to invoke many applications but up to N chars?
Thanks.
You can use getPosition to make sure you don't go past the specified number of characters. I threw this together (using F# 6) and it seems to work, although simpler/faster solutions may be possible:
let manyLimit nChars p =
parse {
let! startPos = getPosition
let rec loop values =
parse {
let! curPos = getPosition
let nRemain = (startPos.Index + nChars) - curPos.Index
if nRemain = 0 then
return values
elif nRemain > 0 then
let! value = p
return! loop (value :: values)
else
return! fail $"limit exceeded by {-nRemain} chars"
}
let! values = loop []
return values |> List.rev
}
Test code:
let ptag =
between
(skipChar '<')
(skipChar '>')
(manySatisfy (fun c -> c <> '>'))
let parser =
parse {
let! nChars = pint64
let! tags = manyLimit nChars ptag
let! rest = restOfLine true
return tags, rest
}
run parser "17<tag><anothertag><a42..."
|> printfn "%A"
Output is:
Success: (["tag"; "anothertag"], "<a42...")
Quite low-level parser, that operates on raw Reply objects. It reads count of chars, creates substring to feed to tags parser and consumes rest. There's should be an easier way, but I don't have much experience with FParsec
open FParsec
type Tag = Tag of string
let pTag = // parses tag string and constructs 'Tag' object
skipChar '<' >>. many1Satisfy isLetter .>> skipChar '>'
|>> Tag
let pCountPrefixedTags stream =
let count = pint32 stream // read chars count
if count.Status = Ok then
let count = count.Result
// take exactly 'count' chars
let tags = manyMinMaxSatisfy count count (fun _ -> true) stream
if tags.Status = Ok then
// parse substring with tags
let res = run (many1 pTag) tags.Result
match res with
| Success (res, _, _) -> Reply(res)
| Failure (_, error, _) -> Reply(ReplyStatus.Error, error.Messages)
else
Reply(tags.Status, tags.Error)
else
Reply(count.Status, count.Error)
let consumeStream =
many1Satisfy (fun _ -> true)
run (pCountPrefixedTags .>>. consumeStream) "17<tag><anothertag><notTag..."
|> printfn "%A" // Success: ([Tag "tag"; Tag "anothertag"], "<notTag...")
You also can do this without going down to stream level.
open FParsec
let ptag =
between
(skipChar '<')
(skipChar '>')
(manySatisfy (fun c -> c <> '>'))
let tagsFromChars (l: char[]) =
let s = new System.String(l)
match run (many ptag) s with
| Success(result, _, _) -> result
| Failure(errorMsg, _, _) -> []
let parser =
parse {
let! nChars = pint32
let! tags = parray nChars anyChar |>> tagsFromChars
let! rest = restOfLine true
return tags, rest
}
run parser "17<tag><anothertag><a42..."
|> printfn "%A"
In the following code, the compiler gets error on index <- index + 1 with error
Error 3 The mutable variable 'index' is used in an invalid way. Mutable variables cannot be captured by closures. Consider eliminating this use of mutation or using a heap-allocated mutable reference cell via 'ref' and '!'. d:\Users....\Program.fs 11 22 ConsoleApplication2
However, it has been defined as mutable?
let rec iterateTupleMemberTypes (tupleArgTypes: System.Type[]) (columnNames: string[]) startingIndex =
seq {
let mutable index = startingIndex
for t in tupleArgTypes do
match t.IsGenericType with
| true -> iterateTupleMemberTypes (t.GetGenericArguments()) columnNames index |> ignore
| false ->
printfn "Name: %s Type: %A" (columnNames.[index]) t
index <- index + 1
yield (columnNames.[index]), t
} |> Map.ofSeq
let myFile = CsvProvider<"""d:\temp\sample.txt""">.GetSample()
let firstRow = myFile.Rows |> Seq.head
let tupleType = firstRow.GetType()
let tupleArgTypes = tupleType.GetGenericArguments()
let m = iterateTupleMemberTypes tupleArgTypes myFile.Headers.Value 0
An idiomatic version of this might look like the following:
#r #"..\packages\FSharp.Data.2.2.2\lib\net40\FSharp.Data.dll"
open FSharp.Data
open System
type SampleCsv = CsvProvider<"Sample.csv">
let sample = SampleCsv.GetSample()
let rec collectLeaves (typeTree : Type) =
seq {
match typeTree.IsGenericType with
| false -> yield typeTree.Name
| true -> yield! typeTree.GetGenericArguments() |> Seq.collect collectLeaves
}
let columnTypes = (sample.Rows |> Seq.head).GetType() |> collectLeaves
let columnDefinitions = columnTypes |> Seq.zip sample.Headers.Value |> Map.ofSeq
let getDefinitions (sample : SampleCsv) = (sample.Rows |> Seq.head).GetType() |> collectLeaves |> Seq.zip sample.Headers.Value |> Map.ofSeq
Personally, I wouldn't be concerned too much about the performance of Map vs Dictionary (and rather have the immutable Map) unless there are hundreds of columns.
The statement after it, let index = 0, shadows your definition of mutable variable index. Also, to make mutables work in sequences, you need refs. https://msdn.microsoft.com/en-us/library/dd233186.aspx
Suggested by #Ming-Tang, I changed the mutable variable to ref and it works now. However, is it a way not to use mutable/ref variable at all?
let rec iterateTupleMemberTypes (tupleArgTypes: System.Type[]) (columnNames: string[]) startingIndex =
seq {
let index = ref startingIndex
for t in tupleArgTypes do
match t.IsGenericType with
| true ->
yield! iterateTupleMemberTypes (t.GetGenericArguments()) columnNames !index
| false ->
printfn "Name: %s Type: %A" (columnNames.[!index]) t
yield (columnNames.[!index]), t
index := !index + 1
} |> dict
let myFile = CsvProvider<"""d:\temp\sample.txt""">.GetSample()
let firstRow = myFile.Rows |> Seq.head
let tupleType = firstRow.GetType()
let tupleArgTypes = tupleType.GetGenericArguments()
let m = iterateTupleMemberTypes tupleArgTypes myFile.Headers.Value 0
Okay, since my last question elicited no responses, I'm forging ahead in a different direction. Lol!
I can't find any examples beyond the official documentation on managing user state, or accessing the results of a prior parser.
N.b. This code does not compile.
namespace MultipartMIMEParser
open FParsec
open System.IO
type Header = { name : string
; value : string
; addl : (string * string) list option }
type Content = Content of string
| Post of Post list
and Post = { headers : Header list
; content : Content }
type private UserState = { Boundary : string }
with static member Default = { Boundary="" }
module internal P =
let ($) f x = f x
let undefined = failwith "Undefined."
let ascii = System.Text.Encoding.ASCII
let str cs = System.String.Concat (cs:char list)
let makeHeader ((n,v),nvps) = { name=n; value=v; addl=nvps}
let runP p s = match runParserOnStream p UserState.Default "" s ascii with
| Success (r,_,_) -> r
| Failure (e,_,_) -> failwith (sprintf "%A" e)
let blankField = parray 2 newline
let delimited d e =
let pEnd = preturn () .>> e
let part = spaces >>. (manyTill $ noneOf d $ (attempt (preturn () .>> pstring d) <|> pEnd)) |>> str
in part .>>. part
let delimited3 firstDelimiter secondDelimiter thirdDelimiter endMarker =
delimited firstDelimiter endMarker
.>>. opt (many (delimited secondDelimiter endMarker
>>. delimited thirdDelimiter endMarker))
// TODO: This is the parser I'm asking about.
let pHeader =
let includesBoundary s = undefined
let setBoundary b = { Boundary=b }
in delimited3 ":" ";" "=" blankField
|>> makeHeader
>>. fun stream -> if includesBoundary // How do I access the output from makeHeader here?
then stream.UserState <- setBoundary b // I need b to be read from the output of makeHeader.
Reply ()
else Reply ()
let pHeaders = manyTill pHeader $ attempt (preturn () .>> blankField)
// N.b. This is the mess I'm currently wrestling with. It does not compile, and is
// not sound yet.
let rec pContent boundary =
match boundary with
| "" -> // Content is text.
let line = restOfLine false
in pipe2 pHeaders (manyTill line $ attempt (preturn () .>> blankField))
$ fun h c -> { headers=h
; content=Content $ System.String.Join (System.Environment.NewLine,c) }
| _ -> // Content contains boundaries.
let b = "--"+boundary
let p = pipe2 pHeaders (pContent b) $ fun h c -> { headers=h; content=c }
in skipString b >>. manyTill p (attempt (preturn () .>> blankField))
let pStream = runP (pipe2 pHeaders pContent $ fun h c -> { headers=h; content=c })
type MParser (s:Stream) =
let r = P.pStream s
let findHeader name =
match r.headers |> List.tryFind (fun h -> h.name.ToLower() = name) with
| Some h -> h.value
| None -> ""
member p.Boundary =
let isBoundary ((s:string),_) = s.ToLower() = "boundary"
let header = r.headers
|> List.tryFind (fun h -> if h.addl.IsSome
then h.addl.Value |> List.exists isBoundary
else false)
in match header with
| Some h -> h.addl.Value |> List.find isBoundary |> snd
| None -> ""
member p.ContentID = findHeader "content-id"
member p.ContentLocation = findHeader "content-location"
member p.ContentSubtype = findHeader "type"
member p.ContentTransferEncoding = findHeader "content-transfer-encoding"
member p.ContentType = findHeader "content-type"
member p.Content = r.content
member p.Headers = r.headers
member p.MessageID = findHeader "message-id"
member p.MimeVersion = findHeader "mime-version"
A truncated example of the POST I am trying to parse follows:
content-type: Multipart/related; boundary="RN-Http-Body-Boundary"; type="multipart/related"
--RN-Http-Body-Boundary
Message-ID: <25845033.1160080657073.JavaMail.webmethods#exshaw>
Mime-Version: 1.0
Content-Type: multipart/related; type="application/xml";
boundary="----=_Part_235_11184805.1160080657052"
------=_Part_235_11184805.1160080657052
Content-Type: Application/XML
Content-Transfer-Encoding: binary
Content-Location: RN-Preamble
Content-ID: <1430586.1160080657050.JavaMail.webmethods#exshaw>
XML document begins here...
So basically, what you want to do in pHeader is to use the parser as a monad, rather than an applicative. Based on your code style you come from Haskell so I'll assume you know these words. Something like this then:
let pHeader =
let includesBoundary s = undefined
let setBoundary b = { Boundary=b }
in delimited3 ":" ";" "=" blankField
|>> makeHeader
>>= fun header stream ->
if includesBoundary header
then let b = undefined // some expression including header, if I understood correctly
stream.UserState <- setBoundary b
Reply ()
else Reply ()
Or you can write it in a computation expression (which would correspond to do-notation in Haskell):
let pHeader =
let includesBoundary s = undefined
let setBoundary b = { Boundary=b }
parse {
let! header =
delimited3 ":" ";" "=" blankField
|>> makeHeader
return! fun stream ->
if includesBoundary header
then let b = undefined // some expression including header, if I understood correctly
stream.UserState <- setBoundary b
Reply ()
else Reply ()
}
This question, first off, is not a duplicate of my question.
Actually I have 3 questions.
In the code below, I try to create a parser which parses possibly nested multiline block comments. In contrast to the cited other question, I try to solve the problem in a straightforward way without any recursive functions (see the accepted answer to the other post).
The first problem I ran into was that skipManyTill parser of FParsec also consumes the end parser from the stream. So I created skipManyTillEx (Ex for 'excluding endp' ;) ). The skipManyTillEx seems to work - at least for the one test case I also added to the fsx script.
Yet in the code, shown, now I get the "The combinator 'many' was applied to a parser that succeeds without consuming..." error. My theory is, that the commentContent parser is the line which produces this error.
Here, my questions:
Is there any reason, why the approach I have chosen cannot work? The solution in 1, which, unfortunately does not seem to compile on my system uses a recursive low level parser for (nested) multiline comments.
Can anyone see a problem with the way I implemented skipManyTillEx? The way I implemented it differs to some degree from the way skipManyTill is implemented, mostly in the aspect of how to control the parsing flow. In original skipManyTill, the Reply<_> of p and endp is tracked, along with the stream.StateTag. In my implementation, in contrast I did not see the need to use stream.StateTag, solely relying on the Reply<_> status code. In case of an unsuccessful parse, skipManyTillEx backtracks to the streams initial state and reports an error. Could possibly the backtracking code cause the 'many' error? What would I have to do instead?
(and that is the main question) - Does anyone see, how to fix the parser such, that this "many ... " error message goes away?
Here is the code:
#r #"C:\hgprojects\fparsec\Build\VS11\bin\Debug\FParsecCS.dll"
#r #"C:\hgprojects\fparsec\Build\VS11\bin\Debug\FParsec.dll"
open FParsec
let testParser p input =
match run p input with
| Success(result, _, _) -> printfn "Success: %A" result
| Failure(errorMsg, _, _) -> printfn "Failure %s" errorMsg
input
let Show (s : string) : string =
printfn "%s" s
s
let test p i =
i |> Show |> testParser p |> ignore
////////////////////////////////////////////////////////////////////////////////////////////////
let skipManyTillEx (p : Parser<_,_>) (endp : Parser<_,_>) : Parser<unit,unit> =
fun stream ->
let tryParse (p : Parser<_,_>) (stm : CharStream<unit>) : bool =
let spre = stm.State
let reply = p stream
match reply.Status with
| ReplyStatus.Ok ->
stream.BacktrackTo spre
true
| _ ->
stream.BacktrackTo spre
false
let initialState = stream.State
let mutable preply = preturn () stream
let mutable looping = true
while (not (tryParse endp stream)) && looping do
preply <- p stream
match preply.Status with
| ReplyStatus.Ok -> ()
| _ -> looping <- false
match preply.Status with
| ReplyStatus.Ok -> preply
| _ ->
let myReply = Reply(Error, mergeErrors preply.Error (messageError "skipManyTillEx failed") )
stream.BacktrackTo initialState
myReply
let ublockComment, ublockCommentImpl = createParserForwardedToRef()
let bcopenTag = "/*"
let bccloseTag = "*/"
let pbcopen = pstring bcopenTag
let pbcclose = pstring bccloseTag
let ignoreCommentContent : Parser<unit,unit> = skipManyTillEx (skipAnyChar) (choice [pbcopen; pbcclose] |>> fun x -> ())
let ignoreSubComment : Parser<unit,unit> = ublockComment
let commentContent : Parser<unit,unit> = skipMany (choice [ignoreCommentContent; ignoreSubComment])
do ublockCommentImpl := between (pbcopen) (pbcclose) (commentContent) |>> fun c -> ()
do test (skipManyTillEx (pchar 'a' |>> fun c -> ()) (pchar 'b') >>. (restOfLine true)) "aaaabcccc"
// do test ublockComment "/**/"
//do test ublockComment "/* This is a comment \n With multiple lines. */"
do test ublockComment "/* Bla bla bla /* nested bla bla */ more outer bla bla */"
let's take a look at your questions...
1. Is there any reason, why the approach I have chosen cannot work?
Your approach can definitely work, you just have to weed out the bugs.
2. Can anyone see a problem with the way I implemented skipManyTillEx?
No. Your implementation looks OK. It's just the combination of skipMany and skipManyTillEx that's the problem.
let ignoreCommentContent : Parser<unit,unit> = skipManyTillEx (skipAnyChar) (choice [pbcopen; pbcclose] |>> fun x -> ())
let commentContent : Parser<unit,unit> = skipMany (choice [ignoreCommentContent; ignoreSubComment])
skipMany in commentContent runs until ignoreCommentContent and ignoreSubComment both fail. But ignoreCommentContent is implemented using your skipManyTillEx, which is implemented in a way that it could succeed without consuming input. This means that the outer skipMany would not be able to determine when to stop because if no input is consumed, it doesn't know whether a subsequent parser has failed or simply didn't consume anything.
This is why it's required that every parser below a many parser has to consume input. Your skipManyTillEx might not, that's what the error message is trying to tell you.
To fix it, you have to implement a skipMany1TillEx, that consumes at least one element itself.
3. Does anyone see, how to fix the parser such, that this "many ... " error message goes away?
How about this approach?
open FParsec
open System
/// Type abbreviation for parsers without user state.
type Parser<'a> = Parser<'a, Unit>
/// Skips C-style multiline comment /*...*/ with arbitrary nesting depth.
let (comment : Parser<_>), commentRef = createParserForwardedToRef ()
/// Skips any character not beginning of comment end marker */.
let skipCommentChar : Parser<_> =
notFollowedBy (skipString "*/") >>. skipAnyChar
/// Skips anx mix of nested comments or comment characters.
let commentContent : Parser<_> =
skipMany (choice [ comment; skipCommentChar ])
// Skips C-style multiline comment /*...*/ with arbitrary nesting depth.
do commentRef := between (skipString "/*") (skipString "*/") commentContent
/// Prints the strings p skipped over on the console.
let printSkipped p =
p |> withSkippedString (printfn "Skipped: \"%s\" Matched: \"%A\"")
[
"/*simple comment*/"
"/** special / * / case **/"
"/*testing /*multiple*/ /*nested*/ comments*/ not comment anymore"
"/*not closed properly/**/"
]
|> List.iter (fun s ->
printfn "Test Case: \"%s\"" s
run (printSkipped comment) s |> printfn "Result: %A\n"
)
printfn "Press any key to exit..."
Console.ReadKey true |> ignore
By using notFollowedBy to only skip characters that are not part of a comment end marker (*/), there is no need for nested many parsers.
Hope this helps :)
Finally found a way to fix the many problem.
Replaced my custom skipManyTillEx with another custom function I called skipManyTill1Ex.
skipManyTill1Ex, in contrast to the previous skipManyTillEx only succeeds if it parsed 1 or more p successfully.
I expected the test for the empty comment /**/ to fail for this version but it works.
...
let skipManyTill1Ex (p : Parser<_,_>) (endp : Parser<_,_>) : Parser<unit,unit> =
fun stream ->
let tryParse (p : Parser<_,_>) (stm : CharStream<unit>) : bool =
let spre = stm.State
let reply = p stm
match reply.Status with
| ReplyStatus.Ok ->
stream.BacktrackTo spre
true
| _ ->
stream.BacktrackTo spre
false
let initialState = stream.State
let mutable preply = preturn () stream
let mutable looping = true
let mutable matchCounter = 0
while (not (tryParse endp stream)) && looping do
preply <- p stream
match preply.Status with
| ReplyStatus.Ok ->
matchCounter <- matchCounter + 1
()
| _ -> looping <- false
match (preply.Status, matchCounter) with
| (ReplyStatus.Ok, c) when (c > 0) -> preply
| (_,_) ->
let myReply = Reply(Error, mergeErrors preply.Error (messageError "skipManyTill1Ex failed") )
stream.BacktrackTo initialState
myReply
let ublockComment, ublockCommentImpl = createParserForwardedToRef()
let bcopenTag = "/*"
let bccloseTag = "*/"
let pbcopen = pstring bcopenTag
let pbcclose = pstring bccloseTag
let ignoreCommentContent : Parser<unit,unit> = skipManyTill1Ex (skipAnyChar) (choice [pbcopen; pbcclose] |>> fun x -> ())
let ignoreSubComment : Parser<unit,unit> = ublockComment
let commentContent : Parser<unit,unit> = skipMany (choice [ignoreCommentContent; ignoreSubComment])
do ublockCommentImpl := between (pbcopen) (pbcclose) (commentContent) |>> fun c -> ()
do test (skipManyTillEx (pchar 'a' |>> fun c -> ()) (pchar 'b') >>. (restOfLine true)) "aaaabcccc"
do test ublockComment "/**/"
do test ublockComment "/* This is a comment \n With multiple lines. */"
do test ublockComment "/* Bla bla bla /* nested bla bla */ more outer bla bla */"
You know that to unwrap a value of a single union type you have to do this:
type Foo = Foo of int*string
let processFoo foo =
let (Foo (t1,t2)) = foo
printfn "%A %A" t1 t2
but my question is: if there a way to do that for lists ?:
let processFooList (foolist:Foo list ) =
let ??? = foolist // how to get a int*string list
...
thanks.
The best way would be to use a function combined with List.map like so
let processFooList (foolist:Foo list ) = foolist |> List.map (function |Foo(t1,t2)->t1,t2)
There's no predefined active pattern for converting the list from Foo to int * string, but you could combine the Named Pattern §7.2 (deconstruct single case union) with the projection into your own single case Active Pattern §7.2.3.
let asTuple (Foo(t1, t2)) = t1, t2 // extract tuple from single Foo
let (|FooList|) = List.map asTuple // apply to list
Use as function argument:
let processFooList (FooList fooList) = // now you can extract tuples from Foo list
... // fooList is an (int * string) list
Use in let-binding:
let (FooList fooList) =
[ Foo(1, "a"); Foo(2, "b") ]
printfn "%A" fooList // prints [(1, "a"); (2, "b")]
Distilling/summarising/restating/reposting the other two answers, your cited line:
let ??? = foolist // how to get a int*string list
Can become:
let ``???`` = foolist |> List.map (function |Foo(x,y) -> x,y)
If you're writing a transformation, you can do the matching in the params having defined an Active Pattern using either of the following:
let (|FooList|) = List.map <| fun (Foo(t1, t2)) -> t1,t2
let (|FooList|) = List.map <| function |Foo(t1, t2) -> t1,t2
which can then be consumed as follows:
let processFooList (fooList:Foo list ) =
// do something with fooList