├── .gitignore ├── .npmignore ├── .paket └── paket.bootstrapper.exe ├── .travis.yml ├── CHANGELOG.md ├── LICENSE.md ├── README.md ├── img └── logo.png ├── package.json ├── paket.dependencies ├── paket.lock ├── src ├── bindings │ ├── babel.fs │ ├── bindings.fsproj │ ├── monaco.fs │ └── virtualdom.fs ├── fableconfig.json ├── libraries │ ├── common.fs │ ├── compost.fs │ ├── general.fs │ ├── google │ │ ├── charts.fs │ │ ├── codegen.fsx │ │ ├── core.fs │ │ ├── extensions.fs │ │ └── options.fs │ ├── html.fs │ ├── interactive.fs │ ├── libraries.fsproj │ ├── series.fs │ └── tables.fs ├── thegamma-script.sln └── thegamma │ ├── App.config │ ├── analyzer │ ├── binder.fs │ ├── interpreter.fs │ └── typechecker.fs │ ├── ast │ ├── ast.fs │ ├── astops.fs │ ├── errors.fs │ └── typeops.fs │ ├── blocks.fs │ ├── codegen │ ├── codegen.fs │ └── runtime.fs │ ├── common │ ├── babel.fs │ └── locations.fs │ ├── live │ ├── live.fs │ ├── pivot.fs │ └── showable.fs │ ├── main.fs │ ├── monaco.fs │ ├── parser │ ├── parser.fs │ └── tokenizer.fs │ ├── providers │ ├── fsharp.fs │ ├── pivot.fs │ ├── providers.fs │ └── rest.fs │ ├── services.fs │ └── thegamma.fsproj ├── tests ├── fableconfig.json └── thegamma-tests │ ├── binder.fs │ ├── compost.fs │ ├── formatter.fs │ ├── fsharptypes.fs │ ├── paket.references │ ├── parser.fs │ ├── pivottypes.fs │ ├── simpletypes.fs │ ├── thegamma-tests.fsproj │ └── tokenizer.fs └── tools └── fsprovider.fsx /.gitignore: -------------------------------------------------------------------------------- 1 | npm-debug.log 2 | .ionide.debug 3 | .paket/paket.exe 4 | node_modules/ 5 | paket-files/ 6 | packages/ 7 | .fake/ 8 | dist/ 9 | 10 | obj 11 | bin 12 | .vs 13 | *.suo 14 | *.bak 15 | debug.log 16 | *.VC.opendb 17 | *.VC.db -------------------------------------------------------------------------------- /.npmignore: -------------------------------------------------------------------------------- 1 | .paket/ 2 | node_modules/ 3 | paket-files/ 4 | packages/ 5 | src/ 6 | tests/ 7 | tools/ 8 | 9 | .travis.yml 10 | paket.* 11 | debug.log 12 | npm-debug.log 13 | .ionide.debug 14 | -------------------------------------------------------------------------------- /.paket/paket.bootstrapper.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/the-gamma/thegamma-script/af3db87797051e8e40a0f8e70109ffdcc60a1faf/.paket/paket.bootstrapper.exe -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: csharp 2 | 3 | sudo: false 4 | 5 | before_script: 6 | - nvm install 4.4 7 | - nvm use 4.4 8 | - mono .paket/paket.bootstrapper.exe 9 | - mono .paket/paket.exe restore 10 | - npm install 11 | 12 | script: 13 | - npm test 14 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | * 0.1.26 - Support absolute links in REST provider nested types 2 | * 0.1.22 - Fix Firefox bug in interactive charts 3 | * 0.1.21 - Include libraries.json in the release 4 | * 0.1.20 - Fix failed release 5 | * 0.1.19 - Log offset in YouGuess offset chart 6 | * 0.1.18 - Dates, joins, line offset colors, lists, encode cookies in REST provider 7 | * 0.1.15 - Interactive (solved comments, better line), + on strings, filter by dates in pivot 8 | * 0.1.14 - Fix parsing of chains with calls 9 | * 0.1.13 - Compatibility fix for schema in REST provider 10 | * 0.1.12 - Support inline numbers, add labels to bubbles 11 | * 0.1.11 - Placeholder for empty charts, auto-trigger completion, Safari and IE fixes 12 | * 0.1.10 - Support preview via preview member, hide hidden members 13 | * 0.1.9 - Type-level arguments on methods; nicer table formatting 14 | * 0.1.8 - Pivot - add like operator and allow windowing on numbers 15 | * 0.1.7 - Mobile friendlier charts, replace bar, column and area with shape 16 | * 0.1.6 - ExpandBy in pivot, area charts, event logging, evaluate returns results, enablePreview 17 | * 0.1.5 - Improve compost axes, labels, legends and clipping; support Safari 18 | * 0.1.4 - Clip body of chart, minimal legends & titles, fixes in axis labels 19 | * 0.1.3 - Labels for youdraw.line, fix labels for ordinary line charts 20 | * 0.1.2 - Compost bars, columns, lines and labels 21 | * 0.1.1 - Fix export of chart types 22 | * 0.1.0 - Bubble charts, windowing, date formatting, remove geo, modulo, F# properties 23 | * 0.0.21 - Add support for markers in youguess line 24 | * 0.0.20 - Refactoring members, placeholders, youguess sort bars, rework axes 25 | * 0.0.19 - Nesting of providers, yougess bars, compost tweaks 26 | * 0.0.18 - Return child entities on demand 27 | * 0.0.17 - Expose generics for generic types 28 | * 0.0.16 - Expose experimental API for type-checking and reading entities 29 | * 0.0.15 - Replace generics with provider methods, expose Monaco editor 30 | * 0.0.14 - Add You Guess for column charts, tweaking visualization 31 | * 0.0.13 - Make You Draw It more mobile friendly 32 | * 0.0.12 - SVG based interactive animations (replace You Draw It) 33 | * 0.0.11 - Add experimental You Draw It visualization 34 | * 0.0.10 - Fix callback for Google Charts loading (IE) 35 | * 0.0.9 - Remove Bootstrap table dependency 36 | * 0.0.8 - Update Fable, remove FontAwesome dependency from pivot 37 | * 0.0.7 - Add empty placeholder visualization 38 | * 0.0.6 - Update README 39 | * 0.0.5 - Fix monaco language registration 40 | * 0.0.4 - Update pdata protocol to match thegamma.net docs 41 | * 0.0.3 - Report errors, inline chart handling 42 | * 0.0.2 - Improvements in the public API 43 | * 0.0.1 - Experimental package release -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016, Tomas Petricek and contributors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The Gamma: Tools for open data-driven storytelling 2 | 3 | [![Build status](https://api.travis-ci.org/the-gamma/thegamma-script.svg)](https://travis-ci.org/the-gamma/thegamma-script) 4 | 5 | The Gamma logo 6 | 7 | The Gamma is a simple JavaScript library that lets anyone create transparent and open data 8 | visualizations that are linked to the original data source and encourage the reader to 9 | further explore data and find interesting facts on their own. 10 | 11 | The Gamma implements a scripting language with spreadsheet-inspired tooling 12 | that runs in the browser and lets users perform simple data aggregation and exploration. 13 | The package lets you run The Gamma scripts and provides a rich web-based editor that 14 | you can embed on your site. 15 | 16 | ## The Gamma in action 17 | 18 | - [Project homepage](http://thegamma.net/) contains all you need to get started 19 | - [The Gamma sample web](http://thegamma-sample-web.azurewebsites.net/) shows a minimal demo ([source](https://github.com/the-gamma/thegamma-sample-web)) 20 | - [Visualization of Olympic medals](http://rio2016.thegamma.net/) is bigger sample project ([source](https://github.com/the-gamma/thegamma-olympics-web)) 21 | 22 | ## The Gamma script 23 | 24 | The core of The Gamma project is a simple scripting langauge that makes it easy to write 25 | code to perform data aggregation and data exploration. For example, if you want to find the 26 | top 8 athletes by the number of gold medals from Rio 2016, you can write: 27 | 28 | ``` 29 | olympics 30 | .'filter data'.'Games is'.'Rio (2016)'.then 31 | .'group data'.'by Athlete'.'sum Gold'.then 32 | .'sort data'.'by Gold descending'.then 33 | .'paging'.take(8) 34 | .'get the data' 35 | ``` 36 | 37 | Rich tooling is available when writing code using The Gamma web-based editor and so you get 38 | auto-completion for available operations when typing `.`, you can see a live preview of 39 | the transformed data and you can even modify the code using a simple user interface. 40 | 41 | ## Documentation 42 | 43 | The full project documentation is available on [thegamma.net](http://thegamma.net) web site: 44 | 45 | - [Contributing: Building from the source code](http://thegamma.net/contributing/) - 46 | explains how to build everything locally for those who want to contribute! 47 | The Gamma is mostly written in [F#](http://fsharp.org) and compiled to JavaScript using 48 | [Fable](http://fable.io/). 49 | - [Developers: Using The Gamma JavaScript library](http://thegamma.net/developers/) 50 | discusses how to embed visualizations using The Gamma JavaScript library and how 51 | to create and interact with the built-in editor. 52 | - [Data: Providing data as a REST services](http://thegamma.net/publishing/) 53 | discusses how to provide data for the visualization. This is just a matter of 54 | writing a simple service that evaluates queries. 55 | - [Exploring: Aggregating and visualizing data](http://thegamma.net/exploring/) 56 | covers The Gamma scripting language and the tools that you and your readers can 57 | use to explore and visualize data. 58 | 59 | ## Credits and license 60 | The Gamma is built at [The Alan Turing Institute](https://www.turing.ac.uk/) and has been 61 | supported through the [Google Digitial News Initiative](https://www.digitalnewsinitiative.com/). 62 | It is available as open-source using the permissive MIT license. This means that you are welcome 63 | to contribute, modify the project as you wish and use it commercially without restrictions. 64 | -------------------------------------------------------------------------------- /img/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/the-gamma/thegamma-script/af3db87797051e8e40a0f8e70109ffdcc60a1faf/img/logo.png -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "thegamma-script", 3 | "version": "0.1.26", 4 | "description": "The Gamma project", 5 | "scripts": { 6 | "pretest": "fable tests", 7 | "test": "mocha dist/tests/thegamma-tests", 8 | "justtest": "mocha dist/tests/thegamma-tests", 9 | "prepublish": "npm run build", 10 | "build": "fable --target es2015 src && fable --target commonjs src && fable --target min src && fable --target dev src", 11 | "watch": "fable -w --target dev src" 12 | }, 13 | "author": "Tomas Petricek", 14 | "license": "MIT", 15 | "dependencies": { 16 | "babel-standalone": "^6.18.1", 17 | "fable-core": "^0.7.26", 18 | "monaco-editor": "^0.7.0", 19 | "virtual-dom": "^2.1.1" 20 | }, 21 | "devDependencies": { 22 | "babel-plugin-transform-runtime": "^6.15.0", 23 | "babel-runtime": "^6.18.0", 24 | "fable-compiler": "^0.7.42", 25 | "fable-plugins-nunit": "^0.7.3", 26 | "mocha": "^3.1.2", 27 | "pmm": "^1.3.1", 28 | "rollup-plugin-commonjs": "^5.0.5", 29 | "rollup-plugin-uglify": "^1.0.1" 30 | }, 31 | "repository": { 32 | "type": "git", 33 | "url": "git+https://github.com/the-gamma/thegamma-script.git" 34 | }, 35 | "keywords": [ 36 | "data", 37 | "visualization", 38 | "storytelling" 39 | ], 40 | "bugs": { 41 | "url": "https://github.com/the-gamma/thegamma-script/issues" 42 | }, 43 | "homepage": "http://thegamma.net", 44 | "main": "./dist/commonjs/main.js", 45 | "module": "./dist/es2015/main/main.js", 46 | "jsnext:main": "./dist/es2015/main/main.js" 47 | } 48 | -------------------------------------------------------------------------------- /paket.dependencies: -------------------------------------------------------------------------------- 1 | framework: >= net40 2 | source https://www.nuget.org/api/v2 3 | 4 | nuget Newtonsoft.Json 5 | nuget NUnit 6 | -------------------------------------------------------------------------------- /paket.lock: -------------------------------------------------------------------------------- 1 | FRAMEWORK: >= NET40 2 | NUGET 3 | remote: https://www.nuget.org/api/v2 4 | Newtonsoft.Json (9.0.1) 5 | NUnit (3.4.1) 6 | -------------------------------------------------------------------------------- /src/bindings/babel.fs: -------------------------------------------------------------------------------- 1 | module Fable.Helpers.Babel 2 | 3 | open Fable.Core 4 | 5 | [] 6 | let eval (s:string) : 'T = failwith "JS only" 7 | 8 | type BabelOptions = 9 | { presets : string[] } 10 | 11 | type BabelResult = 12 | { code : string } 13 | 14 | type Babel = 15 | abstract transformFromAst : obj * string * BabelOptions -> BabelResult 16 | 17 | [] 18 | let babel : Babel = Unchecked.defaultof<_> 19 | -------------------------------------------------------------------------------- /src/bindings/bindings.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | 278a68fc-0256-417c-af13-9a4af7381ccf 9 | Library 10 | bindings 11 | bindings 12 | v4.5 13 | 4.4.0.0 14 | true 15 | bindings 16 | 17 | 18 | 19 | true 20 | full 21 | false 22 | false 23 | bin\Debug\ 24 | DEBUG;TRACE 25 | 3 26 | bin\Debug\bindings.XML 27 | 28 | 29 | pdbonly 30 | true 31 | true 32 | bin\Release\ 33 | TRACE 34 | 3 35 | bin\Release\bindings.XML 36 | 37 | 38 | 39 | ../../node_modules/fable-core/Fable.Core.dll 40 | 41 | 42 | 43 | True 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 11 56 | 57 | 58 | 59 | 60 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 61 | 62 | 63 | 64 | 65 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 66 | 67 | 68 | 69 | 70 | 77 | -------------------------------------------------------------------------------- /src/bindings/virtualdom.fs: -------------------------------------------------------------------------------- 1 | module Fable.Helpers.Virtualdom 2 | 3 | open Fable.Core 4 | open Fable.Core.JsInterop 5 | open System.Diagnostics 6 | 7 | [] 8 | let h(arg1: string, arg2: obj, arg3: obj[]): obj = failwith "JS only" 9 | 10 | [] 11 | let diff (tree1:obj) (tree2:obj): obj = failwith "JS only" 12 | 13 | [] 14 | let patch (node:obj) (patches:obj): Fable.Import.Browser.Node = failwith "JS only" 15 | 16 | [] 17 | let createElement (e:obj): Fable.Import.Browser.Node = failwith "JS only" 18 | -------------------------------------------------------------------------------- /src/fableconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "sourceMaps": true, 3 | "babelPlugins": [ 4 | "transform-runtime" 5 | ], 6 | "projFile": [ 7 | "bindings/bindings.fsproj", 8 | "libraries/libraries.fsproj", 9 | "thegamma/thegamma.fsproj" 10 | ], 11 | "targets": { 12 | "es2015": { 13 | "outDir": "../dist/es2015", 14 | "module": "es2015" 15 | }, 16 | "commonjs": { 17 | "outDir": "../dist/commonjs", 18 | "module": "commonjs", 19 | "coreLib": "fable-core/umd" 20 | }, 21 | "min": { 22 | "outDir": "../dist", 23 | "rollup": { 24 | "dest": "../dist/thegamma.min.js", 25 | "format": "umd", 26 | "external": ["monaco"], 27 | "globals": {"monaco":"na"}, 28 | "plugins": [ 29 | [ "uglify" ], 30 | ["commonjs", { 31 | "namedExports": { 32 | "virtual-dom": [ "h", "create", "diff", "patch" ] 33 | } 34 | }] 35 | ] 36 | } 37 | }, 38 | "dev": { 39 | "outDir": "../dist", 40 | "rollup": { 41 | "dest": "../dist/thegamma.js", 42 | "format": "umd", 43 | "external": ["monaco"], 44 | "globals": {"monaco":"na"}, 45 | "plugins": [ 46 | ["commonjs", { 47 | "namedExports": { 48 | "virtual-dom": [ "h", "create", "diff", "patch" ] 49 | } 50 | }] 51 | ] 52 | } 53 | } 54 | } 55 | } 56 | -------------------------------------------------------------------------------- /src/libraries/common.fs: -------------------------------------------------------------------------------- 1 | module TheGamma.Common 2 | 3 | open Fable.Core 4 | open Fable.Import.JS 5 | open Fable.Import.Browser 6 | open System.Collections.Generic 7 | module FsOption = Microsoft.FSharp.Core.Option 8 | 9 | [] 10 | let getProperty<'T> (obj:obj) (name:string) : 'T = failwith "never" 11 | 12 | [] 13 | let parseInt (s:string) (b:int) : int = failwith "JS" 14 | 15 | [] 16 | let formatInt (i:int) (b:int) : string = failwith "JS" 17 | 18 | [] 19 | let isNumber(n:obj) : bool = failwith "!" 20 | 21 | [] 22 | let isDate(n:obj) : bool = failwith "!" 23 | 24 | [] 25 | let toISOString(o:obj) : string = failwith "!" 26 | 27 | [] 28 | let asDate(n:float) : System.DateTime = failwith "!" 29 | 30 | [] 31 | let dateOrNumberAsNumber(n:obj) : float = failwith "!" 32 | 33 | [] 34 | let formatDate(d:obj) : string = failwith "!" 35 | 36 | [] 37 | let formatLongDate(d:obj) : string = failwith "!" 38 | 39 | [] 40 | let formatTime(d:obj) : string = failwith "!" 41 | 42 | [] 44 | let formatDateTime(d:obj) : string = failwith "!" 45 | 46 | [] 47 | let isObject(n:obj) : bool = failwith "!" 48 | 49 | [] 50 | let isArray(n:obj) : bool = failwith "!" 51 | 52 | [] 53 | let isNaN(n:float) : bool = failwith "!" 54 | 55 | let niceNumber num decs = 56 | let str = string num 57 | let dot = str.IndexOf('.') 58 | let before, after = 59 | if dot = -1 then str, "" 60 | else str.Substring(0, dot), str.Substring(dot + 1, min decs (str.Length - dot - 1)) 61 | let after = 62 | if after.Length < decs then after + System.String [| for i in 1 .. (decs - after.Length) -> '0' |] 63 | else after 64 | let mutable res = before 65 | if before.Length > 5 then 66 | for i in before.Length-1 .. -1 .. 0 do 67 | let j = before.Length - i 68 | if i <> 0 && j % 3 = 0 then res <- res.Insert(i, ",") 69 | if Seq.forall ((=) '0') after then res 70 | else res + "." + after 71 | 72 | [] 73 | let jsonStringify json : string = failwith "JS Only" 74 | 75 | [] 76 | let jsonParse<'R> (str:string) : 'R = failwith "JS Only" 77 | 78 | [] 79 | let consoleLog (args:obj[]) : unit = 80 | let format = args.[0] :?> string 81 | let mutable argIndex = 1 82 | let mutable charIndex = 0 83 | let mutable res = "" 84 | while charIndex < format.Length do 85 | if format.[charIndex] = '%' then 86 | res <- res + 87 | match format.[charIndex+1] with 88 | | 'c' -> "" 89 | | 's' -> args.[argIndex].ToString() 90 | | 'O' -> sprintf "%A" (args.[argIndex]) 91 | | _ -> failwith "consoleLog: Unsupported formatter" 92 | argIndex <- argIndex + 1 93 | charIndex <- charIndex + 2 94 | else 95 | res <- res + format.[charIndex].ToString() 96 | charIndex <- charIndex + 1 97 | printfn "%s" res 98 | 99 | [] 100 | let logEvent (category:string) (evt:string) (article:string) (data:obj) : unit = failwith "JS only" 101 | 102 | [] 103 | let windowUndefined () : bool = true 104 | 105 | let isLocalHost() = 106 | windowUndefined () || 107 | window.location.hostname = "localhost" || 108 | window.location.hostname = "127.0.0.1" 109 | 110 | let mutable enabledCategories = 111 | if not (isLocalHost ()) then set [] 112 | //else set ["TYPECHECKER"; "PROVIDERS"] 113 | else set ["*"] 114 | type Log = 115 | static member setEnabled(cats) = enabledCategories <- cats 116 | 117 | static member event(category:string, evt:string, article:string, data:obj) = 118 | logEvent category evt article data 119 | 120 | static member message(level:string, category:string, msg:string, [] args) = 121 | let args = if args = null then [| |] else args 122 | let category = category.ToUpper() 123 | if not (isLocalHost ()) && level = "EXCEPTION" then 124 | logEvent "system" "exception" "" (JsInterop.createObj ["category", box category; "msg", box msg; "args", box args ]) 125 | 126 | if level = "EXCEPTION" || level = "ERROR" || enabledCategories.Contains "*" || enabledCategories.Contains category then 127 | let dt = System.DateTime.Now 128 | let p2 (s:int) = (string s).PadLeft(2, '0') 129 | let p4 (s:int) = (string s).PadLeft(4, '0') 130 | let prefix = sprintf "[%s:%s:%s:%s] %s: " (p2 dt.Hour) (p2 dt.Minute) (p2 dt.Second) (p4 dt.Millisecond) category 131 | let color = 132 | match level with 133 | | "TRACE" -> "color:#808080" 134 | | "EXCEPTION" -> "color:#c00000" 135 | | "ERROR" -> "color:#900000" 136 | | _ -> "" 137 | consoleLog(FSharp.Collections.Array.append [|box ("%c" + prefix + msg); box color|] args) 138 | 139 | static member trace(category:string, msg:string, [] args) = 140 | Log.message("TRACE", category, msg, args) 141 | 142 | static member exn(category:string, msg:string, [] args) = 143 | Log.message("EXCEPTION", category, msg, args) 144 | 145 | static member error(category:string, msg:string, [] args) = 146 | Log.message("ERROR", category, msg, args) 147 | 148 | type Http = 149 | /// Send HTTP request asynchronously 150 | static member Request(meth, url, ?data, ?cookies) = 151 | Async.FromContinuations(fun (cont, econt, _) -> 152 | let xhr = XMLHttpRequest.Create() 153 | xhr.``open``(meth, url, true) 154 | match cookies with 155 | | Some cookies when cookies <> "" -> xhr.setRequestHeader("X-Cookie", cookies) 156 | | _ -> () 157 | xhr.onreadystatechange <- fun _ -> 158 | if xhr.readyState > 3. && xhr.status = 200. then 159 | cont(xhr.responseText) 160 | if xhr.readyState > 3. && xhr.status = 0. then 161 | econt(System.Exception(meth + " " + url + " failed: " + xhr.statusText)) 162 | obj() 163 | xhr.send(defaultArg data "") ) 164 | 165 | type Future<'T> = 166 | abstract Then : ('T -> unit) -> unit 167 | 168 | type Microsoft.FSharp.Control.Async with 169 | static member AwaitFuture (f:Future<'T>) = Async.FromContinuations(fun (cont, _, _) -> 170 | f.Then(cont)) 171 | 172 | static member Future (n:string option) op start = 173 | let mutable res = Choice1Of3() 174 | let mutable handlers = [] 175 | let mutable running = false 176 | 177 | let trigger h = 178 | match res with 179 | | Choice1Of3 () -> handlers <- h::handlers 180 | | Choice2Of3 v -> h v 181 | | Choice3Of3 e -> raise e 182 | 183 | let ensureStarted() = 184 | if not running then 185 | n |> FsOption.iter (fun n -> Log.trace("system", "Starting future '%s'....", n)) 186 | running <- true 187 | async { try 188 | let! r = op 189 | n |> FsOption.iter (fun n -> Log.trace("system", "Future '%s' evaluated to: %O", n, r)) 190 | res <- Choice2Of3 r 191 | with e -> 192 | Log.exn("system", "Evaluating future failed: %O", e) 193 | res <- Choice3Of3 e 194 | for h in handlers do trigger h } |> Async.StartImmediate 195 | if start = true then ensureStarted() 196 | 197 | { new Future<_> with 198 | member x.Then(f) = 199 | ensureStarted() 200 | trigger f } 201 | 202 | static member CreateFuture(op) = Async.Future None op false 203 | static member StartAsFuture(op) = Async.Future None op true 204 | static member CreateNamedFuture name op = Async.Future (Some name) op false 205 | static member StartAsNamedFuture name op = Async.Future (Some name) op true 206 | 207 | module Async = 208 | module Array = 209 | module Parallel = 210 | let rec map f (ar:_[]) = async { 211 | let res = FSharp.Collections.Array.zeroCreate ar.Length 212 | let work = 213 | [ for i in 0 .. ar.Length-1 -> async { 214 | let! v = f ar.[i] 215 | res.[i] <- v } ] |> Async.Parallel 216 | let! _ = work 217 | return res } 218 | 219 | let rec map f (ar:_[]) = async { 220 | let res = FSharp.Collections.Array.zeroCreate ar.Length 221 | for i in 0 .. ar.Length-1 do 222 | let! v = f ar.[i] 223 | res.[i] <- v 224 | return res } 225 | 226 | let rec collect f l = async { 227 | match l with 228 | | x::xs -> 229 | let! y = f x 230 | let! ys = collect f xs 231 | return List.append y ys 232 | | [] -> return [] } 233 | 234 | let rec choose f l = async { 235 | match l with 236 | | x::xs -> 237 | let! y = f x 238 | let! ys = choose f xs 239 | return match y with None -> ys | Some y -> y::ys 240 | | [] -> return [] } 241 | 242 | let rec map f l = async { 243 | match l with 244 | | x::xs -> 245 | let! y = f x 246 | let! ys = map f xs 247 | return y::ys 248 | | [] -> return [] } 249 | 250 | let rec foldMap f st l = async { 251 | match l with 252 | | x::xs -> 253 | let! y, st = f st x 254 | let! st, ys = foldMap f st xs 255 | return st, y::ys 256 | | [] -> return st, [] } 257 | 258 | let rec fold f st l = async { 259 | match l with 260 | | x::xs -> 261 | let! st = f st x 262 | return! fold f st xs 263 | | [] -> return st } 264 | 265 | /// Symbol is a unique immutable identiifer (we use JavaScript symbols) 266 | type Symbol = interface end 267 | 268 | [] 269 | let createSymbol () = { new Symbol } 270 | 271 | type ListDictionaryNode<'K, 'T> = 272 | { mutable Result : 'T option 273 | Nested : Dictionary<'K, ListDictionaryNode<'K, 'T>> } 274 | 275 | type ListDictionary<'K, 'V> = Dictionary<'K, ListDictionaryNode<'K, 'V>> 276 | 277 | module JsHelpers = 278 | type KeyValue = 279 | abstract key : string 280 | abstract value : obj 281 | 282 | [] 283 | let properties(o:obj) : KeyValue[] = failwith "!" 284 | 285 | [] 286 | module ListDictionary = 287 | let tryFind ks dict = 288 | let rec loop ks node = 289 | match ks, node with 290 | | [], { Result = Some r } -> Some r 291 | | k::ks, { Nested = d } when d.ContainsKey k -> loop ks (d.[k]) 292 | | _ -> None 293 | loop ks { Nested = dict; Result = None } 294 | 295 | let set ks v dict = 296 | let rec loop ks (dict:ListDictionary<_, _>) = 297 | match ks with 298 | | [] -> failwith "Empty key not supported" 299 | | k::ks -> 300 | if not (dict.ContainsKey k) then dict.[k] <- { Nested = Dictionary<_, _>(); Result = None } 301 | if List.isEmpty ks then dict.[k].Result <- Some v 302 | else loop ks (dict.[k].Nested) 303 | loop ks dict 304 | 305 | let count (dict:ListDictionary<_, _>) = 306 | let rec loop node = 307 | let nest = node.Nested |> Seq.sumBy (fun kv -> loop kv.Value) 308 | if node.Result.IsSome then 1 + nest else nest 309 | dict |> Seq.sumBy (fun kv -> loop kv.Value) 310 | 311 | module List = 312 | let groupWith f list = 313 | let groups = ResizeArray<_ * ResizeArray<_>>() 314 | for e in list do 315 | let mutable added = false 316 | let mutable i = 0 317 | while not added && i < groups.Count do 318 | if f e (fst groups.[i]) then 319 | (snd groups.[i]).Add(e) 320 | added <- true 321 | i <- i + 1 322 | if not added then 323 | groups.Add(e, ResizeArray<_>([e])) 324 | groups |> Seq.map (snd >> List.ofSeq) |> List.ofSeq 325 | 326 | let unreduce f s = s |> Seq.unfold (fun s -> 327 | f s |> Microsoft.FSharp.Core.Option.map (fun v -> v, v)) |> List.ofSeq 328 | -------------------------------------------------------------------------------- /src/libraries/general.fs: -------------------------------------------------------------------------------- 1 | namespace TheGamma.General 2 | 3 | open System 4 | open TheGamma 5 | open TheGamma.Html 6 | open TheGamma.Common 7 | open Fable.Import.Browser 8 | open Fable.Core 9 | 10 | type math = 11 | static member sqrt(f:float) = sqrt f 12 | static member pow(f:float, k) = Math.Pow(f, k) 13 | static member log(f:float, ?b) = match b with Some b -> Math.Log(f, b) | _ -> log f 14 | static member min(f1:float, f2:float) = min f1 f2 15 | static member max(f1:float, f2:float) = max f1 f2 16 | static member round(n:float, decimals:int) = Math.Round(n, decimals) 17 | static member ceil(n:float) = Math.Ceiling(n) 18 | static member floor(n:float) = Math.Floor(n) 19 | 20 | type date = 21 | static member now() = DateTime.Now 22 | static member date(year,month,day) = DateTime(year,month,day) 23 | static member time(year,month,day,hour,minute,second) = DateTime(year,month,day,hour,minute,second) 24 | 25 | type dateformat = 26 | static member longDate(dt:obj) : string = formatLongDate (unbox dt) 27 | 28 | type number = 29 | static member format(n:float, ?decimals) = niceNumber n (defaultArg decimals 999) 30 | 31 | type pair<'t1, 't2> internal (v1:'t1, v2:'t2) = 32 | member x.first = v1 33 | member x.second = v2 -------------------------------------------------------------------------------- /src/libraries/google/charts.fs: -------------------------------------------------------------------------------- 1 | namespace TheGamma.GoogleCharts 2 | 3 | open System 4 | open TheGamma 5 | open TheGamma.Series 6 | open TheGamma.GoogleCharts 7 | 8 | type chart = 9 | static member scatter(xval:series<_, _>, yval:series<_, _>) = 10 | { Scatter.data = ChartDataOperations.twoValues xval yval; 11 | typeName = "ScatterChart"; options = ScatterChartOptions.empty } 12 | 13 | static member geo(data:series) = 14 | { Geo.data = ChartDataOperations.oneKeyValue "string" data; 15 | typeName = "GeoChart"; options = GeoChartOptions.empty } 16 | (* 17 | static member geo(data:series) = 18 | { Geo.data = ChartDataOperations.oneKeyTwoValues "string" data; 19 | typeName = "GeoChart"; options = GeoChartOptions.empty } 20 | *) 21 | static member pie(data:series) = 22 | { Pie.data = ChartDataOperations.oneKeyValue "string" data; 23 | typeName = "PieChart"; options = PieChartOptions.empty } 24 | 25 | static member bar(data:series) = 26 | { Bar.data = ChartDataOperations.oneKeyValue "string" data; 27 | typeName = "BarChart"; options = BarChartOptions.empty } 28 | (* 29 | static member bar(data:seq>) = 30 | { Bar.data = ChartDataOperations.oneKeyNValues "string" data; 31 | typeName = "BarChart"; options = BarChartOptions.empty } 32 | static member column(data:seq>) = 33 | { Column.data = ChartDataOperations.oneKeyNValues "string" data; 34 | typeName = "ColumnChart"; options = ColumnChartOptions.empty } 35 | *) 36 | static member column(data:series) = 37 | { Column.data = ChartDataOperations.oneKeyValue "string" data; 38 | typeName = "ColumnChart"; options = ColumnChartOptions.empty } 39 | 40 | static member columns(data:series[], colors:string[]) = 41 | { Line.data = ChartDataOperations.oneKeyAppendValues "string" data colors; 42 | typeName = "ColumnChart"; options = LineChartOptions.empty } 43 | 44 | static member line(data:series) = 45 | { Line.data = ChartDataOperations.oneKeyValue "number" data; 46 | typeName = "LineChart"; options = LineChartOptions.empty } 47 | 48 | static member lines(data:series<'a, series<'b, float>>) = 49 | { Line.data = ChartDataOperations.oneKeyNValues "number" data; 50 | typeName = "LineChart"; options = LineChartOptions.empty } 51 | (* 52 | static member line(data:series) = 53 | { Line.data = ChartDataOperations.oneKeyValue "string" data; 54 | typeName = "LineChart"; options = LineChartOptions.empty } 55 | static member line(data:seq>) = 56 | { Line.data = ChartDataOperations.oneKeyNValues "string" data; 57 | typeName = "LineChart"; options = LineChartOptions.empty } 58 | static member line(data:seq>) = 59 | { Line.data = ChartDataOperations.oneKeyNValues "number" data; 60 | typeName = "LineChart"; options = LineChartOptions.empty } 61 | *) 62 | (* 63 | static member histogram(data) = 64 | { Histogram.data = data; options = HistogramOptions.empty } 65 | *) 66 | static member area(data:series) = 67 | { Area.data = ChartDataOperations.oneKeyValue "number" data; 68 | typeName = "AreaChart"; options = AreaChartOptions.empty } 69 | 70 | static member areas(data:series<'a, series>, ?names:string[]) = 71 | let i = ref 0; 72 | let data = 73 | match names with 74 | | Some names -> data.map(fun s -> incr i; s.setProperties(seriesName=names.[i.Value-1])) 75 | | None -> data 76 | { Area.data = ChartDataOperations.oneKeyNValues "number" data; 77 | typeName = "AreaChart"; options = AreaChartOptions.empty } 78 | (* 79 | static member annotation(data) = 80 | { Annotation.data = data; options = AnnotationChartOptions.empty } 81 | static member steppedArea(data) = 82 | { SteppedArea.data = data; options = SteppedAreaChartOptions.empty } 83 | static member bubble(data) = 84 | { Bubble.data = data; options = BubbleChartOptions.empty } 85 | static member treeMap(data) = 86 | { TreeMap.data = data; options = TreeMapOptions.empty } 87 | static member table(data) = 88 | { Table.data = data; options = TableOptions.empty } 89 | static member timeline(data) = 90 | { Timeline.data = data; options = TimelineOptions.empty } 91 | static member candlestick(data) = 92 | { Candlestick.data = data; options = CandlestickChartOptions.empty } 93 | *) 94 | 95 | static member show(chart:#Chart) = 96 | Helpers.showChart(chart) -------------------------------------------------------------------------------- /src/libraries/google/codegen.fsx: -------------------------------------------------------------------------------- 1 | // -------------------------------------------------------------------------------------------------------------------- 2 | // 3 | // -------------------------------------------------------------------------------------------------------------------- 4 | 5 | #load "options.fs" 6 | open System 7 | open System.Reflection 8 | open Microsoft.FSharp.Reflection 9 | 10 | let gc = Assembly.GetExecutingAssembly().GetTypes() |> Seq.find (fun t -> t.Name = "Options") 11 | let types = gc.GetNestedTypes() 12 | 13 | let optionsTypes = types |> Seq.filter (fun t -> t.Name.EndsWith("Options")) 14 | let otherTypes = types |> Seq.filter (fun t -> not (t.Name.EndsWith("Options"))) 15 | 16 | let camelCase (name:string) = 17 | name.[0].ToString().ToLower() + name.Substring(1) 18 | let dropSuffixes (name:string) = 19 | name.Replace("ChartOptions", "").Replace("Options", "") 20 | 21 | let primitiveTypeNames = 22 | dict [ typeof, "float"; typeof, "bool"; typeof, "obj"; typeof, "DateTime" 23 | typeof, "string"; typeof, "string[]"; typeof, "float[]"; typeof, "obj[]" ] 24 | 25 | let primitiveTypes = 26 | set [ for t in primitiveTypeNames.Keys -> t.FullName ] 27 | 28 | let getOptions t = 29 | [ for f in FSharpType.GetRecordFields(t) do 30 | let typ = f.PropertyType 31 | let isPrimitive = primitiveTypes.Contains(typ.FullName) 32 | let isNested = FSharpType.IsRecord(typ) 33 | if isPrimitive then yield Choice1Of3(f.Name, typ) 34 | elif isNested then yield Choice2Of3(f.Name, typ) 35 | else yield Choice3Of3(f.Name, typ) ] 36 | 37 | let getAllOptions t = 38 | getOptions t |> List.map (function Choice1Of3 v | Choice2Of3 v | Choice3Of3 v -> v) 39 | 40 | let getPrimitivieNestedOtherOptions t = 41 | let options = getOptions t 42 | options |> List.choose (function Choice1Of3 v -> Some v | _ -> None), 43 | options |> List.choose (function Choice2Of3 v -> Some v | _ -> None), 44 | options |> List.choose (function Choice3Of3 v -> Some v | _ -> None) 45 | 46 | let rec formatInputType (t:System.Type) = 47 | if t.IsArray then "seq<" + (formatInputType (t.GetElementType())) + ">" 48 | elif primitiveTypeNames.ContainsKey(t) then primitiveTypeNames.[t] 49 | else t.Name 50 | 51 | let safeName s = if s = "type" then "``type``" else s 52 | 53 | let formatParameters primitive = 54 | [ for n, t in primitive -> 55 | sprintf "?%s:%s" (safeName n) (formatInputType t) ] 56 | |> String.concat "," 57 | 58 | let getConversion (t:System.Type) = 59 | if t.IsArray then Some("Array.ofSeq") 60 | else None 61 | 62 | let formatSetters primitive = 63 | [ for n, t in primitive -> 64 | let converted = 65 | match getConversion t with 66 | | Some f -> sprintf "(Option.map %s %s)" f (safeName n) 67 | | _ -> n 68 | sprintf "%s = right o \"%s\" %s" (safeName n) n converted ] 69 | |> String.concat "; " 70 | 71 | let formatCopies nested = 72 | [ for n, t in nested -> 73 | sprintf "%s = copy o \"%s\"" n n ] 74 | |> String.concat "; " 75 | 76 | let writeSetters (wr:IO.TextWriter) = 77 | for t in optionsTypes do 78 | let primitive, nested, other = getPrimitivieNestedOtherOptions t 79 | let pars = formatParameters primitive 80 | let sets = formatSetters primitive 81 | fprintfn wr "type %s = " (dropSuffixes t.Name) 82 | fprintfn wr " { data : ChartData; typeName : string; " 83 | fprintfn wr " options : %s }" t.Name 84 | fprintfn wr " interface Chart" 85 | fprintfn wr " member x.show(outputId) = Helpers.showChart x outputId" 86 | fprintfn wr " member x.set(%s) = " pars 87 | fprintfn wr " let o = x.options" 88 | fprintfn wr " let newOptions = { x.options with %s }" sets 89 | fprintfn wr " { x with options = newOptions }" 90 | 91 | for name, otyp in other do 92 | let pars = formatParameters [name, otyp] 93 | let sets = formatSetters [name, otyp] 94 | fprintfn wr " member x.%s(%s) =" name pars 95 | fprintfn wr " let o = x.options" 96 | fprintfn wr " { x with options = { x.options with %s } }" sets 97 | 98 | for name, ntyp in nested do 99 | let primitive, nested, other = getPrimitivieNestedOtherOptions ntyp 100 | if other <> [] then failwith "!" 101 | let pars = formatParameters primitive 102 | let sets = formatSetters primitive 103 | let copies = formatCopies nested 104 | if pars <> "" then 105 | fprintfn wr " member x.%s(%s) =" name pars 106 | fprintfn wr " let o = x.options.%s" name 107 | fprintfn wr " let newNested = { %s.%s; %s }" ntyp.Name sets copies 108 | fprintfn wr " { x with options = { x.options with %s = newNested } }" name 109 | 110 | 111 | let formatInitializers primitive = 112 | [ for n, t in primitive -> 113 | let converted = 114 | match getConversion t with 115 | | Some f -> sprintf "(Option.map %s %s)" f (safeName n) 116 | | _ -> (safeName n) 117 | sprintf "%s = orDefault %s" (safeName n) converted ] 118 | |> String.concat "; " 119 | 120 | let writeOtherOptions (wr:IO.TextWriter) = 121 | fprintfn wr "type options =" 122 | for t in otherTypes do 123 | let opts = getAllOptions t 124 | let pars = formatParameters opts 125 | let inits = formatInitializers opts 126 | fprintfn wr " static member %s(%s) =" (camelCase t.Name) pars 127 | fprintfn wr " { %s.%s }" t.Name inits 128 | 129 | 130 | let writeChartType (wr:IO.TextWriter) = 131 | for t in optionsTypes do 132 | let opts = [ for n, _ in getAllOptions t -> sprintf "%s = undefined<_>()" n ] 133 | let optsRest = opts |> String.concat "; " 134 | 135 | fprintfn wr "type %s with" t.Name 136 | fprintfn wr " static member empty =" 137 | fprintfn wr " { %s.%s }" t.Name optsRest 138 | 139 | 140 | let write() = 141 | use fs = IO.File.Create(__SOURCE_DIRECTORY__ + "/extensions.fs") 142 | use fw = new IO.StreamWriter(fs) 143 | fprintfn fw "// AUTO-GENERATED - DO NOT EDIT" 144 | fprintfn fw "[]" 145 | fprintfn fw "module TheGamma.GoogleCharts.Extensions" 146 | fprintfn fw "" 147 | fprintfn fw "open System" 148 | fprintfn fw "open TheGamma.GoogleCharts" 149 | fprintfn fw "open TheGamma.GoogleCharts.Helpers" 150 | fprintfn fw "open TheGamma.GoogleCharts.Options" 151 | fprintfn fw "" 152 | writeSetters fw 153 | fprintfn fw "" 154 | writeChartType fw 155 | fprintfn fw "" 156 | writeOtherOptions fw 157 | 158 | write() -------------------------------------------------------------------------------- /src/libraries/google/core.fs: -------------------------------------------------------------------------------- 1 | // -------------------------------------------------------------------------------------------------------------------- 2 | // Google chart API 3 | // -------------------------------------------------------------------------------------------------------------------- 4 | namespace TheGamma.GoogleCharts 5 | 6 | open TheGamma.Common 7 | open TheGamma.Series 8 | open Fable.Core 9 | open Fable.Import 10 | 11 | module GoogleCharts = 12 | type DataTable = 13 | abstract addRows : obj[][] -> unit 14 | abstract addColumn : string * string -> unit 15 | 16 | [] 17 | let createTable() : DataTable = failwith "Never" 18 | 19 | 20 | type ChartData = 21 | { data : Async } 22 | 23 | type Chart = interface end 24 | 25 | module LazyCharting = 26 | let chartsToDraw = ResizeArray<_>() 27 | let mutable googleLoaded = false 28 | 29 | let drawChartOnLoad f = 30 | if googleLoaded then f() 31 | else chartsToDraw.Add(f) 32 | 33 | [] 37 | let initGoogle (f:unit -> unit) : unit = failwith "JS" 38 | 39 | do initGoogle (fun () -> 40 | googleLoaded <- true 41 | for f in chartsToDraw do f() ) 42 | 43 | [] 48 | let drawChart (chart:#Chart) (data:GoogleCharts.DataTable) (id:string) : unit = failwith "JS" 49 | 50 | module Helpers = 51 | 52 | [] 53 | let undefined<'T>() : 'T = failwith "!" 54 | 55 | [] 56 | let isNull(o:obj) : bool = failwith "never" 57 | 58 | [] 59 | let getProperty<'T> (obj:obj) (name:string) : 'T = failwith "never" 60 | 61 | let copy o prop = 62 | if isNull o then undefined<_>() else getProperty o prop 63 | 64 | let orDefault newValue = 65 | match newValue with 66 | | Some a -> a 67 | | _ -> undefined<_>() 68 | 69 | let right o prop newValue = 70 | match newValue with 71 | | Some a -> a 72 | | _ when isNull o -> undefined<_>() 73 | | _ -> getProperty o prop 74 | 75 | let showChart (chart:#Chart) (outputId:string) = 76 | LazyCharting.drawChartOnLoad(fun () -> 77 | async { 78 | try 79 | let! dt = (getProperty chart "data").data 80 | LazyCharting.drawChart chart dt outputId 81 | with e -> 82 | Log.error("google", "Error when getting data or rendering chart: %O", e) } 83 | |> Async.StartImmediate) 84 | 85 | module ChartDataOperations = 86 | let rec collect f l = async { 87 | match l with 88 | | x::xs -> 89 | let! y = f x 90 | let! ys = collect f xs 91 | return List.append y ys 92 | | [] -> return [] } 93 | 94 | let oneKeyValue keyType (v:series<'k, float>) = { data = async { 95 | let data = GoogleCharts.createTable() 96 | data.addColumn(keyType, v.keyName) |> ignore 97 | data.addColumn("number", v.seriesName) |> ignore 98 | let! vals = v.mapPairs(fun k v -> [| box k; box v |]).data |> Async.AwaitFuture 99 | vals |> Array.map snd |> data.addRows |> ignore 100 | return data } } 101 | 102 | let oneKeyTwoValues keyType (v:series<'k, float * float>) = { data = async { 103 | let data = GoogleCharts.createTable() 104 | data.addColumn(keyType, v.keyName) |> ignore 105 | data.addColumn("number", v.seriesName) |> ignore 106 | data.addColumn("number", v.seriesName) |> ignore 107 | let! vals = v.mapPairs(fun k (v1, v2) -> [| box k; box v1; box v2 |]).data |> Async.AwaitFuture 108 | vals |> Array.map snd |> data.addRows |> ignore 109 | return data } } 110 | 111 | let oneKeyAppendValues keyType (vs:series<'k, float>[]) colors = { data = async { 112 | let data = GoogleCharts.createTable() 113 | data.addColumn(keyType, vs.[0].keyName) |> ignore 114 | data.addColumn("number", vs.[0].valueName) |> ignore 115 | JsInterop.(?) data "addColumn" (JsInterop.createObj [ "type", box "string"; "role", box "style" ]) |> ignore 116 | let! all = Array.zip vs colors |> List.ofArray |> collect (fun (v, clr) -> async { 117 | let! res = v.mapPairs(fun k v -> k, v, clr).data |> Async.AwaitFuture 118 | return res |> Array.map snd |> List.ofArray }) 119 | 120 | all 121 | |> List.sortByDescending (fun (_, v, _) -> v) |> Array.ofList 122 | |> Array.map (fun (k, v, c) -> [| box k; box v; box c |]) 123 | |> data.addRows 124 | 125 | return data } } 126 | 127 | (* 128 | let oneKeyNValues keyType (v:seq>) = { data = async { 129 | let data = GoogleCharts.createTable() 130 | let v = Array.ofSeq v 131 | data.addColumn(keyType, v.[0].keyName) |> ignore 132 | for i in 0 .. v.Length - 1 do 133 | data.addColumn("number", v.[i].seriesName) |> ignore 134 | 135 | let head = v.[0].map(fun v -> Map.ofList [0,v]) 136 | let tail = SeriesInternals.slice 1 (v.Length-1) v |> Array.mapi (fun i v -> i+1, v) 137 | let all = (head,tail) ||> Array.fold (fun s1 (i, s2) -> 138 | s1.joinOuter(s2).map(fun (l, r) -> 139 | match defaultArg l Map.empty, r with 140 | | lm, Some r -> Map.add i r lm 141 | | lm, None -> lm )) 142 | 143 | let! vals = all.mapPairs(fun k vals -> 144 | let data = Array.init v.Length (fun i -> box (defaultArg (Map.tryFind i vals) (Helpers.undefined<_>()))) 145 | Array.append [| box k |] data).data 146 | vals |> Array.map snd |> data.addRows |> ignore 147 | return data } } 148 | *) 149 | let oneKeyNValues keyType (v:series<'a, series<'k, float>>) = { data = async { 150 | let data = GoogleCharts.createTable() 151 | let! v = v.data |> Async.AwaitFuture 152 | let v = Array.map snd v 153 | data.addColumn(keyType, v.[0].keyName) |> ignore 154 | for i in 0 .. v.Length - 1 do 155 | data.addColumn("number", v.[i].seriesName) |> ignore 156 | 157 | let head = v.[0].map(fun v -> Map.ofList [0,v]) 158 | let tail = SeriesInternals.slice 1 (v.Length-1) v |> Array.mapi (fun i v -> i+1, v) 159 | let all = (head,tail) ||> Array.fold (fun s1 (i, s2) -> 160 | s1.joinOuter(s2).map(fun (l, r) -> 161 | match defaultArg l Map.empty, r with 162 | | lm, Some r -> Map.add i r lm 163 | | lm, None -> lm )) 164 | 165 | let! vals = all.mapPairs(fun k vals -> 166 | let data = Array.init v.Length (fun i -> box (defaultArg (Map.tryFind i vals) (Helpers.undefined<_>()))) 167 | Array.append [| box k |] data).data |> Async.AwaitFuture 168 | vals |> Array.map snd |> data.addRows |> ignore 169 | return data } } 170 | 171 | let twoValues (v1:series<'k, float>) (v2:series<'k,float>) = { data = async { 172 | let data = GoogleCharts.createTable() 173 | data.addColumn("number", v1.seriesName) |> ignore 174 | data.addColumn("number", v2.seriesName) |> ignore 175 | let! vals = v1.joinInner(v2).map(fun v -> [| box v.first; box v.second |]).data |> Async.AwaitFuture 176 | vals |> Array.map snd |> data.addRows |> ignore 177 | return data } } 178 | -------------------------------------------------------------------------------- /src/libraries/html.fs: -------------------------------------------------------------------------------- 1 | module TheGamma.Html 2 | 3 | open Fable.Core 4 | open Fable.Helpers 5 | open Fable.Import.Browser 6 | open Fable.Core.JsInterop 7 | open TheGamma.Common 8 | 9 | module FsOption = FSharp.Core.Option 10 | 11 | [] 12 | let private chosen (el:HTMLElement) : unit = failwith "JS" 13 | 14 | [] 15 | let private on (el:HTMLElement) (evt:string) (f:unit -> unit) : unit = failwith "JS" 16 | 17 | [] 18 | let private getProperty (o:obj) (s:string) = failwith "!" 19 | 20 | [] 21 | let private setProperty (o:obj) (s:string) (v:obj) = failwith "!" 22 | 23 | [] 24 | let private event () : Event = failwith "JS" 25 | 26 | type DomAttribute = 27 | | Event of (HTMLElement -> Event -> unit) 28 | | Attribute of string 29 | | Property of obj 30 | 31 | type DomNode = 32 | | Text of string 33 | | Delayed of string * DomNode * (string -> unit) 34 | | Element of ns:string * tag:string * attributes:(string * DomAttribute)[] * children : DomNode[] * onRender : (HTMLElement -> unit) option 35 | | Part of func:(HTMLElement -> unit) 36 | 37 | let createTree ns tag args children = 38 | let attrs = ResizeArray<_>() 39 | let props = ResizeArray<_>() 40 | for k, v in args do 41 | match k, v with 42 | | k, Attribute v -> 43 | attrs.Add (k, box v) 44 | | k, Property o -> 45 | props.Add(k, o) 46 | | k, Event f -> 47 | props.Add ("on" + k, box (fun o -> f (getProperty o "target") o )) 48 | let attrs = JsInterop.createObj attrs 49 | let ns = if ns = null || ns = "" then [] else ["namespace", box ns] 50 | let props = JsInterop.createObj (Seq.append (ns @ ["attributes", attrs]) props) 51 | let elem = Virtualdom.h(tag, props, children) 52 | elem 53 | 54 | let mutable counter = 0 55 | 56 | let rec renderVirtual node = 57 | match node with 58 | | Text(s) -> 59 | box s 60 | | Element(ns, tag, attrs, children, None) -> 61 | createTree ns tag attrs (Array.map renderVirtual children) 62 | | Delayed(symbol, body, func) -> 63 | counter <- counter + 1 64 | let id = sprintf "delayed_%d" counter 65 | 66 | // Virtual dom calls our hook when it creates HTML element, but 67 | // we still need to wait until it is added to the HTML tree 68 | let rec waitForAdded n (el:HTMLElement) = 69 | if el.parentElement <> null then 70 | el?dataset?renderedSymbol <- symbol 71 | el?id <- id 72 | func id 73 | elif n > 0 then window.setTimeout((fun () -> waitForAdded (n-1) el), 1) |> ignore 74 | else Log.error("html", "Delayed element was not created in time") 75 | 76 | // Magic as per https://github.com/Matt-Es`ch/virtual-dom/blob/master/docs/hooks.md 77 | let Hook = box(fun () -> ()) 78 | Hook?prototype?hook <- fun (node:HTMLElement) propertyName previousValue -> 79 | if unbox node?dataset?renderedSymbol <> symbol then 80 | waitForAdded 10 node 81 | let h = createNew Hook () 82 | 83 | createTree null "div" ["renderhk", Property h] [| renderVirtual body |] 84 | | Element _ -> 85 | failwith "renderVirtual: Does not support elements with after-render handlers" 86 | | Part _ -> 87 | failwith "renderVirtual: Does not support parts" 88 | 89 | let rec render node = 90 | match node with 91 | | Text(s) -> 92 | document.createTextNode(s) :> Node, ignore 93 | 94 | | Delayed(_, _, func) -> 95 | counter <- counter + 1 96 | let el = document.createElement("div") 97 | el.id <- sprintf "delayed_%d" counter 98 | el :> Node, (fun () -> func el.id) 99 | 100 | | Part(func) -> 101 | let el = document.createElement("div") 102 | el :> Node, (fun () -> func el) 103 | 104 | | Element(ns, tag, attrs, children, f) -> 105 | let el = 106 | if ns = null || ns = "" then document.createElement(tag) 107 | else document.createElementNS(ns, tag) :?> HTMLElement 108 | let rc = Array.map render children 109 | for c, _ in rc do el.appendChild(c) |> ignore 110 | for k, a in attrs do 111 | match a with 112 | | Property(o) -> setProperty el k o 113 | | Attribute(v) -> el.setAttribute(k, v) 114 | | Event(f) -> el.addEventListener(k, U2.Case1(EventListener(f el))) 115 | let onRender () = 116 | for _, f in rc do f() 117 | f |> FsOption.iter (fun f -> f el) 118 | el :> Node, onRender 119 | 120 | let renderTo (node:HTMLElement) dom = 121 | while box node.lastChild <> null do ignore(node.removeChild(node.lastChild)) 122 | let el, f = render dom 123 | node.appendChild(el) |> ignore 124 | f() 125 | 126 | let createVirtualDomAsyncApp id initial r u = 127 | let event = new Event<'T>() 128 | let trigger e = event.Trigger(e) 129 | let mutable container = document.createElement("div") :> Node 130 | document.getElementById(id).innerHTML <- "" 131 | document.getElementById(id).appendChild(container) |> ignore 132 | let mutable tree = Fable.Core.JsInterop.createObj [] 133 | let mutable state = initial 134 | 135 | let handleEvent evt = Async.StartImmediate <| async { 136 | match evt with 137 | | Some e -> 138 | let! ns = u state e 139 | state <- ns 140 | | _ -> () 141 | let newTree = r trigger state |> renderVirtual 142 | let patches = Virtualdom.diff tree newTree 143 | container <- Virtualdom.patch container patches 144 | tree <- newTree } 145 | 146 | handleEvent None 147 | event.Publish.Add(Some >> handleEvent) 148 | 149 | let createVirtualDomApp id initial r u = 150 | let event = new Event<'T>() 151 | let trigger e = event.Trigger(e) 152 | let mutable container = document.createElement("div") :> Node 153 | document.getElementById(id).innerHTML <- "" 154 | document.getElementById(id).appendChild(container) |> ignore 155 | let mutable tree = Fable.Core.JsInterop.createObj [] 156 | let mutable state = initial 157 | 158 | let handleEvent evt = 159 | state <- match evt with Some e -> u state e | _ -> state 160 | let newTree = r trigger state |> renderVirtual 161 | let patches = Virtualdom.diff tree newTree 162 | container <- Virtualdom.patch container patches 163 | tree <- newTree 164 | 165 | handleEvent None 166 | event.Publish.Add(Some >> handleEvent) 167 | 168 | let text s = Text(s) 169 | let (=>) k v = k, Attribute(v) 170 | let (=!>) k f = k, Event(f) 171 | 172 | 173 | type El(ns) = 174 | member x.Namespace = ns 175 | static member (?) (el:El, n:string) = fun a b -> 176 | let n, f = 177 | if n <> "chosen" then n, None 178 | else "select", Some (fun el -> 179 | chosen el 180 | for k, v in a do 181 | match v with 182 | | Event f -> on el k (fun () -> f el (event())) 183 | | _ -> () 184 | ) 185 | Element(el.Namespace, n, Array.ofList a, Array.ofList b, f) 186 | 187 | member x.delayed sym body f = 188 | Delayed(sym, body, f) 189 | 190 | member x.part (initial:'State) (fold:'State -> 'Event -> 'State) = 191 | let evt = Control.Event<_>() 192 | let mutable state = initial 193 | let mutable container = None 194 | let mutable renderer = None 195 | let render () = 196 | match container, renderer with 197 | | Some el, Some r -> r state |> renderTo el 198 | | _ -> () 199 | evt.Publish.Add(fun e -> state <- fold state e; render ()) 200 | 201 | evt.Trigger, 202 | fun (r:'State -> DomNode) -> 203 | renderer <- Some r 204 | Part(fun el -> 205 | container <- Some el 206 | render() ) 207 | 208 | let h = El(null) 209 | let s = El("http://www.w3.org/2000/svg") 210 | -------------------------------------------------------------------------------- /src/libraries/libraries.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | c103641d-9755-4de4-bda9-fdcfc022c80e 9 | Library 10 | libraries 11 | libraries 12 | v4.5 13 | 4.4.0.0 14 | true 15 | libraries 16 | 17 | 18 | 19 | true 20 | full 21 | false 22 | false 23 | bin\Debug\ 24 | DEBUG;TRACE 25 | 3 26 | bin\Debug\libraries.XML 27 | 28 | 29 | pdbonly 30 | true 31 | true 32 | bin\Release\ 33 | TRACE 34 | 3 35 | bin\Release\libraries.XML 36 | 37 | 38 | 11 39 | 40 | 41 | 42 | 43 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 44 | 45 | 46 | 47 | 48 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | ../../node_modules/fable-core/Fable.Core.dll 69 | 70 | 71 | 72 | True 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | bindings 81 | {278a68fc-0256-417c-af13-9a4af7381ccf} 82 | True 83 | 84 | 85 | 92 | -------------------------------------------------------------------------------- /src/libraries/tables.fs: -------------------------------------------------------------------------------- 1 | namespace TheGamma 2 | 3 | open System 4 | open TheGamma 5 | open TheGamma.Common 6 | open TheGamma.Series 7 | open TheGamma.Html 8 | open Fable.Import.Browser 9 | 10 | type Emit = Fable.Core.EmitAttribute 11 | 12 | open TheGamma.Common.JsHelpers 13 | 14 | type html = 15 | static member img(url:string) = 16 | box (h?img [ "src" => url ] []) 17 | 18 | type list<'k,'v> = 19 | { data : series<'k,'v> 20 | listTag : string 21 | elementTag : string 22 | itemFormat : 'v -> obj } 23 | member t.show(outputId) = Async.StartImmediate <| async { 24 | let! vs = t.data.data |> Async.AwaitFuture 25 | let els = [ for _, v in vs -> sprintf "<%s>%s" t.elementTag (string (t.itemFormat v)) t.elementTag ] 26 | document.getElementById(outputId).innerHTML <- 27 | sprintf "<%s>%s" t.listTag (String.concat "" els) t.listTag } 28 | member t.setTags(list, element) = 29 | { t with listTag = list; elementTag = element } 30 | member t.setFormat(f:'v -> obj) = 31 | { t with itemFormat = f } 32 | static member create(data:series<_, _>) = 33 | { data = data; listTag = "ol"; elementTag = "li" 34 | itemFormat = fun o -> box o } 35 | 36 | type table<'k,'v> = 37 | { data : series<'k,'v> 38 | showKey : bool option 39 | emptyText : string 40 | columnFormatters : Map 41 | hiddenColumns : Set 42 | addedColumns : list obj)> } 43 | 44 | static member create(data:series<_, _>) = 45 | { table.data = data 46 | emptyText = "No data available" 47 | hiddenColumns = Set.empty 48 | columnFormatters = Map.empty 49 | addedColumns = [] 50 | showKey = None } 51 | 52 | member t.set(?title:string, ?showKey:bool, ?emptyText) = 53 | { table.data = t.data.set(t.data.data, seriesName=defaultArg title t.data.seriesName) 54 | hiddenColumns = t.hiddenColumns 55 | addedColumns = t.addedColumns 56 | emptyText = defaultArg emptyText t.emptyText 57 | columnFormatters = t.columnFormatters 58 | showKey = match showKey with None -> t.showKey | sk -> sk } 59 | 60 | member t.setFormat(column, formatter) = 61 | { t with columnFormatters = t.columnFormatters.Add(column, formatter) } 62 | 63 | member t.hideColumns(names:string[]) = 64 | { t with hiddenColumns = Set.ofArray names } 65 | 66 | member t.addColumn(name, f) = 67 | { t with addedColumns = (name, f)::t.addedColumns } 68 | 69 | member t.render() = 70 | let row showKey (el:string) k (things:seq) = 71 | let withTitle = function 72 | | DomNode.Text s -> h?div ["title" => s] [text s] 73 | | nd -> nd 74 | h?tr [] [ 75 | if showKey then yield h?(el) [] [ withTitle (text k) ] 76 | for t in things -> h?(el) [] [ withTitle t ] 77 | ] 78 | 79 | let makeTable showKey k header body = 80 | h?table ["class" => "thegamma-table"] [ 81 | if not (String.IsNullOrWhiteSpace t.data.seriesName) then 82 | yield h?caption [] [ text t.data.seriesName ] 83 | yield h?thead [] [ row showKey "th" k header ] 84 | yield h?tbody [] body 85 | ] 86 | 87 | let formatAdded o = 88 | // Did someone say hack..? 89 | let isSeries = 90 | [ for kv in properties o -> kv.key ] = 91 | ["data"; "keyName"; "valueName"; "seriesName"] 92 | if isSeries then 93 | let mutable result = unbox null 94 | (unbox> o).data.Then(fun r -> result <- r) 95 | h?span [] (List.ofArray (Array.map snd result)) 96 | else text (o.ToString()) 97 | 98 | async { 99 | try 100 | let! vs = t.data.data |> Async.AwaitFuture 101 | if vs.Length = 0 then 102 | return h?div ["class" => "placeholder"] [ h?p [] [ text t.emptyText ] ] 103 | else 104 | let filteredProperties o = 105 | properties o |> Array.filter (fun kv -> not (t.hiddenColumns.Contains kv.key)) 106 | 107 | let _, first = vs |> Seq.head 108 | let headers = 109 | [ if isObject first then for kv in filteredProperties first -> text kv.key 110 | else yield text t.data.valueName 111 | for k, _ in t.addedColumns -> text k ] 112 | let showKey = match t.showKey with Some sk -> sk | _ -> not (isObject first) 113 | return 114 | [ for k, v in vs -> 115 | let formattedVals = 116 | [ if isObject v then 117 | for kv in filteredProperties v do 118 | if t.columnFormatters.ContainsKey kv.key then yield text ((unbox<_ -> _> t.columnFormatters.[kv.key]) kv.value) 119 | elif isDate kv.value then yield text (formatDateTime kv.value) 120 | elif not (isNumber kv.value) then yield text (kv.value.ToString()) 121 | elif isNaN (unbox kv.value) then yield text "" 122 | else yield text (niceNumber kv.value 2) 123 | elif isDate v then yield text (formatDateTime v) 124 | elif not (isNumber v) then yield text (v.ToString()) 125 | elif isNaN (unbox v) then yield text "" 126 | else yield text (niceNumber v 2) 127 | for _, f in t.addedColumns -> formatAdded (f v) ] 128 | row showKey "td" (unbox k) formattedVals ] 129 | |> makeTable showKey t.data.keyName headers 130 | with e -> 131 | Log.exn("live", "Getting data for table failed: %O", e) 132 | return raise e } 133 | 134 | member t.show(outputId) = 135 | async { let! dom = t.render() 136 | dom |> renderTo (document.getElementById(outputId)) } 137 | |> Async.StartImmediate 138 | 139 | type placeholder(message:string) = 140 | static member create(message:string) = placeholder(message) 141 | member x.show(outputId) = 142 | h?div ["class" => "placeholder"] [ h?p [] [ text message ] ] 143 | |> renderTo (document.getElementById(outputId)) 144 | -------------------------------------------------------------------------------- /src/thegamma-script.sln: -------------------------------------------------------------------------------- 1 |  2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio 14 4 | VisualStudioVersion = 14.0.25420.1 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "thegamma", "thegamma\thegamma.fsproj", "{AE8310C8-1F2B-4F9C-83F6-5D188B7517B2}" 7 | EndProject 8 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "bindings", "bindings\bindings.fsproj", "{278A68FC-0256-417C-AF13-9A4AF7381CCF}" 9 | EndProject 10 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "libraries", "libraries\libraries.fsproj", "{C103641D-9755-4DE4-BDA9-FDCFC022C80E}" 11 | EndProject 12 | Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "tools", "tools", "{D6CA65DC-458D-447F-B87E-AD39D715FAD7}" 13 | ProjectSection(SolutionItems) = preProject 14 | ..\tools\fsprovider.fsx = ..\tools\fsprovider.fsx 15 | EndProjectSection 16 | EndProject 17 | Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "project", "project", "{DE272232-9989-46E8-A7C0-64E186628638}" 18 | ProjectSection(SolutionItems) = preProject 19 | ..\CHANGELOG.md = ..\CHANGELOG.md 20 | fableconfig.json = fableconfig.json 21 | ..\package.json = ..\package.json 22 | ..\paket.dependencies = ..\paket.dependencies 23 | ..\webpack.config.js = ..\webpack.config.js 24 | EndProjectSection 25 | EndProject 26 | Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "tests", "tests", "{3E492EDE-8EF0-477C-B45D-8AD8F92E135B}" 27 | EndProject 28 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "thegamma-tests", "..\tests\thegamma-tests\thegamma-tests.fsproj", "{EE8310C8-1F2B-4F9C-83F6-5D188B7517B2}" 29 | EndProject 30 | Global 31 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 32 | Debug|Any CPU = Debug|Any CPU 33 | Release|Any CPU = Release|Any CPU 34 | EndGlobalSection 35 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 36 | {AE8310C8-1F2B-4F9C-83F6-5D188B7517B2}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 37 | {AE8310C8-1F2B-4F9C-83F6-5D188B7517B2}.Debug|Any CPU.Build.0 = Debug|Any CPU 38 | {AE8310C8-1F2B-4F9C-83F6-5D188B7517B2}.Release|Any CPU.ActiveCfg = Release|Any CPU 39 | {AE8310C8-1F2B-4F9C-83F6-5D188B7517B2}.Release|Any CPU.Build.0 = Release|Any CPU 40 | {278A68FC-0256-417C-AF13-9A4AF7381CCF}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 41 | {278A68FC-0256-417C-AF13-9A4AF7381CCF}.Debug|Any CPU.Build.0 = Debug|Any CPU 42 | {278A68FC-0256-417C-AF13-9A4AF7381CCF}.Release|Any CPU.ActiveCfg = Release|Any CPU 43 | {278A68FC-0256-417C-AF13-9A4AF7381CCF}.Release|Any CPU.Build.0 = Release|Any CPU 44 | {C103641D-9755-4DE4-BDA9-FDCFC022C80E}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 45 | {C103641D-9755-4DE4-BDA9-FDCFC022C80E}.Debug|Any CPU.Build.0 = Debug|Any CPU 46 | {C103641D-9755-4DE4-BDA9-FDCFC022C80E}.Release|Any CPU.ActiveCfg = Release|Any CPU 47 | {C103641D-9755-4DE4-BDA9-FDCFC022C80E}.Release|Any CPU.Build.0 = Release|Any CPU 48 | {EE8310C8-1F2B-4F9C-83F6-5D188B7517B2}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 49 | {EE8310C8-1F2B-4F9C-83F6-5D188B7517B2}.Debug|Any CPU.Build.0 = Debug|Any CPU 50 | {EE8310C8-1F2B-4F9C-83F6-5D188B7517B2}.Release|Any CPU.ActiveCfg = Release|Any CPU 51 | {EE8310C8-1F2B-4F9C-83F6-5D188B7517B2}.Release|Any CPU.Build.0 = Release|Any CPU 52 | EndGlobalSection 53 | GlobalSection(SolutionProperties) = preSolution 54 | HideSolutionNode = FALSE 55 | EndGlobalSection 56 | GlobalSection(NestedProjects) = preSolution 57 | {EE8310C8-1F2B-4F9C-83F6-5D188B7517B2} = {3E492EDE-8EF0-477C-B45D-8AD8F92E135B} 58 | EndGlobalSection 59 | EndGlobal 60 | -------------------------------------------------------------------------------- /src/thegamma/App.config: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /src/thegamma/analyzer/binder.fs: -------------------------------------------------------------------------------- 1 | // ------------------------------------------------------------------------------------------------ 2 | // Binder attaches `Entity` objects to `Node` objects produced by the parser 3 | // Entities are reused when possible and contain inferred types etc. 4 | // ------------------------------------------------------------------------------------------------ 5 | module TheGamma.Binder 6 | 7 | open TheGamma.Ast 8 | open TheGamma.Common 9 | 10 | /// Represents case of the EntityKind union 11 | type EntityCode = int 12 | 13 | /// As we bind, we keep root entity, current scope & variables in scope 14 | type BindingContext = 15 | { Variables : Map 16 | GlobalValues : Map 17 | Root : Entity 18 | 19 | /// When we are in `foo(fun x -> ...)` the `x` is linked to the call site 20 | CallSite : Entity option 21 | /// When we are in `foo.[name:x].bar` the Chain represents `foo` so that `x` can be a member 22 | Chain : Entity option 23 | 24 | /// Table with previously created entities. This is a mutable mapping from 25 | /// list of symbols (antecedent entities) together with entity kind & name 26 | /// to the actual entity. Antecedents capture dependencies (if dependency 27 | /// changed, we need to recreate the entity that depends on them) 28 | Table : ListDictionary> 29 | /// Collects all bound entities and their ranges 30 | Bound : ResizeArray } 31 | 32 | /// Represents result of binding syntax tree to entities 33 | /// (provides access to all bound entities & children lookup function) 34 | type BindingResult(ents:(Range * Entity)[]) = 35 | let childrenLookup = 36 | let res = System.Collections.Generic.Dictionary>() 37 | let add a e = 38 | if not (res.ContainsKey(a)) then res.Add(a, ResizeArray()) 39 | res.[a].Add(e) 40 | for _, e in ents do 41 | for a in e.Antecedents do 42 | add a.Symbol e 43 | res 44 | member x.Entities = ents 45 | member x.GetChildren(ent) = 46 | match childrenLookup.TryGetValue(ent.Symbol) with true, res -> res.ToArray() | _ -> [||] 47 | 48 | /// Lookup entity (if it can be reused) or create & cache a new one 49 | let bindEntity ctx kind = 50 | let code, antecedents, name = entityCodeNameAndAntecedents kind 51 | let symbols = ctx.Root::antecedents |> List.map (fun a -> a.Symbol) 52 | let nestedDict = 53 | match ListDictionary.tryFind symbols ctx.Table with 54 | | None -> Map.empty 55 | | Some res -> res 56 | if nestedDict.ContainsKey (code, name) then 57 | Log.trace("binder", "Cached: binding %s %s", formatEntityKind kind, name) 58 | nestedDict.[code, name] 59 | else 60 | Log.trace("binder", "New: binding %s %s", formatEntityKind kind, name) 61 | let symbol = createSymbol () 62 | let entity = { Kind = kind; Symbol = symbol; Type = None; Errors = []; Meta = []; Value = None } 63 | ListDictionary.set symbols (Map.add (code, name) entity nestedDict) ctx.Table 64 | entity 65 | 66 | /// Assign entity to a node in parse tree 67 | let setEntity ctx node entity = 68 | ctx.Bound.Add(node.Range, entity) 69 | node.Entity <- Some entity 70 | entity 71 | 72 | /// Bind entities to expressions in the parse tree 73 | /// (See `EntityKind` for explanation of how the entity tree looks like) 74 | let rec bindExpression ctx node = 75 | let bindCallArgExpression site ctx = bindExpression { ctx with CallSite = Some site; Chain = None } 76 | let bindMemberExpression chain ctx = bindExpression { ctx with CallSite = None; Chain = Some chain } 77 | let bindPlaceExpression ctx = bindExpression { ctx with CallSite = None } 78 | let bindExpression ctx = bindExpression { ctx with CallSite = None; Chain = None } 79 | 80 | match node.Node with 81 | | Expr.Placeholder(name, body) -> 82 | // Keep `ctx.Chain` in case the plceholder contains member access 83 | let bodyEnt = bindPlaceExpression ctx body 84 | bindEntity ctx (EntityKind.Placeholder(name.Node, bodyEnt)) |> setEntity ctx node |> ignore 85 | bodyEnt 86 | 87 | | Expr.Variable(name) -> 88 | // Variable is actually member access inside chain or placeholder inside chain 89 | match ctx.Chain with 90 | | Some chain -> 91 | let memberName = bindEntity ctx (EntityKind.MemberName(name.Node)) |> setEntity ctx name 92 | bindEntity ctx (EntityKind.Member(chain, memberName)) |> setEntity ctx node 93 | | _ -> 94 | // Variable is a local variable defined somewhere in context 95 | match ctx.Variables.TryFind name.Node with 96 | | Some decl -> bindEntity ctx (EntityKind.Variable(name.Node, decl)) |> setEntity ctx node 97 | | _ -> 98 | // Variable is a global, known or unknown variable 99 | match ctx.GlobalValues.TryFind name.Node with 100 | | Some glob -> glob |> setEntity ctx node 101 | | _ -> bindEntity ctx (EntityKind.GlobalValue(name.Node, None)) |> setEntity ctx node 102 | 103 | | Expr.Call(instExpr, argsNode) -> 104 | // Bind instance & create call site that depends on it 105 | let inst = bindExpression ctx instExpr 106 | let site arg = bindEntity ctx (EntityKind.CallSite(inst, arg)) 107 | // Bind arguments - which depend on the call site 108 | let args = argsNode.Node |> List.mapi (fun idx arg -> 109 | let site = site (match arg.Name with Some n -> Choice1Of2 n.Node.Name | _ -> Choice2Of2 idx) 110 | let expr = bindCallArgExpression site ctx arg.Value 111 | match arg.Name with 112 | | Some n -> bindEntity ctx (EntityKind.NamedParam(n.Node, expr)) |> setEntity ctx n 113 | | None -> expr) 114 | let args = bindEntity ctx (EntityKind.ArgumentList(args)) |> setEntity ctx argsNode 115 | bindEntity ctx (EntityKind.Call(inst, args)) |> setEntity ctx node 116 | 117 | | Expr.Member(instExpr, memExpr) -> 118 | let instEnt = bindExpression ctx instExpr 119 | let memEnt = bindMemberExpression instEnt ctx memExpr 120 | bindEntity ctx (EntityKind.MemberAccess(memEnt)) |> setEntity ctx node 121 | 122 | | Expr.Binary(lExpr, op, rExpr) -> 123 | let lEnt = bindExpression ctx lExpr 124 | let rEnt = bindExpression ctx rExpr 125 | bindEntity ctx (EntityKind.Operator(lEnt, op.Node, rEnt)) |> setEntity ctx node 126 | 127 | | Expr.List(elExprs) -> 128 | let elEnts = elExprs |> List.map (bindExpression ctx) 129 | bindEntity ctx (EntityKind.List(elEnts)) |> setEntity ctx node 130 | 131 | | Expr.Function(var, bodyExpr) -> 132 | let callSite = match ctx.CallSite with Some s -> s | None -> failwith "bindExpression: Function missing call site" 133 | let varEnt = bindEntity ctx (EntityKind.Binding(var.Node, callSite)) |> setEntity ctx var 134 | let bodyEnt = bindExpression { ctx with Variables = Map.add var.Node varEnt ctx.Variables } bodyExpr 135 | bindEntity ctx (EntityKind.Function(varEnt, bodyEnt)) |> setEntity ctx node 136 | 137 | | Expr.Boolean b -> bindEntity ctx (EntityKind.Constant(Constant.Boolean b)) |> setEntity ctx node 138 | | Expr.String s -> bindEntity ctx (EntityKind.Constant(Constant.String s)) |> setEntity ctx node 139 | | Expr.Number n -> bindEntity ctx (EntityKind.Constant(Constant.Number n)) |> setEntity ctx node 140 | | Expr.Empty -> bindEntity ctx (EntityKind.Constant Constant.Empty) |> setEntity ctx node 141 | 142 | /// Bind entities to a command in a parse tree. The handling of `let` is similar 143 | /// to the handling of lambda abstraction. This adds variables to context - we ignore 144 | /// bound entities, because nothing depends on it (except via variables) 145 | let bindCommand ctx node = 146 | match node.Node with 147 | | Command.Let(v, e) -> 148 | let body = bindExpression ctx e 149 | let var = bindEntity ctx (EntityKind.Variable(v.Node, body)) |> setEntity ctx v 150 | let node = bindEntity ctx (EntityKind.LetCommand(var, body)) |> setEntity ctx node 151 | { ctx with Variables = Map.add v.Node var ctx.Variables }, node 152 | 153 | | Command.Expr(e) -> 154 | let body = bindExpression ctx e 155 | let node = bindEntity ctx (EntityKind.RunCommand(body)) |> setEntity ctx node 156 | ctx, node 157 | 158 | /// Bind entities to all nodes in the program 159 | let bindProgram ctx (program:Program) = 160 | ctx.Bound.Clear() 161 | let _, ents = 162 | program.Body.Node |> List.fold (fun (ctx, nodes) cmd -> 163 | let ctx, node = bindCommand ctx cmd 164 | ctx, node::nodes) (ctx, []) 165 | bindEntity ctx (EntityKind.Program(ents)) |> setEntity ctx program.Body, 166 | BindingResult(ctx.Bound.ToArray()) 167 | 168 | /// Create a new binding context - this stores cached entities 169 | let createContext (globals:list) name = 170 | let root = 171 | { Kind = EntityKind.Root; Errors = []; Symbol = createSymbol(); Type = None; Meta = []; Value = None } 172 | { Table = System.Collections.Generic.Dictionary<_, _>(); 173 | Bound = ResizeArray<_>(); Variables = Map.empty; 174 | GlobalValues = Map.ofList [ for e in globals -> { Name = e.Name }, e ] 175 | Root = root; CallSite = None; Chain = None } -------------------------------------------------------------------------------- /src/thegamma/analyzer/interpreter.fs: -------------------------------------------------------------------------------- 1 | // ------------------------------------------------------------------------------------------------ 2 | // Interpreter is used to partially evaluate parts of program as needed 3 | // ------------------------------------------------------------------------------------------------ 4 | module TheGamma.Interpreter 5 | 6 | open TheGamma 7 | open TheGamma.Ast 8 | open TheGamma.Common 9 | open TheGamma.Babel 10 | open TheGamma.Babel.BabelOperators 11 | open Fable.Helpers.Babel 12 | open System.Collections.Generic 13 | 14 | // ------------------------------------------------------------------------------------------------ 15 | // Wrappers around `eval` that let us treat runtime values as `Expressions` we can pass to babel 16 | // ------------------------------------------------------------------------------------------------ 17 | 18 | /// Creates an array of objects and list of expressions that refer 19 | /// to them as if they were stored in an array, e.g. `_stored[0]` and `_stored[1]` 20 | let storeArguments values = 21 | values |> Array.ofList, 22 | values |> List.mapi (fun i _ -> 23 | MemberExpression 24 | ( IdentifierExpression("_stored", None), 25 | NumericLiteral(float i, None), true, None )) 26 | 27 | /// Evalaute Babel expression, assuming `_stored` is in scope 28 | let evaluateExpression (_stored:RuntimeValue[]) (expr:Expression) = 29 | let prog = { Babel.Program.location = None; Babel.Program.body = [ExpressionStatement(expr, None)] } 30 | let code = babel.transformFromAst(Serializer.serializeProgram prog, "", { presets = [| "es2015" |] }) 31 | Log.trace("interpreter", "Interpreter evaluating: %O using values %O", code.code, _stored) 32 | try 33 | // HACK (1/2): Get fable to reference everything 34 | let s = TheGamma.Series.series.create(async { return [||] }, "", "", "") 35 | TheGamma.TypeProvidersRuntime.RuntimeContext("lol", "", "troll") |> ignore 36 | TheGamma.TypeProvidersRuntime.trimLeft |> ignore 37 | TheGamma.TypeProvidersRuntime.convertTupleSequence |> ignore 38 | TheGamma.TypeProvidersRuntime.convertSequence |> ignore 39 | TheGamma.GoogleCharts.chart.bar |> ignore 40 | TheGamma.table.create(s) |> ignore 41 | TheGamma.General.date.now() |> ignore 42 | TheGamma.Series.series.values([| 1 |]) |> ignore 43 | TheGamma.placeholder.create("") |> ignore 44 | TheGamma.Interactive.youguess.line |> ignore 45 | 46 | // HACK (2/2) The name `_stored` may appear in the generated code! 47 | _stored.Length |> ignore 48 | eval(code.code) 49 | with e -> 50 | Log.exn("interpreter", "Evaluation failed: %O", e) 51 | reraise() 52 | 53 | /// Store given arguments and evalaute expression 54 | let evaluateExpr args exprBuilder = 55 | let _stored, args = storeArguments args 56 | evaluateExpression _stored (exprBuilder args) 57 | 58 | /// If the value is object with 'preview' method or property, evaluate it! 59 | let evaluatePreview (ent:Entity) value = 60 | let previewName = {Name.Name="preview"} 61 | Log.trace("interpreter", "Evaluating preview on: %O (%s)", ent, Ast.formatType ent.Type.Value) 62 | match ent.Type with 63 | | Some(Type.Object(FindMember previewName mem)) -> 64 | // Member access or member access & call, depending on whether the member is a method 65 | match mem.Type with 66 | | Type.Method(_, _) -> evaluateExpr [value] (fun inst -> mem.Emitter.Emit(List.head inst) /@/ []) |> Some 67 | | _ -> evaluateExpr [value] (fun inst -> mem.Emitter.Emit(List.head inst)) |> Some 68 | | _ -> None 69 | 70 | // ------------------------------------------------------------------------------------------------ 71 | // Recursively walk over entities & evaluate (starting from antecedents) 72 | // ------------------------------------------------------------------------------------------------ 73 | 74 | let rec evaluateEntity (e:Entity) = 75 | match e.Kind with 76 | // Constants, variables & global values (using expression stored in GlobalValue entity) 77 | | EntityKind.Constant(Constant.Boolean b) -> Some(unbox b) 78 | | EntityKind.Constant(Constant.Number n) -> Some(unbox n) 79 | | EntityKind.Constant(Constant.String s) -> Some(unbox s) 80 | | EntityKind.Constant(Constant.Empty) -> Some(unbox null) 81 | 82 | | EntityKind.Variable(_, value) -> 83 | value.Value |> Option.map (fun v -> v.Value) 84 | 85 | | EntityKind.GlobalValue(name, expr) -> 86 | match expr with 87 | | Some expr -> Some(evaluateExpression [| |] expr) 88 | | _ -> None 89 | 90 | // Member access and call - method call is member access followed by a call 91 | | EntityKind.Member(inst, { Kind = EntityKind.MemberName(name) }) -> 92 | match inst.Type.Value with 93 | | Type.Object(FindMember name mem) -> 94 | Some(evaluateExpr [getValue inst] (fun inst -> mem.Emitter.Emit(List.head inst))) 95 | | _ -> None 96 | 97 | | EntityKind.MemberAccess(mem) -> 98 | Some(getValue mem) 99 | 100 | | EntityKind.Call(inst, { Kind = EntityKind.ArgumentList(args) }) -> 101 | // Split arguments between index-based and position-based 102 | let pb = args |> List.takeWhile (function { Kind = EntityKind.NamedParam _ } -> false | _ -> true) 103 | let nb = args |> List.skipWhile (function { Kind = EntityKind.NamedParam _ } -> false | _ -> true) 104 | 105 | let positionBased = 106 | pb |> List.map (getValue) |> Array.ofList 107 | let nameBased = 108 | nb |> List.choose(function 109 | | { Kind = EntityKind.NamedParam(name, value) } -> Some(name.Name, getValue value) 110 | | _ -> None) |> dict 111 | 112 | // Get expected arguments from the method type 113 | let expectedArgs = 114 | match inst.Type.Value with 115 | | Type.Method(args, resTy) -> args 116 | | _ -> [] 117 | 118 | // Evalate arguments and instance and run the call 119 | let pars = expectedArgs |> List.mapi (fun i ma -> 120 | if i < positionBased.Length then positionBased.[i] 121 | elif nameBased.ContainsKey(ma.Name) then nameBased.[ma.Name] 122 | else (unbox null) ) 123 | 124 | match inst with 125 | | { Kind = EntityKind.MemberAccess { Kind = EntityKind.Member(inst, { Kind = EntityKind.MemberName(n) }) } } -> 126 | let instValue = getValue inst 127 | match inst.Type with 128 | | Some(Type.Object(FindMember n mem)) -> 129 | evaluateExpr (instValue::pars) (fun stored -> mem.Emitter.Emit(List.head stored) /@/ List.tail stored) 130 | | _ -> 131 | evaluateExpr (instValue::pars) (fun stored -> ((List.head stored) /?/ str n.Name) /@/ List.tail stored) 132 | | _ -> 133 | let instValue = getValue inst 134 | evaluateExpr (instValue::pars) (fun stored -> List.head stored /@/ List.tail stored) 135 | 136 | | EntityKind.Member(inst, _) -> 137 | Log.error("interpreter", "typeCheckEntity: Member access is missing member name!") 138 | None 139 | | EntityKind.Call(inst, _) -> 140 | Log.error("interpreter", "typeCheckEntity: Call to %s is missing argument list!", (lastChainElement inst).Name) 141 | None 142 | 143 | // Binary operators - most map to JavaScript except for power, which is a JS function 144 | | EntityKind.Operator(l, Operator.Power, r) -> 145 | evaluateExpr [getValue l; getValue r] (function 146 | | [l; r] -> ident("Math")?pow /@/ [l; r] 147 | | _ -> failwith "evaluateEntity: Expected two arguments") |> Some 148 | 149 | | EntityKind.Operator(l, op, r) -> 150 | evaluateExpr [getValue l; getValue r] (function 151 | | [l; r] -> 152 | let op = 153 | match op with 154 | | Operator.Modulo -> BinaryModulus 155 | | Operator.Equals -> BinaryEqualStrict 156 | | Operator.Plus -> BinaryPlus 157 | | Operator.Minus -> BinaryMinus 158 | | Operator.Multiply -> BinaryMultiply 159 | | Operator.Divide -> BinaryDivide 160 | | Operator.GreaterThan -> BinaryGreater 161 | | Operator.LessThan -> BinaryLess 162 | | Operator.GreaterThanOrEqual -> BinaryGreaterOrEqual 163 | | Operator.LessThanOrEqual -> BinaryLessOrEqual 164 | | Operator.Power -> failwith "evaluateEntity: Power is not a binary operation" 165 | BinaryExpression(op, l, r, None) 166 | | _ -> failwith "evaluateEntity: Expected two arguments") |> Some 167 | 168 | // Other simple language constructs 169 | | EntityKind.List(ents) -> 170 | evaluateExpr (List.map (getValue) ents) (fun elements -> 171 | ArrayExpression(elements, None)) |> Some 172 | 173 | | EntityKind.Placeholder(_, body) -> 174 | Some(getValue body) 175 | 176 | // The following entities do not represent anything that has a value 177 | | EntityKind.ArgumentList _ 178 | | EntityKind.NamedParam _ 179 | | EntityKind.MemberName _ 180 | | EntityKind.Binding _ 181 | | EntityKind.Root _ 182 | | EntityKind.CallSite _ -> 183 | Some(unbox null) 184 | 185 | | EntityKind.Function _ 186 | | EntityKind.Program _ 187 | | EntityKind.LetCommand _ 188 | | EntityKind.RunCommand _ -> 189 | Log.error("interpreter", "Cannot evaluate entity (probably not supported yet): %O", e) 190 | None 191 | 192 | // Evaluate value and lazily generate preview, if it is None 193 | and ensureValue (e:Entity) = 194 | if e.Value.IsNone then 195 | match evaluateEntity e with 196 | | Some value -> 197 | e.Value <- Some { Value = value; Preview = Lazy.Create(fun () -> evaluatePreview e value) } 198 | | _ -> () 199 | 200 | /// Get value assumes that `evaluateEntityTree` evaluated antecedents already 201 | and getValue (e:Entity) = 202 | if e.Value.IsNone then Log.error("interpreter", "getValue: Value of entity %O has not been evaluated.", e) 203 | e.Value.Value.Value 204 | 205 | /// Evalaute antecedents (caching them in `visited`) and then evalaute `e` 206 | let evaluateEntityTree (e:Entity) = 207 | let visited = Dictionary() 208 | let rec loop (e:Entity) = 209 | if not (visited.ContainsKey(e.Symbol)) && e.Value.IsNone then 210 | visited.[e.Symbol] <- true 211 | for e in e.Antecedents do loop e 212 | ensureValue e 213 | loop e 214 | e.Value 215 | 216 | // ------------------------------------------------------------------------------------------------ 217 | // Public interface - creating global entities and evaluating entities 218 | // ------------------------------------------------------------------------------------------------ 219 | 220 | let globalEntity name meta typ expr = 221 | { Kind = EntityKind.GlobalValue({ Name = name }, expr) 222 | Symbol = createSymbol() 223 | Type = Some typ 224 | Meta = meta 225 | Value = None 226 | Errors = [] } 227 | 228 | let evaluate (globals:seq) (e:Entity) = 229 | //Log.trace("interpreter", "Evaluating entity %s (%O)", e.Name, e.Kind) 230 | let res = evaluateEntityTree e 231 | //Log.trace("interpreter", "Evaluated entity %s (%O) = %O", e.Name, e.Kind, res) 232 | res 233 | -------------------------------------------------------------------------------- /src/thegamma/ast/ast.fs: -------------------------------------------------------------------------------- 1 | namespace TheGamma 2 | open TheGamma.Common 3 | 4 | // ------------------------------------------------------------------------------------------------ 5 | // Tokens and common 6 | // ------------------------------------------------------------------------------------------------ 7 | 8 | /// Represents a range as character offset in a file. 0-indexed, the End position is the position 9 | /// of the last character of the thing in the range. Consider range of "42" in "1 + 42 + 2". 10 | /// The range of the token 42 here would be { Start = 4; End = 5 }: 11 | /// 12 | /// 1 + 4 2 + 2 13 | /// 0 1 2 3 4 5 6 7 8 9 14 | /// 15 | type Range = 16 | { Start : int 17 | End : int } 18 | 19 | /// Error with a range. Message can be Markdown, Range is generic so that we can reuse 20 | /// the data structure with both `Range` and line-based range when reporting errors. 21 | type Error<'Range> = 22 | { Number : int 23 | Message : string 24 | Range : 'Range } 25 | 26 | /// Binary operators (Equals is tokenized as separate token, but after parsing it can be operator) 27 | type [] Operator = 28 | | Equals 29 | | Modulo 30 | | Plus 31 | | Minus 32 | | Multiply 33 | | Divide 34 | | Power 35 | | GreaterThan 36 | | LessThan 37 | | GreaterThanOrEqual 38 | | LessThanOrEqual 39 | 40 | /// Tokens produced by tokenizer 41 | type [] TokenKind = 42 | | LParen 43 | | RParen 44 | | Equals 45 | | Dot 46 | | Comma 47 | | Let 48 | | LSquare 49 | | RSquare 50 | | Colon 51 | | Fun 52 | | Arrow 53 | | Operator of Operator 54 | | Boolean of bool 55 | | Number of string * float 56 | | String of string 57 | | Ident of string 58 | | QIdent of string 59 | | White of string 60 | | Newline 61 | | Error of char 62 | | EndOfFile 63 | 64 | /// Token with a range 65 | type Token = 66 | { Token : TokenKind 67 | Range : Range } 68 | 69 | // ------------------------------------------------------------------------------------------------ 70 | // Types and code generation 71 | // ------------------------------------------------------------------------------------------------ 72 | 73 | type Emitter = 74 | { Emit : Babel.Expression (* Babel.Expression list *) -> Babel.Expression } 75 | 76 | type Metadata = 77 | { Context : string 78 | Type : string 79 | Data : obj } 80 | 81 | type [] Documentation = 82 | | Text of string 83 | | Details of string * string 84 | | None 85 | 86 | type Member = 87 | { Name : string 88 | Type : Type 89 | Metadata : Metadata list 90 | Emitter : Emitter } 91 | 92 | and ObjectType = 93 | abstract Members : Member[] 94 | abstract TypeEquals : ObjectType -> bool 95 | 96 | and [] PrimitiveType = 97 | | Number 98 | | Date 99 | | String 100 | | Bool 101 | | Unit 102 | 103 | and MethodArgument = 104 | { Name : string 105 | Optional : bool 106 | Static : bool 107 | Type : Type } 108 | 109 | and [] Type = 110 | | Delayed of Future 111 | | Object of ObjectType 112 | | Primitive of PrimitiveType 113 | | List of elementType:Type 114 | | Method of arguments:MethodArgument list * typ:((Type * RuntimeValue option) list -> Type option) 115 | | Any 116 | 117 | // ------------------------------------------------------------------------------------------------ 118 | // Entities - binder attaches those to individual constructs in the parsed AST 119 | // ------------------------------------------------------------------------------------------------ 120 | 121 | /// Name. In expressions, it usually appears as Node 122 | and Name = 123 | { Name : string } 124 | 125 | /// Represents constants that can appear in the code 126 | /// (We create separate entity for each, so that we can calculate 127 | /// values of entities and not just types) 128 | and [] Constant = 129 | | Number of float 130 | | String of string 131 | | Boolean of bool 132 | | Empty 133 | 134 | /// Represents different kinds of entities that we create. Roughhly 135 | /// corresponds to all places in code where something has a name. 136 | and [] EntityKind = 137 | 138 | // Entities that represent root node, program and commands 139 | | Root 140 | | Program of commands:Entity list 141 | | RunCommand of body:Entity 142 | | LetCommand of variable:Entity * assignment:Entity 143 | 144 | // Standard constructs of the language 145 | | List of elements:Entity list 146 | | Constant of Constant 147 | | Function of variable:Entity * body:Entity 148 | | Operator of left:Entity * operator:Operator * right:Entity 149 | 150 | /// Reference to a global symbol or a local variable 151 | | GlobalValue of name:Name * Babel.Expression option 152 | | Variable of name:Name * value:Entity 153 | 154 | /// Variable binding in lambda abstraction 155 | | Binding of name:Name * callSite:Entity 156 | /// Call site in which a lambda function appears. Marks method reference & argument 157 | /// (the argument is the name or the index of the parameter in the list) 158 | | CallSite of instance:Entity * parameter:Choice 159 | 160 | /// Represents all arguments passed to method; Antecedants are individual arguments 161 | /// (a mix of named parameter & ordinary expression entities) 162 | | ArgumentList of arguments:Entity list 163 | /// Named param in a call site with an expression assigned to it 164 | | NamedParam of name:Name * assignment:Entity 165 | 166 | /// Placeholder with its name and the body entity 167 | | Placeholder of name:Name * body:Entity 168 | 169 | /// Member access and call with arguments (call has member access 170 | /// as the instance; second argument of Member is MemberName) 171 | | Call of instance:Entity * arguments:Entity 172 | | Member of instance:Entity * name:Entity 173 | | MemberAccess of membr:Entity 174 | | MemberName of name:Name 175 | 176 | 177 | 178 | /// An entity represents a thing in the source code to which we attach additional info. 179 | /// It is uniquely identified by its `Symbol` (which is also used for lookups) 180 | and Entity = 181 | { Kind : EntityKind 182 | Symbol : Symbol 183 | mutable Value : EntityValue option 184 | mutable Meta : Metadata list 185 | mutable Type : Type option 186 | mutable Errors : Error list } 187 | 188 | and RuntimeValue = obj 189 | 190 | and EntityValue = 191 | { Value : RuntimeValue 192 | Preview : Lazy } 193 | 194 | // ------------------------------------------------------------------------------------------------ 195 | // Parsed AST 196 | // ------------------------------------------------------------------------------------------------ 197 | 198 | /// Node wraps syntax element with other information. Whitespce before/after are tokens 199 | /// around it that the parser skipped (they may be whitespace, but also skipped error tokens). 200 | /// Entity is assigned to the expression later by a binder. 201 | type Node<'T> = 202 | { WhiteBefore : Token list 203 | WhiteAfter : Token list 204 | Range : Range 205 | Node : 'T 206 | mutable Entity : Entity option } 207 | 208 | /// Method call argument, optionally with a named 209 | type Argument = 210 | { Name : Node option 211 | Value : Node } 212 | 213 | /// A program is a list of commands (with range info) 214 | and Program = 215 | { Body : Node list> } 216 | 217 | /// Variable binding or an expression 218 | and Command = 219 | | Let of Node * Node 220 | | Expr of Node 221 | 222 | /// An expression (does not include let binding, which is a command) 223 | and [] Expr = 224 | | Variable of Node 225 | | Member of Node * Node 226 | | Call of Node * Node 227 | | Function of Node * Node 228 | | Placeholder of Node * Node 229 | | String of string 230 | | Number of float 231 | | Boolean of bool 232 | | Binary of Node * Node * Node 233 | | List of Node list 234 | | Empty 235 | 236 | -------------------------------------------------------------------------------- /src/thegamma/ast/errors.fs: -------------------------------------------------------------------------------- 1 | module TheGamma.Errors 2 | open TheGamma.Ast 3 | 4 | module Tokenizer = 5 | let inputEndInsideString rng s = 6 | { Number = 101; Range = rng; Message = sprintf "Missing \" at the end of the input. The string \"%s\" ends without closing double-quote." s } 7 | let missingClosingQuote rng q = 8 | { Number = 102; Range = rng; Message = sprintf "Quoted identifier '%s' is missing closing quote." q } 9 | let unexpectedCharacter rng (c:char) = 10 | { Number = 103; Range = rng; Message = sprintf "Unexcpected character '%s' in the input." (string c) } 11 | 12 | module Parser = 13 | let unexpectedTokenAfterDot rng tok = 14 | { Number = 201; Range = rng; Message = sprintf "Unexpected %s after '.' in method chain" (formatTokenInfo tok) } 15 | 16 | let unexpectedScopeEndAfterDot rng tok = 17 | { Number = 202; Range = rng; Message = sprintf "Unexpected end of scope after %s. Did you forget to indent the rest of the member chain?" (formatTokenInfo tok) } 18 | 19 | let unexpectedTokenInPlaceholder rng tok = 20 | { Number = 203; Range = rng; Message = sprintf "Unexpected token '%s' in placeholder expression. Shold be `[ident: ]`" (formatTokenInfo tok) } 21 | 22 | let unexpectedScopeEndInPlaceholder rng tok = 23 | if Option.isSome tok then { Number = 204; Range = rng; Message = sprintf "Unexpected end of scope in placeholder after %s. Did you forget to indent the body of the plceholder?" (formatTokenInfo tok.Value) } 24 | else { Number = 204; Range = rng; Message = "Unexpected end of scope in placeholder after expression. Did you forget to indent the body of the plceholder?" } 25 | 26 | let unexpectedEndOfPlaceholder rng = 27 | { Number = 205; Range = rng; Message = "Incomplete placeholder expression. Shold be `[ident: ]`" } 28 | 29 | let unexpectedEndAfterOperator rng op = 30 | { Number = 206; Range = rng; Message = sprintf "Unexpected token after operator '%s'. Expected an expression or closing parenthesis." (formatTokenInfo op) } 31 | 32 | let unexpectedTokenInArgList rng tok = 33 | { Number = 207; Range = rng; Message = sprintf "Unexpected token '%s' in list of call arguments" (formatTokenInfo tok) } 34 | 35 | let unexpectedScopeEndInArgList rng = 36 | { Number = 208; Range = rng; Message = "Unexpected end of argument list. Did you forget to indent the arguments?" } 37 | 38 | let unexpectedTokenInParenthesizedExpr rng tok = 39 | { Number = 209; Range = rng; Message = sprintf "Unexpected token '%s' in parenthesized expression. Are you missing ')'?" (formatTokenInfo tok) } 40 | 41 | let unexpectedScopeEndInParenthesizedExpr rng = 42 | { Number = 210; Range = rng; Message = "Unexpected end of nested expression in `(`. Did you forget to indent the body of the expression?" } 43 | 44 | let missingParenthesizedExpr rng = 45 | { Number = 211; Range = rng; Message = "The parenthesized expression (...) is missing body!" } 46 | 47 | let unexpectedTokenInList rng tok = 48 | { Number = 212; Range = rng; Message = sprintf "Unexpected token '%s' in list expression" (formatTokenInfo tok) } 49 | 50 | let unexpectedScopeEndInList rng = 51 | { Number = 213; Range = rng; Message = "Unexpected end of list expression. Did youu forget to indent the elements of the list?" } 52 | 53 | let unexpectedTokenInLetBinding rng tok = 54 | { Number = 214; Range = rng; Message = sprintf "Unexpected token '%s' in let declaration (should be `let name = expr`)" (formatTokenInfo tok) } 55 | 56 | let missingBodyInLetBinding rng = 57 | { Number = 215; Range = rng; Message = "This let binding is missing body after equals (should be `let name = expr`" } 58 | 59 | let unexpectedNestedTokenInCommand rng tok = 60 | { Number = 216; Range = rng; Message = sprintf "Unexpected indented token '%s' in command list. Try removing the indentation before the token." (formatTokenInfo tok) } 61 | 62 | let unexpectedTokenAfterFun rng tok = 63 | { Number = 217; Range = rng; Message = sprintf "Unexpected token '%s' after `fun`. Expected variable name." (formatTokenInfo tok) } 64 | 65 | let missingArrowInFunc rng = 66 | { Number = 218; Range = rng; Message = "Missing arrow after variable in function definition" } 67 | 68 | let unexpectedScopeEndInFunc rng = 69 | { Number = 219; Range = rng; Message = "Unexpected end of function declaration. Did you forget to indent the body of the function?" } 70 | 71 | let missingBodyOfFunc rng = 72 | { Number = 220; Range = rng; Message = "The function is missing body. Did you forget to indent the body of the function?" } 73 | 74 | let unexpectedScopeEndInLet rng = 75 | { Number = 221; Range = rng; Message = "Unexpected end of let declaration. Did you forget to indent the body of the let declaration?" } 76 | 77 | let exceptionWhileParsing rng msg = 78 | { Number = 299; Range = rng; Message = "Unexpected exception while parsing: " + msg } 79 | 80 | 81 | module TypeChecker = 82 | let numericOperatorExpectsNumbers op idx typs typ rng = 83 | { Number = 301; Range = rng 84 | Message = 85 | sprintf "Both operands of binary operator '%s' should be %s but the %s operand was %s instead." 86 | (String.concat " or " (List.map formatTypeInfo typs)) 87 | (formatToken (TokenKind.Operator op)) (if idx = 0 then "left" else "right") (formatTypeInfo typ) } 88 | 89 | let variableNotInScope name rng = 90 | { Number = 302; Range = rng 91 | Message = sprintf "Variable '%s' is not in scope." name } 92 | 93 | let private formatMembers (members:seq) = 94 | let members = members |> Array.ofSeq 95 | let suffix = if members.Length > 10 then sprintf ", (%d members)" (members.Length - 10) else "" 96 | (String.concat ", " [ for m in members -> m.Name ]) + suffix 97 | 98 | let memberMissing name members rng = 99 | { Number = 303; Range = rng 100 | Message = sprintf "Could not find property '%s' in the list '%s'." name (formatMembers members) } 101 | 102 | let notAnObject name typ rng = 103 | { Number = 305; Range = rng 104 | Message = sprintf "Type is not an object but %s and it does not have member `%s`" (formatTypeInfo typ) name } 105 | 106 | let listElementTypeDoesNotMatch listty elty rng = 107 | { Number = 306; Range = rng 108 | Message = sprintf "The type of this list element is %s but it should be %s" (formatTypeInfo elty) (formatTypeInfo listty) } 109 | 110 | let nameBasedParamMustBeLast rng = 111 | { Number = 307; Range = rng 112 | Message = "All named parameters must be at the end of parameter list." } 113 | 114 | let parameterMissingValue par rng = 115 | { Number = 308; Range = rng 116 | Message = sprintf "Required parameter `%s` is not given a value." par } 117 | 118 | let notAnMethod name typ rng = 119 | { Number = 309; Range = rng 120 | Message = sprintf "The type of member %s is `%s` and not a method and so it cannot be called." name (formatTypeInfo typ) } 121 | 122 | (* 123 | let incorrectParameterType parName parType actualType err1 err2 rng = 124 | { Number = 309; Range = rng 125 | Message = 126 | sprintf "The value of parameter `%s` has wrong type. Expected %s but got %s. The type %s does not match the type %s." 127 | parName (formatTypeInfo parType) (formatTypeInfo actualType) (formatTypeInfo err1) (formatTypeInfo err2) } 128 | 129 | let inferenceConflict var t1 t2 rng = 130 | { Number = 310; Range = rng 131 | Message = 132 | sprintf "The arguments of the call have conflicting types. The type %s assigned to a variable %s does not match the type %s." 133 | (formatTypeInfo t1) var (formatTypeInfo t2) } 134 | *) 135 | let parameterConflict rng = 136 | { Number = 310; Range = rng 137 | Message = "Invalid argument type" } 138 | 139 | let callMissingInstance name rng = 140 | { Number = 311; Range = rng 141 | Message = sprintf "The `%s` property access or call is missing an instance" name } 142 | -------------------------------------------------------------------------------- /src/thegamma/ast/typeops.fs: -------------------------------------------------------------------------------- 1 | module TheGamma.Types 2 | open TheGamma.Common 3 | 4 | // ------------------------------------------------------------------------------------------------ 5 | // Helper functions for working with types 6 | // ------------------------------------------------------------------------------------------------ 7 | 8 | let rec listsEqual l1 l2 f = 9 | match l1, l2 with 10 | | [], [] -> true 11 | | x::xs, y::ys when f x y -> listsEqual xs ys f 12 | | _ -> false 13 | 14 | let optionsEqual o1 o2 f = 15 | match o1, o2 with 16 | | None, None -> true 17 | | Some v1, Some v2 -> f v1 v2 18 | | _ -> false 19 | 20 | let rec typesEqual t1 t2 = 21 | match t1, t2 with 22 | | Type.Any, _ | _, Type.Any -> true 23 | | Type.List t1, Type.List t2 -> typesEqual t1 t2 24 | | Type.Method(a1, r1), Type.Method(a2, r2) -> 25 | optionsEqual (r1 [for ma in a1 -> ma.Type, None]) (r2 [for ma in a2 -> ma.Type, None]) typesEqual && 26 | listsEqual a1 a2 (fun m1 m2 -> m1.Name = m2.Name && m1.Optional = m2.Optional && m1.Static = m2.Static && typesEqual m1.Type m2.Type) 27 | | Type.Object(o1), Type.Object(o2) -> o1.TypeEquals(o2) 28 | | Type.Primitive n1, Type.Primitive n2 -> n1 = n2 29 | | _ -> false 30 | -------------------------------------------------------------------------------- /src/thegamma/blocks.fs: -------------------------------------------------------------------------------- 1 | module TheGamma.Blocks 2 | 3 | open Fable.Import.Browser 4 | open TheGamma.Common 5 | open TheGamma.Html 6 | open TheGamma.Ast 7 | open TheGamma.TypeProviders.FSharpProvider 8 | 9 | open System 10 | 11 | let getEntity (svc:Services.CheckingService) code = async { 12 | let! success, bound, prog = svc.TypeCheck("let it = " + code) 13 | let _, ent = bound.Entities |> Seq.find (function (_, { Kind = EntityKind.Variable({ Name = "it" }, _) }) -> true | _ -> false) 14 | let _, prog = bound.Entities |> Seq.find (function (_, { Kind = EntityKind.Program _ }) -> true | _ -> false) 15 | let errors = TypeChecker.collectTypeErrors prog 16 | let errors = [ for e in errors -> code.Substring(e.Range.Start, e.Range.End - e.Range.Start + 1), e.Message ] 17 | return errors, ent } 18 | 19 | 20 | type Event = 21 | | RemoveLast 22 | | AddElement of string 23 | | UpdateParameter of string * string 24 | 25 | type State = 26 | { CheckingService : Services.CheckingService 27 | Globals : Entity list 28 | Chain : list 29 | Completions : string[] 30 | Entity : Entity option } 31 | static member Create(svc, globals) = 32 | { CheckingService = svc; Globals = globals 33 | Entity = None; Chain = []; Completions = [||] } 34 | 35 | let getTypeName state = 36 | match state.Entity with 37 | | Some { Type = Some(Type.Object(:? GenericType as s)) } -> s.TypeDefinition.FullName 38 | | _ -> "object" 39 | 40 | 41 | let formatChain chain = 42 | chain 43 | |> List.rev 44 | |> List.map (fun (id, args) -> 45 | Ast.escapeIdent id + 46 | match args with 47 | | Some args -> "(" + String.concat ", " (List.map snd args) + ")" 48 | | None -> "") 49 | |> String.concat "." 50 | 51 | 52 | let updateCompletions state = async { 53 | let! state = state 54 | match state with 55 | | { Chain = [] } -> 56 | return { state with Completions = [| for g in state.Globals -> g.Name |] } 57 | | { Chain = chain } -> 58 | let code = formatChain chain 59 | let! errs, ent = getEntity state.CheckingService code 60 | match errs, ent with 61 | | [], { Type = Some(Type.Object(obj)) } -> 62 | let compls = [| for m in obj.Members do if m.Name <> "preview" then yield m.Name |] 63 | return { state with Entity = Some ent; Completions = compls } 64 | | _ -> 65 | return { state with Entity = Some ent; Completions = [||] } } 66 | 67 | 68 | let update state evt = updateCompletions <| async { 69 | match evt, state with 70 | | RemoveLast, { Chain = [] } 71 | | RemoveLast, { Chain = [_] } -> 72 | return { state with Chain = []; Entity = None } 73 | | RemoveLast, { Chain = _::chain } -> 74 | return { state with Chain = chain } 75 | 76 | | AddElement(m), _ -> 77 | let code = formatChain ((m, None)::state.Chain) 78 | let! errs, ent = getEntity state.CheckingService code 79 | match ent with 80 | | { Type = Some(Type.Method(args, _)) } -> 81 | return { state with Chain = (m, Some [ for a in args -> a.Name, "" ])::state.Chain } 82 | | _ -> 83 | return { state with Chain = (m, None)::state.Chain } 84 | 85 | | UpdateParameter(p, v), { Chain = (m, Some pars)::rest } -> 86 | let newPars = pars |> List.map (fun (po, vo) -> if p = po then p, v else po, vo) 87 | return { state with Chain = (m, Some newPars)::rest } 88 | 89 | | _ -> return state } 90 | 91 | 92 | let tryGetPreview state = 93 | let (|Evaluate|) (l:Lazy<_>) = l.Value 94 | match state.Entity with 95 | | Some ent -> 96 | Interpreter.evaluate state.Globals ent |> ignore 97 | match ent.Value with 98 | | Some { Preview = Evaluate (Some preview) } -> 99 | let mutable node = h?div ["id" => "blockspreview"] [text "Loading preview..."] 100 | let mutable returned = false 101 | async { let! nd = table.create(unbox> preview).render() 102 | if returned then nd |> renderTo (document.getElementById "blockspreview") 103 | else node <- nd } |> Async.StartImmediate 104 | returned <- true 105 | node 106 | | _ -> h?div [] [text "Preview has no value"] 107 | | _ -> h?div [] [text "No preview available"] 108 | 109 | 110 | let render trigger state = 111 | h?div ["class" => "pilleditor"] [ 112 | h?ul ["class" => "pills"] [ 113 | let renderCoreChain (chain:list<_ * _ option>) = 114 | [ for id, pars in List.rev chain -> 115 | h?li [] [ text (id + if pars.IsSome then " (...)" else "") ] ] 116 | 117 | let renderChain removeLast chain = 118 | match removeLast, chain with 119 | | true, (last, _)::rest -> 120 | renderCoreChain rest @ 121 | [ h?li [] [ text last; h?a ["click" =!> fun _ _ -> trigger RemoveLast ] [ h?i ["class" => "gfa gfa-times"] [] ] ] ] 122 | | _, rest -> 123 | renderCoreChain rest 124 | 125 | match state.Chain with 126 | | (meth, Some pars)::rest -> yield! renderChain false rest 127 | | chain -> yield! renderChain true chain 128 | 129 | match state.Chain with 130 | | (meth, Some pars)::rest -> 131 | yield h?li [] [ 132 | yield text (meth + "(") 133 | for p, v in pars do 134 | yield text (p + " = ") 135 | yield h?input ["type"=>"text"; "value"=>v; "input" =!> fun el _ -> 136 | trigger (UpdateParameter(p, (unbox el).value)) ] [] 137 | yield text ")" 138 | yield h?a ["click" =!> fun _ _ -> trigger RemoveLast ] [ h?i ["class" => "gfa gfa-times"] [] ] 139 | ] 140 | | _ -> () 141 | 142 | if state.Completions.Length > 0 then 143 | yield h?li [] [ 144 | h?div ["class" => "selectwrapper"] [ 145 | h?select [ "change" =!> fun el _ -> trigger(AddElement((unbox el).value)) ] [ 146 | yield h?option [] [text "(choose an operation to add)"] 147 | for s in state.Completions -> h?option [ "value" => s ] [ text s ] 148 | ] 149 | ] 150 | ] 151 | ] 152 | 153 | tryGetPreview state 154 | 155 | h?p [] [ text (getTypeName state) ] 156 | ] 157 | 158 | let createBlockEditor svc globals id = Async.StartImmediate <| async { 159 | try 160 | let! globals = globals |> Async.AwaitFuture 161 | let state = State.Create(svc, globals) 162 | let! state = 163 | //["olympics"; "group data"; "by Games"; "average Year"] 164 | //["olympics"; "paging"; "take"] 165 | ["enigma"] 166 | |> List.fold (fun st s -> async { let! st = st in return! update st (AddElement(s)) }) (async.Return state) 167 | createVirtualDomAsyncApp id state render update 168 | with e -> 169 | Log.exn("system", "Something went wrong: %O", e) 170 | } 171 | 172 | 173 | 174 | 175 | 176 | -------------------------------------------------------------------------------- /src/thegamma/codegen/codegen.fs: -------------------------------------------------------------------------------- 1 | // ------------------------------------------------------------------------------------------------ 2 | // Code generator is used to compile complete well-typed programs 3 | // ------------------------------------------------------------------------------------------------ 4 | module TheGamma.CodeGenerator 5 | 6 | open TheGamma 7 | open TheGamma.Babel 8 | open TheGamma.Babel.BabelOperators 9 | open TheGamma.Common 10 | 11 | // ------------------------------------------------------------------------------------------------ 12 | // Compiling code to Babel AST 13 | // ------------------------------------------------------------------------------------------------ 14 | 15 | type CompilationContext = 16 | { LineLengths : int list 17 | Globals : Map } 18 | 19 | let rec offsetToLocation lines offs lengths = 20 | match lengths with 21 | | l::lengths when offs <= l -> { line = lines; column = offs } 22 | | l::lengths -> offsetToLocation (lines+1) (offs-l-1) lengths 23 | | [] -> failwith "offsetToLocation: Out of range" 24 | 25 | let rangeToLoc ctx rng = 26 | { start = offsetToLocation 1 rng.Start ctx.LineLengths 27 | ``end`` = offsetToLocation 1 rng.Start ctx.LineLengths } |> Some 28 | 29 | let rec getMember name typ = 30 | match typ with 31 | | Type.Object(o) -> 32 | match o.Members |> Seq.tryPick (fun m -> if m.Name = name then Some(m) else None) with 33 | | Some res -> res 34 | | _ -> 35 | Log.exn("codegen", "getMember: Member %s not found in object %O", name, o) 36 | failwith "getMember: Member not found" 37 | | t -> 38 | Log.exn("codegen", "getMember: Not an object %O", t) 39 | failwith "getMember: Not an object" 40 | 41 | let rec compileExpression ctx (expr:Node) = 42 | Log.trace("codegen", "Compiling expression: %O", expr) 43 | match expr.Node with 44 | // Binary operators map to BinaryExpression, except for pow, which is a JS function 45 | | Expr.Binary(l, { Node = Operator.Power }, r) -> 46 | let l = compileExpression ctx l 47 | let r = compileExpression ctx r 48 | let rng = rangeToLoc ctx expr.Range 49 | let pow = ident("Math")?pow 50 | CallExpression(pow, [l; r], rangeToLoc ctx expr.Range) 51 | 52 | | Expr.Binary(l, op, r) -> 53 | let l = compileExpression ctx l 54 | let r = compileExpression ctx r 55 | let op = 56 | match op.Node with 57 | | Operator.Modulo -> BinaryModulus 58 | | Operator.Equals -> BinaryEqualStrict 59 | | Operator.Plus -> BinaryPlus 60 | | Operator.Minus -> BinaryMinus 61 | | Operator.Multiply -> BinaryMultiply 62 | | Operator.Divide -> BinaryDivide 63 | | Operator.GreaterThan -> BinaryGreater 64 | | Operator.LessThan -> BinaryLess 65 | | Operator.GreaterThanOrEqual -> BinaryGreaterOrEqual 66 | | Operator.LessThanOrEqual -> BinaryLessOrEqual 67 | | Operator.Power -> failwith "compileExpression: Power is not a binary operator" 68 | BinaryExpression(op, l, r, rangeToLoc ctx expr.Range) 69 | 70 | // Handle member access and calls - method call is a combination of the two 71 | | Expr.Member(inst, { Node = Expr.Placeholder(_, { Node = Expr.Variable n }) }) 72 | | Expr.Member(inst, { Node = Expr.Variable n }) -> 73 | let mem = getMember n.Node.Name inst.Entity.Value.Type.Value 74 | let inst = compileExpression ctx inst 75 | mem.Emitter.Emit(inst) 76 | 77 | | Expr.Member(inst, _) -> 78 | failwith "compileExpression: Member in member access is not a variable" 79 | 80 | | Expr.Call(inst, args) -> 81 | // Split arguments between position & name based 82 | let compiledArgs = args.Node |> List.map (fun a -> a.Name, compileExpression ctx a.Value) 83 | let positionArgs = compiledArgs |> Seq.takeWhile (fun (n, _) -> n.IsNone) |> Seq.map snd |> Array.ofSeq 84 | let namedArgs = compiledArgs |> Seq.choose (function (Some n, a) -> Some(n.Node.Name, a) | _ -> None) |> dict 85 | 86 | // Get expected arguments from the method type 87 | let expectedArgs = 88 | match inst.Entity.Value.Type.Value with 89 | | Type.Method(args, resTy) -> args 90 | | _ -> [] 91 | 92 | // Compile the instance, the arguments and call the emitter 93 | let inst = compileExpression ctx inst 94 | let pars = expectedArgs |> List.mapi (fun i ma -> 95 | if i < positionArgs.Length then positionArgs.[i] 96 | elif namedArgs.ContainsKey ma.Name then namedArgs.[ma.Name] 97 | else NullLiteral(rangeToLoc ctx args.Range)) 98 | CallExpression(inst, pars, rangeToLoc ctx expr.Range) 99 | 100 | // Variables and literals are easy 101 | | Expr.Variable(n) when ctx.Globals.ContainsKey(n.Node.Name) -> 102 | ctx.Globals.[n.Node.Name] 103 | | Expr.Variable(n) -> 104 | IdentifierExpression(n.Node.Name, rangeToLoc ctx n.Range) 105 | 106 | | Expr.Number(n) -> 107 | NumericLiteral(n, rangeToLoc ctx expr.Range) 108 | | Expr.String(s) -> 109 | StringLiteral(s, rangeToLoc ctx expr.Range) 110 | | Expr.Boolean(b) -> 111 | BooleanLiteral(b, rangeToLoc ctx expr.Range) 112 | 113 | // Other constructs that map fairly directly to JS 114 | | Expr.Placeholder(_, body) -> 115 | compileExpression ctx body 116 | 117 | | Expr.List(es) -> 118 | let es = List.map (compileExpression ctx) es 119 | ArrayExpression(es, rangeToLoc ctx expr.Range) 120 | 121 | | Expr.Function(n, e) -> 122 | let var = IdentifierExpression(n.Node.Name, rangeToLoc ctx n.Range) 123 | let ce = compileExpression { ctx with Globals = Map.add n.Node.Name var ctx.Globals } e 124 | let body = BlockStatement([ReturnStatement(ce, rangeToLoc ctx e.Range)], rangeToLoc ctx e.Range) 125 | FunctionExpression(None, [IdentifierPattern(n.Node.Name, rangeToLoc ctx n.Range)], body, false, false, rangeToLoc ctx expr.Range) 126 | 127 | // Empty expressions should not happen... 128 | | Expr.Empty -> 129 | Log.error("codegen", "getEmitterAndParams: Empty expression in the AST") 130 | NullLiteral(rangeToLoc ctx expr.Range) 131 | 132 | 133 | let compileCommand ctx idx (cmd:Node) = 134 | let loc = rangeToLoc ctx cmd.Range 135 | let statements, idx, assign = 136 | match cmd.Node with 137 | | Command.Let(n, e) -> 138 | let e = compileExpression ctx e 139 | let name = IdentifierPattern(n.Node.Name, rangeToLoc ctx n.Range) 140 | let decl = VariableDeclarator(name, Some e, loc) 141 | [ VariableDeclaration(Var, [decl], rangeToLoc ctx cmd.Range) ], 142 | str(n.Node.Name), ident(n.Node.Name) 143 | 144 | | Command.Expr(e) -> 145 | [], num(float idx), compileExpression ctx e 146 | 147 | let res = MemberExpression(ident("_results"), idx, true, loc) 148 | statements @ [ ExpressionStatement(AssignmentExpression(AssignEqual, res, assign, loc), loc) ] 149 | 150 | let compileProgram ctx (prog:TheGamma.Program) = 151 | let decl = VariableDeclarator(IdentifierPattern("_results", None), Some (ArrayExpression([], None)), None) 152 | let res = VariableDeclaration(Var, [decl], None) 153 | let body = List.mapi (compileCommand ctx) prog.Body.Node |> List.concat 154 | 155 | let ret = ReturnStatement(ident("_results"), None) 156 | let body = BlockStatement(res :: body @ [ ret ], None) 157 | let body = CallExpression(FunctionExpression(None, [], body, false, false, None), [], None) 158 | { location = rangeToLoc ctx prog.Body.Range; body = [ ExpressionStatement(body, None) ] } 159 | 160 | // ------------------------------------------------------------------------------------------------ 161 | // Cmpile program and return JS source code 162 | // ------------------------------------------------------------------------------------------------ 163 | 164 | open Fable.Helpers.Babel 165 | 166 | let compile globals (text:string) prog = async { 167 | try 168 | let! globals = Async.AwaitFuture globals 169 | let globals = 170 | globals |> List.choose (function 171 | | { Kind = EntityKind.GlobalValue(n, Some e) } -> Some(n.Name, e) 172 | | _ -> None ) |> Map.ofSeq 173 | let ctx = { LineLengths = [ for l in text.Split('\n') -> l.Length ]; Globals = globals } 174 | let res = compileProgram ctx prog 175 | let code = babel.transformFromAst(Serializer.serializeProgram res, text, { presets = [| "es2015" |] }) 176 | Log.trace("codegen", "Evaluating: %O", code) 177 | return code.code 178 | 179 | with e -> 180 | Log.exn("codegen", "Evaluating code failed: %O", e) 181 | return "" } 182 | -------------------------------------------------------------------------------- /src/thegamma/codegen/runtime.fs: -------------------------------------------------------------------------------- 1 | module TheGamma.TypeProvidersRuntime 2 | open System 3 | open TheGamma.Common 4 | 5 | let convertTupleSequence f g data = async { 6 | let! values = data 7 | return values |> Array.map (fun (a, b) -> f a, g b) } 8 | 9 | let convertSequence f data = async { 10 | let! values = data 11 | return values |> Array.map f } 12 | 13 | let trimLeft c (s:string) = s.ToCharArray() |> Array.skipWhile ((=) c) |> System.String 14 | let trimRight c (s:string) = s.ToCharArray() |> Array.rev |> Array.skipWhile ((=) c) |> Array.rev |> System.String 15 | 16 | let concatUrl (a:string) (b:string) = 17 | (trimRight '/' a) + "/" + (trimLeft '/' b) 18 | 19 | type RuntimeContext(root:string, cookies:string, trace:string) = 20 | member x.root = root 21 | member x.trace = trace 22 | 23 | member x.addTrace(suffix) = 24 | let traces = 25 | [ if not (String.IsNullOrEmpty trace) then yield trace 26 | if not (String.IsNullOrEmpty suffix) then yield suffix ] 27 | RuntimeContext(root, cookies, String.concat "&" traces) 28 | 29 | member x.getValue(endpoint:string) = 30 | async { 31 | let! res = Http.Request("POST", concatUrl root endpoint, trace, cookies) 32 | // TODO: This is wrong - it may return an integer too! 33 | return jsonParse res } 34 | 35 | type PivotContext(root, calls) = 36 | member x.addCall(callid:string, values:obj[]) = 37 | let values = values |> Array.map (fun v -> 38 | if isDate v then box (toISOString v) else v) 39 | PivotContext(root, Array.append [| callid, values |] calls) 40 | 41 | member x.getData(conv:obj -> obj, tfs:string, isPreview) = async { 42 | let url = calls |> Array.fold (fun (tfs:string) (id, vals) -> 43 | let vals = String.concat "," (Seq.map string vals) 44 | tfs.Replace(id, string vals)) tfs 45 | let url = Fable.Import.JS.encodeURIComponent url 46 | let url = root + "?" + url + if isPreview then "&preview" else "" 47 | Log.trace("runtime", "Pivot: %s", url) 48 | let! res = Http.Request("GET", url) 49 | return jsonParse res |> Array.map conv } 50 | -------------------------------------------------------------------------------- /src/thegamma/common/locations.fs: -------------------------------------------------------------------------------- 1 | namespace TheGamma 2 | 3 | /// Represents range in 1-based line / 1-based column format 4 | type LineColumnRange = 5 | { StartLineNumber : int 6 | StartColumn : int 7 | EndLineNumber : int 8 | EndColumn : int } 9 | 10 | type LocationMapper(code:string) = 11 | // ResizeArray is workaround for "TypeError: TypedArray.from requires its this argument subclass a TypedArray constructor" in Safari 12 | let lengths = ResizeArray<_>(code.Split('\n') |> Seq.map (fun s -> s.Length)) 13 | 14 | /// Convert absolute 0-based location to 1-based line and 1-based column location 15 | member x.AbsoluteToLineCol(offs) = 16 | let mutable line = 0 17 | let mutable col = 0 18 | let mutable offs = offs 19 | while line <= lengths.Count && offs > lengths.[line] do 20 | offs <- offs - lengths.[line] - 1 21 | line <- line + 1 22 | line + 1, offs + 1 23 | 24 | /// Convert 1-based line and 1-based column location to an absolute 0-based location 25 | member x.LineColToAbsolute(line, col) = 26 | let mutable offs = 0 27 | for l in 1 .. line-1 do offs <- offs + lengths.[l-1] + 1 28 | offs + col - 1 29 | 30 | -------------------------------------------------------------------------------- /src/thegamma/live/live.fs: -------------------------------------------------------------------------------- 1 | // ------------------------------------------------------------------------------------------------ 2 | // Shared components for creating live previews 3 | // ------------------------------------------------------------------------------------------------ 4 | module TheGamma.Live.Common 5 | 6 | open TheGamma 7 | open Fable.Import 8 | 9 | type CustomLiveState = interface end 10 | type CustomLiveEvent = interface end 11 | type LiveEditorZone = { Line:int; Preview:Html.DomNode } 12 | 13 | type LivePreview<'TState, 'TEvent> = 14 | { ID : string 15 | Update : (LiveEvent<'TEvent> -> unit) -> LiveState<'TState> -> LiveEvent<'TEvent> -> LiveState<'TState> option 16 | Render : (LiveEvent<'TEvent> -> unit) -> LiveState<'TState> -> LiveEditorZone option 17 | InitialState : 'TState } 18 | 19 | and LiveState<'T> = 20 | { // Initialized once - global values 21 | Globals : seq 22 | // Updated when code changes - parsed program 23 | Code : string 24 | Program : Program 25 | Mapper : LocationMapper 26 | // Updated when cursor moves 27 | Location : int 28 | // Instructing the event loop to do things to the editor 29 | Selection : option 30 | 31 | State : 'T 32 | CurrentPreview : option> } 33 | 34 | and LiveEvent<'T> = 35 | | InitializeGlobals of seq 36 | | UpdateSource of string * int * Program * LocationMapper 37 | | UpdateLocation of int 38 | | CustomEvent of 'T 39 | 40 | let updateLiveState state event = 41 | match event with 42 | | InitializeGlobals(globals) -> 43 | { state with Globals = globals } 44 | | UpdateLocation(loc) -> 45 | { state with Location = loc } 46 | | UpdateSource(code, loc, program, mapper) -> 47 | { state with Location = loc; Program = program; Code = code; Mapper = mapper } 48 | | CustomEvent _ -> state 49 | 50 | // ------------------------------------------------------------------------------------------------ 51 | // Generally usefl functions for previews 52 | // ------------------------------------------------------------------------------------------------ 53 | 54 | open TheGamma.Ast 55 | 56 | /// Represents a chain such as `foo.bar(1).goo`, potentially 57 | /// inside a command (that may contain things like `let` etc.) 58 | type NestedChain = 59 | { // List containing Expr.Member, Expr.Call and Expr.Variable nodes 60 | // from a call chain with their starting offset 61 | Chain : (int * Node) list } 62 | 63 | let rec collectChain acc node = 64 | match node.Node with 65 | | Expr.Call(e, a) -> collectChain ((a.Range.Start, node)::acc) e 66 | | Expr.Member(e, n) -> collectChain ((n.Range.Start, node)::acc) e 67 | | Expr.Variable(n) -> Some((n.Range.Start, node)::acc) 68 | | _ -> None 69 | 70 | let rec collectFirstChain expr = 71 | match collectChain [] expr with 72 | | Some((_::_) as chain) -> Some { Chain = chain } 73 | | _ -> 74 | match expr with 75 | | { Node = ExprNode(es, ns) } -> es |> Seq.tryPick collectFirstChain 76 | | _ -> None 77 | -------------------------------------------------------------------------------- /src/thegamma/live/showable.fs: -------------------------------------------------------------------------------- 1 | // ------------------------------------------------------------------------------------------------ 2 | // Live preview for anything with 'show' method 3 | // ------------------------------------------------------------------------------------------------ 4 | module TheGamma.Live.Showable 5 | 6 | open Fable.Core 7 | open Fable.Import 8 | open Fable.Import.Browser 9 | 10 | open TheGamma 11 | open TheGamma.Ast 12 | open TheGamma.Html 13 | open TheGamma.Live.Common 14 | open TheGamma.Common 15 | open TheGamma.TypeChecker 16 | open TheGamma.TypeProviders 17 | 18 | module FsOption = Microsoft.FSharp.Core.Option 19 | 20 | // ------------------------------------------------------------------------------------------------ 21 | // 22 | // ------------------------------------------------------------------------------------------------ 23 | 24 | let commandAtLocation loc (program:Program) = 25 | program.Body.Node |> List.tryFind (fun cmd -> 26 | cmd.Range.Start <= loc && cmd.Range.End + 1 >= loc) 27 | 28 | type ShowableEditorState = 29 | { EndLocation : int 30 | Preview : DomNode 31 | PreviewSymbol : Symbol 32 | PreviewID : int 33 | } 34 | 35 | [] 36 | let callShow (inst:obj) (id:string) : unit = failwith "JS" 37 | 38 | let (|HasShow|_|) = function 39 | | Type.Object obj -> 40 | let hasShow = obj.Members |> Array.exists (function 41 | | { Name="show"; Type=Type.Method([{ Type = Type.Primitive PrimitiveType.String }], _) } -> true 42 | | _ -> false) 43 | if hasShow then Some() else None 44 | | _ -> None 45 | 46 | let updateBody trigger state = 47 | Log.trace("live", "Showable - updating body") 48 | match commandAtLocation state.Location state.Program with 49 | | Some({ Node = Command.Let(_, e); Entity = Some { Kind = EntityKind.LetCommand(_, ent) } } as cmd) 50 | | Some({ Node = Command.Expr e; Entity = Some { Kind = EntityKind.RunCommand ent } } as cmd) -> 51 | let chain = collectFirstChain e 52 | match ent.Type.Value, chain with 53 | | HasShow, _ -> 54 | match Interpreter.evaluate state.Globals ent with 55 | | Some res -> 56 | let id = 57 | if ent.Symbol <> state.State.PreviewSymbol then state.State.PreviewID + 1 58 | else state.State.PreviewID 59 | let placeholder = h?div ["class"=>"placeholder"] [text "Loading preview..."] 60 | let dom = h?div [] [h.delayed (string id) placeholder (fun id -> 61 | Log.trace("live", "Show: %O", res.Value) 62 | callShow res.Value id 63 | )] 64 | Some { state with State = { PreviewSymbol = ent.Symbol; PreviewID = id; EndLocation = cmd.Range.End; Preview = dom } } 65 | | _ -> None 66 | 67 | | _, Some chain -> 68 | chain.Chain |> Seq.sortByDescending fst |> Seq.tryPick (fun (_, node) -> 69 | let nm = { Name.Name="preview" } 70 | match node.Entity.Value.Type with 71 | | Some(Type.Object(FindMember nm m)) -> 72 | match pickMetaByType "http://schema.org" "WebPage" m.Metadata with 73 | | Some meta -> 74 | let url = getProperty meta "url" 75 | let dom = h?iframe [ "src" => url ] [] 76 | let id = state.State.PreviewID + 1 77 | Some { state with State = { PreviewSymbol = ent.Symbol; PreviewID = id; EndLocation = cmd.Range.End; Preview = dom } } 78 | | _ -> None 79 | | _ -> None) 80 | 81 | | _ -> None 82 | | _ -> None 83 | 84 | 85 | let rec updateShowableState trigger state event = 86 | match event with 87 | | UpdateSource _ 88 | | UpdateLocation _ -> state |> updateBody trigger 89 | | InitializeGlobals _ 90 | | CustomEvent () -> Some state 91 | 92 | let renderShowable trigger (state:LiveState<_>) = 93 | let endLine, _ = state.Mapper.AbsoluteToLineCol(state.State.EndLocation) 94 | let dom = 95 | h?div [ "class" => "pivot-preview" ] [ 96 | h?ul ["class" => "tabs"] [ 97 | h?li ["class" => "selected"] [ h?a [] [ text "preview" ] ] 98 | ] 99 | h?div ["class" => "preview-body"] [ 100 | yield state.State.Preview 101 | ] 102 | ] 103 | Some { Line = endLine; Preview = dom } 104 | 105 | 106 | // ------------------------------------------------------------------------------------------------ 107 | // 108 | // ------------------------------------------------------------------------------------------------ 109 | 110 | let preview = 111 | { ID = "Showable" 112 | Update = updateShowableState 113 | Render = renderShowable 114 | InitialState = { PreviewID = 0; PreviewSymbol = createSymbol(); EndLocation = 0; Preview = text "not created" } } -------------------------------------------------------------------------------- /src/thegamma/monaco.fs: -------------------------------------------------------------------------------- 1 | module TheGamma.Monaco 2 | 3 | open Fable.Core 4 | open Fable.Import.monaco 5 | open Fable.Import.Browser 6 | 7 | open TheGamma.Common 8 | open TheGamma.Services 9 | open TheGamma.TypeChecker 10 | open Fable.Core.JsInterop 11 | 12 | [] 13 | let hack : unit = () 14 | hack 15 | 16 | let noState = 17 | { new languages.IState with 18 | member this.clone() = this 19 | member this.equals(other) = true } 20 | 21 | let getColorClass = function 22 | | TokenKind.String _ -> "string" 23 | | TokenKind.QIdent _ | TokenKind.Ident _ -> "ident" 24 | | TokenKind.Dot _ -> "operator" 25 | | TokenKind.Let | TokenKind.Boolean _ | TokenKind.Fun | TokenKind.Arrow -> "keyword" 26 | | TokenKind.Number _ -> "number" 27 | | _ -> "" 28 | 29 | let tokensProvider = 30 | { new languages.TokensProvider with 31 | member this.tokenize(line, state) = 32 | let tokens = JsInterop.createEmpty 33 | tokens.endState <- noState 34 | tokens.tokens <- ResizeArray() 35 | 36 | let tokenized, _ = Tokenizer.tokenize line 37 | for t in tokenized do 38 | let tok = JsInterop.createEmpty 39 | tok.startIndex <- float t.Range.Start 40 | tok.scopes <- Fable.Core.U2.Case1 (getColorClass t.Token) 41 | tokens.tokens.Add(tok) 42 | 43 | tokens 44 | member this.getInitialState() = noState } 45 | 46 | let createCompletionProvider (getService:string -> CheckingService) = 47 | { new languages.CompletionItemProvider with 48 | member this.triggerCharacters = Some(ResizeArray [| for i in 0 .. 255 -> string (char i) |]) 49 | member this.provideCompletionItems(model, position, token) = 50 | async { 51 | try 52 | let svc = getService (model.uri.toString()) 53 | 54 | let input = model.getValue(editor.EndOfLinePreference.LF, false) 55 | Log.event("editor", "completions", "", JsInterop.createObj ["source", box input; "position", box position]) 56 | 57 | let conv = LocationMapper(input) 58 | let loc = conv.LineColToAbsolute(int position.lineNumber, int position.column) 59 | 60 | let! _, ents, _ = svc.TypeCheck(input) 61 | let optMembers = 62 | ents.Entities |> Seq.tryPick (fun (rng, ent) -> 63 | match ent with 64 | | { Kind = EntityKind.Member({ Type = Some t }, { Kind = EntityKind.MemberName(n) }) } 65 | when loc >= rng.Start && loc <= rng.End + 1 -> 66 | Log.trace("completions", "Antecedant at current location (member '%s'): %O", n.Name, t) 67 | match t with 68 | | Type.Object obj -> Some(n.Name, rng, obj.Members) 69 | | _ -> None 70 | | { Kind = EntityKind.Member({ Type = Some t }, { Kind = EntityKind.MemberName(n) }) } -> 71 | Log.trace("completions", "Ignoring '%s' at location %s-%s (current=%s)", n.Name, rng.Start, rng.End, loc) 72 | None 73 | | _ -> None) 74 | 75 | let convertRange (rng:TheGamma.Range) = 76 | let sl, sc = conv.AbsoluteToLineCol(rng.Start) 77 | let el, ec = conv.AbsoluteToLineCol(rng.End) 78 | let res = JsInterop.createEmpty 79 | res.startColumn <- float sc 80 | res.startLineNumber <- float sl 81 | res.endColumn <- float ec + 1.0 82 | res.endLineNumber <- float el 83 | res 84 | 85 | match optMembers with 86 | | None -> 87 | Log.trace("completions", "no members at %s", loc) 88 | return ResizeArray [] 89 | | Some (currentName, nameRange, members) -> 90 | let nameRange = convertRange nameRange 91 | Log.trace("completions", "providing %s members at %O", members.Length, nameRange) 92 | 93 | let members = members |> Array.filter (fun m -> 94 | match Ast.pickMetaByType "http://schema.thegamma.net" "CompletionItem" m.Metadata with 95 | | Some item -> not (getProperty item "hidden") 96 | | _ -> true) 97 | 98 | let completion = 99 | [ for m in members -> 100 | let ci = JsInterop.createEmpty 101 | let n = m.Name 102 | let k = 103 | match m.Type with 104 | | Type.Method _ -> languages.CompletionItemKind.Method 105 | | _ -> languages.CompletionItemKind.Property 106 | ci.kind <- k 107 | ci.label <- n 108 | ci.insertText <- Some(Ast.escapeIdent n) 109 | // We set the current text in the range as 'filterText' so Monaco 110 | // does not filter things out when Ctrl+Space is typed (trick!) 111 | ci.filterText <- Some(Ast.escapeIdent currentName + n) 112 | match m.Type with 113 | | Type.Method(arguments=args) -> 114 | let acc, l = 115 | [ for ma in args -> (if ma.Optional then "?" else "") + ma.Name ] 116 | |> Seq.fold (fun (acc, l:string) s -> 117 | if l.Length > 100 then (l::acc, s) 118 | else (acc, if l = "" then s else l+","+s)) ([], "") 119 | let args = l::acc |> List.rev |> String.concat ",\n" 120 | ci.documentation <- Some("(" + args + ")") 121 | | _ -> () 122 | 123 | let eo = JsInterop.createEmpty 124 | eo.text <- Ast.escapeIdent n 125 | eo.range <- nameRange 126 | ci.textEdit <- Some eo 127 | ci ] 128 | Log.trace("completions", "returning %O", Array.ofSeq completion) 129 | return ResizeArray(completion) 130 | with e -> 131 | Log.exn("completions", "completions failed %O", e) 132 | return ResizeArray() } |> Async.StartAsPromise |> Fable.Core.U4.Case2 133 | 134 | member this.resolveCompletionItem(item, token) = Fable.Core.U2.Case1 item } 135 | 136 | let createdEditors = System.Collections.Generic.Dictionary() 137 | let getService uri = createdEditors.[uri] 138 | 139 | let setupMonacoServices () = 140 | let lang = JsInterop.createEmpty 141 | lang.id <- "thegamma" 142 | languages.Globals.register(lang) 143 | languages.Globals.setTokensProvider("thegamma", tokensProvider) |> ignore 144 | languages.Globals.registerCompletionItemProvider("thegamma", createCompletionProvider getService) |> ignore 145 | 146 | let createMonacoEditor id code svc customize = 147 | if createdEditors.Count = 0 then setupMonacoServices () 148 | let services = JsInterop.createEmpty 149 | let options = JsInterop.createEmpty 150 | let scroll = JsInterop.createEmpty 151 | scroll.vertical <- Some "none" 152 | scroll.horizontal <- Some "auto" 153 | options.scrollbar <- Some scroll 154 | options.value <- Some code 155 | options.language <- Some "thegamma" 156 | options.lineNumbersMinChars <- Some 3.0 157 | options.contextmenu <- Some false 158 | options.scrollBeyondLastLine <- Some false 159 | options.overviewRulerLanes <- Some 0.0 160 | customize options 161 | let ed = editor.Globals.create(document.getElementById(id), options, services) 162 | createdEditors.Add(ed.getModel().uri.toString(), svc) 163 | ed -------------------------------------------------------------------------------- /src/thegamma/parser/tokenizer.fs: -------------------------------------------------------------------------------- 1 | // ------------------------------------------------------------------------------------------------ 2 | // Tokenizer for TheGamma script language - turns string into Token[] 3 | // ------------------------------------------------------------------------------------------------ 4 | module TheGamma.Tokenizer 5 | open TheGamma 6 | 7 | /// Tokenization context for storing input, errors & parsed tokens 8 | type Context = 9 | { Tokens : ResizeArray 10 | Errors : ResizeArray> 11 | Input : string } 12 | 13 | /// Test whether 's' has 'prefix' at offset 'i'. The 14 | /// parameter 'j' is index inside prefix where we're starting. 15 | let rec startsWith (s:string) i j (prefix:string) = 16 | if j = prefix.Length then true 17 | elif i = s.Length then false 18 | elif s.[i] <> prefix.[j] then false 19 | else startsWith s (i+1) (j+1) prefix 20 | 21 | /// Is given character a string? 22 | let letter c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') 23 | 24 | /// Is given character a number? 25 | let number c = c >= '0' && c <= '9' 26 | 27 | 28 | /// Add newly parsed token to the context, increment 29 | /// offset correctly & continue tokenizing 30 | let rec addAndTokenize ctx tok i l = 31 | { Token = tok 32 | Range = { Start = i; End = i + l - 1 } } |> ctx.Tokens.Add 33 | tokenizeInput ctx (i + l) 34 | 35 | 36 | /// Tokenize identifier (continue consuming letters & characters) 37 | and tokenizeIdent ctx start l = 38 | if start + l < ctx.Input.Length && 39 | (letter ctx.Input.[start+l] || number ctx.Input.[start+l]) then 40 | tokenizeIdent ctx start (l+1) 41 | else 42 | addAndTokenize ctx (TokenKind.Ident(ctx.Input.Substring(start, l))) start l 43 | 44 | 45 | /// Tokenize string (until end of input or closing double-quote) 46 | and tokenizeString ctx acc start l = 47 | if start + l >= ctx.Input.Length then 48 | tokenizeStringEnd true ctx acc start l 49 | else 50 | match ctx.Input.[start + l] with 51 | | '\\' when start + l + 1 >= ctx.Input.Length -> 52 | tokenizeStringEnd true ctx ('\\'::acc) start (l + 1) 53 | | '\\' -> 54 | match ctx.Input.[start + l + 1] with 55 | | 'n' -> tokenizeString ctx ('\n'::acc) start (l + 2) 56 | | 't' -> tokenizeString ctx ('\t'::acc) start (l + 2) 57 | | '\\' -> tokenizeString ctx ('\\'::acc) start (l + 2) 58 | | '"' -> tokenizeString ctx ('"'::acc) start (l + 2) 59 | | c -> tokenizeString ctx (c::'\\'::acc) start (l + 2) 60 | | '"' -> tokenizeStringEnd false ctx acc start (l + 1) 61 | | c -> tokenizeString ctx (c::acc) start (l+1) 62 | 63 | and tokenizeStringEnd error ctx acc start l = 64 | let str = acc |> List.toArray |> Array.rev |> System.String 65 | let rng = { Start = start; End = start + l } 66 | if error then ctx.Errors.Add(Errors.Tokenizer.inputEndInsideString rng str) 67 | addAndTokenize ctx (TokenKind.String(str)) start l 68 | 69 | 70 | /// Tokenize quoted ident (until end of input or closing single-quote) 71 | and tokenizeQuotedIdent ctx start l = 72 | if start + l >= ctx.Input.Length then 73 | tokenizeQuotedIdentEnd true ctx start l 74 | else 75 | match ctx.Input.[start + l] with 76 | | '\n' -> tokenizeQuotedIdentEnd true ctx start (l + 1) 77 | | '\'' -> tokenizeQuotedIdentEnd false ctx start (l + 1) 78 | | c -> tokenizeQuotedIdent ctx start (l + 1) 79 | 80 | and tokenizeQuotedIdentEnd error ctx start l = 81 | let rng = { Start = start; End = start + l } 82 | let qid = ctx.Input.Substring(start + 1, l - if error then 1 else 2) 83 | let qid = if qid.EndsWith("\n") then qid.Substring(0, qid.Length-1) else qid 84 | if error then ctx.Errors.Add(Errors.Tokenizer.missingClosingQuote rng qid) 85 | addAndTokenize ctx (TokenKind.QIdent(qid)) start l 86 | 87 | 88 | /// Tokenize whitespace - consume all spaces available 89 | and tokenizeWhite ctx start l = 90 | if start + l < ctx.Input.Length && ctx.Input.[start+l] = ' ' then 91 | tokenizeWhite ctx start (l+1) 92 | else 93 | addAndTokenize ctx (TokenKind.White(ctx.Input.Substring(start, l))) start l 94 | 95 | 96 | /// Tokenize number - consume all numbers, or '.' when 'decimal = false' 97 | and tokenizeNumber ctx decimal start l = 98 | if start + l < ctx.Input.Length && number ctx.Input.[start+l] then 99 | tokenizeNumber ctx decimal start (l+1) 100 | elif start + l < ctx.Input.Length && not decimal && ctx.Input.[start+l] = '.' then 101 | tokenizeNumber ctx true start (l+1) 102 | else 103 | let str = ctx.Input.Substring(start, l) 104 | addAndTokenize ctx (TokenKind.Number(str, float str)) start l 105 | 106 | 107 | and tokenizeInput ctx i = 108 | // Reached the end of the input 109 | if i >= ctx.Input.Length then ctx else 110 | 111 | // Keyword or multi-letter symbol 112 | match ctx.Input.[i] with 113 | | '-' when startsWith ctx.Input i 0 "->" -> 114 | addAndTokenize ctx (TokenKind.Arrow) i 2 115 | | 'f' when startsWith ctx.Input i 0 "fun" -> 116 | addAndTokenize ctx (TokenKind.Fun) i 3 117 | | 'l' when startsWith ctx.Input i 0 "let" -> 118 | addAndTokenize ctx (TokenKind.Let) i 3 119 | | 't' when startsWith ctx.Input i 0 "true" -> 120 | addAndTokenize ctx (TokenKind.Boolean true) i 4 121 | | 'f' when startsWith ctx.Input i 0 "false" -> 122 | addAndTokenize ctx (TokenKind.Boolean false) i 5 123 | | '<' when startsWith ctx.Input i 0 "<=" -> 124 | addAndTokenize ctx (TokenKind.Operator Operator.LessThanOrEqual) i 2 125 | | '>' when startsWith ctx.Input i 0 ">=" -> 126 | addAndTokenize ctx (TokenKind.Operator Operator.GreaterThanOrEqual) i 2 127 | 128 | // Single-letter tokens 129 | | '(' -> addAndTokenize ctx TokenKind.LParen i 1 130 | | ')' -> addAndTokenize ctx TokenKind.RParen i 1 131 | | '=' -> addAndTokenize ctx TokenKind.Equals i 1 132 | | '.' -> addAndTokenize ctx TokenKind.Dot i 1 133 | | ',' -> addAndTokenize ctx TokenKind.Comma i 1 134 | | ':' -> addAndTokenize ctx TokenKind.Colon i 1 135 | | '[' -> addAndTokenize ctx TokenKind.LSquare i 1 136 | | ']' -> addAndTokenize ctx TokenKind.RSquare i 1 137 | | '\n' -> addAndTokenize ctx TokenKind.Newline i 1 138 | 139 | // Single-letter operators 140 | | '>' -> addAndTokenize ctx (TokenKind.Operator(Operator.GreaterThan)) i 1 141 | | '<' -> addAndTokenize ctx (TokenKind.Operator(Operator.LessThan)) i 1 142 | | '+' -> addAndTokenize ctx (TokenKind.Operator(Operator.Plus)) i 1 143 | | '-' -> addAndTokenize ctx (TokenKind.Operator(Operator.Minus)) i 1 144 | | '*' -> addAndTokenize ctx (TokenKind.Operator(Operator.Multiply)) i 1 145 | | '%' -> addAndTokenize ctx (TokenKind.Operator(Operator.Modulo)) i 1 146 | | '/' -> addAndTokenize ctx (TokenKind.Operator(Operator.Divide)) i 1 147 | | '^' -> addAndTokenize ctx (TokenKind.Operator(Operator.Power)) i 1 148 | 149 | // Symbols that start something (string, whitespace, quoted ident) 150 | | '"' -> tokenizeString ctx [] i 1 151 | | ' ' -> tokenizeWhite ctx i 1 152 | | '\'' -> tokenizeQuotedIdent ctx i 1 153 | | c -> 154 | 155 | // Letter starts identifer, number starts number 156 | if letter c then tokenizeIdent ctx i 1 157 | elif number c then tokenizeNumber ctx false i 1 158 | else 159 | 160 | // Otherwise report an error & skip one character 161 | ctx.Errors.Add(Errors.Tokenizer.unexpectedCharacter { Start = i; End = i } c) 162 | addAndTokenize ctx (TokenKind.Error c) i 1 163 | 164 | 165 | /// Tokenize the given input. Consumes all input characters and returns 166 | /// list of parsed tokens together with an array of tokenization errors. 167 | let tokenize input = 168 | let ctx = 169 | { Errors = new ResizeArray<_>() 170 | Tokens = new ResizeArray<_>() 171 | Input = input } 172 | let ctx = tokenizeInput ctx 0 173 | ctx.Tokens.Add { Token = TokenKind.EndOfFile; Range = { Start = input.Length; End = input.Length } } 174 | ctx.Tokens.ToArray(), ctx.Errors.ToArray() 175 | -------------------------------------------------------------------------------- /src/thegamma/providers/providers.fs: -------------------------------------------------------------------------------- 1 | namespace TheGamma.TypeProviders 2 | 3 | open TheGamma 4 | open TheGamma.Babel 5 | open TheGamma.Common 6 | open Fable.Import 7 | 8 | type ProvidedType = 9 | | NamedType of name:string * typ:Type 10 | | GlobalValue of string * Metadata list * Expression * Type 11 | 12 | module ProviderHelpers = 13 | let docMeta doc = 14 | { Context = "http://thegamma.net" 15 | Type = "Documentation" 16 | Data = box doc } 17 | -------------------------------------------------------------------------------- /src/thegamma/providers/rest.fs: -------------------------------------------------------------------------------- 1 | // ------------------------------------------------------------------------------------------------ 2 | // REST type provider 3 | // ------------------------------------------------------------------------------------------------ 4 | module TheGamma.TypeProviders.RestProvider 5 | 6 | open TheGamma 7 | open TheGamma.Babel 8 | open TheGamma.Babel.BabelOperators 9 | open TheGamma.Common 10 | open TheGamma.TypeProviders.ProviderHelpers 11 | open Fable.Import 12 | 13 | // ------------------------------------------------------------------------------------------------ 14 | // Types to represent JSON data returned by REST service 15 | // ------------------------------------------------------------------------------------------------ 16 | 17 | type AnyType = { kind:string } 18 | type TypeNested = { kind:string (* = nested *); endpoint:string } 19 | type TypeProvider = { kind:string (* = provider *); provider:string; endpoint:string } 20 | type TypePrimitive = { kind:string (* = primitive *); ``type``:obj; endpoint:string } 21 | 22 | [] 23 | let jstypeof (o:obj) : string = failwith "!" 24 | 25 | type Documentation = 26 | { title : string option 27 | details : string option } 28 | 29 | type Parameter = 30 | { name : string 31 | optional : bool 32 | kind : string 33 | cookie : string option 34 | trace : string option 35 | ``type`` : obj } 36 | 37 | type Member = 38 | { name : string 39 | returns : AnyType 40 | parameters : Parameter[] option 41 | documentation : obj option 42 | schema : obj[] 43 | trace : string[] } 44 | 45 | type ResultType = 46 | | Primitive of string 47 | | Generic of string * ResultType[] 48 | | Record of (string * ResultType)[] 49 | 50 | type RawField = 51 | { name : string 52 | ``type`` : obj } 53 | 54 | type RawResultType = 55 | { name : string 56 | fields : RawField[] 57 | ``params`` : obj[] } 58 | 59 | let parseDoc (json:obj option) = 60 | if json.IsNone then Documentation.None 61 | elif jstypeof json.Value = "string" then Documentation.Text(unbox json) 62 | else 63 | let doc = unbox json.Value 64 | match doc.title, doc.details with 65 | | Some title, Some dets -> Documentation.Details(title, dets) 66 | | _ -> Documentation.None 67 | 68 | let rec fromRawType (json:obj) = 69 | if jstypeof json = "string" then Primitive(unbox json) 70 | else 71 | let res = unbox json 72 | if res.name = "record" then res.fields |> Array.map (fun f -> f.name, fromRawType f.``type``) |> Record 73 | else Generic(res.name, res.``params`` |> Array.map fromRawType) 74 | 75 | // ------------------------------------------------------------------------------------------------ 76 | // Code generation for provided members 77 | // ------------------------------------------------------------------------------------------------ 78 | 79 | let trimLeft c (s:string) = s.ToCharArray() |> Array.skipWhile ((=) c) |> System.String 80 | let trimRight c (s:string) = s.ToCharArray() |> Array.rev |> Array.skipWhile ((=) c) |> Array.rev |> System.String 81 | 82 | let concatUrl (a:string) (b:string) = 83 | if b.StartsWith("http://") || b.StartsWith("https://") then b 84 | else (trimRight '/' a) + "/" + (trimLeft '/' b) 85 | 86 | let load url cookies = async { 87 | let! json = Http.Request("GET", url, cookies=cookies) 88 | let members = jsonParse json 89 | return members } 90 | 91 | let addTraceCall inst trace = 92 | if Seq.isEmpty trace then inst 93 | else inst?addTrace /@/ [str (String.concat "&" trace)] 94 | 95 | let propAccess trace = 96 | { Emit = fun inst -> addTraceCall inst trace } 97 | 98 | let methCall traceNames trace = 99 | { Emit = fun inst -> funcN (Seq.length traceNames) (fun args -> 100 | let withTrace = addTraceCall inst trace 101 | Seq.zip traceNames args |> Seq.fold (fun inst (name, value) -> 102 | let trace = BinaryExpression(BinaryPlus, str(name + "="), value, None) 103 | inst?addTrace /@/ [trace] ) withTrace) } 104 | 105 | let dataCall parser trace endp = 106 | { Emit = fun inst -> 107 | let tr = (propAccess trace).Emit(inst) 108 | let mem = MemberExpression(tr, IdentifierExpression("getValue", None), false, None) 109 | CallExpression(mem, [StringLiteral(endp, None)], None) |> parser } 110 | 111 | 112 | // Turn "Async" into the required type 113 | // I guess we should keep a flag whether the input is still async (or something) 114 | let rec getTypeAndEmitter (lookupNamed:string -> Type) ty = 115 | match ty with 116 | | Primitive("string") -> Type.Primitive(PrimitiveType.String), id 117 | | Primitive("obj") -> Type.Primitive(PrimitiveType.String), id 118 | | Primitive("int") 119 | | Primitive("float") -> Type.Primitive(PrimitiveType.Number), fun e -> ident("Number") /@/ [e] 120 | | Primitive("date") -> Type.Primitive(PrimitiveType.Date), fun e -> NewExpression(ident("Date"), [ident("Date")?parse /@/ [e]], None) 121 | | Generic("seq", [|Generic("tuple", [|t1; t2|])|]) -> 122 | let t1, e1 = getTypeAndEmitter lookupNamed t1 123 | let t2, e2 = getTypeAndEmitter lookupNamed t2 124 | let typ = FSharpProvider.applyTypes (lookupNamed "series") [t1; t2] 125 | typ, 126 | fun d -> 127 | ident("series")?create /@/ 128 | [ ident("convertTupleSequence") /@/ [func "v" e1; func "v" e2; d] 129 | str "key"; str "value"; str "" ] // TODO: We don't have any info - that sucks 130 | | Generic("seq", [|ty|]) -> 131 | let elTy, emitter = getTypeAndEmitter lookupNamed ty 132 | let serTy = FSharpProvider.applyTypes (lookupNamed "series") [Type.Primitive PrimitiveType.Number; elTy] 133 | serTy, 134 | // This is over async, but the child `emitter` is not over async 135 | fun d -> 136 | ident("series")?ordinal /@/ 137 | [ ident("convertSequence") /@/ [func "v" emitter; d] 138 | str "key"; str "value"; str "" ] 139 | | Record(membs) -> 140 | let membs = 141 | membs |> Array.map (fun (name, ty) -> 142 | let memTy, memConv = getTypeAndEmitter lookupNamed ty 143 | let emitter = { Emit = fun inst -> memConv <| inst?(name) } 144 | { Member.Name = name; Type = memTy; Metadata = [docMeta(Documentation.Text "")]; Emitter = emitter }) 145 | let obj = 146 | { new ObjectType with 147 | member x.Members = membs 148 | member x.TypeEquals _ = false } 149 | |> TheGamma.Type.Object 150 | obj, id 151 | | _ -> 152 | Browser.console.log("getTypeAndEmitter: Cannot handle %O", ty) 153 | failwith "getTypeAndEmitter: Cannot handle type" 154 | 155 | // ------------------------------------------------------------------------------------------------ 156 | // Type provider 157 | // ------------------------------------------------------------------------------------------------ 158 | 159 | let restTypeCache = System.Collections.Generic.Dictionary<_, _>() 160 | 161 | let rec createRestType lookupNamed resolveProvider root cookies url = 162 | 163 | let provideMember m = 164 | let schema = 165 | if m.schema = null then [] 166 | elif isArray m.schema then m.schema |> Array.map (fun s -> 167 | { Type = getProperty s "@type"; Context = getProperty s "@context"; Data = s }) |> List.ofSeq 168 | else 169 | [ { Type = getProperty m.schema "@type"; Context = getProperty m.schema "@context"; Data = m.schema } ] 170 | 171 | match m.returns.kind with 172 | | "provider" -> 173 | let returns = unbox m.returns 174 | let typ, emitter = resolveProvider returns.provider returns.endpoint 175 | { Member.Name = m.name; Type = typ; Metadata = (docMeta (parseDoc m.documentation))::schema; Emitter = emitter } 176 | | "nested" -> 177 | let returns = unbox m.returns 178 | let createReturnType cookies = 179 | try Some(createRestType lookupNamed resolveProvider root cookies returns.endpoint) 180 | with _ -> None 181 | 182 | match m.parameters with 183 | | Some parameters -> 184 | let args = 185 | [ for p in parameters -> 186 | let ty = fromRawType p.``type`` 187 | let ty, _ = getTypeAndEmitter lookupNamed ty 188 | { MethodArgument.Name = p.name; Optional = p.optional; Type = ty; Static = p.kind = "static" } ] 189 | 190 | let retFunc tys = 191 | if not (Types.listsEqual (List.map fst tys) [ for ma in args -> ma.Type ] Types.typesEqual) then None else 192 | let matched = Seq.zip parameters tys 193 | let newCookies = 194 | matched |> Seq.choose (function 195 | | pa, (_, Some value) when pa.kind = "static" -> Some(pa.cookie.Value + "=" + Fable.Import.JS.encodeURIComponent(string value)) 196 | | _ -> None) 197 | let cookies = Seq.append [cookies] newCookies |> String.concat "&" 198 | createReturnType cookies 199 | 200 | let traceNames = parameters |> Seq.choose (fun p -> p.trace) 201 | { Member.Name = m.name; Metadata = [docMeta (parseDoc m.documentation)] 202 | Type = Type.Method(args, retFunc); Emitter = methCall traceNames m.trace } 203 | | None -> 204 | let retTyp = defaultArg (createReturnType cookies) Type.Any 205 | { Member.Name = m.name; Type = retTyp; Metadata = (docMeta (parseDoc m.documentation))::schema; Emitter = propAccess m.trace } 206 | | "primitive" -> 207 | let returns = unbox m.returns 208 | let ty = fromRawType returns.``type`` 209 | let typ, parser = getTypeAndEmitter lookupNamed ty 210 | { Member.Name = m.name; Type = typ; Metadata = (docMeta (parseDoc m.documentation))::schema; 211 | Emitter = dataCall parser m.trace returns.endpoint } 212 | | _ -> failwith "?" 213 | 214 | let guid = (concatUrl root url) + cookies 215 | match restTypeCache.TryGetValue guid with 216 | | true, res -> res 217 | | _ -> 218 | let future = async { 219 | try 220 | let! members = load (concatUrl root url) cookies 221 | let members = members |> Array.map provideMember 222 | return 223 | { new ObjectType with 224 | member x.Members = members 225 | member x.TypeEquals _ = false } |> Type.Object 226 | with e -> 227 | Log.error("providers", "Cannot provide object type: %O", e) 228 | return Type.Any } 229 | let ty = Type.Delayed(Async.CreateNamedFuture guid future) 230 | restTypeCache.[guid] <- ty 231 | ty 232 | 233 | let rec provideRestType lookupNamed resolveProvider name root cookies = 234 | let ctx = ident("RuntimeContext") 235 | ProvidedType.GlobalValue 236 | ( name, [], 237 | NewExpression(ctx, [str root; str cookies; str ""], None), 238 | createRestType lookupNamed resolveProvider root cookies "/") -------------------------------------------------------------------------------- /src/thegamma/services.fs: -------------------------------------------------------------------------------- 1 | module TheGamma.Services 2 | 3 | open Fable.Import 4 | open TheGamma.Html 5 | open TheGamma.Common 6 | open TheGamma.Ast 7 | 8 | module FsOption = Microsoft.FSharp.Core.Option 9 | 10 | // ------------------------------------------------------------------------------------------------ 11 | // Type checker 12 | // ------------------------------------------------------------------------------------------------ 13 | 14 | type CheckingMessage = 15 | | TypeCheck of code:string * AsyncReplyChannel 16 | | IsWellTyped of code:string * AsyncReplyChannel 17 | 18 | type Position = { Line:int; Column:int } 19 | type LineRange = { Start:Position; End:Position } 20 | 21 | let rec offsetToLocation lines offs lengths = 22 | match lengths with 23 | | l::lengths when offs <= l -> { Line = lines; Column = offs } 24 | | l::lengths -> offsetToLocation (lines+1) (offs-l-1) lengths 25 | | [] -> { Line = lines; Column = offs } // error? out of range 26 | 27 | let rangeToLoc lengths (rng:Range) = 28 | { Start = offsetToLocation 1 rng.Start lengths 29 | End = offsetToLocation 1 rng.Start lengths } 30 | 31 | type CheckingService(article, globals:Future) = 32 | let errorsReported = Control.Event<_>() 33 | let emptyProg = { Body = Ast.node { Start = 0; End = 0 } [] } 34 | let bindingContext = 35 | async { 36 | let! globals = globals |> Async.AwaitFuture 37 | return Binder.createContext globals article } |> Async.StartAsFuture 38 | 39 | let errorsToLineCol (code:string) errors = 40 | let lengths = code.Split('\n') |> Array.toList |> List.map (fun l -> l.Length) 41 | errors |> Array.map (fun e -> 42 | { Number = e.Number; Message = e.Message; Range = rangeToLoc lengths e.Range }) 43 | 44 | let typeCheck code = async { 45 | let! globals = Async.AwaitFuture globals 46 | Log.trace("service", "Evaluated globals") 47 | for g in globals do Log.trace("service", "Global value '%s' : %O = %O", g.Name, Option.map formatType g.Type, g.Value) 48 | try 49 | let progSyntax, parseErrors = Parser.parseProgram code 50 | let! bindingContext = bindingContext |> Async.AwaitFuture 51 | let progEntity, boundEntities = Binder.bindProgram bindingContext progSyntax 52 | do! TypeChecker.typeCheckProgram globals boundEntities (Interpreter.evaluate globals) progEntity 53 | let typeErrors = TypeChecker.collectTypeErrors progEntity 54 | Log.trace("service", "Type checking completed") 55 | let errors = errorsToLineCol code (Array.append parseErrors typeErrors) 56 | return Some(progSyntax, boundEntities, errors) 57 | with e -> 58 | Log.exn("service", "Type checking failed: %O", e) 59 | return None } 60 | 61 | let agent = MailboxProcessor.Start(fun inbox -> 62 | let rec loop lastCode lastResult = async { 63 | let! msg = inbox.Receive() 64 | match msg with 65 | | IsWellTyped(code, repl) -> 66 | let! tc = typeCheck code 67 | match tc with 68 | | Some(_, _, errs) when errs.Length = 0 -> repl.Reply(true) 69 | | _ -> repl.Reply(false) 70 | return! loop lastCode lastResult 71 | 72 | | TypeCheck(code, repl) when code = lastCode -> 73 | Log.trace("service", "Returning previous result") 74 | repl.Reply(lastResult) 75 | return! loop lastCode lastResult 76 | 77 | | TypeCheck(code, repl) -> 78 | Log.trace("service", "Type checking source code") 79 | let! tc = typeCheck code 80 | match tc with 81 | | Some(prog, ents, errors) -> 82 | errorsReported.Trigger(code, errors) 83 | let result = (errors.Length = 0, ents, prog) 84 | repl.Reply(result) 85 | return! loop code result 86 | | None -> 87 | repl.Reply((false, Binder.BindingResult [||], emptyProg)) 88 | return! loop lastCode lastResult } 89 | 90 | loop "" (false, Binder.BindingResult [||], emptyProg)) 91 | 92 | member x.ErrorsReported = errorsReported.Publish 93 | member x.TypeCheck(code) = agent.PostAndAsyncReply(fun ch -> TypeCheck(code, ch)) 94 | member x.IsWellTyped(code) = agent.PostAndAsyncReply(fun ch -> IsWellTyped(code, ch)) 95 | 96 | 97 | // ------------------------------------------------------------------------------------------------ 98 | // Live previews 99 | // ------------------------------------------------------------------------------------------------ 100 | 101 | open Fable.Core 102 | open Fable.Helpers 103 | open Fable.Import.Browser 104 | open TheGamma.Live.Common 105 | 106 | type PreviewService(checker:CheckingService, globals:Future>, ed:monaco.editor.ICodeEditor, livePreviews) = 107 | 108 | let zoneSizeChanged = new Event() 109 | let mutable currentZone : option = None 110 | let mutable zoneHeight = 0.0 111 | let mutable tree = JsInterop.createObj [] 112 | let mutable container = document.createElement("div") :> Node 113 | 114 | let removeZone () = 115 | match currentZone with 116 | | Some(id, _) -> ed.changeViewZones(fun accessor -> accessor.removeZone(id)) 117 | | None -> () 118 | currentZone <- None 119 | zoneSizeChanged.Trigger() 120 | 121 | let createAndAddZone endLine = 122 | let mutable zoneId = -1. 123 | let zone = JsInterop.createEmpty 124 | 125 | let node = document.createElement_div() 126 | node.style.width <- "1000px" 127 | node.style.height <- "1000px" 128 | container <- document.createElement_div() :> Node 129 | tree <- JsInterop.createObj [] 130 | node.appendChild(container) |> ignore 131 | ed.changeViewZones(fun accessor -> 132 | match currentZone with Some(id, _) -> accessor.removeZone(id) | _ -> () 133 | zone.afterLineNumber <- endLine 134 | zone.heightInPx <- Some 1.0 135 | zone.domNode <- node 136 | zoneHeight <- 1.0 137 | zoneId <- accessor.addZone(zone) 138 | currentZone <- Some (zoneId, zone) ) 139 | 140 | let updateZones trigger liveState = 141 | let dom = 142 | liveState.CurrentPreview |> FsOption.bind (fun p -> 143 | p.Render trigger liveState ) 144 | match dom with 145 | | None -> removeZone () 146 | | Some prev -> 147 | if currentZone.IsNone then createAndAddZone (float prev.Line) 148 | let id, zone = currentZone.Value 149 | let newTree = prev.Preview |> renderVirtual 150 | let patches = Virtualdom.diff tree newTree 151 | container <- Virtualdom.patch container patches 152 | tree <- newTree 153 | 154 | let rec waitForActualHeight n = async { 155 | let newHeight = (container :?> HTMLElement).clientHeight 156 | if n = 10 || newHeight <> 0.0 then return newHeight 157 | else 158 | do! Async.Sleep (n*n) 159 | return! waitForActualHeight (n+1) } 160 | 161 | async { 162 | let! newHeight = waitForActualHeight 1 163 | Log.trace("live", "Old height: %s, New height: %s", zoneHeight, newHeight) 164 | if zoneHeight <> newHeight || zone.afterLineNumber <> float prev.Line then 165 | zone.afterLineNumber <- float prev.Line 166 | zone.heightInPx <- Some newHeight 167 | zoneHeight <- newHeight 168 | ed.changeViewZones(fun accessor -> accessor.layoutZone(id)) 169 | zoneSizeChanged.Trigger() } |> Async.StartImmediate 170 | 171 | let mutable lastCode = "" 172 | let mutable lastMapper = LocationMapper("") 173 | let mutable changingEditor = false 174 | 175 | let getUpdateEventAfterChange () = async { 176 | let code = ed.getModel().getValue(monaco.editor.EndOfLinePreference.LF, false) 177 | let position = ed.getPosition() 178 | if code <> lastCode then 179 | lastCode <- code 180 | lastMapper <- LocationMapper(code) 181 | let loc = lastMapper.LineColToAbsolute(int position.lineNumber, int position.column) 182 | let! _, _, program = checker.TypeCheck(code) 183 | return (UpdateSource(code, loc, program, lastMapper)) 184 | else 185 | let loc = lastMapper.LineColToAbsolute(int position.lineNumber, int position.column) 186 | return (UpdateLocation(loc)) } 187 | 188 | let createLivePreview (ed:monaco.editor.ICodeEditor) = 189 | let liveEvent = new Event>() 190 | let noState = { new CustomLiveState } 191 | let mutable liveState = 192 | { Mapper = LocationMapper("") 193 | Location = 0 194 | Program = { Body = Ast.node { Start = 0; End = 0 } [] } 195 | Globals = [] 196 | Code = "" 197 | Selection = None 198 | State = noState 199 | CurrentPreview = None } 200 | 201 | let applyEvent evt = 202 | let liveState = updateLiveState liveState evt 203 | let newState = 204 | match liveState.CurrentPreview with 205 | | Some(prev) -> prev.Update liveEvent.Trigger liveState evt 206 | | None -> None 207 | 208 | let newPreview = 209 | match evt with 210 | | UpdateSource _ | UpdateLocation _ -> 211 | Log.trace("live", "Searching for available previews") 212 | let state = livePreviews |> Seq.tryPick (fun lp -> 213 | let state = { liveState with CurrentPreview = Some lp; State = lp.InitialState } 214 | lp.Update liveEvent.Trigger state evt) 215 | state 216 | | _ -> None 217 | 218 | match newState, newPreview with 219 | | Some (st & { CurrentPreview = Some p1 }), Some (pr & { CurrentPreview = Some p2 }) 220 | when p1.ID <> p2.ID -> pr 221 | | Some st, _ -> st 222 | | _, Some pr -> pr 223 | | _ -> { liveState with CurrentPreview = None; State = noState } 224 | 225 | liveEvent.Publish.Add(fun evt -> 226 | try 227 | Log.trace("live", "Updating state %O with event %O", liveState, evt) 228 | let oldState = liveState 229 | liveState <- applyEvent evt 230 | 231 | if (match evt with UpdateSource _ -> false | _ -> true) && (oldState.Code <> liveState.Code) then 232 | changingEditor <- true 233 | ed.getModel().setValue(liveState.Code) 234 | match liveState.Selection with 235 | | Some rng -> 236 | changingEditor <- true 237 | let mrng = JsInterop.createEmpty 238 | mrng.startColumn <- float rng.StartColumn 239 | mrng.startLineNumber <- float rng.StartLineNumber 240 | mrng.endColumn <- float rng.EndColumn 241 | mrng.endLineNumber <- float rng.EndLineNumber 242 | ed.setSelection(mrng) 243 | liveState <- { liveState with Selection = None } 244 | | _ -> () 245 | 246 | if changingEditor = true then 247 | changingEditor <- false 248 | async { 249 | Log.trace("live", "Editor changed. Getting after change event...") 250 | let! evt = getUpdateEventAfterChange () 251 | Log.trace("live", "Editor changed. Updating state %O with event %O", liveState, evt) 252 | liveState <- applyEvent evt 253 | Log.trace("live", "Editor changed. New state %O", liveState) 254 | updateZones liveEvent.Trigger liveState } |> Async.StartImmediate 255 | else 256 | updateZones liveEvent.Trigger liveState 257 | with e -> 258 | Log.exn("live", "Error when updating state %O with event %O: %O", liveState, evt, e) ) 259 | 260 | async { let! glob = globals |> Async.AwaitFuture 261 | liveEvent.Trigger(InitializeGlobals glob) } |> Async.StartImmediate 262 | 263 | liveEvent.Trigger 264 | 265 | let trigger = createLivePreview ed 266 | 267 | do 268 | ed.onDidChangeCursorPosition(fun ce -> 269 | if not changingEditor then 270 | let code = ed.getModel().getValue(monaco.editor.EndOfLinePreference.LF, false) 271 | Log.trace("live", "Cursor position changed: code <> lastCode = %s", code <> lastCode) 272 | async { let! evt = getUpdateEventAfterChange () 273 | trigger evt } |> Async.StartImmediate ) |> ignore 274 | 275 | member x.ZoneSizeChanged = 276 | zoneSizeChanged.Publish 277 | 278 | member x.ZoneHeight = 279 | if currentZone <> None then zoneHeight 280 | else 0.0 -------------------------------------------------------------------------------- /src/thegamma/thegamma.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | ae8310c8-1f2b-4f9c-83f6-5d188b7517b2 9 | Library 10 | TheGamma 11 | thegamma 12 | v4.5 13 | true 14 | 4.4.0.0 15 | TheGamma 16 | 17 | 18 | 19 | true 20 | full 21 | false 22 | false 23 | bin\Debug\ 24 | DEBUG;TRACE 25 | 3 26 | AnyCPU 27 | 28 | 29 | true 30 | 31 | 32 | pdbonly 33 | true 34 | true 35 | bin\Release\ 36 | TRACE 37 | 3 38 | AnyCPU 39 | bin\Release\TheGamma.xml 40 | true 41 | 42 | 43 | 11 44 | 45 | 46 | 47 | 48 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 49 | 50 | 51 | 52 | 53 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 54 | 55 | 56 | 57 | 58 | 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 | Always 92 | 93 | 94 | 95 | 96 | ../../node_modules/fable-core/Fable.Core.dll 97 | 98 | 99 | 100 | True 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | bindings 109 | {278a68fc-0256-417c-af13-9a4af7381ccf} 110 | True 111 | 112 | 113 | libraries 114 | {c103641d-9755-4de4-bda9-fdcfc022c80e} 115 | True 116 | 117 | 118 | -------------------------------------------------------------------------------- /tests/fableconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "outDir": "../dist/tests", 3 | "module": "umd", 4 | "sourceMaps": true, 5 | "plugins": [ "../node_modules/fable-plugins-nunit/Fable.Plugins.NUnit.dll" ], 6 | "coreLib": "fable-core/umd", 7 | "projFile": [ 8 | "../src/bindings/bindings.fsproj", 9 | "../src/libraries/libraries.fsproj", 10 | "../src/thegamma/thegamma.fsproj", 11 | "thegamma-tests/thegamma-tests.fsproj" 12 | ] 13 | } 14 | -------------------------------------------------------------------------------- /tests/thegamma-tests/binder.fs: -------------------------------------------------------------------------------- 1 | #if INTERACTIVE 2 | #r "../../src/thegamma/bin/Debug/libraries.dll" 3 | #r "../../src/thegamma/bin/Debug/thegamma.dll" 4 | #r "../../packages/NUnit/lib/net45/nunit.framework.dll" 5 | #else 6 | [] 7 | module TheGamma.Tests.Binder 8 | #endif 9 | open TheGamma 10 | open TheGamma.Common 11 | open NUnit.Framework 12 | 13 | // -------------------------------------------------------------------------------------- 14 | // Binder tests 15 | // -------------------------------------------------------------------------------------- 16 | 17 | /// Type-safe assertion 18 | let equal (expected:'T) (actual:'T) = Assert.AreEqual(expected, actual) 19 | 20 | /// Check that nth commands of programs have equal/not equal entities 21 | let checkCommands eq n (p1:Program) (p2:Program) = 22 | equal eq (p1.Body.Node.[n].Entity.Value.Symbol = p2.Body.Node.[n].Entity.Value.Symbol) 23 | 24 | /// Parse sample that's indented with 2 spaces 25 | let parse (code:string) = 26 | let code = code.Replace("\n ", "\n").TrimStart() 27 | code, code |> Parser.parseProgram |> fst 28 | 29 | /// Olympic sample code (in process of writing if `not completed`) 30 | let olympicSample complete = 31 | """ 32 | let data1 = 33 | olympics.data 34 | .'group data'.'by Athlete'.'sum Gold'.then 35 | .'sort data'.'by Gold descending' 36 | .then.paging.take(10) 37 | """ 38 | + ( if complete then "let data2 = data1.'get the data'" 39 | else "let data2 = data1.'get th" ) 40 | + """ 41 | table.create(data2).set(title="yadda")""" 42 | 43 | /// Disable all logging when running tests 44 | do Log.setEnabled(set []) 45 | 46 | [] 47 | let ``Binder reuses entities when binding twice`` () = 48 | let ctx = Binder.createContext [] "script1" 49 | let _, p1 = parse (olympicSample true) 50 | let e1 = Binder.bindProgram ctx p1 51 | let c1 = ctx.Table |> ListDictionary.count 52 | let _, p2 = parse (olympicSample true) 53 | let e2 = Binder.bindProgram ctx p2 54 | let c2 = ctx.Table |> ListDictionary.count 55 | equal c1 c2 56 | 57 | [] 58 | let ``Binder reuses some entities when one member is changed`` () = 59 | let ctx = Binder.createContext [] "script1" 60 | let _, p1 = parse (olympicSample false) 61 | let e1 = Binder.bindProgram ctx p1 62 | let c1 = ctx.Table |> ListDictionary.count 63 | let _, p2 = parse (olympicSample true) 64 | let e2 = Binder.bindProgram ctx p2 65 | let c2 = ctx.Table |> ListDictionary.count 66 | equal true (c2 > c1 && c2 < c1*2) 67 | checkCommands true 0 p1 p2 68 | checkCommands false 1 p1 p2 69 | checkCommands false 2 p1 p2 70 | 71 | [] 72 | let ``Binder binds all names in a sample program`` () = 73 | let ctx = Binder.createContext [] "script1" 74 | let code, p1 = parse (olympicSample true) 75 | let _, e1 = Binder.bindProgram ctx p1 76 | let bound = [ for rng, e in e1.Entities -> code.Substring(rng.Start, rng.End - rng.Start + 1) ] 77 | let names = 78 | [ "data1"; "olympics"; "data"; "'group data'"; "'by Athlete'"; "'sum Gold'"; 79 | "'sort data'"; "'by Gold descending'"; "paging"; "take"; "10"; "then" 80 | "data2"; "'get the data'"; "table"; "create"; "set"; "title"; "\"yadda\"" ] 81 | equal true (Set.isSubset (set names) (set bound)) -------------------------------------------------------------------------------- /tests/thegamma-tests/compost.fs: -------------------------------------------------------------------------------- 1 | #if INTERACTIVE 2 | #r "../../src/libraries/bin/Debug/Fable.Core.dll" 3 | #r "../../src/libraries/bin/Debug/libraries.dll" 4 | #r "../../packages/NUnit/lib/net45/nunit.framework.dll" 5 | #else 6 | [] 7 | module TheGamma.Tests.Compost 8 | #endif 9 | open TheGamma 10 | open TheGamma.Html 11 | open TheGamma.Interactive.Compost 12 | open TheGamma.Interactive.Compost.Derived 13 | open NUnit.Framework 14 | 15 | // -------------------------------------------------------------------------------------- 16 | // Helpers for writing tests for parser 17 | // -------------------------------------------------------------------------------------- 18 | 19 | /// Type-safe assertion 20 | let equal (expected:'T) (actual:'T) = Assert.AreEqual(expected, actual) 21 | 22 | 23 | let rec renderChildren childs = 24 | Seq.map render childs |> String.concat "" 25 | 26 | and renderAttrs attrs = 27 | let s = Seq.map renderAttr attrs |> String.concat "" 28 | if s <> "" then " " + s else s 29 | 30 | and renderAttr = function 31 | | k, Event _ -> "" 32 | | k, Attribute v -> sprintf "%s='%s'" k v 33 | | k, Property _ -> failwith "Properties not supported" 34 | 35 | and render = function 36 | | DomNode.Text s -> s 37 | | Element(null, tag, attrs, childs, None) -> 38 | sprintf "<%s%s>%s" tag (renderAttrs attrs) (renderChildren childs) tag 39 | | Element(ns, tag, attrs, childs, None) -> 40 | sprintf "<%s xmlns='%s'%s>%s" tag ns (renderAttrs attrs) (renderChildren childs) tag 41 | | Element(_, _, _, _, Some _) -> failwith "On render not supported" 42 | | Part _ | Delayed _ -> failwith "Delayed and parts not supported" 43 | 44 | #if INTERACTIVE 45 | let tmp = System.IO.Path.GetTempFileName() + ".html" 46 | let preview html = 47 | System.IO.File.WriteAllText(tmp, html) 48 | System.Diagnostics.Process.Start(tmp) |> ignore 49 | #else 50 | let preview html = () 51 | #endif 52 | 53 | // -------------------------------------------------------------------------------------- 54 | // TESTS: Call chains and nesting 55 | // -------------------------------------------------------------------------------------- 56 | 57 | [] 58 | let zz() = 59 | let sx : Scale<1> = Continuous(CO 1000.0, CO 2000.0) 60 | let sy : Scale<1> = Categorical [| CA "A"; CA "B"; CA "C" |] 61 | let pt = (COV (CO 1200.), CAR (CA "C", 0.5)) 62 | let proj = Projections.Scale((0.0, 100.0), (0.0, 100.0)) 63 | let px, py = Projections.project sx sy pt proj 64 | let npt = Projections.projectInv (sx, sy) (px, py) proj 65 | // npt = pt 66 | () 67 | 68 | [] 69 | let zzzz() = 70 | let sx : Scale<1> = Continuous(CO 1000.0, CO 2000.0) 71 | let sy : Scale<1> = Categorical [| CA "A"; CA "B"; CA "C" |] 72 | let pt = (COV (CO 1200.), CAR (CA "C", 0.5)) 73 | let proj = Projections.Rescale((0.5, 0.6), (0.0, 1.0), Projections.Scale((0.0, 100.0), (0.0, 100.0))) 74 | let px, py = Projections.project sx sy pt proj 75 | let npt = Projections.projectInv (sx, sy) (px, py) proj 76 | // npt = pt 77 | () 78 | 79 | [] 80 | let zzzzz() = 81 | let sx : Scale<1> = Continuous(CO 1000.0, CO 2000.0) 82 | let sy : Scale<1> = Categorical [| CA "A"; CA "B"; CA "C" |] 83 | let pt = (COV (CO 1200.), CAR (CA "C", 0.5)) 84 | let proj = Projections.Rescale((0.0, 1.0), (0.5, 0.6), Projections.Scale((0.0, 100.0), (0.0, 100.0))) 85 | let px, py = Projections.project sx sy pt proj 86 | let npt = Projections.projectInv (sx, sy) (px, py) proj 87 | // npt = pt 88 | () 89 | 90 | [] 91 | let zzzzzzz() = 92 | let sx : Scale<1> = Continuous(CO 1000.0, CO 2000.0) 93 | let sy : Scale<1> = Categorical [| CA "A"; CA "B"; CA "C" |] 94 | let (xl, xh), (yl, yh) = Scales.getExtremes sx, Scales.getExtremes sy 95 | let proj = 96 | Projections.Rescale((0.0, 1.0), (0.5, 0.6), 97 | Projections.Padding((10.,10.,10.,10.), 98 | (xl, xh, yl, yh), 99 | Projections.Scale((0.0, 100.0), (0.0, 100.0)))) 100 | 101 | let pt = (COV (CO 1200.), CAR (CA "C", 0.5)) 102 | let px, py = Projections.project sx sy pt proj 103 | let npt = Projections.projectInv (sx, sy) (px, py) proj 104 | // npt = pt 105 | () 106 | 107 | [] 108 | let zzzzzzzz() = 109 | let sx : Scale<1> = Continuous(CO 1000.0, CO 2000.0) 110 | let sy : Scale<1> = Categorical [| CA "A"; CA "B"; CA "C" |] 111 | let (xl, xh), (yl, yh) = Scales.getExtremes sx, Scales.getExtremes sy 112 | let proj = 113 | Projections.Padding((10.,10.,5.,5.), 114 | (xl, xh, yl, yh), 115 | Projections.Rescale((0.0, 1.0), (0.5, 0.6), 116 | Projections.Scale((0.0, 500.0), (0.0, 500.0)))) 117 | 118 | let pt = (COV (CO 1200.), CAR (CA "C", 0.5)) 119 | let px, py = Projections.project sx sy pt proj 120 | let npt = Projections.projectInv (sx, sy) (px, py) proj 121 | // npt = pt 122 | () 123 | 124 | [] 125 | let zzzzzz() = 126 | let s1 : Shape<1,1> = Stack(Vertical, [ Bar(CO 50.0, CA "A"); Bar(CO 100.0, CA "B") ]) 127 | let s2 : Shape<1,1> = Stack(Vertical, [ Bar(CO 50.0, CA "A"); Bar(CO 100.0, CA "B") ]) 128 | let s1e = Interactive([ Click(fun _ a -> printfn "1: %A" a) ], s1) 129 | let s2e = Interactive([ Click(fun _ a -> printfn "2: %A" a) ], s2) 130 | let s = 131 | Layered 132 | [ OuterScale(None, Some(Continuous(CO 0.0, CO 1.0)), s1e) 133 | OuterScale(None, Some(Continuous(CO 1.0, CO 2.0)), s2e) ] 134 | 135 | let scaled = Scales.calculateScales Compost.defstyle s 136 | let master = Projections.Scale((0.0, 500.0), (500.0, 0.0)) 137 | let projected = Projections.calculateProjections scaled master 138 | 139 | Events.triggerEvent projected null (Events.MouseEvent(Events.Click, (COV (CO 250.), COV (CO 100.)))) 140 | Events.triggerEvent projected null (Events.MouseEvent(Events.Click, (COV (CO 250.), COV (CO 150.)))) 141 | Events.triggerEvent projected null (Events.MouseEvent(Events.Click, (COV (CO 250.), COV (CO 350.)))) 142 | Events.triggerEvent projected null (Events.MouseEvent(Events.Click, (COV (CO 250.), COV (CO 400.)))) 143 | 144 | (* 145 | [] 146 | let zzz() = 147 | let s1 : Shape<1,1> = Stack(Vertical, [ Bar(CO 50.0, CA "A"); Bar(CO 100.0, CA "B") ]) 148 | let s2 : Shape<1,1> = Line [ COV(CO 0.0), COV(CO 0.0); COV(CO 50.0), COV(CO 10.0); COV(CO 100.0), COV(CO 0.0) ] 149 | let s3 : Shape<1,1> = Bar(CO 50.0, CA "C") 150 | let s = 151 | Layered 152 | [ OuterScale(None, Some(Continuous(CO 0.0, CO 2.0)), Axes(false, false, true, true, s1)) 153 | OuterScale(None, Some(Continuous(CO 2.0, CO 3.0)), Axes(false, false, true, true, s2)) 154 | OuterScale(None, Some(Continuous(CO 3.0, CO 4.0)), Padding((0.,0.,0.,100.), s3)) ] 155 | let svg = Compost.createSvg false false (500.0, 500.0) s 156 | preview (render svg) 157 | 158 | render svg 159 | *) -------------------------------------------------------------------------------- /tests/thegamma-tests/formatter.fs: -------------------------------------------------------------------------------- 1 | #if INTERACTIVE 2 | #r "../../src/thegamma/bin/Debug/thegamma.dll" 3 | #r "../../packages/NUnit/lib/net45/nunit.framework.dll" 4 | #else 5 | [] 6 | module TheGamma.Tests.Formatter 7 | #endif 8 | open TheGamma 9 | open TheGamma.Ast 10 | open NUnit.Framework 11 | 12 | // -------------------------------------------------------------------------------------- 13 | // Helpers for writing tests for parser 14 | // -------------------------------------------------------------------------------------- 15 | 16 | /// Type-safe assertion 17 | let equal (expected:'T) (actual:'T) = Assert.AreEqual(expected, actual) 18 | 19 | /// Tokenize & parse test code 20 | let parse (code:string) = 21 | let code = code.Replace("\r", "").Replace("\n ","\n") 22 | code, Parser.parseProgram code |> fst 23 | 24 | // -------------------------------------------------------------------------------------- 25 | // TESTS: Parser keeps all the whitespace 26 | // -------------------------------------------------------------------------------------- 27 | 28 | [] 29 | let ``Whitespace preserved in sample call chain (dot at the start)``() = 30 | let code, prog = parse """ 31 | let z = olympics 32 | .'by athlete' 33 | .'United States'.'Michael Phelps'.data 34 | .'group data'.'by Athlete'.'sum Gold'.then 35 | .paging.skip(10).take(10) 36 | .'get series' 37 | .'with key Athlete'.'and value Gold'""" 38 | equal code (Ast.formatProgram prog) 39 | 40 | [] 41 | let ``Whitespace preserved including placeholder``() = 42 | let code, prog = parse """ 43 | let z = olympics 44 | .'by athlete' 45 | .'United States'.'Michael Phelps'.data 46 | .'group data'.[foo:'by Athlete'].'sum Gold'.then 47 | .paging.skip(10).take(10) 48 | .'get series' 49 | .'with key Athlete'.'and value Gold'""" 50 | equal code (Ast.formatProgram prog) 51 | 52 | [] 53 | let ``Whitespace preserved in sample call chain (dot at the end)``() = 54 | let code, prog = parse """ 55 | let z = olympics. 56 | 'by athlete'. 57 | 'United States'.'Michael Phelps'.data. 58 | 'group data'.'by Athlete'.'sum Gold'.then. 59 | paging.skip(10).take(10). 60 | 'get series'. 61 | 'with key Athlete'.'and value Gold'""" 62 | equal code (Ast.formatProgram prog) 63 | -------------------------------------------------------------------------------- /tests/thegamma-tests/fsharptypes.fs: -------------------------------------------------------------------------------- 1 | #if INTERACTIVE 2 | #r "../../packages/NUnit/lib/net45/nunit.framework.dll" 3 | #I "../../src/libraries/bin/Debug" 4 | #I "../../src/thegamma/bin/Debug" 5 | #r "libraries.dll" 6 | #r "thegamma.dll" 7 | #else 8 | [] 9 | module TheGamma.Tests.FSharpTypes 10 | #endif 11 | open TheGamma 12 | open TheGamma.Common 13 | open TheGamma.TypeChecker 14 | open TheGamma.TypeProviders.FSharpProvider 15 | open NUnit.Framework 16 | 17 | // ------------------------------------------------------------------------------------------------ 18 | // Helper functions for writing assertions (copy & paste from simpletypes.fs) 19 | // ------------------------------------------------------------------------------------------------ 20 | 21 | /// Type-safe assertion 22 | let equal (expected:'T) (actual:'T) = Assert.AreEqual(expected, actual) 23 | 24 | /// Assert that two types are equal 25 | let assertType t1 (t2, _) = 26 | equal (Ast.formatType t1) (Ast.formatType t2) 27 | 28 | /// Assert that result contains given errors 29 | let assertErrors expectErrors (_, errs) = 30 | equal (List.length expectErrors) (List.length errs) 31 | for (en, ec), (an, ac) in List.zip expectErrors errs do 32 | equal en an 33 | equal ec ac 34 | 35 | // Find variable entity 36 | let isVariable name = function { Kind = EntityKind.Variable(n, _) } when n.Name = name -> true | _ -> false 37 | 38 | /// Parse and type check given code, find the specified entity & return its type 39 | /// together with all the errors produced by type checking of the program 40 | let check (code:string) cond vars = 41 | let ctx = Binder.createContext [] "script" 42 | let code = code.Replace("\n ", "\n") 43 | let prog, _ = code |> Parser.parseProgram 44 | let prog, entities = Binder.bindProgram ctx prog 45 | let globals = [ for n, t in vars -> Interpreter.globalEntity n [] t None ] 46 | let mutable completed = false 47 | async { do! TypeChecker.typeCheckProgram globals entities (Interpreter.evaluate globals) prog 48 | completed <- true } |> Async.StartImmediate 49 | if not completed then failwith "Asynchronosu operation did not complete" 50 | let _, ent = entities.Entities |> Seq.find (snd >> cond) 51 | let errors = TypeChecker.collectTypeErrors prog 52 | ent.Type.Value, 53 | [ for e in errors -> e.Number, code.Substring(e.Range.Start, e.Range.End - e.Range.Start + 1) ] 54 | 55 | // ------------------------------------------------------------------------------------------------ 56 | // Fake provided types for tests 57 | // ------------------------------------------------------------------------------------------------ 58 | 59 | let fpar n = { GenericParameterType.kind = "parameter"; name = n } :> AnyType 60 | let flist t = { ArrayType.kind = "array"; element = t } :> AnyType 61 | let fnum = { PrimitiveType.kind = "primitive"; name = "int" } :> AnyType 62 | let fbool = { PrimitiveType.kind = "primitive"; name = "bool" } :> AnyType 63 | let ffunc a b = { FunctionType.kind = "function"; arguments = [| a |]; returns = b } :> AnyType 64 | 65 | let fmeth n tya rty args = 66 | let args = args |> Array.ofList |> Array.map (fun (n, o, t) -> 67 | { name = n; optional = o; ``type`` = t }) 68 | { MethodMember.kind = "method"; name = n; typepars = Array.ofList tya 69 | arguments = args; returns = rty } 70 | let ftyp n tya mems = 71 | { ExportedType.name = n; typepars = Array.ofList tya; 72 | ``static`` = false; instance = [| |]; members = Array.ofList mems } 73 | let fnamed n tya = 74 | { NamedType.kind = "named"; name = n; typargs = Array.ofList tya } 75 | 76 | let pair = 77 | ftyp "pair" [fpar "a"; fpar "b"] [ 78 | fmeth "first" [] (fpar "a") [] 79 | fmeth "second" [] (fpar "b") [] 80 | ] 81 | 82 | let series = 83 | ftyp "series" [fpar "a"] [ 84 | fmeth "make" [fpar "b"] (fnamed "series" [fpar "b"]) [ 85 | "vals", false, flist (fpar "b") ] 86 | fmeth "makeTwo" [fpar "b"] (fnamed "series" [fpar "b"]) [ 87 | "val1", false, fpar "b" 88 | "val2", false, fpar "b" ] 89 | fmeth "range" [] (fnamed "series" [fnum]) [ 90 | "count", false, fnum ] 91 | fmeth "add" [] (fnamed "series" [fpar "a"]) [ 92 | "val", false, fpar "a" ] 93 | fmeth "map" [fpar "b"] (fnamed "series" [fpar "b"]) [ 94 | "f", false, (ffunc (fpar "a") (fpar "b")) ] 95 | fmeth "sort" [] (fnamed "series" [fpar "a"]) [ 96 | "fast", true, fbool 97 | "reverse", true, fbool ] 98 | fmeth "join" [fpar "b"] (fnamed "series" [fnamed "pair" [fpar "a"; fpar "b"]]) [ 99 | "s", false, fnamed "series" [fpar "b"] ] 100 | fmeth "head" [] (fpar "a") [] 101 | ] 102 | 103 | let table = 104 | ftyp "table" [fpar "a"] [ 105 | fmeth "make" [fpar "b"] (fnamed "table" [fpar "b"]) [ 106 | "data", false, fnamed "series" [fpar "b"] ] 107 | fmeth "data" [] (fnamed "series" [fpar "a"]) [] 108 | ] 109 | 110 | let types = System.Collections.Generic.Dictionary<_, _>() 111 | let lookupNamed n = types.[n] 112 | types.Add("pair", importProvidedType "http://demo" lookupNamed pair) 113 | types.Add("table", importProvidedType "http://demo" lookupNamed table) 114 | types.Add("series", importProvidedType "http://demo" lookupNamed series) 115 | 116 | let fapply n typ = 117 | match lookupNamed n with 118 | | Type.Object (:? GenericTypeDefinition as gtd) -> 119 | Type.Object(gtd.Apply([TypeSchema.Primitive typ]).Substitute(fun _ -> None)) 120 | | _ -> failwith "expected GenericTypeDefinition as named type" 121 | 122 | let vars = 123 | [ "series", fapply "series" Type.Any 124 | "numbers", fapply "series" (Type.Primitive PrimitiveType.Number) 125 | "table", fapply "table" (Type.Any) ] 126 | 127 | // ------------------------------------------------------------------------------------------------ 128 | // Testing the type checker & F# type provider 129 | // ------------------------------------------------------------------------------------------------ 130 | 131 | [] 132 | let ``Type check method call and infer result type from argument`` () = 133 | let code = """ 134 | let res = series.make([1,2,3]).head() 135 | """ 136 | let actual = check code (isVariable "res") vars 137 | actual |> assertType (Type.Primitive PrimitiveType.Number) 138 | actual |> assertErrors [] 139 | 140 | [] 141 | let ``Type check method call chain and infer result type from argument`` () = 142 | let code = """ 143 | let res = series.make([1,2,3]) 144 | .add(4).sort(reverse=true).head() 145 | """ 146 | let actual = check code (isVariable "res") vars 147 | actual |> assertType (Type.Primitive PrimitiveType.Number) 148 | actual |> assertErrors [] 149 | 150 | [] 151 | let ``Type check method call and infer result type from object argument`` () = 152 | let code = """ 153 | let res = table.make(numbers).data().head() 154 | """ 155 | let actual = check code (isVariable "res") vars 156 | actual |> assertType (Type.Primitive PrimitiveType.Number) 157 | actual |> assertErrors [] 158 | 159 | [] 160 | let ``Type check method call with function as an argument`` () = 161 | let code = """ 162 | let res = series.make([1,2,3]).map(fun x -> true).head() 163 | """ 164 | let actual = check code (isVariable "res") vars 165 | actual |> assertType (Type.Primitive PrimitiveType.Bool) 166 | actual |> assertErrors [] 167 | 168 | [] 169 | let ``Report error when name based param is not last`` () = 170 | let code = """ 171 | let res = numbers.sort(fast=true, false).head() 172 | """ 173 | let actual = check code (isVariable "res") vars 174 | actual |> assertType (Type.Primitive PrimitiveType.Number) 175 | actual |> assertErrors [307,"false"] 176 | 177 | [] 178 | let ``Report error when required parameter is missing value`` () = 179 | let code = """ 180 | let res = numbers.add().head() 181 | """ 182 | let actual = check code (isVariable "res") vars 183 | actual |> assertType (Type.Primitive PrimitiveType.Number) 184 | actual |> assertErrors [308,"()"] 185 | 186 | [] 187 | let ``Report error when method parameter is given a wrong value`` () = 188 | let code = """ 189 | let res = numbers.add("yo").head() 190 | """ 191 | let actual = check code (isVariable "res") vars 192 | actual |> assertErrors [310,"(\"yo\")"] 193 | 194 | [] 195 | let ``Report error when generic method type cannot be inferred`` () = 196 | let code = """ 197 | let res = series.makeTwo(1, true).head() 198 | """ 199 | let actual = check code (isVariable "res") vars 200 | actual |> assertErrors [310,"(1, true)"] 201 | 202 | [] 203 | let ``Type check call to join method that returns a pair`` () = 204 | let code = """ 205 | let res = series.make([1]).join(series.make(["a"])).head().first() 206 | """ 207 | let actual = check code (isVariable "res") vars 208 | actual |> assertType (Type.Primitive PrimitiveType.Number) 209 | actual |> assertErrors [] 210 | -------------------------------------------------------------------------------- /tests/thegamma-tests/paket.references: -------------------------------------------------------------------------------- 1 | NUnit -------------------------------------------------------------------------------- /tests/thegamma-tests/pivottypes.fs: -------------------------------------------------------------------------------- 1 | #if INTERACTIVE 2 | #r "../../packages/NUnit/lib/net45/nunit.framework.dll" 3 | #I "../../src/libraries/bin/Debug" 4 | #I "../../src/thegamma/bin/Debug" 5 | #r "libraries.dll" 6 | #r "thegamma.dll" 7 | #else 8 | [] 9 | module TheGamma.Tests.PivotTypes 10 | #endif 11 | open TheGamma 12 | open TheGamma.Common 13 | open TheGamma.TypeChecker 14 | open TheGamma.TypeProviders 15 | open TheGamma.TypeProviders.Pivot 16 | open NUnit.Framework 17 | 18 | // ------------------------------------------------------------------------------------------------ 19 | // Helper functions for writing assertions (copy & paste from simpletypes.fs) 20 | // ------------------------------------------------------------------------------------------------ 21 | 22 | /// Type-safe assertion 23 | let equal (expected:'T) (actual:'T) = Assert.AreEqual(expected, actual) 24 | 25 | /// Assert that type has specified members 26 | let assertMember mem (t, _) = 27 | match t with 28 | | Type.Object(obj) -> 29 | let names = set [ for m in obj.Members -> m.Name ] 30 | if not (names.Contains mem) then equal (String.concat "," names) mem 31 | | _ -> equal "{ object }" (Ast.formatType t) 32 | 33 | /// Assert that result contains given errors 34 | let assertErrors expectErrors (_, errs) = 35 | equal (List.length expectErrors) (List.length errs) 36 | for (en, ec), (an, ac) in List.zip expectErrors errs do 37 | equal en an 38 | equal ec ac 39 | 40 | // Find variable entity 41 | let isVariable name = function { Kind = EntityKind.Variable(n, _) } when n.Name = name -> true | _ -> false 42 | 43 | /// Parse and type check given code, find the specified entity & return its type 44 | /// together with all the errors produced by type checking of the program 45 | let check (code:string) cond vars = 46 | let ctx = Binder.createContext [] "script" 47 | let code = code.Replace("\n ", "\n") 48 | let prog, _ = code |> Parser.parseProgram 49 | let prog, entities = Binder.bindProgram ctx prog 50 | let globals = [ for n, t in vars -> Interpreter.globalEntity n [] t None ] 51 | let mutable completed = false 52 | async { do! TypeChecker.typeCheckProgram globals entities (Interpreter.evaluate globals) prog 53 | completed <- true } |> Async.StartImmediate 54 | if not completed then failwith "Asynchronosu operation did not complete" 55 | let _, ent = entities.Entities |> Seq.find (snd >> cond) 56 | let errors = TypeChecker.collectTypeErrors prog 57 | ent.Type.Value, 58 | [ for e in errors -> e.Number, code.Substring(e.Range.Start, e.Range.End - e.Range.Start + 1) ] 59 | 60 | // ------------------------------------------------------------------------------------------------ 61 | // Fake series and fake pivot types for tests 62 | // ------------------------------------------------------------------------------------------------ 63 | 64 | let series = 65 | { new FSharpProvider.GenericTypeDefinition with 66 | member x.Members = [| |] 67 | member x.TypeEquals t = false 68 | member x.FullName = "series" 69 | member x.TypeParameterCount = 2 70 | member x.Apply tys = 71 | { new FSharpProvider.GenericTypeSchema with 72 | member y.Members = [| |] 73 | member y.TypeEquals t = false 74 | member y.TypeDefinition = x 75 | member y.TypeArguments = tys 76 | member y.Substitute _ = 77 | { new FSharpProvider.GenericType with 78 | member z.Members = [| |] 79 | member z.TypeEquals t = false 80 | member z.TypeArguments = [] 81 | member z.TypeDefinition = x } } } 82 | 83 | let types = System.Collections.Generic.Dictionary<_, _>() 84 | let lookupNamed n = types.[n] 85 | types.Add("series", Type.Object series) 86 | 87 | let olympics = 88 | makePivotGlobalValue "http://demo" "olympics" lookupNamed false 89 | [ "Athlete", PrimitiveType.String; "Team", PrimitiveType.String 90 | "Gold", PrimitiveType.Number; "Silver", PrimitiveType.Number ] 91 | 92 | let typ = 93 | match olympics with 94 | | TypeProviders.ProvidedType.GlobalValue(_, _, _, typ) -> typ 95 | | _ -> failwith "makePivotGlobalValue did not return type" 96 | types.Add("olympics", typ) 97 | 98 | let vars = [ "olympics", typ ] 99 | 100 | // ------------------------------------------------------------------------------------------------ 101 | // Testing the type checker & Pivot type provider 102 | // ------------------------------------------------------------------------------------------------ 103 | 104 | [] 105 | let ``Correctly type check simple grouping and aggregation`` () = 106 | let code = """ 107 | let res = 108 | olympics 109 | .'group data'.'by Athlete'.'sum Gold'.then 110 | .'get series' 111 | """ 112 | let actual = check code (isVariable "res") vars 113 | actual |> assertMember "with key Athlete" 114 | actual |> assertMember "with key Gold" 115 | actual |> assertErrors [] 116 | 117 | [] 118 | let ``Correctly type check grouping and aggregation with paging and drop`` () = 119 | let code = """ 120 | let res = 121 | olympics 122 | .'group data'.'by Athlete'.'sum Gold'.'sum Silver'.then 123 | .paging.skip(10).take(15) 124 | .'drop columns'.'drop Silver'.then 125 | .'get series' 126 | """ 127 | let actual = check code (isVariable "res") vars 128 | actual |> assertMember "with key Athlete" 129 | actual |> assertMember "with key Gold" 130 | actual |> assertErrors [] 131 | 132 | [] 133 | let ``Correctly type check grouping and aggregation with placeholder`` () = 134 | let code = """ 135 | let res = 136 | olympics 137 | .'group data'.'by Athlete'.'sum Gold'.'sum Silver'.then 138 | .'drop columns'.[drop:'drop Silver'].then 139 | .'get series' 140 | """ 141 | let actual = check code (isVariable "res") vars 142 | actual |> assertMember "with key Athlete" 143 | actual |> assertMember "with key Gold" 144 | actual |> assertErrors [] -------------------------------------------------------------------------------- /tests/thegamma-tests/simpletypes.fs: -------------------------------------------------------------------------------- 1 | #if INTERACTIVE 2 | #r "../../packages/NUnit/lib/net45/nunit.framework.dll" 3 | #I "../../src/libraries/bin/Debug" 4 | #I "../../src/thegamma/bin/Debug" 5 | #r "libraries.dll" 6 | #r "thegamma.dll" 7 | #else 8 | [] 9 | module TheGamma.Tests.SimpleTypes 10 | #endif 11 | open TheGamma 12 | open TheGamma.Common 13 | open TheGamma.TypeChecker 14 | open NUnit.Framework 15 | 16 | // ------------------------------------------------------------------------------------------------ 17 | // Helper functions for type-checking code & producing fake types 18 | // ------------------------------------------------------------------------------------------------ 19 | 20 | // Helpers for generating object types 21 | let noEmitter = { Emit = fun _ -> failwith "mock emitter" } 22 | let prop n t = { Member.Name = n; Metadata = []; Emitter = noEmitter; Type = t } 23 | let meth n t a = { Member.Name = n; Metadata = []; Emitter = noEmitter; Type = Type.Method(a, fun _ -> t) } 24 | let delay n f = Type.Delayed(Async.CreateNamedFuture n (async { return f () })) 25 | let obj membrs = 26 | { new ObjectType with 27 | member x.Members = Array.ofList membrs 28 | member x.TypeEquals _ = false } |> Type.Object 29 | 30 | // Helpers for generating primitive types 31 | let str = Type.Primitive PrimitiveType.String 32 | let num = Type.Primitive PrimitiveType.Number 33 | let bool = Type.Primitive PrimitiveType.Bool 34 | 35 | // Helper for generating other types 36 | let list t = Type.List(t) 37 | let func t1 t2 = Type.Method([{ MethodArgument.Name = ""; Optional = false; Static = false; Type = t1 }], t2) 38 | 39 | // Find variable entity 40 | let isVariable name = function { Kind = EntityKind.Variable(n, _) } when n.Name = name -> true | _ -> false 41 | 42 | /// Parse and type check given code, find the specified entity & return its type 43 | /// together with all the errors produced by type checking of the program 44 | let check (code:string) cond vars = 45 | let ctx = Binder.createContext [] "script" 46 | let code = code.Replace("\n ", "\n") 47 | let prog, _ = code |> Parser.parseProgram 48 | let prog, entities = Binder.bindProgram ctx prog 49 | let globals = [ for n, t in vars -> Interpreter.globalEntity n [] t None ] 50 | let mutable completed = false 51 | async { do! TypeChecker.typeCheckProgram globals entities (Interpreter.evaluate globals) prog 52 | completed <- true } |> Async.StartImmediate 53 | if not completed then failwith "Asynchronosu operation did not complete" 54 | let _, ent = entities.Entities |> Seq.find (snd >> cond) 55 | let errors = TypeChecker.collectTypeErrors prog 56 | ent.Type.Value, 57 | [ for e in errors -> e.Number, code.Substring(e.Range.Start, e.Range.End - e.Range.Start + 1) ] 58 | 59 | /// Type-safe assertion 60 | let equal (expected:'T) (actual:'T) = Assert.AreEqual(expected, actual) 61 | 62 | /// Assert that two types are equal 63 | let assertType t1 (t2, _) = 64 | equal (Ast.formatType t1) (Ast.formatType t2) 65 | 66 | /// Assert that result contains given errors 67 | let assertErrors expectErrors (_, errs) = 68 | equal (List.length expectErrors) (List.length errs) 69 | for (en, ec), (an, ac) in List.zip expectErrors errs do 70 | equal en an 71 | equal ec ac 72 | 73 | // ------------------------------------------------------------------------------------------------ 74 | // Fake types for tests 75 | // ------------------------------------------------------------------------------------------------ 76 | 77 | // Simple types 78 | let rec fieldsObj t = delay "fieldsObj" (fun () -> 79 | obj [ 80 | prop "one" (fieldsObj t) 81 | prop "two" (fieldsObj t) 82 | prop "three" (fieldsObj t) 83 | prop "then" t 84 | ]) 85 | 86 | let rec testObj () = delay "testObj" (fun () -> 87 | obj [ 88 | prop "group data" (fieldsObj (testObj ())) 89 | prop "sort data" (fieldsObj (testObj ())) 90 | prop "get the data" num 91 | ]) 92 | 93 | 94 | // Type-level computations 95 | let typeLevelObj s = delay "typeLevelObj" (fun () -> 96 | obj [ 97 | prop (s + " (str)") str 98 | prop (s + " (num)") num 99 | ]) 100 | 101 | let typeLevelVar = 102 | Type.Method 103 | ( [ { MethodArgument.Name = ""; Type = Type.Primitive PrimitiveType.String; Static = true; Optional = false } ], 104 | function [_, Some s] -> Some(typeLevelObj (unbox s)) | _ -> None) 105 | 106 | // Available variables 107 | let vars = [ "test", testObj (); "typelevel", typeLevelVar ] 108 | 109 | // ------------------------------------------------------------------------------------------------ 110 | // Type-level tests 111 | // ------------------------------------------------------------------------------------------------ 112 | 113 | [] 114 | let foo () = 115 | let code = """ 116 | let res = typelevel("hello").'hello (num)' 117 | res""" 118 | let actual = check code (isVariable "res") vars 119 | actual |> assertType (Type.Primitive PrimitiveType.Number) 120 | actual |> assertErrors [] 121 | 122 | // ------------------------------------------------------------------------------------------------ 123 | // Simple type tests 124 | // ------------------------------------------------------------------------------------------------ 125 | 126 | [] 127 | let ``Type check chain consisting of property accesses`` () = 128 | let code = """ 129 | let res = test. 130 | 'group data' 131 | .one.two.three.then. 132 | 'sort data' 133 | .three.two.one.then. 134 | 'get the data' 135 | res""" 136 | let actual = check code (isVariable "res") vars 137 | actual |> assertType (Type.Primitive PrimitiveType.Number) 138 | actual |> assertErrors [] 139 | 140 | [] 141 | let ``Report errors for list with elements of mismatching types`` () = 142 | let code = """ 143 | let res = [ 144 | test.'group data'.one.then.'get the data', 145 | 42, 146 | test.'group data'.two.then.'get the data', 147 | test.'group data'.three.then, 148 | "evil" ] 149 | """ 150 | let actual = check code (isVariable "res") vars 151 | actual |> assertType (Type.List (Type.Primitive PrimitiveType.Number)) 152 | actual |> assertErrors [306, "test.'group data'.three.then"; 306, "\"evil\"" ] 153 | 154 | [] 155 | let ``Report error when property not found`` () = 156 | let code = "let res = test.yadda" 157 | let actual = check code (isVariable "res") vars 158 | actual |> assertErrors [303, "yadda"] 159 | 160 | [] 161 | let ``Report error when method not found`` () = 162 | let code = "let res = test.yadda()" 163 | let actual = check code (isVariable "res") vars 164 | actual |> assertErrors [303, "yadda"] 165 | 166 | [] 167 | let ``Report error when instance is not an object`` () = 168 | let code = """let res = test.'get the data'.bar""" 169 | let actual = check code (isVariable "res") vars 170 | actual |> assertErrors [305, "test.'get the data'"] -------------------------------------------------------------------------------- /tests/thegamma-tests/thegamma-tests.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | ee8310c8-1f2b-4f9c-83f6-5d188b7517b2 9 | Library 10 | TheGamma 11 | thegamma-tests 12 | v4.5 13 | true 14 | 4.4.0.0 15 | TheGamma 16 | 17 | 18 | 19 | true 20 | full 21 | false 22 | false 23 | bin\Debug\ 24 | DEBUG;TRACE 25 | 3 26 | AnyCPU 27 | 28 | 29 | true 30 | 31 | 32 | pdbonly 33 | true 34 | true 35 | bin\Release\ 36 | TRACE 37 | 3 38 | AnyCPU 39 | bin\Release\TheGamma.xml 40 | true 41 | 42 | 43 | 11 44 | 45 | 46 | 47 | 48 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 49 | 50 | 51 | 52 | 53 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 54 | 55 | 56 | 57 | 58 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | ../../packages/NUnit/lib/net45/nunit.framework.dll 79 | 80 | 81 | ../../node_modules/fable-core/Fable.Core.dll 82 | 83 | 84 | 85 | True 86 | 87 | 88 | 89 | 90 | 91 | libraries 92 | {c103641d-9755-4de4-bda9-fdcfc022c80e} 93 | True 94 | 95 | 96 | thegamma 97 | {ae8310c8-1f2b-4f9c-83f6-5d188b7517b2} 98 | True 99 | 100 | 101 | -------------------------------------------------------------------------------- /tests/thegamma-tests/tokenizer.fs: -------------------------------------------------------------------------------- 1 | #if INTERACTIVE 2 | #r "../../src/thegamma/bin/Debug/thegamma.dll" 3 | #r "../../packages/NUnit/lib/net45/nunit.framework.dll" 4 | #else 5 | [] 6 | module TheGamma.Tests.Tokenizer 7 | #endif 8 | open TheGamma 9 | open TheGamma.Ast 10 | open TheGamma.Tokenizer 11 | open NUnit.Framework 12 | 13 | // -------------------------------------------------------------------------------------- 14 | // Helpers for writing property tests for tokenizer 15 | // -------------------------------------------------------------------------------------- 16 | 17 | /// Global random number generator 18 | let rnd = System.Random() 19 | 20 | /// Turn series of tokens into string, using their Range and original input 21 | let formatTokensUsingRange (source:string) (tokens:seq) = 22 | tokens 23 | |> Seq.map (fun t -> source.Substring(t.Range.Start, t.Range.End - t.Range.Start + 1)) 24 | |> String.concat "" 25 | 26 | /// Generate short, potentially empty random string using characters from the given input string 27 | let randomString (s:string) = 28 | Array.init (rnd.Next 10) (fun _ -> s.[rnd.Next(s.Length)]) |> System.String 29 | 30 | /// List of tokens that do not have any parameters 31 | let constantTokens = 32 | [ TokenKind.LParen; TokenKind.RParen; TokenKind.Equals; TokenKind.Dot; TokenKind.Comma 33 | TokenKind.Let; TokenKind.LSquare; TokenKind.RSquare; TokenKind.Fun; TokenKind.Arrow 34 | TokenKind.Colon; TokenKind.Operator Operator.Divide; TokenKind.Operator Operator.GreaterThan 35 | TokenKind.Operator Operator.GreaterThanOrEqual; TokenKind.Operator Operator.LessThan 36 | TokenKind.Operator Operator.LessThanOrEqual; TokenKind.Operator Operator.Minus 37 | TokenKind.Operator Operator.Multiply; TokenKind.Operator Operator.Plus; TokenKind.Newline 38 | TokenKind.Boolean true; TokenKind.Boolean false ] 39 | 40 | /// Generate random token - takes last token to avoid generating token pairs that 41 | /// would be parsed differently (e.g. Number 1; Number 2 would be Number 12) 42 | let randomToken last = 43 | match rnd.Next(12) with 44 | | 0 | 1 | 2 | 3 when constantTokens |> Seq.exists ((=) last) |> not -> 45 | match last, constantTokens.[rnd.Next(constantTokens.Length)] with 46 | | TokenKind.Ident _, TokenKind.Let 47 | | TokenKind.Ident _, TokenKind.Fun 48 | | TokenKind.Ident _, TokenKind.Boolean _ 49 | | TokenKind.Number _, TokenKind.Dot -> TokenKind.Arrow 50 | | _, t -> t 51 | | 4 when (match last with TokenKind.Ident _ | TokenKind.Number _ -> false | _ -> true) -> 52 | let n = rnd.Next(0, 1000000000) 53 | TokenKind.Number(string n, float n) 54 | | 5 when (match last with TokenKind.Ident _ | TokenKind.Number _ -> false | _ -> true) -> 55 | let n1, n2 = rnd.Next(0, 1000000), rnd.Next(0, 1000000) 56 | let n = string n1 + "." + string n2 57 | TokenKind.Number(n, float n) 58 | | 6 -> TokenKind.String(randomString "abcDEF012$*^!@#+,. \n\\\"") 59 | | 7 when (match last with TokenKind.Number _ | TokenKind.Ident _ -> false | _ -> true) -> 60 | TokenKind.Ident("a" + randomString "bcdEFG0123") 61 | | 8 -> TokenKind.QIdent(randomString "bcdEFG0123$*^!@#+,. \\\"") 62 | | _ when (match last with TokenKind.White _ -> false | _ -> true) -> 63 | TokenKind.White(" " + randomString " ") 64 | | _ -> TokenKind.Comma 65 | 66 | /// Generate completely random string 67 | let withString () = 68 | Array.init 100 (fun _ -> randomString "\"'\\\n abcDEF1234,[].+-/<>=@#$%") 69 | |> String.concat "" 70 | 71 | /// Generate random array of tokens (with incorrect ranges) 72 | let withTokens () = 73 | TokenKind.Dot 74 | |> Seq.unfold (fun last -> 75 | let t = { Token = randomToken last; Range = { Start = 0; End = 0 } } 76 | Some(t, t.Token)) 77 | |> Seq.take (20 + rnd.Next(100)) 78 | |> List.ofSeq 79 | 80 | /// Check property involving random tokens 81 | let check g (f:_ -> unit) = 82 | for i in 1 .. 100 do 83 | f (g()) 84 | printfn " (Passed 100 tests)" 85 | 86 | /// Check that tokens are equal (ignoring ranges) 87 | let tokensEqual t1 t2 = 88 | let equal = 89 | List.zip (List.ofSeq t1) (List.ofSeq t2) 90 | |> List.forall (fun (t1, t2) -> t1.Token = t2.Token) 91 | if not equal then 92 | printfn " *** Assertion failed: Tokens do not match ***" 93 | printfn " *** Tokens:" 94 | let n = Seq.zip t1 t2 |> Seq.takeWhile (fun (t1, t2) -> t1 = t2) |> Seq.length 95 | Seq.zip t1 t2 96 | |> Seq.skip (max 0 (n - 2)) 97 | |> Seq.truncate 5 98 | |> Seq.iter (fun (t1, t2) -> 99 | printfn " *** - '%s' %s '%s' " (formatToken t1.Token) (if t1.Token = t2.Token then "=" else "<>") (formatToken t2.Token)) 100 | Assert.AreEqual(true, equal) 101 | 102 | /// Shorter assertion 103 | let equal (a:'T) (b:'T) = 104 | if a <> b then 105 | printfn " *** Assertion failed: Values do not match ***" 106 | printfn " *** Expected: %A" a 107 | printfn " *** Actual: %A" b 108 | Assert.AreEqual(true, (a = b)) 109 | 110 | 111 | // -------------------------------------------------------------------------------------- 112 | // TESTS: Property tests for tokenizer 113 | // -------------------------------------------------------------------------------------- 114 | 115 | [] 116 | let ``Format and tokenize returns original tokens`` () = 117 | check withTokens (fun sourceTokens -> 118 | let parsedTokens, errors = Tokenizer.tokenize (formatTokens sourceTokens) 119 | tokensEqual parsedTokens sourceTokens) 120 | 121 | [] 122 | let ``Format and tokenize does not produce errors`` () = 123 | check withTokens (fun sourceTokens -> 124 | let parsedTokens, errors = Tokenizer.tokenize (formatTokens sourceTokens) 125 | equal [||] errors) 126 | 127 | [] 128 | let ``Concatenate using ranges recreates original input for valid tokens`` () = 129 | check withTokens (fun sourceTokens -> 130 | let input = formatTokens sourceTokens 131 | let parsedTokens, _ = Tokenizer.tokenize input 132 | let output = formatTokensUsingRange input parsedTokens 133 | equal input output) 134 | 135 | [] 136 | let ``Concatenate using ranges recreates original input for random string`` () = 137 | check withString (fun input -> 138 | let parsedTokens, _ = Tokenizer.tokenize input 139 | let output = formatTokensUsingRange input parsedTokens 140 | equal input output) 141 | --------------------------------------------------------------------------------