Functional Thread 14 : Parser Combinators

[[)roi(]]

Define the named procedure parser
A name procedure consists of three parts:

• A header that start with the string "to" followed by an Identifier and a set of Parameters.
• A body that contains one or more pcommand lines.
• A footer that contains the string "end"

In the code below we define a phead, pbody and pfoot parsers, which is tied together using the logical conjunction (AND) operators .>>. and ,>>; the dots (.) indicate which of the parsed output we are holding onto namely:

• name -- the identifier of the named procedure
• ps -- the parameters of the named procedure
• body -- the commands within the named procedure

Before returning the AST type Procedure; we first update the mutable reference to procs by adding newly identified named procedures and their parameters; follow by an updateCalls() to dynamically generate new procedural call parsers and to also update the mutable reference to the pcall parser; to ensure that the in progress parsing will correctly be able to parse procedural calls to the encountered name procedures.

  let pprocedure =
    let pparameters = many (pparameter .>> spaces)
    let phead = pstring "to" >>. spaces1 >>. pidentifier .>> spaces1 .>>. pparameters
    let pbody = many (pcommand .>> spaces1)
    let pfoot = pstring "end"
    phead .>>. pbody .>> pfoot
    |>> fun ((name, ps), body) ->
      procs := (name, ps) :: !procs; updateCalls()
      Procedure(name, ps, body)

Wrap everything together
Finally we wrap everything together in a plogo parser which is a parser that merges a logical disjunction between a parser that can parse a pprocedure and pcommand. The sepEndBy is a combinator that will match an indeterminate number of pprocedure or pcommand parsers separated by 1 or more spaces.

  let plogo = spaces >>. (sepEndBy (pcommand <|> pprocedure) spaces1)

Finally we create a helper function to parse a file
To simplify the use of our logo parser we finally create a simple function with a single parameter, representing the code we want to parse. Internally we parse the code with the plogo parser and then pattern match over the result; in the case of a Success we return the result; which is the AST, and in the case of a Failure we throw an exception with the error message.

  let parse code =
    match run plogo code with
    | Success(result, _, _) -> result
    | Failure(msg, _, _) -> failwith msg

 

[[)roi(]]

Updating the Interpreter
I'm going to focus on describing the changes to the previous Interpreter code that didn't use FParsec.

module Interpreter =
  open System
  open SkiaSharp
  open Microsoft.Xna.Framework.Graphics
  open System.Runtime.InteropServices
  open AST

  let calcTargetCoord turtle distance =
    let r = Math.PI * float turtle.Angle / 180.0
    (turtle.X, turtle.Y, turtle.X + float distance * cos r, turtle.Y + float distance * sin r)

  let execute w h g cmds =
    let procedures = ref Map.empty
    let texture = new Texture2D(g, w, h)
    let imageInfo = SKImageInfo(w, h, SKImageInfo.PlatformColorType, SKAlphaType.Premul)
    let surface = SKSurface.Create(imageInfo)
    let canvas = surface.Canvas
    let turtle = { X = float w / 2.0; Y = float h / 2.0; Angle = -90; PenDown = true }
    let pen = new SKPaint()
    pen.Color <- SKColors.White
    pen.IsAntialias <- true
    let random = Random()
    let rec perform env turtle command =
      match command with
      | Forward distance ->
        let x, y, x', y' = calcTargetCoord turtle (unwrapValue env distance)
        if turtle.PenDown then canvas.DrawLine(float32 x, float32 y, float32 x', float32 y', pen)
        { turtle with X = x'; Y = y' }
      | Backward distance ->
        let x, y, x', y' = calcTargetCoord turtle -(unwrapValue env distance)
        if turtle.PenDown then canvas.DrawLine(float32 x, float32 y, float32 x', float32 y', pen)
        { turtle with X = x'; Y = y' }
      | Left degree -> { turtle with Angle = turtle.Angle - (unwrapValue env degree) }
      | Right degree -> { turtle with Angle = turtle.Angle + (unwrapValue env degree) }
      | PenSize width ->
        pen.StrokeWidth <- float32 (unwrapValue env width)
        turtle
      | SetX x -> { turtle with X = float w / 2.0 + float (unwrapValue env x) }
      | SetY y -> { turtle with Y = float h / 2.0 + float (unwrapValue env y) }
      | SetXY (x, y) -> { turtle with X = float w / 2.0 + float (unwrapValue env x); Y = float h / 2.0 + float (unwrapValue env y) }
      | SetRandomXY ->
        let (x, y) = (random.Next(w) |> float, random.Next(h) |> float)
        { turtle with X = x; Y = y }
      | SetH degree -> { turtle with Angle = (unwrapValue env degree) }
      | PenDown x -> { turtle with PenDown = x }
      | SetPenColor (red, green, blue) ->
        pen.Color <- SKColor(byte (unwrapValue env red), byte (unwrapValue env green), byte (unwrapValue env blue), 255uy)
        turtle
      | SetPenAlpha alpha ->
        pen.Color <- pen.Color.WithAlpha(byte (unwrapValue env alpha))  
        turtle
      | Repeat (value, commands) ->
        let n = unwrapValue env value
        let rec repeat turtle count =
          match count with
          | 0 -> turtle
          | n -> repeat (performAll env turtle commands) (n - 1)
        repeat turtle n
      | Procedure (name, parameters, commands) ->
        procedures := Map.add name (parameters, commands) !procedures
        turtle
      | Call (name, values) ->
        let parameters, commands = (!procedures).[name]
        if parameters.Length <> values.Length then failwith (sprintf "Parameter count mismatch for procedure: %s" name)
        let paramsValues = List.zip parameters values
        let env = paramsValues |> List.fold (fun e (parameter, value) -> Map.add parameter value e) env
        commands |> performAll env turtle  
    and performAll env turtle commands =
      commands |> List.fold (perform env) turtle
    and unwrapValue env = function
      | Number n -> n
      | Variable name -> unwrapValue env (Map.tryFind name env).Value
    performAll Map.empty turtle cmds |> ignore
    let pixelMap = surface.PeekPixels()
    let pixelAddr = pixelMap.GetPixels()
    let pixels : byte[] = Array.zeroCreate (h * pixelMap.RowBytes)
    Marshal.Copy(pixelAddr, pixels, 0, pixels.Length)
    texture.SetData(pixels)
    texture

New variables
The following code has been added to the prefix of the execute function. The procedures variable is a mutable Map that will store a keyed link to the Procedure(s); the (name, parameters, commands) which can later be used by a procedural Call to pattern match / execute a tied procedure with parsed input arguments.

  let execute w h g cmds =
    let procedures = ref Map.empty
...
    let random = Random()
let rec perform env turtle command =
...

The perform recursive function that pattern matches over the AST has an additional argument; env. This env (environment) argument is used to build an in memory set of variables and their associated literal values; determined by pattern matching against procedural calls. env is Map which is initialised as an empty Map. The random variable create an instance to the Random number generator that we use in the SetRandomXY to randomly generate X and Y coordinates.


Forward / Backward
The previous Walk type has been split into two Forward and Backward AST types; the other change is to use a unwrapValue function that pattern matches over the two Value types; Number or Variable.

...
     | Forward distance ->
        let x, y, x', y' = calcTargetCoord turtle (unwrapValue env distance)
        if turtle.PenDown then canvas.DrawLine(float32 x, float32 y, float32 x', float32 y', pen)
        { turtle with X = x'; Y = y' }
      | Backward distance ->
        let x, y, x', y' = calcTargetCoord turtle -(unwrapValue env distance)
        if turtle.PenDown then canvas.DrawLine(float32 x, float32 y, float32 x', float32 y', pen)
        { turtle with X = x'; Y = y' }
...

Call / unwrapValue
The Call looks up the parameters and commands for a named procedure; as long as there is no parameters mismatched to the input values; we construct a new env; environment tying the literal values found in the procedural calls to a procedure's parameters.

This env (environment); the literal values associated with a procedure's parameters is looked up in the unwrapValue function to be converting to its matching literal value.

...
     | Call (name, values) ->
        let parameters, commands = (!procedures).[name]
        if parameters.Length <> values.Length then failwith (sprintf "Parameter count mismatch for procedure: %s" name)
        let paramsValues = List.zip parameters values
        let env = paramsValues |> List.fold (fun e (parameter, value) -> Map.add parameter value e) env
        commands |> performAll env turtle 
...
    and unwrapValue env = function
      | Number n -> n
      | Variable name -> unwrapValue env (Map.tryFind name env).Value
...

For the PenSize, SetX, SetY, SetXY,SetH and Repeat pattern matches the code is the same, except for adaption to get literal values using the unwrapValue function.


SetPenAlpha, SetRandomXY
The SetPenAlpha and SetRandomXY functions should be fairly easy to understand; SetPenAlpha we change the pen variable Color's alpha value and with the SetRandomXY, we update the turtle record with randomly generated X and Y coordinates.

...
     | SetRandomXY ->
        let (x, y) = (random.Next(w) |> float, random.Next(h) |> float)
        { turtle with X = x; Y = y }
...
      | SetPenAlpha alpha ->
        pen.Color <- pen.Color.WithAlpha(byte (unwrapValue env alpha))   
        turtle
...

Procedure
The Procedure branch updates the procedures Map variable; to ensure match in the keyed lookups in the Call branch.

...    
      | Procedure (name, parameters, commands) ->
        procedures := Map.add name (parameters, commands) !procedures
        turtle
...

Controller
Finally let's look at the changed to the Controller.fs

...
type Controller (code) as this = 
  inherit Game()
  let mutable code: string = code
...

  override this.LoadContent() =
...
    backBuffer <- Parser.parse code |> Interpreter.execute h w graphics.GraphicsDevice

...

The only lines that were changed is:

• Added a new mutable property code to store the code; which is tied in the Controller signature
• Change the backBuffer texture assignment in the LoadContent method.

 

[[)roi(]]

Program.fs
Change Program.fs to accept a logo file as an input parameter.

open Endofunk
[<EntryPoint>]
let main argv =
  if argv.Length = 0 then
   printfn "<logo filename>.logo"
  else
    let code = Prelude.readFile argv.[0]
    use controller = new Controller(code)
    controller.Run()
  0 // return an integer exit code

Prelude.fs

namespace Endofunk

module Prelude =
  open System.IO
  let readFile filePath = try File.ReadAllText(filePath) with e -> ""

Time for some Testing
In the project sub folder TurtleDesktop, we need to create 6 text files namely test1.logo through to test6.logo co0ntaining the code listed above each image below.

To test out logo parser; we open a terminal / console window and navigate to the Turtle project folder and build the project dotnet build; and to run the parser on test1.logo, we enter the following:

./TurtleDesktop/bin/Debug/netcoreapp3.1/Turtle ./TurtleDesktop/test1.logo

Test1.logo

right 25 forward 100

Test2.logo

repeat 10 [right 36 repeat 5 [forward 54 right 72]]

Test3.logo

setxy -200 0 setpensize 4 setpencolor 240 240 112 repeat 12 [repeat 5 [pd fd 120 rt 144] setpensize 2 pu fd 120 rt 30]

Test4.logo

to square
repeat 4 [forward 50 right 90]
end
to flower
repeat 36 [right 10 square]
end
to garden :count
repeat :count [setrandomxy flower]
end
garden 25

Test5.logo

to square :size                                                          
  repeat 4 [fd :size rt 90]                         
end
to go :number :s
  repeat :number [fd 12 square :s rt 15 ]                 
end
go 25 250

Test6.logo

to sd :r :g :b
setpencolor :r :g :b repeat 900 [ fd 72 rt 743]
end
sd 100 200 230

 

[[)roi(]]

Trace debugging for the combinator parsers
We're going to wrap up this thread with adding on code to enable tracing within each of parser combinator functions for better track / trace of parsing issues.


Tracing operator <!>
To be able to finely control to which parser combinator functions we want to enable for track / trace, we define a custom infix operator <!> which intercepts the input stream and allows us to inject our own custom code before and after a parsing combinator operation.

In the Logo.fs file in the Parser module we add:

module Parser =
  open FParsec
  open AST
  let debug = false
  let (||>>) fa fb =
    let f n = fa n || fb n
    f
  let backtrackingSepBy1 p sep = pipe2 p (many (sep >>? p)) (fun head tail -> head :: tail)

  let indentCount = ref 0
  let (<!>) (p: Parser<_,_>) label : Parser<_,_> =
    fun stream ->
    if debug then
      indentCount := indentCount.Value + 1
      let index = sprintf "%i:%i" stream.Position.Line stream.Position.Column
      let filler = String.replicate (indentCount.Value) " │"
      printfn "%*s%s Entering %s --< %c" 6 index filler label (stream.Peek())
      let reply = p stream
      let index = sprintf "%i:%i" stream.Position.Line stream.Position.Column
      let filler = String.replicate (indentCount.Value) " │"
      printfn "%*s%s Leaving %s (%A)" 6 index filler label reply.Status
      indentCount := indentCount.Value - 1
      reply
    else
      p stream
...

We've also defined a debug variable as a switch to control the turning on or off of track / trace debugging, and we also defined a mutable indentCount variable to visually keep track of our stack calls between the parser combinators; we simply increment the count before the parsing of the stream:

let (<!>) (p: Parser<_,_>) label : Parser<_,_> =
...
      indentCount := indentCount.Value + 1
...
      let reply = p stream
...
      indentCount := indentCount.Value - 1
...

Enabling tracing for a combinator function
The code below show how we enable tracing for the pforward parser combinator function.

let private pforward = (pstring "forward" <|> pstring "fd") >>. spaces1 >>. pvariable <!> "pforward" |>> Forward

The change insertion of <!> "pforward" activates the debiug tracing code above and the "string" parameter is the custom label we've chosen for this combinator to appear in the output.

Here is a complete code listing for the Parser module in Logo,fs with the tracing infix operator added to all combinators.

module Parser =
  open FParsec
  open AST
  let debug = false
  let (||>>) fa fb =
    let f n = fa n || fb n
    f
  let backtrackingSepBy1 p sep = pipe2 p (many (sep >>? p)) (fun head tail -> head :: tail)
  let indentCount = ref 0
  let (<!>) (p: Parser<_,_>) label : Parser<_,_> =
    fun stream ->
    if debug then
      indentCount := indentCount.Value + 1
      let index = sprintf "%i:%i" stream.Position.Line stream.Position.Column
      let filler = String.replicate (indentCount.Value) " │"
      printfn "%*s%s Entering %s --< %c" 6 index filler label (stream.Peek())
      let reply = p stream
      let index = sprintf "%i:%i" stream.Position.Line stream.Position.Column
      let filler = String.replicate (indentCount.Value) " │"
      printfn "%*s%s Leaving %s (%A)" 6 index filler label reply.Status
      indentCount := indentCount.Value - 1
      reply 
    else
      p stream     
  let procs = ref []
  let private pidentifier =
    let isDash c = c = '-'
    many1Satisfy2L (isLetter ||>> isDash) (isLetter ||>> isDigit ||>> isDash)  "identifier" <!> "pidentifier"
  let private pparameter = pstring ":" >>. pidentifier <!> "pparameter"
  let private pnumber = pfloat |>> (int >> Number) <!> "pnumber"
  let private pvariable = pnumber <|> (pparameter |>> Variable) <!> "pvariable"
  let private pforward = (pstring "forward" <|> pstring "fd") >>. spaces1 >>. pvariable <!> "pforward" |>> Forward
  let private pbackward = (pstring "backward" <|> pstring "bk") >>. spaces1 >>. pvariable <!> "pbackward" |>> Backward
  let private pleft = (pstring "left" <|> pstring "lt") >>. spaces1 >>. pvariable <!> "pleft" |>> Left
  let private pright = (pstring "right" <|> pstring "rt") >>. spaces1 >>. pvariable <!> "pright" |>> Right
  let private ppensize = pstring "setpensize" >>. spaces1 >>. pvariable <!> "ppensize" |>> PenSize
  let private pbool b: Parser<bool, unit> = preturn b <!> "pbool"
  let private ppenup = (pstring "penup" <|> pstring "pu") >>. pbool false <!> "ppenup" |>> PenDown
  let private ppendown = (pstring "pendown" <|> pstring "pd") >>. pbool true <!> "ppendown" |>> PenDown
  let private psetx = pstring "setx" >>. spaces1 >>. pvariable <!> "psetx" |>> SetX
  let private psety = pstring "sety" >>. spaces1 >>. pvariable <!> "psety" |>> SetY
  let private psetxy = pstring "setxy" >>. spaces1 >>. pvariable .>>. spaces1 .>>. pvariable <!> "psetxy" |>> fun ((x, _), y) -> SetXY(x, y)
  let private psetrandomxy = pstring "setrandomxy" <!> "psetrandomxy" >>% SetRandomXY
  let private pseth = pstring "seth" >>. spaces1 >>. pvariable <!> "pseth" |>> SetH
  let private psetpencolor = pstring "setpencolor" >>. spaces1 >>. pvariable .>>. spaces1 .>>. pvariable .>>. spaces1 .>>. pvariable <!> "psetpencolor" |>> fun ((((red, _), green), _), blue) -> SetPenColor(red, green, blue)
  let private psetpenalpha = pstring "setpenalpah" >>. spaces >>. pvariable .>> spaces1 <!> "psetpenalpha" |>> SetPenAlpha
  let private prepeat, prepeatRef = createParserForwardedToRef ()
  let private pcall, pcallRef = createParserForwardedToRef ()
  let private pcommand = choice [pforward; pbackward; pleft; pright; ppensize; ppenup; ppendown; psetxy; psetx; psety; psetrandomxy; pseth; psetpencolor; psetpenalpha; prepeat; pcall] <!> "pcommand"
 
  let updateCalls () =
    pcallRef :=
      choice [
        for (name, ps) in (!procs) ->
          pstring name >>. spaces >>. opt (backtrackingSepBy1 pvariable spaces) <!> (sprintf "pcallimpl: %s %A" name ps)
          |>> fun optArgs ->
            match optArgs with
            | Some args -> Call(name, args)
            | _ -> Call(name, [])
      ]
  updateCalls()
  let pblock = between (pstring "[" .>> spaces) (spaces >>. pstring "]") (many1 (pcommand .>> spaces)) <!> "pblock"
  prepeatRef := pstring "repeat" >>. spaces1 >>. pvariable .>> spaces .>>. pblock <!> "prepeat" |>> fun (arg, commands) -> Repeat(arg, commands)
 
  let pprocedure =
    let pparameters = many (pparameter .>> spaces)
    let phead = pstring "to" >>. spaces1 >>. pidentifier .>> spaces1 .>>. pparameters
    let pbody = many (pcommand .>> spaces1)
    let pfoot = pstring "end"
    phead .>>. pbody .>> pfoot <!> "pprocedure"
    |>> fun ((name, ps), body) ->
      procs := (name, ps) :: !procs; updateCalls()
      Procedure(name, ps, body)
  let plogo = spaces >>. (sepEndBy (pcommand <|> pprocedure) spaces1) <!> "plogo"
  let parse code =
    match run plogo code with
    | Success(result, _, _) -> result
    | Failure(msg, _, _) -> failwith msg

 

[[)roi(]]

Finally let's run the tracer
Change the let debug = false to true; build the project, and run one of the examples test2.logo:

repeat 10 [right 36 repeat 5 [forward 54 right 72]]

The tracing output from this is as follows.
The two numbers indicate the line and column offset, the indentation shows the call stack between the parser combinator functions; and the custom parser label are suffixed to the Entering and Leaving text.

Finally the --< is a hint to the starting character that the parser combinator is evaluating; this can be increased to show more detailed. The lines with the (Error) text indicated a parser failure i.e. the particular combinator did not match the text at the line / column offset.

   1:1 │ Entering plogo --< r
   1:1 │ │ Entering pcommand --< r
   1:1 │ │ │ Entering pforward --< r
   1:1 │ │ │ Leaving pforward (Error)
   1:1 │ │ │ Entering pbackward --< r
   1:1 │ │ │ Leaving pbackward (Error)
   1:1 │ │ │ Entering pleft --< r
   1:1 │ │ │ Leaving pleft (Error)
   1:1 │ │ │ Entering pright --< r
   1:1 │ │ │ Leaving pright (Error)
   1:1 │ │ │ Entering ppensize --< r
   1:1 │ │ │ Leaving ppensize (Error)
   1:1 │ │ │ Entering ppenup --< r
   1:1 │ │ │ Leaving ppenup (Error)
   1:1 │ │ │ Entering ppendown --< r
   1:1 │ │ │ Leaving ppendown (Error)
   1:1 │ │ │ Entering psetxy --< r
   1:1 │ │ │ Leaving psetxy (Error)
   1:1 │ │ │ Entering psetx --< r
   1:1 │ │ │ Leaving psetx (Error)
   1:1 │ │ │ Entering psety --< r
   1:1 │ │ │ Leaving psety (Error)
   1:1 │ │ │ Entering psetrandomxy --< r
   1:1 │ │ │ Leaving psetrandomxy (Error)
   1:1 │ │ │ Entering pseth --< r
   1:1 │ │ │ Leaving pseth (Error)
   1:1 │ │ │ Entering psetpencolor --< r
   1:1 │ │ │ Leaving psetpencolor (Error)
   1:1 │ │ │ Entering psetpenalpha --< r
   1:1 │ │ │ Leaving psetpenalpha (Error)
   1:1 │ │ │ Entering prepeat --< r
   1:8 │ │ │ │ Entering pvariable --< 1
   1:8 │ │ │ │ │ Entering pnumber --< 1
  1:10 │ │ │ │ │ Leaving pnumber (Ok)
  1:10 │ │ │ │ Leaving pvariable (Ok)
  1:11 │ │ │ │ Entering pblock --< [
  1:12 │ │ │ │ │ Entering pcommand --< r
  1:12 │ │ │ │ │ │ Entering pforward --< r
  1:12 │ │ │ │ │ │ Leaving pforward (Error)
  1:12 │ │ │ │ │ │ Entering pbackward --< r
  1:12 │ │ │ │ │ │ Leaving pbackward (Error)
  1:12 │ │ │ │ │ │ Entering pleft --< r
  1:12 │ │ │ │ │ │ Leaving pleft (Error)
  1:12 │ │ │ │ │ │ Entering pright --< r
  1:18 │ │ │ │ │ │ │ Entering pvariable --< 3
  1:18 │ │ │ │ │ │ │ │ Entering pnumber --< 3
  1:20 │ │ │ │ │ │ │ │ Leaving pnumber (Ok)
  1:20 │ │ │ │ │ │ │ Leaving pvariable (Ok)
  1:20 │ │ │ │ │ │ Leaving pright (Ok)
  1:20 │ │ │ │ │ Leaving pcommand (Ok)
  1:21 │ │ │ │ │ Entering pcommand --< r
  1:21 │ │ │ │ │ │ Entering pforward --< r
  1:21 │ │ │ │ │ │ Leaving pforward (Error)
  1:21 │ │ │ │ │ │ Entering pbackward --< r
  1:21 │ │ │ │ │ │ Leaving pbackward (Error)
  1:21 │ │ │ │ │ │ Entering pleft --< r
  1:21 │ │ │ │ │ │ Leaving pleft (Error)
  1:21 │ │ │ │ │ │ Entering pright --< r
  1:21 │ │ │ │ │ │ Leaving pright (Error)
  1:21 │ │ │ │ │ │ Entering ppensize --< r
  1:21 │ │ │ │ │ │ Leaving ppensize (Error)
  1:21 │ │ │ │ │ │ Entering ppenup --< r
  1:21 │ │ │ │ │ │ Leaving ppenup (Error)
  1:21 │ │ │ │ │ │ Entering ppendown --< r
  1:21 │ │ │ │ │ │ Leaving ppendown (Error)
  1:21 │ │ │ │ │ │ Entering psetxy --< r
  1:21 │ │ │ │ │ │ Leaving psetxy (Error)
  1:21 │ │ │ │ │ │ Entering psetx --< r
  1:21 │ │ │ │ │ │ Leaving psetx (Error)
  1:21 │ │ │ │ │ │ Entering psety --< r
  1:21 │ │ │ │ │ │ Leaving psety (Error)
  1:21 │ │ │ │ │ │ Entering psetrandomxy --< r
  1:21 │ │ │ │ │ │ Leaving psetrandomxy (Error)
  1:21 │ │ │ │ │ │ Entering pseth --< r
  1:21 │ │ │ │ │ │ Leaving pseth (Error)
  1:21 │ │ │ │ │ │ Entering psetpencolor --< r
  1:21 │ │ │ │ │ │ Leaving psetpencolor (Error)
  1:21 │ │ │ │ │ │ Entering psetpenalpha --< r
  1:21 │ │ │ │ │ │ Leaving psetpenalpha (Error)
  1:21 │ │ │ │ │ │ Entering prepeat --< r
  1:28 │ │ │ │ │ │ │ Entering pvariable --< 5
  1:28 │ │ │ │ │ │ │ │ Entering pnumber --< 5
  1:29 │ │ │ │ │ │ │ │ Leaving pnumber (Ok)
  1:29 │ │ │ │ │ │ │ Leaving pvariable (Ok)
  1:30 │ │ │ │ │ │ │ Entering pblock --< [
  1:31 │ │ │ │ │ │ │ │ Entering pcommand --< f
  1:31 │ │ │ │ │ │ │ │ │ Entering pforward --< f
  1:39 │ │ │ │ │ │ │ │ │ │ Entering pvariable --< 5
  1:39 │ │ │ │ │ │ │ │ │ │ │ Entering pnumber --< 5
  1:41 │ │ │ │ │ │ │ │ │ │ │ Leaving pnumber (Ok)
  1:41 │ │ │ │ │ │ │ │ │ │ Leaving pvariable (Ok)
  1:41 │ │ │ │ │ │ │ │ │ Leaving pforward (Ok)
  1:41 │ │ │ │ │ │ │ │ Leaving pcommand (Ok)
  1:42 │ │ │ │ │ │ │ │ Entering pcommand --< r
  1:42 │ │ │ │ │ │ │ │ │ Entering pforward --< r
  1:42 │ │ │ │ │ │ │ │ │ Leaving pforward (Error)
  1:42 │ │ │ │ │ │ │ │ │ Entering pbackward --< r
  1:42 │ │ │ │ │ │ │ │ │ Leaving pbackward (Error)
  1:42 │ │ │ │ │ │ │ │ │ Entering pleft --< r
  1:42 │ │ │ │ │ │ │ │ │ Leaving pleft (Error)
  1:42 │ │ │ │ │ │ │ │ │ Entering pright --< r
  1:48 │ │ │ │ │ │ │ │ │ │ Entering pvariable --< 7
  1:48 │ │ │ │ │ │ │ │ │ │ │ Entering pnumber --< 7
  1:50 │ │ │ │ │ │ │ │ │ │ │ Leaving pnumber (Ok)
  1:50 │ │ │ │ │ │ │ │ │ │ Leaving pvariable (Ok)
  1:50 │ │ │ │ │ │ │ │ │ Leaving pright (Ok)
  1:50 │ │ │ │ │ │ │ │ Leaving pcommand (Ok)
  1:50 │ │ │ │ │ │ │ │ Entering pcommand --< ]
  1:50 │ │ │ │ │ │ │ │ │ Entering pforward --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving pforward (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering pbackward --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving pbackward (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering pleft --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving pleft (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering pright --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving pright (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering ppensize --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving ppensize (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering ppenup --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving ppenup (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering ppendown --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving ppendown (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering psetxy --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving psetxy (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering psetx --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving psetx (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering psety --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving psety (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering psetrandomxy --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving psetrandomxy (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering pseth --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving pseth (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering psetpencolor --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving psetpencolor (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering psetpenalpha --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving psetpenalpha (Error)
  1:50 │ │ │ │ │ │ │ │ │ Entering prepeat --< ]
  1:50 │ │ │ │ │ │ │ │ │ Leaving prepeat (Error)
  1:50 │ │ │ │ │ │ │ │ Leaving pcommand (Error)
  1:51 │ │ │ │ │ │ │ Leaving pblock (Ok)
  1:51 │ │ │ │ │ │ Leaving prepeat (Ok)
  1:51 │ │ │ │ │ Leaving pcommand (Ok)
  1:51 │ │ │ │ │ Entering pcommand --< ]
  1:51 │ │ │ │ │ │ Entering pforward --< ]
  1:51 │ │ │ │ │ │ Leaving pforward (Error)
  1:51 │ │ │ │ │ │ Entering pbackward --< ]
  1:51 │ │ │ │ │ │ Leaving pbackward (Error)
  1:51 │ │ │ │ │ │ Entering pleft --< ]
  1:51 │ │ │ │ │ │ Leaving pleft (Error)
  1:51 │ │ │ │ │ │ Entering pright --< ]
  1:51 │ │ │ │ │ │ Leaving pright (Error)
  1:51 │ │ │ │ │ │ Entering ppensize --< ]
  1:51 │ │ │ │ │ │ Leaving ppensize (Error)
  1:51 │ │ │ │ │ │ Entering ppenup --< ]
  1:51 │ │ │ │ │ │ Leaving ppenup (Error)
  1:51 │ │ │ │ │ │ Entering ppendown --< ]
  1:51 │ │ │ │ │ │ Leaving ppendown (Error)
  1:51 │ │ │ │ │ │ Entering psetxy --< ]
  1:51 │ │ │ │ │ │ Leaving psetxy (Error)
  1:51 │ │ │ │ │ │ Entering psetx --< ]
  1:51 │ │ │ │ │ │ Leaving psetx (Error)
  1:51 │ │ │ │ │ │ Entering psety --< ]
  1:51 │ │ │ │ │ │ Leaving psety (Error)
  1:51 │ │ │ │ │ │ Entering psetrandomxy --< ]
  1:51 │ │ │ │ │ │ Leaving psetrandomxy (Error)
  1:51 │ │ │ │ │ │ Entering pseth --< ]
  1:51 │ │ │ │ │ │ Leaving pseth (Error)
  1:51 │ │ │ │ │ │ Entering psetpencolor --< ]
  1:51 │ │ │ │ │ │ Leaving psetpencolor (Error)
  1:51 │ │ │ │ │ │ Entering psetpenalpha --< ]
  1:51 │ │ │ │ │ │ Leaving psetpenalpha (Error)
  1:51 │ │ │ │ │ │ Entering prepeat --< ]
  1:51 │ │ │ │ │ │ Leaving prepeat (Error)
  1:51 │ │ │ │ │ Leaving pcommand (Error)
  1:52 │ │ │ │ Leaving pblock (Ok)
  1:52 │ │ │ Leaving prepeat (Ok)
  1:52 │ │ Leaving pcommand (Ok)
  1:52 │ Leaving plogo (Ok)

In closing
The track / trace is completely customisable; and nothing prevents you from creating a set of different infix operators that do different things. The debug variable could also be tied into command line argument to avoid the need to recompile the parser for debugging in production.

In this thread my goal was to introduce your to a different side of the core functional algebras like Functor, Monad, and currying, function composition, etc.. to hopefully give you some sense that these functional building blocks are not limited to just data container types like Maybe, Either, List, etc.

Anyway if anyone has any questions; either send a PM or add it to this thread.