Initial LegacySyntax Shim

This layer should allow switching parts of the compiler over to the new
syntax tree in a picewise manner. The idea is we can start accepting the
new tree types, and filter them through the LegacySyntax shim when the
old syntax is needed.

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
 

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
 

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
 

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

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 =

src/Feersum.CompilerServices/Feersum.CompilerServices.fsproj

@@ -11,11 +11,13 @@
     <Compile Include="Ice.fs" />
     <Compile Include="Utils.fs" />
     <Compile Include="Options.fs" />
+    <Compile Include="Text.fs" />
     <Compile Include="Diagnostics.fs" />
     <Compile Include="LegacySyntax.fs" />
     <Compile Include="Syntax/Lex.fs" />
     <Compile Include="Syntax/Tree.fs" />
     <Compile Include="Syntax/Parse.fs" />
+    <Compile Include="Syntax/SyntaxShim.fs" />
     <Compile Include="Scope.fs" />
     <Compile Include="Binding/Libraries.fs" />
     <Compile Include="Binding/Macros.fs" />

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 =

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 =

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

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 }

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 .
+
 [<AbstractClass>]
 type AstItem internal (red: NodeOrToken<SyntaxNode, SyntaxToken>) =
 
@@ -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.
+[<AutoOpen>]
+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())

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)

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"

test/Feersum.Tests/Feersum.Tests.fsproj

@@ -4,6 +4,7 @@
   </PropertyGroup>
   <ItemGroup>
     <ProjectReference Include="..\..\src\Feersum\Feersum.fsproj" />
+    <ProjectReference Include="..\..\src\Feersum.CompilerServices\Feersum.CompilerServices.fsproj" />
     <ProjectReference Include="..\..\src\Feersum.Core\Feersum.Core.scmproj" />
   </ItemGroup>
   <ItemGroup>

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)

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 =

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)
+
+[<Fact>]
+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)

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