TagRenderers can output Blocks, we now slurp sections
The big one is probably that tagrenderers can output blocks such as tables. We also slurp sections, so that subsections become a part of the above sections children. The FSI evaluator adds about 1000% of runtime for testing, so I added a NullEvaluator. I also added default constructors for many of the base elements. The parsers are not yet done, but you can do very rudimentary tables. The AST has gotten a large update, and it is pretty much complete.
This commit is contained in:
parent
f1fefece72
commit
c3f2f98dc8
11 changed files with 875 additions and 404 deletions
|
|
@ -1,6 +1,7 @@
|
|||
namespace Fibble.FibLib
|
||||
|
||||
open System.Net
|
||||
|
||||
open System
|
||||
open FParsec
|
||||
open YamlDotNet.Serialization
|
||||
open System.Collections.Generic
|
||||
|
|
@ -10,10 +11,13 @@ open System.Collections.Generic
|
|||
// 1. AST & Utils
|
||||
// ==========================================
|
||||
module Ast =
|
||||
|
||||
type Attr = { id: string; classes: string list; kvp: (string * string) list }
|
||||
|
||||
|
||||
|
||||
type Attr =
|
||||
{ id: string
|
||||
classes: string list
|
||||
kvp: (string * string) list }
|
||||
|
||||
|
||||
type InlineNode =
|
||||
| Text of string
|
||||
| RawHtml of string
|
||||
|
|
@ -31,114 +35,149 @@ module Ast =
|
|||
| LineBreak
|
||||
| Expr of code: string * result: string option
|
||||
| Command of tag: string * args: string list * kwargs: Map<string, string> * children: InlineNode list
|
||||
|
||||
and BlockNode =
|
||||
| BlockCommand of tag: string * args: string list * kwargs: Map<string, string> * children: InlineNode list
|
||||
| CodeBlock of attributes: Attr * text: string
|
||||
| Figure of attributes: Attr * caption: InlineNode list * blocks: BlockNode list
|
||||
| Figure of attributes: Attr * caption: InlineNode list * blocks: BlockNode list
|
||||
| ListBlock of ListKind
|
||||
| Plain of InlineNode list
|
||||
| Paragraph of children: InlineNode list
|
||||
| Section of level: int * args: (string * string) list * children: InlineNode list
|
||||
and ListKind =
|
||||
| Section of attributes: Attr * level: int * title: InlineNode list * body: BlockNode list
|
||||
| Table of attrs: Attr * rows: TableRow list
|
||||
|
||||
and TableRow = Row of cells: TableCell list
|
||||
and TableCell = Cell of children: InlineNode list
|
||||
|
||||
and ListKind =
|
||||
| Orderedlist of attributes: Attr * start: int * blocksList: (BlockNode list) list
|
||||
| BulletList of attributes: Attr * blocksList: (BlockNode list) list
|
||||
|
||||
and Url = string
|
||||
and Target = Url * InlineNode list
|
||||
|
||||
type Document = BlockNode list
|
||||
|
||||
type TagRenderer = Map<string,string>
|
||||
-> string list
|
||||
-> Map<string,string>
|
||||
-> InlineNode list -> InlineNode
|
||||
type TocEntry =
|
||||
| TocGroup of title: string * id: string * children: TocEntry list
|
||||
| TocEntity of title: string * id: string
|
||||
|
||||
type NextDocument =
|
||||
{ document: BlockNode list
|
||||
Toc: TocEntry list
|
||||
Footnotes: BlockNode list list
|
||||
Metadata: Map<string, string> }
|
||||
|
||||
type NodeResult =
|
||||
| Inline of InlineNode
|
||||
| Block of BlockNode
|
||||
|
||||
type TagRenderer = Map<string, string> -> string list -> Map<string, string> -> InlineNode list -> NodeResult
|
||||
|
||||
|
||||
let rec stringifyNodes (nodes: InlineNode list) =
|
||||
nodes
|
||||
|> List.map (function
|
||||
| Text t -> t
|
||||
| RawHtml h -> h
|
||||
| Expr(_, Some res) -> res
|
||||
| Expr(code, None) -> sprintf "@(%s)" code // Fallback om den inte evaluerats
|
||||
| _ -> failwith "haha"
|
||||
)
|
||||
|> String.concat ""
|
||||
|
||||
|
||||
|
||||
module Utils =
|
||||
open Ast
|
||||
|
||||
let dedentNodes (nodes: InlineNode list) =
|
||||
let fullText =
|
||||
nodes |> List.choose (function Text t -> Some t | _ -> None) |> String.concat ""
|
||||
|
||||
let fullText =
|
||||
nodes
|
||||
|> List.choose (function
|
||||
| Text t -> Some t
|
||||
| _ -> None)
|
||||
|> String.concat ""
|
||||
|
||||
let lines = fullText.Replace("\r\n", "\n").Split('\n')
|
||||
|
||||
|
||||
// 1. Räkna BARA ut minIndent från rader som kommer efter en radbrytning (skippa rad 0)
|
||||
let minIndent =
|
||||
if lines.Length <= 1 then 0
|
||||
let minIndent =
|
||||
if lines.Length <= 1 then
|
||||
0
|
||||
else
|
||||
lines |> Array.skip 1
|
||||
lines
|
||||
|> Array.skip 1
|
||||
|> Array.filter (fun l -> not (System.String.IsNullOrWhiteSpace(l)))
|
||||
|> Array.map (fun l -> l.Length - l.TrimStart().Length)
|
||||
|> function [||] -> 0 | arr -> Array.min arr
|
||||
|> function
|
||||
| [||] -> 0
|
||||
| arr -> Array.min arr
|
||||
|
||||
let mutable isFirstText = true
|
||||
let indentStr = "\n" + String.replicate minIndent " "
|
||||
|
||||
// 2. Applicera formateringen
|
||||
let dedented =
|
||||
nodes |> List.map (function
|
||||
| Text t ->
|
||||
let dedented =
|
||||
nodes
|
||||
|> List.map (function
|
||||
| Text t ->
|
||||
let t1 = t.Replace("\r\n", "\n")
|
||||
|
||||
|
||||
// Ta bort inledande mellanslag på den allra första texten direkt efter '{'
|
||||
let t2 =
|
||||
if isFirstText then
|
||||
let t2 =
|
||||
if isFirstText then
|
||||
isFirstText <- false
|
||||
t1.TrimStart(' ', '\t')
|
||||
else t1
|
||||
|
||||
else
|
||||
t1
|
||||
|
||||
// Ta bort minIndent antal mellanslag efter varje radbrytning i noden
|
||||
let t3 = if minIndent > 0 then t2.Replace(indentStr, "\n") else t2
|
||||
Text t3
|
||||
| otherNode -> otherNode
|
||||
)
|
||||
| otherNode -> otherNode)
|
||||
|
||||
// 3. Städa bort överflödiga radbrytningar och blanksteg i ytterkanterna
|
||||
let rec trimStart = function
|
||||
| Text t :: rest ->
|
||||
let rec trimStart =
|
||||
function
|
||||
| Text t :: rest ->
|
||||
let trimmed = t.TrimStart('\n', '\r', ' ', '\t')
|
||||
if trimmed = "" then trimStart rest else Text trimmed :: rest
|
||||
|
||||
if trimmed = "" then
|
||||
trimStart rest
|
||||
else
|
||||
Text trimmed :: rest
|
||||
| other -> other
|
||||
|
||||
let rec trimEnd = function
|
||||
| Text t :: rest ->
|
||||
|
||||
let rec trimEnd =
|
||||
function
|
||||
| Text t :: rest ->
|
||||
let trimmed = t.TrimEnd('\n', '\r', ' ', '\t')
|
||||
if trimmed = "" then trimEnd rest else Text trimmed :: rest
|
||||
| other -> other
|
||||
|
||||
|
||||
dedented |> trimStart |> List.rev |> trimEnd |> List.rev
|
||||
|
||||
let positional f: TagRenderer =
|
||||
let positional f : TagRenderer =
|
||||
fun _ (args: string list) _ children -> f args children
|
||||
|
||||
|
||||
let onlyArgs f =
|
||||
fun _ args kwargs children -> f args kwargs
|
||||
|
||||
let getArgIdx (args: (string*string) list) index defaultVal =
|
||||
let getArgIdx (args: (string * string) list) index defaultVal =
|
||||
let unnamed = args |> List.filter (fun (k, _) -> k = "")
|
||||
if index < unnamed.Length then (snd unnamed.[index]).Trim('"')
|
||||
else defaultVal
|
||||
|
||||
if index < unnamed.Length then
|
||||
(snd unnamed.[index]).Trim('"')
|
||||
else
|
||||
defaultVal
|
||||
|
||||
// This gets the arg defined by "key" unless it is not set, it then tries to get it by index. If that fails, it gets the defaultVal
|
||||
let getArg (args: (string * string) list) (key: string) (index: int) (defaultVal: string) =
|
||||
match args |> List.tryFind (fun (k, _) -> k = key) with
|
||||
| Some (_, v) -> v.Trim('"')
|
||||
| Some(_, v) -> v.Trim('"')
|
||||
| None -> getArgIdx args index defaultVal
|
||||
|
||||
|
||||
let withArg1 def (f: string -> InlineNode list -> InlineNode) =
|
||||
fun _ args children -> f (getArgIdx args 0 def) children
|
||||
|
||||
let withArg2 (k1: string) (d1: string) (k2: string) (d2: string) (f: string -> string -> InlineNode list -> InlineNode) =
|
||||
let withArg2
|
||||
(k1: string)
|
||||
(d1: string)
|
||||
(k2: string)
|
||||
(d2: string)
|
||||
(f: string -> string -> InlineNode list -> InlineNode)
|
||||
=
|
||||
fun _ args children -> f (getArg args k1 0 d1) (getArg args k2 1 d2) children
|
||||
|
||||
|
||||
|
|
@ -150,183 +189,247 @@ module Utils =
|
|||
|
||||
module Parser =
|
||||
open Ast
|
||||
let pseudoRandom = new System.Random()
|
||||
|
||||
let pInline, pInlineRef = createParserForwardedToRef<InlineNode, unit>()
|
||||
let pInline, pInlineRef = createParserForwardedToRef<InlineNode, unit> ()
|
||||
|
||||
let getSectionLevel (name: string) =
|
||||
if name = "section" then 1
|
||||
elif name = "subsection" then 2
|
||||
elif name.StartsWith("sub") && name.EndsWith("section") then (name.Length - 7) / 3 + 1
|
||||
else 1
|
||||
if name = "section" then
|
||||
1
|
||||
elif name = "subsection" then
|
||||
2
|
||||
elif name.StartsWith("sub") && name.EndsWith("section") then
|
||||
(name.Length - 7) / 3 + 1
|
||||
else
|
||||
1
|
||||
|
||||
let rec alistGet<'T when 'T: comparison> (lst: ('T * 'B) list) (k: 'T) =
|
||||
match lst with
|
||||
| [] -> None
|
||||
| ktp :: _ when (fst ktp) = k -> Some(snd ktp)
|
||||
| _ :: rst -> alistGet rst k
|
||||
|
||||
let separateArgs rawArgs : (string list * (string * string) list) =
|
||||
let posArgs = rawArgs |> List.choose (fun (k, v) -> if k = "" then Some v else None)
|
||||
let kwargs = rawArgs |> List.filter (fun (k, _) -> k <> "")
|
||||
posArgs, kwargs
|
||||
|
||||
let isSection (name: string) = name.EndsWith("section")
|
||||
|
||||
let pNewline = newline
|
||||
|
||||
|
||||
let pNamedArg =
|
||||
// Leta efter "nyckel=värde"
|
||||
attempt (many1Chars (asciiLetter <|> digit <|> anyOf "-_")
|
||||
.>> spaces .>> pchar '=' .>> spaces)
|
||||
attempt (
|
||||
many1Chars (asciiLetter <|> digit <|> anyOf "-_")
|
||||
.>> spaces
|
||||
.>> pchar '='
|
||||
.>> spaces
|
||||
)
|
||||
.>>. manyChars (noneOf ",]")
|
||||
|>> fun (k, v) -> (k, v.Trim())
|
||||
|>> fun (k, v) -> k, v.Trim()
|
||||
|
||||
let pPositionalArg =
|
||||
// Bara "värde"
|
||||
manyChars (noneOf ",]") |>> fun v -> ("", v.Trim())
|
||||
manyChars (noneOf ",]") |>> fun v -> "", v.Trim()
|
||||
|
||||
let pSingleArg = spaces >>. (pNamedArg <|> pPositionalArg) .>> spaces
|
||||
|
||||
let pArgs =
|
||||
let pArgs =
|
||||
between (pstring "[") (pstring "]") (sepBy pSingleArg (pchar ','))
|
||||
>>= fun args ->
|
||||
// Validera att positionella argument alltid kommer först
|
||||
let rec validate canBePositional = function
|
||||
let rec validate canBePositional =
|
||||
function
|
||||
| [] -> preturn args // Allt är okej, returnera listan
|
||||
| ("", _) :: tail ->
|
||||
if not canBePositional then
|
||||
| ("", _) :: tail ->
|
||||
if not canBePositional then
|
||||
fail "Syntaxfel: Positionella argument får inte komma efter namngivna argument."
|
||||
else validate true tail
|
||||
| _ :: tail ->
|
||||
validate false tail
|
||||
|
||||
else
|
||||
validate true tail
|
||||
| _ :: tail -> validate false tail
|
||||
|
||||
validate true args
|
||||
|
||||
// --- 1. Måsvinge-parser (för @kommandon) ---
|
||||
// Lägg till en referens för pBody högst upp bland dina referenser
|
||||
// (Bör ligga precis under let pInline, pInlineRef = ...)
|
||||
let pBody, pBodyRef = createParserForwardedToRef<InlineNode list, unit>()
|
||||
|
||||
let pBody, pBodyRef = createParserForwardedToRef<InlineNode list, unit> ()
|
||||
|
||||
// --- 2. Parentes-parser (för @(...) med sträng-stöd) ---
|
||||
let pParenBody, pParenBodyRef = createParserForwardedToRef<string, unit>()
|
||||
let pParenBody, pParenBodyRef = createParserForwardedToRef<string, unit> ()
|
||||
|
||||
let pFSharpString =
|
||||
let normal = many1Chars (noneOf "\"\\")
|
||||
let escaped = pstring "\\" >>. anyChar |>> sprintf "\\%c"
|
||||
|
||||
pstring "\"" .>>. manyStrings (normal <|> escaped) .>>. pstring "\""
|
||||
|>> fun ((start, inner), end_) -> start + inner + end_
|
||||
|
||||
pParenBodyRef.Value <-
|
||||
manyStrings (choice [
|
||||
pFSharpString
|
||||
many1Chars (noneOf "()\"")
|
||||
pchar '(' >>. pParenBody .>> pchar ')' |>> sprintf "(%s)"
|
||||
])
|
||||
pParenBodyRef.Value <-
|
||||
manyStrings (
|
||||
choice
|
||||
[ pFSharpString
|
||||
many1Chars (noneOf "()\"")
|
||||
pchar '(' >>. pParenBody .>> pchar ')' |>> sprintf "(%s)" ]
|
||||
)
|
||||
|
||||
let pExpr =
|
||||
attempt (pstring "@(") >>. pParenBody .>> pstring ")"
|
||||
|>> fun c -> Expr(c, None)
|
||||
let pExpr =
|
||||
attempt (pstring "@(") >>. pParenBody .>> pstring ")" |>> fun c -> Expr(c, None)
|
||||
|
||||
// --- Övriga inline-parsers ---
|
||||
let pMultilineCode =
|
||||
pstring "@\"\"\"" >>. manyCharsTill anyChar (pstring "\"\"\"")
|
||||
|>> fun c -> Expr(c, None)
|
||||
|
||||
// pInlineCommand använder nu forward-referensen pBodyRef
|
||||
let pInlineCommand =
|
||||
attempt (pchar '@' >>. many1Chars asciiLetter)
|
||||
.>>. opt pArgs
|
||||
.>>. opt pBody
|
||||
|>> fun ((name, argsOpt), bodyOpt) ->
|
||||
let pInlineCommand =
|
||||
attempt (pchar '@' >>. many1Chars asciiLetter) .>>. opt pArgs .>>. opt pBody
|
||||
|>> fun ((name, argsOpt), bodyOpt) ->
|
||||
let rawArgs = defaultArg argsOpt []
|
||||
let posArgs = rawArgs |> List.choose (fun (k, v) -> if k = "" then Some v else None)
|
||||
let kwargs = rawArgs |> List.filter (fun (k, _) -> k <> "") |> Map.ofList
|
||||
|
||||
// dedentNodes anropas här från Utils
|
||||
let posArgs, kwargs = separateArgs rawArgs
|
||||
// dedentNodes fixes indentation of inline commands spanning several lines
|
||||
let children = defaultArg bodyOpt [] |> Utils.dedentNodes
|
||||
|
||||
Command(name, posArgs, kwargs, children)
|
||||
|
||||
// Nu när pInlineCommand, pExpr och pMultilineCode är definierade
|
||||
// kan vi skapa pInnerInline
|
||||
Command(name, posArgs, Map.ofList (kwargs), children)
|
||||
|
||||
let pAtCommand =
|
||||
pchar '@'
|
||||
>>. choice
|
||||
[
|
||||
// Matchar """ (Eftersom @ redan är konsumerat)
|
||||
pstring "\"\"\"" >>. manyCharsTill anyChar (pstring "\"\"\"")
|
||||
|>> fun c -> Expr(c, None)
|
||||
|
||||
// Matchar (
|
||||
pchar '(' >>. pParenBody .>> pchar ')' |>> fun c -> Expr(c, None)
|
||||
|
||||
// Matchar ASCII-bokstäver (för kommandon)
|
||||
many1Chars asciiLetter .>>. opt pArgs .>>. opt pBody
|
||||
|>> fun ((name, argsOpt), bodyOpt) ->
|
||||
let rawArgs = defaultArg argsOpt []
|
||||
let posArgs = rawArgs |> List.choose (fun (k, v) -> if k = "" then Some v else None)
|
||||
let kwargs = rawArgs |> List.filter (fun (k, _) -> k <> "") |> Map.ofList
|
||||
let children = defaultArg bodyOpt [] |> Utils.dedentNodes
|
||||
Command(name, posArgs, kwargs, children)
|
||||
|
||||
// Fallback: det var bara ett löst @ i texten
|
||||
preturn (Text "@") ]
|
||||
|
||||
// / Hjälpare för att bara svälja mellanslag och tabbar (inte radbrytningar)
|
||||
let pHorizontalSpace = skipMany (anyOf " \t")
|
||||
|
||||
let pCommandHead = pchar '@' >>. many1Chars (asciiLetter <|> digit)
|
||||
|
||||
let pBlockCommand =
|
||||
// 1. Tillåt indrag, men inga radbrytningar
|
||||
pHorizontalSpace >>. pCommandHead .>>. opt pArgs .>>. opt pBody
|
||||
|
||||
// 2. MAGIN: Se till att det inte finns mer text på raden efter kommandot
|
||||
.>> pHorizontalSpace
|
||||
.>> choice [ skipNewline; eof ] // Måste följas av radbrytning eller filslut
|
||||
|
||||
|>> fun ((name, argsOpt), bodyOpt) ->
|
||||
let args, kwargsList = separateArgs (defaultArg argsOpt [])
|
||||
// Se till att eventuell dedent/städning appliceras här om du har Utils.dedentNodes
|
||||
let children = defaultArg bodyOpt []
|
||||
|
||||
BlockCommand(name, args, Map.ofList kwargsList, children)
|
||||
|
||||
|
||||
let pInnerInline =
|
||||
choice [
|
||||
attempt pInlineCommand
|
||||
attempt pExpr
|
||||
pMultilineCode
|
||||
many1Chars (noneOf "@}") |>> Text
|
||||
pchar '@' |>> fun _ -> Text "@"
|
||||
]
|
||||
choice
|
||||
[ pAtCommand // Hanterar alla @-baserade noder
|
||||
many1Chars (noneOf "@}") |>> Text ] // Denna äter råtext ultrasnabbt
|
||||
|
||||
// Tilldela värdet till pBodyRef
|
||||
pBodyRef.Value <- between (pstring "{") (pstring "}") (many pInnerInline)
|
||||
|
||||
// Tilldela värdet till pInlineRef
|
||||
pInlineRef.Value <- choice [
|
||||
pMultilineCode
|
||||
pExpr
|
||||
pInlineCommand
|
||||
many1Chars (noneOf "@{}\n\r") |>> Text
|
||||
attempt (pNewline .>> notFollowedBy pNewline) |>> fun _ -> Text "\n"
|
||||
pchar '@' |>> fun _ -> Text "@"
|
||||
]
|
||||
|
||||
pInlineRef.Value <-
|
||||
choice
|
||||
[ pAtCommand
|
||||
many1Chars (noneOf "@{}\n\r") |>> Text
|
||||
attempt (pNewline .>> notFollowedBy pNewline) |>> fun _ -> Text "\n" ]
|
||||
// --- Block Parsers ---
|
||||
let pSectionBlock =
|
||||
|
||||
let generateId title maybeid =
|
||||
let extractIdFromTitle =
|
||||
function
|
||||
| Text(t) :: rest -> t.Substring(0, (min 20 t.Length)) + pseudoRandom.GetHexString(8)
|
||||
| _ -> pseudoRandom.GetHexString(8)
|
||||
|
||||
match maybeid with
|
||||
| Some v -> v
|
||||
| None -> extractIdFromTitle title
|
||||
|
||||
let tryGetId args kwargs =
|
||||
match args with
|
||||
| [ id ] -> Some(id)
|
||||
| _ -> alistGet kwargs "id"
|
||||
|
||||
attempt (
|
||||
pchar '@' >>. many1Chars asciiLetter >>= fun name ->
|
||||
if isSection name then preturn name
|
||||
else fail "Inte en sektion."
|
||||
)
|
||||
.>>. opt pArgs
|
||||
pchar '@' >>. many1Chars asciiLetter
|
||||
>>= fun name ->
|
||||
if isSection name then
|
||||
preturn name
|
||||
else
|
||||
fail "Inte en sektion."
|
||||
)
|
||||
.>>. opt pArgs
|
||||
.>>. opt pBody
|
||||
|>> fun ((name, argsOpt), bodyOpt) ->
|
||||
Section(getSectionLevel name, defaultArg argsOpt [], defaultArg bodyOpt [])
|
||||
let title = defaultArg bodyOpt []
|
||||
let posArgs, kwargs = separateArgs (defaultArg argsOpt [])
|
||||
let id = tryGetId posArgs kwargs |> generateId title
|
||||
let attrs = { id = id; classes = []; kvp = kwargs }
|
||||
|
||||
// There are no children in this section yet, since we slurp the children once the
|
||||
// AST parsing is done
|
||||
Section(attrs, getSectionLevel name, title, [])
|
||||
|
||||
let pParagraphBlock = many1 pInline |>> Paragraph
|
||||
|
||||
let pBlock = choice [ pSectionBlock; pParagraphBlock ]
|
||||
let pBlock = choice [ pSectionBlock; attempt pBlockCommand; pParagraphBlock ]
|
||||
|
||||
// --- Dokument Parser ---
|
||||
let pDocument =
|
||||
spaces
|
||||
let pDocument =
|
||||
spaces
|
||||
>>. opt (
|
||||
pstring "---"
|
||||
>>. manyCharsTill anyChar (attempt (pNewline >>. pstring "---"))
|
||||
|>> fun yamlStr ->
|
||||
pstring "---" >>. manyCharsTill anyChar (attempt (pNewline >>. pstring "---"))
|
||||
|>> fun yamlStr ->
|
||||
let deserializer = DeserializerBuilder().Build()
|
||||
let dict = deserializer.Deserialize<Dictionary<string, string>>(yamlStr)
|
||||
if isNull dict then Map.empty
|
||||
else dict |> Seq.map (fun kvp -> kvp.Key, kvp.Value) |> Map.ofSeq
|
||||
)
|
||||
.>> spaces
|
||||
|
||||
if isNull dict then
|
||||
Map.empty
|
||||
else
|
||||
dict |> Seq.map (fun kvp -> kvp.Key, kvp.Value) |> Map.ofSeq
|
||||
)
|
||||
.>> spaces
|
||||
.>>. sepEndBy pBlock (many1 pNewline)
|
||||
.>> eof
|
||||
|>> fun (headerOpt, blocks) ->
|
||||
(defaultArg headerOpt Map.empty, blocks)
|
||||
|>> fun (headerOpt, blocks) -> (defaultArg headerOpt Map.empty, blocks)
|
||||
|
||||
let parse i =
|
||||
match run pDocument i with
|
||||
| Success(r, _, _) -> r
|
||||
let parse i =
|
||||
match run pDocument i with
|
||||
| Success(r, _, _) -> r
|
||||
| Failure(e, _, _) -> failwith e
|
||||
|
||||
|
||||
// ==========================================
|
||||
// 3. Execution & Printer
|
||||
// ==========================================
|
||||
type IEvaluator =
|
||||
[<AbstractClass>]
|
||||
type IEvaluator() =
|
||||
abstract member Evaluate: string -> string
|
||||
|
||||
module Execution =
|
||||
open Ast
|
||||
|
||||
let rec transform (metadata: Map<string, string>) (prelude: Map<string, TagRenderer>) (eval: IEvaluator) = function
|
||||
| Command(name, args, kwargs, children) when prelude.ContainsKey name ->
|
||||
prelude.[name] metadata args kwargs (children |> List.map (transform metadata prelude eval))
|
||||
| Command(n, _, _ ,_) -> failwithf "%s is not a defined command" n
|
||||
| Expr(c, _) -> RawHtml (eval.Evaluate c)
|
||||
| n -> n
|
||||
|
||||
|
||||
|
||||
abstract member NewSession: unit -> unit
|
||||
|
||||
module Evaluators =
|
||||
open System.IO
|
||||
open System.Text
|
||||
open FSharp.Compiler.Interactive.Shell
|
||||
|
||||
type NullEvaluator() =
|
||||
inherit IEvaluator()
|
||||
override this.Evaluate(code: string) = ""
|
||||
override this.NewSession() = ()
|
||||
|
||||
|
||||
|
||||
type FsiEvaluator() =
|
||||
inherit IEvaluator()
|
||||
let sbOut = StringBuilder()
|
||||
let sbErr = StringBuilder()
|
||||
let sbErr = StringBuilder()
|
||||
let inStream = new StringReader("")
|
||||
let outStream = new StringWriter(sbOut)
|
||||
let errStream = new StringWriter(sbErr)
|
||||
|
|
@ -334,62 +437,180 @@ module Evaluators =
|
|||
// Initiera FSI-sessionen
|
||||
let fsiConfig = FsiEvaluationSession.GetDefaultConfiguration()
|
||||
let argv = [| "fsi.exe"; "--noninteractive" |]
|
||||
let session = FsiEvaluationSession.Create(fsiConfig, argv, inStream, outStream, errStream)
|
||||
|
||||
interface IEvaluator with
|
||||
member _.Evaluate(code: string) =
|
||||
sbOut.Clear() |> ignore
|
||||
sbErr.Clear() |> ignore
|
||||
let session =
|
||||
FsiEvaluationSession.Create(fsiConfig, argv, inStream, outStream, errStream)
|
||||
|
||||
try
|
||||
let result, _warnings = session.EvalInteractionNonThrowing(code)
|
||||
override this.Evaluate(code: string) =
|
||||
sbOut.Clear() |> ignore
|
||||
sbErr.Clear() |> ignore
|
||||
|
||||
let output = sbOut.ToString()
|
||||
let errors = sbErr.ToString().Trim()
|
||||
try
|
||||
let result, _warnings = session.EvalInteractionNonThrowing(code)
|
||||
|
||||
// Filtrera bort FSI:s automatiska typsignaturer från utskriften
|
||||
let cleanOutput =
|
||||
output.Replace("\r\n", "\n").Split('\n')
|
||||
|> Array.filter (fun line ->
|
||||
let l = line.TrimStart()
|
||||
not (l.StartsWith("val ") || l.StartsWith("type ") || l.StartsWith("module ") || l.StartsWith("namespace "))
|
||||
)
|
||||
|> String.concat "\n"
|
||||
|> fun s -> s.Trim()
|
||||
let output = sbOut.ToString()
|
||||
let errors = sbErr.ToString().Trim()
|
||||
|
||||
match result with
|
||||
| Choice1Of2 (Some fsiValue) ->
|
||||
// Plocka ut värdet. Om det är en sträng, undvik "%A" för att slippa citattecken.
|
||||
let valStr =
|
||||
if isNull fsiValue.ReflectionValue then ""
|
||||
else
|
||||
match fsiValue.ReflectionValue with
|
||||
| :? string as s -> s
|
||||
| v -> sprintf "%A" v
|
||||
|
||||
if System.String.IsNullOrEmpty(cleanOutput) then valStr
|
||||
elif System.String.IsNullOrEmpty(valStr) then cleanOutput
|
||||
else cleanOutput + "\n" + valStr
|
||||
|
||||
| Choice1Of2 None ->
|
||||
if not (System.String.IsNullOrEmpty(errors)) then
|
||||
cleanOutput + sprintf "%A" errors
|
||||
// Filtrera bort FSI:s automatiska typsignaturer från utskriften
|
||||
let cleanOutput =
|
||||
output.Replace("\r\n", "\n").Split('\n')
|
||||
|> Array.filter (fun line ->
|
||||
let l = line.TrimStart()
|
||||
|
||||
not (
|
||||
l.StartsWith("val ")
|
||||
|| l.StartsWith("type ")
|
||||
|| l.StartsWith("module ")
|
||||
|| l.StartsWith("namespace ")
|
||||
))
|
||||
|> String.concat "\n"
|
||||
|> fun s -> s.Trim()
|
||||
|
||||
match result with
|
||||
| Choice1Of2(Some fsiValue) ->
|
||||
// Plocka ut värdet. Om det är en sträng, undvik "%A" för a tattecken.
|
||||
let valStr =
|
||||
if isNull fsiValue.ReflectionValue then
|
||||
""
|
||||
else
|
||||
cleanOutput
|
||||
|
||||
| Choice2Of2 ex ->
|
||||
let fsiErrorOutput = if System.String.IsNullOrEmpty(errors) then "Ingen ytterligare FSI-output." else errors
|
||||
sprintf """
|
||||
<div style="color: #721c24; background-color: #f8d7da; border-color: #f5c6cb; padding: 10px; margin-bottom: 10px; border-radius: 5px;">
|
||||
<strong>FSI Exekveringsfel!</strong><br/>
|
||||
<strong>Kod som kördes:</strong> <code>%s</code><br/><br/>
|
||||
<strong>Exception:</strong> %s<br/>
|
||||
<strong>FSI Stderr:</strong> <pre style="margin:0; background: rgba(255,255,255,0.5); padding: 5px;">%s</pre>
|
||||
</div>""" code ex.Message fsiErrorOutput
|
||||
|
||||
with ex ->
|
||||
sprintf """<div style="color: red; border: 1px solid red; padding: 10px;">
|
||||
<strong>Kritiskt FSI-systemfel:</strong> %s
|
||||
</div>""" ex.Message
|
||||
match fsiValue.ReflectionValue with
|
||||
| :? string as s -> s
|
||||
| v -> sprintf "%A" v
|
||||
|
||||
|
||||
if System.String.IsNullOrEmpty(cleanOutput) then valStr
|
||||
elif System.String.IsNullOrEmpty(valStr) then cleanOutput
|
||||
else cleanOutput + "\n" + valStr
|
||||
|
||||
| Choice1Of2 None ->
|
||||
if not (System.String.IsNullOrEmpty(errors)) then
|
||||
cleanOutput + sprintf "%A" errors
|
||||
else
|
||||
cleanOutput
|
||||
|
||||
| Choice2Of2 ex ->
|
||||
let fsiErrorOutput =
|
||||
if System.String.IsNullOrEmpty(errors) then
|
||||
"Ingen ytterligare FSI-output."
|
||||
else
|
||||
errors
|
||||
|
||||
sprintf
|
||||
"""
|
||||
<div style="color: #721c24; background-color: #f8d7da; border-color: #f5c6cb; padding: 10px; margin-bottom: 10px; border-radius: 5px;">
|
||||
<strong>FSI Exekveringsfel!</strong><br/>
|
||||
<strong>Kod som kördes:</strong> <code>%s</code><br/><br/>
|
||||
<strong>Exception:</strong> %s<br/>
|
||||
<strong>FSI Stderr:</strong> <pre style="margin:0; background: rgba(255,255,255,0.5); padding: 5px;">%s</pre>
|
||||
</div>"""
|
||||
code
|
||||
ex.Message
|
||||
fsiErrorOutput
|
||||
|
||||
with ex ->
|
||||
sprintf
|
||||
"""<div style="color: red; border: 1px solid red; padding: 10px;">
|
||||
<strong>Kritiskt FSI-systemfel:</strong> %s
|
||||
</div>"""
|
||||
ex.Message
|
||||
|
||||
override this.NewSession() =
|
||||
this.Evaluate($"module {Random.Shared.GetHexString(10)}")
|
||||
()
|
||||
|
||||
|
||||
|
||||
module CommandEvaluator =
|
||||
open Ast
|
||||
// Interface för att utvärdera Expr-noder (kodblock/matte)
|
||||
|
||||
// Huvudfunktionen
|
||||
let rec evaluateDocument
|
||||
(metadata: Map<string, string>)
|
||||
(prelude: Map<string, TagRenderer>)
|
||||
(exprEval: IEvaluator)
|
||||
(blocks: BlockNode list)
|
||||
=
|
||||
blocks |> List.map (evaluateBlock metadata prelude exprEval)
|
||||
|
||||
// Evaluerar Block-noder
|
||||
and evaluateBlock metadata prelude exprEval block =
|
||||
let evalBlocks = evaluateDocument metadata prelude exprEval
|
||||
let evalInlines = List.map (evaluateInline metadata prelude exprEval)
|
||||
|
||||
match block with
|
||||
| CodeBlock(attr, text) -> CodeBlock(attr, text)
|
||||
|
||||
| Figure(attr, caption, blocks) -> Figure(attr, evalInlines caption, evalBlocks blocks)
|
||||
|
||||
| Plain inlines -> Plain(evalInlines inlines)
|
||||
|
||||
| Paragraph inlines -> Paragraph(evalInlines inlines)
|
||||
|
||||
| Section(attr, lvl, title, body) -> Section(attr, lvl, evalInlines title, evalBlocks body)
|
||||
|
||||
| ListBlock kind ->
|
||||
match kind with
|
||||
| Orderedlist(attr, start, blocksList) ->
|
||||
Orderedlist(attr, start, blocksList |> List.map evalBlocks) |> ListBlock
|
||||
| BulletList(attr, blocksList) -> BulletList(attr, blocksList |> List.map evalBlocks) |> ListBlock
|
||||
// TODO: This should run recursively to make sure a command can return a new command!
|
||||
| BlockCommand(name, args, kwargs, children) ->
|
||||
let evalChildren = children |> List.map (evaluateInline metadata prelude exprEval)
|
||||
|
||||
match prelude.TryFind name with
|
||||
| Some renderer ->
|
||||
// Om du ändrar TagRenderer att returnera BlockNode direkt är det ännu bättre.
|
||||
match renderer metadata args kwargs evalChildren with
|
||||
| Block i -> i // Exempel: @table blev en riktig Table-nod
|
||||
| Inline i -> Plain [ i ]
|
||||
| None -> failwithf "Okänt block-kommando: %s" name
|
||||
|
||||
// Evaluerar Inline-noder
|
||||
and evaluateInline metadata prelude exprEval inlineNode =
|
||||
let evalInlines = List.map (evaluateInline metadata prelude exprEval)
|
||||
let evalBlocks = evaluateDocument metadata prelude exprEval
|
||||
|
||||
match inlineNode with
|
||||
// Noder som inte har några barn eller commands i sig
|
||||
| Text _
|
||||
| RawHtml _
|
||||
| SoftBreak
|
||||
| LineBreak -> inlineNode
|
||||
|
||||
// Enkla wrappers som bara skickar vidare barnen
|
||||
| Emph children -> Emph(evalInlines children)
|
||||
| Underline children -> Underline(evalInlines children)
|
||||
| Strong children -> Strong(evalInlines children)
|
||||
| Strikeout children -> Strikeout(evalInlines children)
|
||||
| Superscript children -> Superscript(evalInlines children)
|
||||
| Subscript children -> Subscript(evalInlines children)
|
||||
|
||||
// Komplexa noder
|
||||
| Link(attr, target) ->
|
||||
let url, content = target
|
||||
Link(attr, (url, evalInlines content))
|
||||
|
||||
| Image(attr, altText, url) -> Image(attr, evalInlines altText, url)
|
||||
|
||||
| Code(attr, text) -> Code(attr, text)
|
||||
|
||||
| Note blocks ->
|
||||
// Här går vi tillbaka till att evaluera block!
|
||||
Note(evalBlocks blocks)
|
||||
|
||||
| Expr(code, res) -> Expr(code, Some(exprEval.Evaluate code))
|
||||
|
||||
// TODO: This should run recursively to make sure a command can return a new command!
|
||||
| Command(tag, args, kwargs, children) ->
|
||||
// 1. Evaluera barnen först (Bottom-Up)
|
||||
let evaluatedChildren = evalInlines children
|
||||
|
||||
// 2. Slå upp kommandot i preluden
|
||||
match prelude.TryFind tag with
|
||||
| Some renderer ->
|
||||
// 3. Kör funktionen och returnera den nya noden
|
||||
match renderer metadata args kwargs evaluatedChildren with
|
||||
| Inline i -> i
|
||||
| Block b -> failwithf "Syntaxfel: Blocknod i inline-kontext: %A" b
|
||||
|
||||
| None -> failwithf "Syntaxfel: Okänt kommando '@%s' hittades under evaluering." tag
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue