5 people like it.

Simple AST parser

Parsers a minimal expression tree allowing for functions of the form "func(arg1,arg2,...)->{body}"

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
134: 
135: 
136: 
137: 
138: 
139: 
140: 
141: 
142: 
143: 
144: 
145: 
146: 
147: 
148: 
149: 
150: 
151: 
152: 
153: 
154: 
155: 
156: 
157: 
158: 
159: 
160: 
161: 
162: 
163: 
164: 
165: 
166: 
167: 
168: 
169: 
170: 
171: 
172: 
173: 
174: 
175: 
176: 
177: 
178: 
179: 
180: 
181: 
182: 
183: 
184: 
185: 
186: 
187: 
188: 
189: 
190: 
191: 
192: 
193: 
194: 
195: 
196: 
197: 
198: 
199: 
200: 
201: 
202: 
203: 
204: 
205: 
206: 
207: 
208: 
209: 
210: 
211: 
212: 
213: 
214: 
215: 
216: 
217: 
218: 
219: 
220: 
221: 
222: 
223: 
224: 
225: 
226: 
227: 
228: 
229: 
230: 
231: 
232: 
233: 
234: 
235: 
236: 
237: 
238: 
239: 
240: 
241: 
242: 
243: 
244: 
245: 
246: 
247: 
248: 
249: 
250: 
251: 
252: 
253: 
254: 
255: 
256: 
257: 
258: 
259: 
module LanguageCombinator

open FParsec
open System

exception Error of string

type Op = 
    | Plus
    | Minus
    | GreaterThan
    | LessThan
    | Mult
    | Divide
    | Carrot
       
type Ast =     
    | Statement of Ast    
    | Expression of Ex    
    | Function of string option * Argument list option * Ast
    | Scope of Ast list option
    | Class of Ex * Ast
    | Conditional of Ex * Ast * Ast option 
    | WhileLoop of Ex * Ast
    | ForLoop of Ast * Ex * Ex * Ast    
    | Call of string * Argument list option
    | Assign of Ex * Ex
and Ex =
    | Single of Ast
    | Full of Ex * Op * Ex
    | Float of float
    | Int of int
    | Literal of string
    | Variable of string
and Argument = 
    | Element of Ex

(* Literals *)

let semicolon = skipStringCI ";"

let quote = skipStringCI "\""

let literal = quote >>. manyCharsTill anyChar quote |>> Literal

let floatNum = pfloat |>> Float

let intNum = pint32 |>> Int

(* Variables *)

let variable = many1Chars (satisfy isAsciiLetter) |>> Variable

(* Operators *)

let plus = pstring "+" >>% Plus

let minus = pstring "-" >>% Minus

let divide = pstring "/" >>% Divide

let mult = pstring "*" >>% Mult

let carrot = pstring "^" >>% Carrot

let gt = pstring ">" >>% GreaterThan

let lt = pstring  "<" >>% LessThan

let op = spaces >>. choice[plus;minus;divide;mult;carrot;gt;lt]

(* expressions *)

// create a forward reference 
// the expr is what we'll use in our parser combinators
// the exprImpl we'll populate with all the recursive options later
let expr, exprImpl = createParserForwardedToRef()

let expression1 = spaces >>? choice[floatNum;intNum;literal;variable] 

let between a b p = pstring a >>. p .>> pstring b

let bracketExpression = expr |> between "(" ")"

let lhExpression = choice[expression1; bracketExpression]

let expressionOpration =  lhExpression                           >>=? fun operandL ->
                          op                                     >>=? fun operator ->
                          choice[expr;bracketExpression]         >>=? fun operandR ->
                          preturn (operandL, operator, operandR) |>> Full 

do exprImpl := spaces >>. choice[attempt expressionOpration;
                                 attempt bracketExpression; 
                                 expression1]

(* Scope *)

let funcInners, funcInnersImpl = createParserForwardedToRef()

let scope = parse{
    do! spaces
    do! skipStringCI "{"
    do! spaces
    let! text = opt funcInners
    do! spaces
    do! skipStringCI "}"    
    do! spaces
    return Scope(text)
}

(* Classes *)

let classItem = parse{
    do! skipStringCI "class"
    do! spaces
    let! name = variable    
    let! classStatements = scope
    do! spaces
    return Class(name, classStatements)
}    

(* Functions *)

let innerArgs = sepEndBy1 (expr |>> Element) (pstring ",")
let arguments = innerArgs |> between "(" ")"

let func = parse {
    do! skipStringCI "func"
    do! spaces
    let! name = opt (many1Chars (satisfy isAsciiLetter))
    let! arguments = opt arguments
    do! spaces 
    do! skipStringCI "->"
    let! scope = scope
    return Function(name, arguments, scope)
}


(* Conditionals *)

let conditionalParser, conditionalParserImpl = createParserForwardedToRef()

let ifBlock = parse{
    do! skipStringCI "if"
    let! condition = expr |> between "(" ")"
    do! spaces
    let! onTrue = scope
    do! spaces

    let elseKeyword = skipStringCI "else" .>> spaces

    let elseParse = parse{
        do! elseKeyword
        let! onFalse = scope
        return (condition, onTrue, Some(onFalse)) |> Conditional
    }

    let elseIfParse = parse{
        do! elseKeyword
        let! onFalse = conditionalParser
        return (condition, onTrue, Some(onFalse)) |> Conditional
    }

    let noElseParse = parse{        
        return (condition, onTrue, None) |> Conditional
    }

    let! result = choice[attempt elseIfParse;elseParse;noElseParse]
    return result
}

do conditionalParserImpl:= ifBlock 

let conditional = ifBlock 

(* Assignment *)

let assign = parse{
    let! ex = expr
    do! spaces
    do! skipStringCI "="
    do! spaces
    let! assignEx = expr
    do! spaces    
    return (ex, assignEx) |> Assign
}

(* Loops *)

let whileLoop = (pstring "while" >>. spaces) >>. (expr |> between "(" ")") >>= fun predicate ->
                scope >>= fun body ->
                preturn (WhileLoop(predicate, body))


let forLoop = 
    let startCondition = assign .>> pstring ";"
    let predicate = expr .>> pstring ";"
    let endCondition = expr 
    let forKeyword = pstring "for" .>> spaces

    let forItems = tuple3 startCondition predicate endCondition |> between "(" ")"

    forKeyword >>. forItems .>>. scope >>= fun ((s, p, e), b) ->
        preturn (s, p, e, b) |>> ForLoop
        

(* Function calls *)

let call = parse{
    let! name = many1Chars (satisfy isAsciiLetter)
    do! spaces
    do! skipStringCI "("
    let! args = opt innerArgs
    do! spaces
    do! skipStringCI ")"
    do! spaces
    return Call(name, args)
}           


(* Statements *)


let delineatedStatement = choice[
                                 attempt call;
                                 attempt assign;
                                 expr |>> Expression
                                ] .>> semicolon |>> Statement

let statement = choice[
                        conditional;
                        whileLoop;
                        forLoop;                  
                        delineatedStatement
                     ]
                                           

(* things that can be in functions *)

do funcInnersImpl := many1 (spaces >>? choice [scope; func; statement])

(* Things can be in the program root *)

let programLines = spaces >>. choice[
                                        classItem;
                                        func;
                                        scope;
                                        statement
                                    ]

(* The full program *)
                                    
let program = many programLines

let test input = match run (program .>> eof) input with
                    | Success(r,_,_) -> r
                    | Failure(r,_,_) -> 
                            Console.WriteLine r
                            raise (Error(r))
module LanguageCombinator
namespace System
exception Error of string

Full name: LanguageCombinator.Error
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = String

Full name: Microsoft.FSharp.Core.string
type Op =
  | Plus
  | Minus
  | GreaterThan
  | LessThan
  | Mult
  | Divide
  | Carrot

Full name: LanguageCombinator.Op
union case Op.Plus: Op
union case Op.Minus: Op
union case Op.GreaterThan: Op
union case Op.LessThan: Op
union case Op.Mult: Op
union case Op.Divide: Op
union case Op.Carrot: Op
type Ast =
  | Statement of Ast
  | Expression of Ex
  | Function of string option * Argument list option * Ast
  | Scope of Ast list option
  | Class of Ex * Ast
  | Conditional of Ex * Ast * Ast option
  | WhileLoop of Ex * Ast
  | ForLoop of Ast * Ex * Ex * Ast
  | Call of string * Argument list option
  | Assign of Ex * Ex

Full name: LanguageCombinator.Ast
union case Ast.Statement: Ast -> Ast
union case Ast.Expression: Ex -> Ast
type Ex =
  | Single of Ast
  | Full of Ex * Op * Ex
  | Float of float
  | Int of int
  | Literal of string
  | Variable of string

Full name: LanguageCombinator.Ex
union case Ast.Function: string option * Argument list option * Ast -> Ast
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
type Argument = | Element of Ex

Full name: LanguageCombinator.Argument
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
union case Ast.Scope: Ast list option -> Ast
Multiple items
union case Ast.Class: Ex * Ast -> Ast

--------------------
type ClassAttribute =
  inherit Attribute
  new : unit -> ClassAttribute

Full name: Microsoft.FSharp.Core.ClassAttribute

--------------------
new : unit -> ClassAttribute
union case Ast.Conditional: Ex * Ast * Ast option -> Ast
union case Ast.WhileLoop: Ex * Ast -> Ast
union case Ast.ForLoop: Ast * Ex * Ex * Ast -> Ast
union case Ast.Call: string * Argument list option -> Ast
union case Ast.Assign: Ex * Ex -> Ast
Multiple items
union case Ex.Single: Ast -> Ex

--------------------
type Single =
  struct
    member CompareTo : value:obj -> int + 1 overload
    member Equals : obj:obj -> bool + 1 overload
    member GetHashCode : unit -> int
    member GetTypeCode : unit -> TypeCode
    member ToString : unit -> string + 3 overloads
    static val MinValue : float32
    static val Epsilon : float32
    static val MaxValue : float32
    static val PositiveInfinity : float32
    static val NegativeInfinity : float32
    ...
  end

Full name: System.Single
union case Ex.Full: Ex * Op * Ex -> Ex
union case Ex.Float: float -> Ex
Multiple items
val float : value:'T -> float (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.float

--------------------
type float = Double

Full name: Microsoft.FSharp.Core.float

--------------------
type float<'Measure> = float

Full name: Microsoft.FSharp.Core.float<_>
union case Ex.Int: int -> Ex
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
Multiple items
union case Ex.Literal: string -> Ex

--------------------
type LiteralAttribute =
  inherit Attribute
  new : unit -> LiteralAttribute

Full name: Microsoft.FSharp.Core.LiteralAttribute

--------------------
new : unit -> LiteralAttribute
union case Ex.Variable: string -> Ex
union case Argument.Element: Ex -> Argument
val semicolon : obj

Full name: LanguageCombinator.semicolon
val quote : obj

Full name: LanguageCombinator.quote
val literal : obj

Full name: LanguageCombinator.literal
val floatNum : '_arg3

Full name: LanguageCombinator.floatNum
val intNum : '_arg3

Full name: LanguageCombinator.intNum
val variable : '_arg3

Full name: LanguageCombinator.variable
val plus : '_arg3

Full name: LanguageCombinator.plus
val minus : '_arg3

Full name: LanguageCombinator.minus
val divide : '_arg3

Full name: LanguageCombinator.divide
val mult : '_arg3

Full name: LanguageCombinator.mult
val carrot : '_arg3

Full name: LanguageCombinator.carrot
val gt : '_arg3

Full name: LanguageCombinator.gt
val lt : '_arg3

Full name: LanguageCombinator.lt
val op : '_arg3 (requires member ( >>=? ))

Full name: LanguageCombinator.op
val expr : 'a (requires member ( >>. ) and member ( .>> ) and member ( .>> ) and member ( >>. ) and member ( >>. ) and member ( >>= ) and member ( .>>. ) and member ( >>= ) and member ( >>= ))

Full name: LanguageCombinator.expr
val exprImpl : '_arg3 ref

Full name: LanguageCombinator.exprImpl
val expression1 : '_arg3

Full name: LanguageCombinator.expression1
val between : a:'a -> b:'b -> p:'c -> '_arg3 (requires member ( >>. ) and member ( .>> ) and member ( .>> ) and member ( >>. ) and member ( >>. ) and member ( >>= ) and member ( .>>. ) and member ( >>= ) and member ( >>= ))

Full name: LanguageCombinator.between
val a : 'a
val b : 'a
val p : 'a (requires member ( >>. ) and member ( .>> ) and member ( .>> ) and member ( >>. ) and member ( >>. ) and member ( >>= ) and member ( .>>. ) and member ( >>= ) and member ( >>= ))
val bracketExpression : '_arg3 (requires member ( >>. ) and member ( >>. ) and member ( >>= ) and member ( .>>. ) and member ( >>= ) and member ( >>= ))

Full name: LanguageCombinator.bracketExpression
val lhExpression : 'a (requires member ( >>=? ))

Full name: LanguageCombinator.lhExpression
val expressionOpration : '_arg3

Full name: LanguageCombinator.expressionOpration
val operandL : 'a
val operator : 'a
val operandR : 'a
val funcInners : 'a

Full name: LanguageCombinator.funcInners
val funcInnersImpl : 'a ref

Full name: LanguageCombinator.funcInnersImpl
val scope : 'a (requires member ( >>= ) and member ( .>>. ) and member ( >>= ))

Full name: LanguageCombinator.scope
val classItem : 'a

Full name: LanguageCombinator.classItem
val innerArgs : 'a (requires member ( >>. ) and member ( .>> ) and member ( .>> ) and member ( >>. ) and member ( >>. ) and member ( >>= ) and member ( .>>. ) and member ( >>= ) and member ( >>= ))

Full name: LanguageCombinator.innerArgs
val arguments : '_arg3 (requires member ( >>. ) and member ( >>. ) and member ( >>= ) and member ( .>>. ) and member ( >>= ) and member ( >>= ))

Full name: LanguageCombinator.arguments
val func : 'a

Full name: LanguageCombinator.func
val conditionalParser : 'a

Full name: LanguageCombinator.conditionalParser
val conditionalParserImpl : 'a ref

Full name: LanguageCombinator.conditionalParserImpl
val ifBlock : 'a

Full name: LanguageCombinator.ifBlock
union case Option.Some: Value: 'T -> Option<'T>
union case Option.None: Option<'T>
val conditional : 'a

Full name: LanguageCombinator.conditional
val assign : 'a (requires member ( .>> ))

Full name: LanguageCombinator.assign
val whileLoop : '_arg3

Full name: LanguageCombinator.whileLoop
val predicate : 'a
val body : 'a
val forLoop : '_arg12

Full name: LanguageCombinator.forLoop
val startCondition : '_arg3
val predicate : '_arg6
val endCondition : 'a (requires member ( >>. ) and member ( .>> ) and member ( .>> ) and member ( >>. ) and member ( >>. ) and member ( >>= ) and member ( .>>. ) and member ( >>= ) and member ( >>= ))
val forKeyword : '_arg9 (requires member ( >>. ) and member ( >>. ) and member ( >>= ) and member ( .>>. ) and member ( >>= ) and member ( >>= ))
val forItems : '_arg3 (requires member ( >>. ) and member ( >>. ) and member ( >>= ) and member ( .>>. ) and member ( >>= ) and member ( >>= ))
val s : 'a
val p : 'a
val e : 'a
val call : 'a

Full name: LanguageCombinator.call
val delineatedStatement : obj

Full name: LanguageCombinator.delineatedStatement
val statement : 'a

Full name: LanguageCombinator.statement
val programLines : '_arg3

Full name: LanguageCombinator.programLines
val program : 'a

Full name: LanguageCombinator.program
val test : input:'a -> 'b

Full name: LanguageCombinator.test
val input : 'a
Multiple items
val Failure : message:string -> exn

Full name: Microsoft.FSharp.Core.Operators.Failure

--------------------
active recognizer Failure: exn -> string option

Full name: Microsoft.FSharp.Core.Operators.( |Failure|_| )
type Console =
  static member BackgroundColor : ConsoleColor with get, set
  static member Beep : unit -> unit + 1 overload
  static member BufferHeight : int with get, set
  static member BufferWidth : int with get, set
  static member CapsLock : bool
  static member Clear : unit -> unit
  static member CursorLeft : int with get, set
  static member CursorSize : int with get, set
  static member CursorTop : int with get, set
  static member CursorVisible : bool with get, set
  ...

Full name: System.Console
Console.WriteLine() : unit
   (+0 other overloads)
Console.WriteLine(value: string) : unit
   (+0 other overloads)
Console.WriteLine(value: obj) : unit
   (+0 other overloads)
Console.WriteLine(value: uint64) : unit
   (+0 other overloads)
Console.WriteLine(value: int64) : unit
   (+0 other overloads)
Console.WriteLine(value: uint32) : unit
   (+0 other overloads)
Console.WriteLine(value: int) : unit
   (+0 other overloads)
Console.WriteLine(value: float32) : unit
   (+0 other overloads)
Console.WriteLine(value: float) : unit
   (+0 other overloads)
Console.WriteLine(value: decimal) : unit
   (+0 other overloads)
val raise : exn:Exception -> 'T

Full name: Microsoft.FSharp.Core.Operators.raise

More information

Link:http://fssnip.net/iJ
Posted:6 years ago
Author:devshorts
Tags: fparsec , parsing , ast , expressions