diff --git a/src/Feersum.CompilerServices/Binding/Binder.fs b/src/Feersum.CompilerServices/Binding/Binder.fs index 2b080dd..0f066c2 100644 --- a/src/Feersum.CompilerServices/Binding/Binder.fs +++ b/src/Feersum.CompilerServices/Binding/Binder.fs @@ -3,6 +3,7 @@ namespace Feersum.CompilerServices.Binding open Feersum.CompilerServices open Feersum.CompilerServices.Ice open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text open Feersum.CompilerServices.Syntax open Feersum.CompilerServices.Utils diff --git a/src/Feersum.CompilerServices/Binding/Libraries.fs b/src/Feersum.CompilerServices/Binding/Libraries.fs index 79aeeed..4e7e23b 100644 --- a/src/Feersum.CompilerServices/Binding/Libraries.fs +++ b/src/Feersum.CompilerServices/Binding/Libraries.fs @@ -1,6 +1,7 @@ namespace Feersum.CompilerServices.Binding open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text open Feersum.CompilerServices.Syntax open Feersum.CompilerServices.Utils diff --git a/src/Feersum.CompilerServices/Binding/Macros.fs b/src/Feersum.CompilerServices/Binding/Macros.fs index 1acbc37..7950a9c 100644 --- a/src/Feersum.CompilerServices/Binding/Macros.fs +++ b/src/Feersum.CompilerServices/Binding/Macros.fs @@ -2,6 +2,7 @@ namespace Feersum.CompilerServices.Binding open Feersum.CompilerServices.Ice open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text open Feersum.CompilerServices.Syntax open Feersum.CompilerServices.Utils diff --git a/src/Feersum.CompilerServices/Compile/Compiler.fs b/src/Feersum.CompilerServices/Compile/Compiler.fs index a075d5a..a73867b 100644 --- a/src/Feersum.CompilerServices/Compile/Compiler.fs +++ b/src/Feersum.CompilerServices/Compile/Compiler.fs @@ -10,6 +10,7 @@ open System.Collections.Generic open Feersum.CompilerServices open Feersum.CompilerServices.Ice open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text open Feersum.CompilerServices.Binding open Feersum.CompilerServices.Syntax open Feersum.CompilerServices.Compile.MonoHelpers diff --git a/src/Feersum.CompilerServices/Diagnostics.fs b/src/Feersum.CompilerServices/Diagnostics.fs index 8be423f..ee48b08 100644 --- a/src/Feersum.CompilerServices/Diagnostics.fs +++ b/src/Feersum.CompilerServices/Diagnostics.fs @@ -1,48 +1,8 @@ namespace Feersum.CompilerServices.Diagnostics -open System.IO +open Feersum.CompilerServices.Text -/// A point in the source text -type TextPoint = - // FIXME: this _should_ just be the offset into the file, with line and - // other information resolved later from a workspace or similar. We're stuck - // like this for the time being though becuase of FParsec. - { Source: string - Line: int64 - Col: int64 } - - static member public FromExternal(position: FParsec.Position) : TextPoint = - TextPoint.FromParts(position.StreamName, position.Line, position.Column) - - static member public FromParts(source: string, line: int64, col: int64) = - { Source = source - Line = line - Col = col } - -/// A lcation in the source text -/// -/// A text position represents either a single `Point` in the source text that -/// lies 'between' two characters, or a `Span` that encompases a range of text. -type TextLocation = - | Span of TextPoint * TextPoint - | Point of TextPoint - | Missing - - /// Get the start of the text location. This returns a cursor that lies just - /// before any text represented by this locaiton. - member x.Start = - match x with - | Span (s, _) -> s - | Point p -> p - | Missing -> TextPoint.FromParts("missing", 0, 0) - - /// Get the end of the text location. This returns a cursot that lies just - /// after any text represented by this location. - member x.End = - match x with - | Span (_, e) -> e - | Point p -> p - | Missing -> TextPoint.FromParts("missing", 0, 0) +open System.IO /// Level of diagnostic. Used to tell warnings from errors. type DiagnosticLevel = diff --git a/src/Feersum.CompilerServices/Feersum.CompilerServices.fsproj b/src/Feersum.CompilerServices/Feersum.CompilerServices.fsproj index 786abda..965832c 100644 --- a/src/Feersum.CompilerServices/Feersum.CompilerServices.fsproj +++ b/src/Feersum.CompilerServices/Feersum.CompilerServices.fsproj @@ -11,11 +11,13 @@ + + diff --git a/src/Feersum.CompilerServices/LegacySyntax.fs b/src/Feersum.CompilerServices/LegacySyntax.fs index 739d637..e700795 100644 --- a/src/Feersum.CompilerServices/LegacySyntax.fs +++ b/src/Feersum.CompilerServices/LegacySyntax.fs @@ -5,6 +5,7 @@ open System.Globalization open System.Text open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text /// Constant or literal value in the syntax tree type SyntaxConstant = diff --git a/src/Feersum.CompilerServices/Syntax/Lex.fs b/src/Feersum.CompilerServices/Syntax/Lex.fs index 1473014..9ea41c9 100644 --- a/src/Feersum.CompilerServices/Syntax/Lex.fs +++ b/src/Feersum.CompilerServices/Syntax/Lex.fs @@ -2,7 +2,7 @@ module Feersum.CompilerServices.Syntax.Lex open System open System.Text -open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text /// Token kinds for the language. type TokenKind = diff --git a/src/Feersum.CompilerServices/Syntax/Parse.fs b/src/Feersum.CompilerServices/Syntax/Parse.fs index afe25b2..5dedd55 100644 --- a/src/Feersum.CompilerServices/Syntax/Parse.fs +++ b/src/Feersum.CompilerServices/Syntax/Parse.fs @@ -7,6 +7,7 @@ open Firethorn.Red open Feersum.CompilerServices.Ice open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text open Feersum.CompilerServices.Syntax.Tree open Lex diff --git a/src/Feersum.CompilerServices/Syntax/SyntaxShim.fs b/src/Feersum.CompilerServices/Syntax/SyntaxShim.fs new file mode 100644 index 0000000..50dfaf7 --- /dev/null +++ b/src/Feersum.CompilerServices/Syntax/SyntaxShim.fs @@ -0,0 +1,30 @@ +module Feersum.CompilerServices.Syntax.SyntaxShim + +open Feersum.CompilerServices.Syntax.Tree +open Feersum.CompilerServices.Text + +type LegacyNode = Feersum.CompilerServices.Syntax.AstNode +type LegacyNodeKind<'a> = Feersum.CompilerServices.Syntax.AstNodeKind<'a> + +/// Transform a single expression into a legcy AST +let rec transformExpr (doc: TextDocument) (expr: Expression): LegacyNode = + let kind = + match expr with + | Form f -> + f.Body + |> Seq.map (transformExpr doc) + |> List.ofSeq + |> LegacyNodeKind.Form + | _ -> + // TODO: All the other node kinds + LegacyNodeKind.Error + { Kind = kind; Location = TextDocument.rangeToLocation doc expr.SyntaxRange } + +/// Transform a program into a legacy AST +let transformProgram (doc: TextDocument) (prog: Program): LegacyNode = + let body = + prog.Body + |> Seq.map (transformExpr doc) + |> List.ofSeq + |> LegacyNodeKind.Seq + { Kind = body; Location = TextDocument.rangeToLocation doc prog.SyntaxRange } diff --git a/src/Feersum.CompilerServices/Syntax/Tree.fs b/src/Feersum.CompilerServices/Syntax/Tree.fs index 7b12dcb..b1efa5b 100644 --- a/src/Feersum.CompilerServices/Syntax/Tree.fs +++ b/src/Feersum.CompilerServices/Syntax/Tree.fs @@ -4,6 +4,7 @@ open Firethorn open Firethorn.Green open Firethorn.Red + /// Node kind for each element in the raw tree. type AstKind = | ERROR = -1 @@ -57,10 +58,10 @@ module private Utils = /// from the Firethorn library. This last layer is a colleciton of classes that /// 'query' the underlying untyped tree to provide structured access to the /// data. -/// - +/// /// Root type in the AST Tree. All node types should inherit from this /// either directly or indeirectly . + [] type AstItem internal (red: NodeOrToken) = @@ -125,8 +126,7 @@ and BoolVal internal (red: SyntaxToken) = inherit ConstantValue(red) - member public x.Value = - x.Text.StartsWith("#t") + member public x.Value = x.Text.StartsWith("#t") /// Character node in the syntax tree. @@ -157,10 +157,7 @@ type Form internal (red: SyntaxNode) = |> Seq.choose (NodeOrToken.asToken) |> Seq.tryFind (tokenOfKind AstKind.OPEN_PAREN) - // FIXME: This should return a seq of expression, not raw syntax noddes - member public _.Body = - red.Children() - |> Seq.choose Expression.TryCast + member public _.Body = red.Children() |> Seq.choose Expression.TryCast member public _.ClosingParen = red.ChildrenWithTokens() @@ -204,8 +201,9 @@ and ByteVec internal (red: SyntaxNode) = /// be either a simple datum (`Constant`), an identifier `Symbol`, or a comple /// `Form` datum. and Expression internal (red: SyntaxNode) = + inherit AstNode(red) - static member TryCast (node: SyntaxNode) = + static member TryCast(node: SyntaxNode) = match node.Kind |> greenToAst with | AstKind.FORM -> Some(new Form(node) :> Expression) | AstKind.SYMBOL -> Some(new Symbol(node)) @@ -241,3 +239,21 @@ type Program internal (red: SyntaxNode) = Some(new Program(red)) else None + + +/// Active patterns to make working with elements in the syntax tree more +/// ergonomic. +[] +module Patterns = + + open Feersum.CompilerServices.Ice + + /// Pattern to match on known expression types + let (|ByteVec|Vec|Form|Constant|Symbol|) (expr: Expression) = + match expr with + | :? ByteVec as b -> ByteVec b + | :? Vec as v -> Vec v + | :? Form as f -> Form f + | :? Constant as c -> Constant c + | :? Symbol as s -> Symbol s + | _ -> icef "Unexpected expression type: %A" (expr.GetType()) diff --git a/src/Feersum.CompilerServices/Text.fs b/src/Feersum.CompilerServices/Text.fs new file mode 100644 index 0000000..ff23d9f --- /dev/null +++ b/src/Feersum.CompilerServices/Text.fs @@ -0,0 +1,83 @@ +namespace Feersum.CompilerServices.Text + +/// A point in the source text +type public TextPoint = + // FIXME: this _should_ just be the offset into the file, with line and + // other information resolved later from a workspace or similar. We're stuck + // like this for the time being though becuase of FParsec. + { Source: string + Line: int64 + Col: int64 } + + static member public FromExternal(position: FParsec.Position) : TextPoint = + TextPoint.FromParts(position.StreamName, position.Line, position.Column) + + static member public FromParts(source: string, line: int64, col: int64) = + { Source = source + Line = line + Col = col } + +/// A lcation in the source text +/// +/// A text position represents either a single `Point` in the source text that +/// lies 'between' two characters, or a `Span` that encompases a range of text. +type public TextLocation = + | Span of TextPoint * TextPoint + | Point of TextPoint + | Missing + + /// Get the start of the text location. This returns a cursor that lies just + /// before any text represented by this locaiton. + member x.Start = + match x with + | Span (s, _) -> s + | Point p -> p + | Missing -> TextPoint.FromParts("missing", 0, 0) + + /// Get the end of the text location. This returns a cursot that lies just + /// after any text represented by this location. + member x.End = + match x with + | Span (_, e) -> e + | Point p -> p + | Missing -> TextPoint.FromParts("missing", 0, 0) + +/// A document +type public TextDocument = + { Path: string + LineStarts: int list } + +module public TextDocument = + + let private lineStarts body = + body + |> Seq.indexed + |> Seq.choose (fun (idx , ch) -> + if ch = '\n' then Some(idx) else None) + |> List.ofSeq + + let public fromParts path body = + { Path = path + LineStarts = lineStarts body } + + let private offsetToLineCol lines offset = + match List.tryFindIndex (fun x -> x > offset) lines with + | Some(0) -> + (1, offset) + | Some(idx) -> + (idx, offset - lines[idx - 1]) + | None -> + let lineCount = List.length lines + if lineCount = 0 then + (1, offset) + else + (lineCount, offset - (List.last lines)) + + let public offsetToPoint document offset = + let (line, col) = offsetToLineCol document.LineStarts offset + TextPoint.FromParts(document.Path, line, col) + + let public rangeToLocation document (range: Firethorn.TextRange) = + let s = range.Start + let e = range.End + Span(s |> offsetToPoint document, e |> offsetToPoint document) diff --git a/test/Feersum.Tests/DiagnosticsTests.fs b/test/Feersum.Tests/DiagnosticsTests.fs index 4144388..198234f 100644 --- a/test/Feersum.Tests/DiagnosticsTests.fs +++ b/test/Feersum.Tests/DiagnosticsTests.fs @@ -1,6 +1,7 @@ module DiagnosticsTests open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text open Xunit let errKind = DiagnosticKind.Create Error 123 "test diagnostic" diff --git a/test/Feersum.Tests/Feersum.Tests.fsproj b/test/Feersum.Tests/Feersum.Tests.fsproj index fcf439f..83cc94e 100644 --- a/test/Feersum.Tests/Feersum.Tests.fsproj +++ b/test/Feersum.Tests/Feersum.Tests.fsproj @@ -4,6 +4,7 @@ + diff --git a/test/Feersum.Tests/LexTests.fs b/test/Feersum.Tests/LexTests.fs index e687b87..71d3e18 100644 --- a/test/Feersum.Tests/LexTests.fs +++ b/test/Feersum.Tests/LexTests.fs @@ -4,7 +4,7 @@ open Xunit open Feersum.CompilerServices.Syntax open Feersum.CompilerServices.Syntax.Lex -open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text let private p name line col = TextPoint.FromParts(name, line, col) diff --git a/test/Feersum.Tests/MacroTests.fs b/test/Feersum.Tests/MacroTests.fs index e37e752..bbc6664 100644 --- a/test/Feersum.Tests/MacroTests.fs +++ b/test/Feersum.Tests/MacroTests.fs @@ -8,7 +8,7 @@ open Feersum.CompilerServices.Binding open Feersum.CompilerServices.Binding.Macros open Feersum.CompilerServices.Syntax open Feersum.CompilerServices.Utils -open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text let private parse pattern literals = diff --git a/test/Feersum.Tests/SyntaxTestsNew.fs b/test/Feersum.Tests/SyntaxTestsNew.fs index 5a6ef22..c5c5d02 100644 --- a/test/Feersum.Tests/SyntaxTestsNew.fs +++ b/test/Feersum.Tests/SyntaxTestsNew.fs @@ -1,9 +1,12 @@ module SyntaxTestsNew open Xunit +open Firethorn.Red +open Feersum.CompilerServices.Utils open Feersum.CompilerServices.Syntax +open Feersum.CompilerServices.Text open Feersum.CompilerServices.Syntax.Tree -open Firethorn.Red +open Feersum.CompilerServices.Syntax.Parse let readSingle line = let result = Parse.readRaw Parse.ReadMode.Script "repl" line @@ -235,3 +238,23 @@ let ``multiple diagnostics on error`` () = let source = "(- 1 ยง (display \"foo\")" let result = Parse.readExpr source Assert.True(List.length result.Diagnostics > 1) + +[] +let ``syntax shim test`` () = + let body = "(+ 1 2)" + let doc = TextDocument.fromParts "a/file/path.scm" body + let tree = + readProgram doc.Path body + |> ParseResult.toResult + |> Result.map (fun x -> + x.Body + |> Seq.map (SyntaxShim.transformExpr doc) + |> Seq.exactlyOne) + |> Result.unwrap + + printfn "@%A" tree.Location + + Assert.Equal(1L, tree.Location.Start.Line) + Assert.Equal(0L, tree.Location.Start.Col) + Assert.Equal(1L, tree.Location.End.Line) + Assert.Equal(7L, tree.Location.End.Col) diff --git a/test/Feersum.Tests/SyntaxUtils.fs b/test/Feersum.Tests/SyntaxUtils.fs index 1b6f38d..4a33405 100644 --- a/test/Feersum.Tests/SyntaxUtils.fs +++ b/test/Feersum.Tests/SyntaxUtils.fs @@ -3,6 +3,7 @@ module SyntaxUtils open Feersum.CompilerServices.Syntax open Feersum.CompilerServices.Syntax.LegacyParse open Feersum.CompilerServices.Diagnostics +open Feersum.CompilerServices.Text open System.IO /// Helpers for fabricating syntax elements