namespace LanguageTest 

​

type [<RequireQualifiedAccess>] RawCharacterType =

  | Whitespace

  | NewLine

  | Word

  | PunctuationOrSymbol

  static member FromChar char =

    if System.Char.IsWhiteSpace(char) then

      RawCharacterType.Whitespace

    elif char = '\r' || char = '\n' then

      RawCharacterType.NewLine

    elif System.Char.IsLetterOrDigit(char) then

      RawCharacterType.Word

    else

      RawCharacterType.PunctuationOrSymbol

  ///If true, then multiple occurences of this character may be chained together into one token.

  member this.ChainType =

    match this with

    | Whitespace | NewLine | Word -> true

    | PunctuationOrSymbol -> false

type [<RequireQualifiedAccess>] Keyword = 

  | Let

  | False

  | True

​

type [<RequireQualifiedAccess>] TokenType =

  | Whitespace

  | Keyword of Keyword

  | Integer 

  | NewLine

  | Decimal 

  | Identifier

  | Punctuation of char

  | Character of char

  | StringLiteral of string

​

​

​

module Lexer =

  open System

  type Token = 

    { Text: string

      Line: int

      Column: int

      RawCharacterType: RawCharacterType

      TokenType: TokenType

    }

  let (|Keyword|_|) arg =

    if String.IsNullOrWhiteSpace(arg) then None

    else

      match arg.Trim().ToLower() with

      | "let" -> Some(Keyword.Let)

      | "false" -> Some(Keyword.False)

      | "true" -> Some(Keyword.True)

      | _ -> None

  let (|Integer|_|) arg =

    if String.IsNullOrWhiteSpace(arg) then None

    else

      match Int32.TryParse arg with

      | true, result -> Some(result)

      | _ -> None

  let GetTokenType (text: string) rawCharType =

    match rawCharType with

    | RawCharacterType.Whitespace -> TokenType.Whitespace

    | RawCharacterType.NewLine -> TokenType.NewLine

    | RawCharacterType.PunctuationOrSymbol -> TokenType.Punctuation(text.[0])

    | RawCharacterType.Word ->

      match text with

      | Keyword(word) -> TokenType.Keyword(word)

      | Integer(integer) -> TokenType.Integer

      | _ -> TokenType.Identifier

  let Tokenize (text: string) lineNumber =

    let endWord rawCharType nextChar =

      match nextChar with

      | Some(x) -> 

        let nextTokenType = RawCharacterType.FromChar x

        if nextTokenType = rawCharType && rawCharType.ChainType then false, None

        else true, Some(nextTokenType)

      | None -> true, None

    let rec addToken rawCharType startColumn endColumn =

      let createToken() =

        let tokenText = text.[startColumn..endColumn]

        { Token.Text = tokenText

          Line = lineNumber

          Column = startColumn

          RawCharacterType = rawCharType

          TokenType = (GetTokenType tokenText rawCharType)

        }

      let nextColumn = endColumn + 1

      let peekChar = if nextColumn >= text.Length then None

                     else Some(text.[nextColumn])

      match endWord rawCharType peekChar with

      | false, Some(_) -> failwithf "Word continuation should not return Token Type: \"%s\"" text

      | true, Some(nextTokenType) -> createToken() :: (addToken nextTokenType nextColumn nextColumn)

      | true, None -> [ createToken() ]      

      | false, None -> addToken rawCharType startColumn nextColumn

    if text.Length = 0 then []

    else

      let initialTokenType = RawCharacterType.FromChar text.[0]

      addToken initialTokenType 0 0

module AST =

  open System.Text.RegularExpressions

  type OperatorType =

    | Equals

    | Terminator

    member this.OperatorText =

      match this with

      | Equals -> "="

      | Terminator -> ";"

  type [<RequireQualifiedAccess>] ASTBatch =

    | Batch of ASTStatement list

  and [<RequireQualifiedAccess>] ASTStatement = 

    | Assignment of ASTIdentifier * ASTExpression

  and [<RequireQualifiedAccess>] ASTExpression = 

  //  | StringLiteral of string

    | IntegerLiteral of int

    | DecimalLiteral of decimal

  and [<RequireQualifiedAccess>] ASTIdentifier = 

    | Identifier of string

  and [<RequireQualifiedAccess>] ASTOperator =

    | Operator of OperatorType

  type [<RequireQualifiedAccess>] ParseResult<'T> =

    | Success of 'T * Lexer.Token list

    | Failure of string

  type Parser<'T> = ((Lexer.Token list) -> ParseResult<'T>)

  let private choose (parsers: Parser<_> list) (tokens: Lexer.Token list) =

    let rec combinator (remainingParsers: Parser<_> list) (parserResults: ParseResult<_> list) =

      match remainingParsers with

      | [] -> 

        parserResults.Head

      | singleParser :: remain ->

        let testResults = singleParser tokens

        match testResults with

        | ParseResult.Success(_) -> 

          testResults

        | ParseResult.Failure(_) -> 

          combinator remain (testResults :: parserResults)

    combinator parsers []

  let Chain (parser1: Parser<'a>) (parser2: Parser<'b>) (tokens: Lexer.Token list) =

    let parser1Result = parser1 tokens

    match parser1Result with

    | ParseResult.Success(p1R, remainingTokens1) ->

      let parser2Result = parser2 remainingTokens1

      match parser2Result with

      | ParseResult.Success(p2R, remainingTokens2) ->

        ParseResult.Success((p1R, p2R), remainingTokens2)

      | ParseResult.Failure(error2) ->

        ParseResult.Failure(error2)

    | ParseResult.Failure(error1) ->

      ParseResult.Failure(error1)  

  let ChainLeft (parser1: Parser<_>) (parser2: Parser<_>) (tokens: Lexer.Token list) =

    let parser1Result = parser1 tokens

    match parser1Result with

    | ParseResult.Success(p1R, remainingTokens1) ->

      let parser2Result = parser2 remainingTokens1

      match parser2Result with

      | ParseResult.Success(_, remainingTokens2) ->

        ParseResult.Success(p1R, remainingTokens2)

      | ParseResult.Failure(error2) ->

        ParseResult.Failure(error2)

    | ParseResult.Failure(error1) ->

      ParseResult.Failure(error1)

  let ChainRight (parser1: Parser<_>) (parser2: Parser<_>) (tokens: Lexer.Token list) =

    let parser1Result = parser1 tokens

    match parser1Result with

    | ParseResult.Success(_, remainingTokens1) ->

      let parser2Result = parser2 remainingTokens1

      match parser2Result with

      | ParseResult.Success(p2R, remainingTokens2) ->

        ParseResult.Success(p2R, remainingTokens2)

      | ParseResult.Failure(error2) ->

        ParseResult.Failure(error2)

    | ParseResult.Failure(error1) ->

      ParseResult.Failure(error1)

  let private next (tokenList: Lexer.Token list) =

    match tokenList with

    | [] -> None, []

    | x :: items -> Some(x), items 

  let ParseWhitespace tokenList = 

    let rec ignoreWhitespace remainingTokens initialWhiteSpace = 

      match next remainingTokens with

      | Some(x1), l1 -> 

        match x1.TokenType with 

        | TokenType.Whitespace ->

          ignoreWhitespace l1 false

        | _ ->

          match initialWhiteSpace with

          | true -> ParseResult.Failure("Expected whitespace")

          | false -> ParseResult.Success((), remainingTokens)

      | _ -> ParseResult.Failure("End of file")

    ignoreWhitespace tokenList true

  let ParseASTIdentifier tokenList =

    match next tokenList with

    | Some(x1), l1 -> 

      match x1.TokenType with

      | TokenType.Identifier ->

        match Regex.IsMatch(x1.Text, "^[A-Za-z][A-Za-z0-9]*$") with

        | true -> ParseResult.Success(ASTIdentifier.Identifier x1.Text, l1)

        | false -> ParseResult.Failure(sprintf "\"%s\" is not identifier." x1.Text)

      | _ -> ParseResult.Failure(sprintf "\"%s\" is not identifier." x1.Text)

    | _ -> ParseResult.Failure("End of file")

  let ParseASTInteger tokenList =

    match next tokenList with

    | Some(x1), l1 -> 

      match x1.TokenType with

      | TokenType.Integer ->

        match System.Int32.TryParse x1.Text with

        | true, value -> ParseResult.Success(ASTExpression.IntegerLiteral value, l1)

        | false, _ -> ParseResult.Failure(sprintf "\"%s\" is not integer." x1.Text)

      | _ -> ParseResult.Failure(sprintf "\"%s\" is not integer." x1.Text)

    | _ -> ParseResult.Failure("End of file")

  let ParseASTIsOperator (operator: OperatorType) tokenList =

    let operatorText = operator.OperatorText

    let rec readOperator remainingTokens remainingOperatorText = 

      match remainingOperatorText with

      | [] -> 

        ParseResult.Success((), remainingTokens)

      | x :: remain ->

        match next remainingTokens with

        | Some(x1), l1 -> 

          match x1.TokenType with 

          | TokenType.Punctuation(c) when x = c -> 

            readOperator l1 remain

          | _ -> 

            ParseResult.Failure(sprintf "Expected \"%s\"" operatorText)

        | _ -> 

          ParseResult.Failure("End of file")

    readOperator tokenList (operatorText.ToCharArray() |> Array.toList)

  let ParseASTIsKeyword (keyword: Keyword) tokenList =

    match next tokenList with

    | Some(x1), l1 -> 

      match x1.TokenType with

      | TokenType.Keyword(k) when k = keyword -> ParseResult.Success((), l1)

      | _ -> ParseResult.Failure(sprintf "\"%s\" is not keyword \"%A\"." x1.Text keyword)

    | _ -> ParseResult.Failure("End of file")

  let ParseTerminator = (ParseASTIsOperator OperatorType.Terminator)

  let inline (<!>) parser1 parser2 = Chain parser1 parser2

  let inline (<<) parser1 parser2 = ChainLeft parser1 parser2

  let inline (>>) parser1 parser2 = ChainRight parser1 parser2

  let Translate<'a,'b> (success: 'a -> 'b) (parser: Parser<'a>) =

    (fun tokens ->

      match parser tokens with 

      | ParseResult.Success(t, remainingTokens) -> ParseResult.Success(success t, remainingTokens)

      | ParseResult.Failure(error) -> ParseResult.Failure(error))

  let TranslateWithError<'a,'b> (success: 'a -> 'b, error: string -> string) (parser: ParseResult<'a>) =

    match parser with 

    | ParseResult.Success(t, remainingTokens) -> ParseResult.Success(success t, remainingTokens)

    | ParseResult.Failure(error) -> ParseResult.Failure(error)

  let ParseAssignment =

    (((ParseASTIsKeyword Keyword.Let) >> ParseWhitespace) >> ParseASTIdentifier << ParseWhitespace << (ParseASTIsOperator OperatorType.Equals) << ParseWhitespace <!> ParseASTInteger << ParseTerminator)

    |> Translate (ASTStatement.Assignment)

​

module Main =

​

  [<EntryPoint>]

  let main argv = 

    printfn "#### Printing Tokens ####"

    let tokens = Lexer.Tokenize "let four = 5;" 0  

    for i in tokens do

      printfn "%A" i

    let parseResult = AST.ParseAssignment tokens

    printfn ""

    printfn ""

    printfn "#### Printing Abstract Syntax Tree ####"

    printfn "%A" parseResult  

    0 // return an integer exit code

​