Excercising F# Formatting Prototype from F# Deep Dives

FsFormatProto.fs

type MarkdownDocument = MarkdownBlock list

and MarkdownBlock =
	| Heading of int * MarkdownSpans
	| Paragraph of MarkdownSpans
	| CodeBlock of string list
	| BlockQuote of MarkdownBlock list

and MarkdownSpans = MarkdownSpan list

and MarkdownSpan = 
	| Literal of string
	| InlineCode of string
	| Strong of MarkdownSpans
	| Emphasis of MarkdownSpans
	| HyperLink of MarkdownSpans * string
	| HardLineBreak

let (|StartWith|_|) prefix input =
	let rec loop = function
		| p::prefix, r::rest when p = r -> loop (prefix, rest)
		| [], rest -> Some(rest)
		| _ -> None

	loop (prefix, input)

let rec parseBracketBody closing acc = function
	| StartWith closing (rest) -> Some(List.rev acc, rest)
	| c::chars -> parseBracketBody closing (c::acc) chars
	| _ -> None

let parseBracket opening closing = function
	| StartWith opening chars -> parseBracketBody closing [] chars
	| _ -> None

let (|Delimited|_|) delim = parseBracket delim delim

// ** Exercise 1 **
let (|Bracketed|_|) brackets input =
	let parseBracketPair (opening, closing) = parseBracket [opening] [closing]
	let rec loop rest brackets acc =
		match brackets with
		| b::xs -> 
			match parseBracketPair b rest with
			| None -> None
			| Some (body, rest) -> loop rest xs (body::acc)
		| [] -> Some (List.rev acc, rest)

	loop input brackets []

let rec parseSpans acc chars =
	let toString chars = System.String(chars |> Array.ofList)
	let emitLiteral = seq {
		if acc <> [] then yield acc |> List.rev |> toString |> Literal
	}

	seq {
		match chars with
		| StartWith [' '; ' '; '\n'; '\r'] (chars) 
		| StartWith [' '; ' '; '\r'] (chars) 
		| StartWith [' '; ' '; '\n'] (chars) ->  // Exercise 2
			yield! emitLiteral
			yield HardLineBreak
			yield! parseSpans [] chars
		| Delimited ['`'] (body, chars) -> 
			yield! emitLiteral
			yield InlineCode(body |> toString) 
			yield! parseSpans [] chars
		// Emphasisより先にマッチングを試みること
		| Delimited ['*'; '*'] (body, chars)
		| Delimited ['_'; '_'] (body, chars) ->
			yield! emitLiteral 
			yield Strong(parseSpans [] body |> List.ofSeq)
			yield! parseSpans [] chars			
		| Delimited ['*'] (body, chars)
		| Delimited ['_'] (body, chars) ->
			yield! emitLiteral 
			yield Emphasis(parseSpans [] body |> List.ofSeq)
			yield! parseSpans [] chars
		| Bracketed [('[', ']'); ('(', ')') ] ([body; url], chars) ->
			yield! emitLiteral 
			yield HyperLink(parseSpans [] body |> List.ofSeq, url |> toString)
			yield! parseSpans [] chars
		| c::chars -> 
			yield! parseSpans (c::acc) chars
		| [] -> 
			yield! emitLiteral 
	}

// Parse block with active patterns

module List =
	let partitionWhile f =
		let rec loop acc = function
			| x::xs when f x -> loop (x::acc) xs
			| xs -> List.rev acc, xs

		loop []

let partitionWithPrefix prefix (lines: string list) =
	let prefixed, others =
		lines 
		|> List.partitionWhile (fun line -> line.StartsWith(prefix))

	[ for line in prefixed -> line.Substring(prefix.Length) ], others

let (|PrefixedLines|) = partitionWithPrefix

let (|LineSeparated|) lines = 
	let isWhite = System.String.IsNullOrWhiteSpace

	match List.partitionWhile (isWhite >> not) lines with
	| par, _::rest 
	| par, ([] as rest) -> par, rest 

let (|AsCharList|) (str: string) = List.ofSeq str

let (|Heading|_|) lines =
	let rec countDepth depth = function
		| '#'::chars -> countDepth (depth+1) chars
		| ' '::chars when depth > 0 -> Some(depth, chars)
		| _ -> None

	match lines with
	| x::xs -> 
		match countDepth 0 (List.ofSeq x) with
		| None -> None
		| Some (depth, chars) -> Some ((depth, chars), xs)
	| xs -> None

let (|RepeatLine|_|) (c: char) (chars: char list) =
	match List.partitionWhile (fun s -> s = c) chars with
	| (pat, []) -> Some(List.length pat)
	| _ -> None

// Exercise 3
let (|HeadingAlt|_|) = function
	| line::border::rest -> 
		match List.ofSeq border with
		| RepeatLine '=' len when len > 3 -> Some ((1, line |> List.ofSeq), rest)
		| RepeatLine '-' len when len > 3 -> Some ((2, line |> List.ofSeq), rest)
		| _ -> None
	| _ -> None

// Excercise 4
let (|BlockQuote|_|) lines =
	match partitionWithPrefix "> " lines with
	| (quotes, others) when quotes <> [] -> Some (quotes, others)
	| _ -> None

let rec parseBlocks lines =
	let isWhite = System.String.IsNullOrWhiteSpace

	seq {
		match lines with
		| HeadingAlt ((depth, heading), lines) 
		| Heading ((depth, heading), lines) ->
			yield Heading (depth, parseSpans [] heading |> List.ofSeq)
			yield! parseBlocks lines
		| BlockQuote (quotes, lines) ->
			yield BlockQuote (parseBlocks quotes |> List.ofSeq)
			yield! parseBlocks lines
		| PrefixedLines "    " (body, rest) when body <> [] ->
			yield CodeBlock (body)
			yield! parseBlocks rest
		| LineSeparated (body, rest) when body <> [] ->
			let body = String.concat " " body |> List.ofSeq
			yield Paragraph (parseSpans [] body |> List.ofSeq)
			yield! parseBlocks rest
		| line::lines when isWhite line ->
			yield! parseBlocks lines
		| _ -> ()
	}

gistfile1.fth

> let sample = """# Introducing F#
- F# is a _functional-first_ language,
- which looks like this:
- 
-     let msg = "world"
-     printfn "hello %s!" msg
- 
- This sample prints `hello world!` 
- See [somewhere](http://example.com/somewhere)
- 
- Subtitle
- -------
- > ## quoted chapter
- > This is a quotation that contains F# code:
- > 
- >     printfn "Hello from quoted code!"
- > 
- qwerty
- """
- ;;
val sample : string =
  "# Introducing F#
F# is a _functional-first_ language,
which l"+[285 chars]
> 
> sample.Split('\r', '\n') |> List.ofSeq |> parseBlocks |> List.ofSeq;;
val it : MarkdownBlock list =
  [Heading (1,[Literal "Introducing F#"]);
   Paragraph
     [Literal "F# is a "; Emphasis [Literal "functional-first"];
      Literal " language, which looks like this:"];
   CodeBlock ["let msg = "world""; "printfn "hello %s!" msg"];
   Paragraph
     [Literal "This sample prints "; InlineCode "hello world!";
      Literal "  See ";
      HyperLink ([Literal "somewhere"],"http://example.com/somewhere")];
   Heading (2,[Literal "Subtitle"]);
   BlockQuote
     [Heading (2,[Literal "quoted chapter"]);
      Paragraph [Literal "This is a quotation that contains F# code:"];
      CodeBlock ["printfn "Hello from quoted code!""]];
   Paragraph [Literal "qwerty"]]