├── .gitignore ├── .gitmodules ├── Makefile ├── README.md ├── elm-package.json ├── hacked-compiler └── elm-make ├── img └── fac-screenshot.png ├── package.json ├── server.js └── src ├── ASTDecoder.elm ├── Elm ├── AST.elm ├── Decode.elm ├── Interpret.elm └── Trace.elm ├── ExampleData.elm ├── FlameGraph.elm ├── Main.elm ├── Model.elm ├── Style.elm ├── Utils.elm ├── ViewCompileErrors.elm ├── Viewer.elm └── Viz.elm /.gitignore: -------------------------------------------------------------------------------- 1 | elm-stuff 2 | node_modules 3 | public 4 | empty-elm-dir 5 | index.html 6 | src/Test.elm 7 | .idea 8 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "elm-diagrams"] 2 | path = elm-diagrams 3 | url = git@github.com:vilterp/elm-diagrams 4 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: empty-elm-dir 2 | # https://github.com/elm-lang/elm-make/issues/33 3 | export LANG=en_US.UTF-8 && elm make --yes src/Main.elm --output=public/index.html 4 | 5 | deps: 6 | git submodule init 7 | git submodule update elm-diagrams 8 | elm package install --yes 9 | npm install 10 | 11 | empty-elm-dir: 12 | mkdir -p empty-elm-dir && cd empty-elm-dir && ../hacked-compiler/elm-make --yes 13 | 14 | 15 | clean: 16 | rm -rf elm-stuff 17 | rm -rf node_modules 18 | rm public/elm.js 19 | rm -rf empty-elm-dir 20 | 21 | 22 | loc: 23 | find src -regex ".*elm" | xargs wc -l 24 | 25 | start: all 26 | node server.js 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Elm Tracing Interpreter 2 | 3 | ![image](/img/fac-screenshot.png) 4 | 5 | _Visualization of computing the factorial of 3: a flame graph with red lines representing the flow of values._ 6 | 7 | - *return values may come from return values of other functions* 8 | - *arguments may come from return values of prior function calls* 9 | - *arguments can come from literals, represented as a small square to the right of the arguments of the function in which they were evaluated.* 10 | 11 | ## Overview 12 | 13 | We love Elm because our code runs without runtime exceptions, but what if you have the wrong output? Even if we know what arguments the misbehaving function was passed to produce the bad output, we still have to start at both ends (the arguments and output) toward some point in between where something went wrong, often by inserting many log statements, recompiling, and re-running. 14 | 15 | This project is an attempt to give total knowledge of the execution of an Elm function, so we can track down what went wrong, or just explore. 16 | 17 | ## Build & Run 18 | ``` 19 | make deps 20 | make start 21 | ``` 22 | And go to `localhost:4000`. 23 | 24 | **Note:** I've included `hacked-compiler/elm-make`, which I pre-built from my forks of elm-make and elm-compiler: [`vilterp/elm-make:json-ast`](https://github.com/vilterp/elm-make/tree/json-ast) and [`vilterp/elm-compiler:json-ast`](https://github.com/vilterp/elm-compiler/tree/json-ast). Those are built as the core tools normally are, which is a little more involved. 25 | 26 | ## How it works 27 | 28 | ``` 29 | Elm source 30 | =(compiler)=> JSON AST 31 | =(tracing interpreter)=> Call Tree w/ TVals 32 | =(elm-diagrams)=> Visualization 33 | ``` 34 | 35 | 36 | ## Current state, future work 37 | 38 | More detail in [the Trello](https://trello.com/b/6fNpWjix/reversible-interpreter#). 39 | 40 | - interpreter 41 | - doesn't cover ADTs, records, or `case` expressions yet 42 | - doesn't even handle importing Elm code from other modules (almost there); doesn't yet reimplement things in `core` that are implemented with native code 43 | - visualization 44 | - would like to link the flame graph, value viewer, and source code viewer together a lot more. 45 | - uncurrying: we interpret functions in a curried fashion, but it would be nice to collapse applications of multiple arguments to one stack frame in the visualization; currently this is only done with binary operators. 46 | - general usability & explorability… (i.e. don't show all the red lines at once; enable drilling down and following a thread) 47 | - a nested DAG resembling [lemur](https://github.com/vilterp/lemur) instead of a flame graph? idk… 48 | 49 | 50 | ## Practical challenges 51 | 52 | - Upstreaming the JSON AST compiler backend (currently it's not even a flag or anything; always does JSON. "hacking" is really a descriptive word of what I did here) 53 | - How to keep Elm AST types in sync with Haskell types (this may be useful for other projects though) 54 | - How to fit this inside of the time-travelling debugger, or generally make it usable in more places 55 | 56 | ## Prior art 57 | 58 | Total-recording debuggers are not a new idea; I can't remember any to cite and am not taking direct inspiration from any of them. The closest thing in my mind is Ravi Chugh's [Sketch-n-Sketch](https://github.com/ravichugh/sketch-n-sketch) (written in Elm, but with its own language), which uses interpreter traces to infer program changes from direct manipulation of graphical program output. (Much more advanced than this!) 59 | -------------------------------------------------------------------------------- /elm-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "1.0.0", 3 | "summary": "helpful summary of your project, less than 80 characters", 4 | "repository": "https://github.com/vilterp/elm-reversible-interpreter.git", 5 | "license": "BSD3", 6 | "source-directories": [ 7 | "src", 8 | "elm-diagrams" 9 | ], 10 | "exposed-modules": [], 11 | "dependencies": { 12 | "bartavelle/json-helpers": "1.1.1 <= v < 2.0.0", 13 | "elm-community/list-extra": "3.1.0 <= v < 4.0.0", 14 | "elm-lang/core": "4.0.0 <= v < 5.0.0", 15 | "elm-lang/html": "1.0.0 <= v < 2.0.0", 16 | "elm-lang/svg": "1.1.1 <= v < 2.0.0", 17 | "elm-lang/window": "1.0.0 <= v < 2.0.0", 18 | "evancz/elm-graphics": "1.0.0 <= v < 2.0.0", 19 | "evancz/elm-http": "3.0.1 <= v < 4.0.0", 20 | "lukewestby/elm-http-builder": "2.0.0 <= v < 3.0.0" 21 | }, 22 | "elm-version": "0.17.1 <= v < 0.18.0" 23 | } 24 | -------------------------------------------------------------------------------- /hacked-compiler/elm-make: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vilterp/elm-tracing-interpreter/8b151b1550fa5cc2d5fd2ebbb681d7a16babcd09/hacked-compiler/elm-make -------------------------------------------------------------------------------- /img/fac-screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vilterp/elm-tracing-interpreter/8b151b1550fa5cc2d5fd2ebbb681d7a16babcd09/img/fac-screenshot.png -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "reversible-interpreter", 3 | "repository": { 4 | "type": "git", 5 | "url": "https://github.com/vilterp/elm-reversible-interpreter.git" 6 | }, 7 | "version": "0.0.0", 8 | "description": "execute your elm programs in reverse", 9 | "dependencies": { 10 | "body-parser": "^1.12.4", 11 | "express": "^4.12.3", 12 | "fs-extra": "^0.18.3", 13 | "morgan": "^1.5.3", 14 | "tmp": "0.0.26" 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /server.js: -------------------------------------------------------------------------------- 1 | const express = require('express'); 2 | const bodyParser = require('body-parser'); 3 | const events = require('events'); 4 | const childProcess = require('child_process'); 5 | const tmp = require('tmp'); 6 | const fs = require('fs-extra'); 7 | const EventEmitter = require('events').EventEmitter; 8 | const util = require('util'); 9 | const path = require('path'); 10 | 11 | // const multer = require('multer'); 12 | 13 | const app = express(); 14 | 15 | // really annoyed that express doesn't do this by default 16 | app.use(bodyParser.json()); // to support JSON-encoded bodies 17 | app.use(bodyParser.urlencoded({ // to support URL-encoded bodies 18 | extended: true 19 | })); 20 | // tell express to print requests in the console as they come in 21 | app.use(require('morgan')('tiny')); 22 | // for uploading files 23 | // app.use(multer({ dest: './saved_data/uploads/'})); 24 | 25 | // serve static files 26 | app.use(express.static(__dirname + '/public')); 27 | 28 | // tell express how to handle requests 29 | app.get('/', (req, res) => { 30 | res.sendFile('public/index.html'); 31 | }); 32 | 33 | const emptyElmDir = path.join(path.dirname(process.argv[1]), 'empty-elm-dir'); 34 | const hackedMake = path.join(path.dirname(process.argv[1]), 'hacked-compiler', 'elm-make'); 35 | 36 | app.post('/compile_elm', (req, res) => { 37 | 38 | tmp.dir((err, tmpDir, cleanupCallback) => { 39 | console.log('dir:', tmpDir); 40 | fs.copy(emptyElmDir, tmpDir, () => { 41 | const code = req.body.code; 42 | console.log('CODE:', code); 43 | fs.writeFile(path.join(tmpDir, 'Main.elm'), code, () => { 44 | const cmd = `${hackedMake} Main.elm --output out.json`; 45 | console.log(cmd); 46 | childProcess.exec(cmd, { cwd: tmpDir }, (error, stdout, stderr) => { 47 | if (error && error.code !== 0) { 48 | res.status(400); 49 | res.send(stdout + stderr); 50 | console.log('ERRORS:', stdout); 51 | } else { 52 | res.status(200); 53 | res.sendFile(path.join(tmpDir, 'out.json')); 54 | console.log('SUCCESS'); 55 | } 56 | }); 57 | }); 58 | }); 59 | 60 | }); 61 | 62 | }); 63 | 64 | app.listen(4000, () => { 65 | console.log('listening on http://localhost:4000/'); 66 | }); 67 | -------------------------------------------------------------------------------- /src/ASTDecoder.elm: -------------------------------------------------------------------------------- 1 | module ASTDecoder exposing (..) 2 | 3 | import Html exposing (..) 4 | import Html.Attributes exposing (..) 5 | import Html.Events exposing (..) 6 | import Html.App as App 7 | import Json.Decode as JsDec 8 | 9 | import Elm.AST exposing (..) 10 | import Elm.Decode exposing (..) 11 | import Utils 12 | 13 | 14 | type alias Model = 15 | { text : String 16 | , decoded : Maybe (Result String (List (Module (List Def)))) 17 | --, decoded : Maybe (Result String Int) 18 | } 19 | 20 | 21 | type Msg 22 | = UpdateText String 23 | | Decode 24 | 25 | 26 | update : Msg -> Model -> Model 27 | update msg model = 28 | case msg of 29 | UpdateText txt -> 30 | { model | text = txt } 31 | 32 | Decode -> 33 | { model | decoded = 34 | JsDec.decodeString (JsDec.list Elm.Decode.decodeModuleOfDefs) model.text |> Just 35 | --Nothing 36 | } 37 | 38 | 39 | view : Model -> Html Msg 40 | view model = 41 | let 42 | result = 43 | model.decoded 44 | |> Maybe.map (Result.map toString >> Utils.getResult) 45 | |> Maybe.withDefault "Paste a JSON AST & hit 'Decode'" 46 | in 47 | div 48 | [] 49 | [ textarea [ onInput UpdateText, rows 10, cols 50 ] [ text model.text ] 50 | , button [ onClick Decode ] [ text "Decode" ] 51 | , pre [ style [("white-space", "pre-wrap")] ] [ text result ] 52 | ] 53 | 54 | 55 | main = 56 | App.beginnerProgram 57 | { model = { text = "", decoded = Nothing } 58 | , view = view 59 | , update = update 60 | } 61 | -------------------------------------------------------------------------------- /src/Elm/AST.elm: -------------------------------------------------------------------------------- 1 | module Elm.AST exposing (..) 2 | 3 | 4 | type alias ModuleDefs = 5 | List (Module (List Def)) 6 | 7 | 8 | -- shit, maybe I'll have to send the whole source code of 9 | -- core across. 10 | type alias FilePath = 11 | String 12 | 13 | 14 | type alias Module phase = 15 | { name : CanonicalModuleName 16 | , path : FilePath 17 | , info : phase 18 | } 19 | 20 | 21 | -- canonical module name 22 | type alias CanonicalModuleName = 23 | { package : PackageName 24 | , modul : ModuleName 25 | } 26 | 27 | 28 | -- user/project 29 | type alias PackageName = 30 | String 31 | 32 | 33 | -- raw module name (?) 34 | type alias ModuleName = 35 | List String 36 | 37 | 38 | -- def need this (ha) 39 | type Def = 40 | -- canonical pattern, then canonical type 41 | Def Facts CanonicalPattern Expr (Maybe (Located CanonicalType)) 42 | 43 | 44 | type alias Facts = 45 | { dependencies : (List TopLevel) 46 | } 47 | 48 | 49 | -- top level var 50 | type alias TopLevel = 51 | { topHome : CanonicalModuleName 52 | , topName : String 53 | } 54 | 55 | 56 | -- var 57 | 58 | type alias CanonicalVar = 59 | { home : Home 60 | , name : String 61 | } 62 | 63 | 64 | type Home = 65 | BuiltIn 66 | | ModuleHome CanonicalModuleName 67 | | TopLevelHome CanonicalModuleName 68 | | Local 69 | 70 | 71 | -- expr 72 | 73 | 74 | type alias Expr = 75 | Annotated Region (Expr' Region Def CanonicalVar CanonicalType) 76 | 77 | 78 | type alias ParamExpr ann def var typ = 79 | Annotated ann (Expr' ann def var typ) 80 | 81 | 82 | type Expr' ann def var typ = 83 | Literal Literal 84 | | Var var 85 | | Range (ParamExpr ann def var typ) (ParamExpr ann def var typ) 86 | | ExplicitList (List (ParamExpr ann def var typ)) 87 | | Binop var (ParamExpr ann def var typ) (ParamExpr ann def var typ) 88 | | Lambda (Pattern ann var) (ParamExpr ann def var typ) 89 | | App (ParamExpr ann def var typ) (ParamExpr ann def var typ) 90 | | If (List ((ParamExpr ann def var typ), (ParamExpr ann def var typ))) (ParamExpr ann def var typ) 91 | | Let (List def) (ParamExpr ann def var typ) 92 | | Case (ParamExpr ann def var typ) (List ((Pattern ann var), (ParamExpr ann def var typ))) 93 | | Data String (List (ParamExpr ann def var typ)) 94 | | Access (ParamExpr ann def var typ) String 95 | | Update (ParamExpr ann def var typ) (List (String, (ParamExpr ann def var typ))) 96 | | Record (List (String, (ParamExpr ann def var typ))) 97 | | Cmd CanonicalModuleName 98 | | Sub CanonicalModuleName 99 | | OutgoingPort String typ 100 | | IncomingPort String typ 101 | | Program (Main typ) (ParamExpr ann def var typ) 102 | --| SaveEnv Canonical Canonical 103 | --| GLShader String String GLShaderTipe 104 | 105 | 106 | type Main typ = 107 | VDom 108 | | NoFlags 109 | | Flags typ 110 | 111 | 112 | type Aliased t = 113 | Holey t 114 | | Filled t 115 | 116 | 117 | -- Pattern 118 | 119 | type alias CanonicalPattern = 120 | Pattern Region CanonicalVar 121 | 122 | 123 | type alias Pattern ann var = 124 | Annotated ann (Pattern' ann var) 125 | 126 | 127 | type Pattern' ann var = 128 | DataPattern var (List (Pattern ann var)) 129 | | RecordPattern (List String) 130 | | Alias String (Pattern ann var) 131 | | VarPattern String 132 | | Anything 133 | | LiteralPattern Literal 134 | 135 | 136 | -- literal 137 | 138 | type Literal = 139 | IntNum Int 140 | | FloatNum Float 141 | | Chr Char 142 | | Str String 143 | | Boolean Bool 144 | 145 | 146 | -- type 147 | 148 | type CanonicalType = 149 | LambdaType CanonicalType CanonicalType 150 | | VarType String 151 | | Type CanonicalType 152 | | AppType CanonicalType (List CanonicalType) 153 | | RecordType (List (String, CanonicalType)) (Maybe CanonicalType) 154 | | Aliased CanonicalType (List (String, CanonicalType)) (Aliased CanonicalType) 155 | 156 | 157 | -- reporting stuff 158 | 159 | type alias Located a = 160 | Annotated Region a 161 | 162 | 163 | type Annotated annotation a = 164 | A annotation a 165 | 166 | 167 | type alias Region = 168 | { start : Position 169 | , end : Position 170 | } 171 | 172 | 173 | type alias Position = 174 | { line : Int 175 | , column : Int 176 | } 177 | -------------------------------------------------------------------------------- /src/Elm/Decode.elm: -------------------------------------------------------------------------------- 1 | module Elm.Decode exposing (..) 2 | 3 | import Json.Decode as JsDec 4 | import Json.Decode exposing ((:=)) 5 | import Json.Encode exposing (Value) 6 | -- The following module comes from bartavelle/json-helpers 7 | import Json.Helpers exposing (..) 8 | import Dict 9 | import Set 10 | import String 11 | 12 | import Elm.AST exposing (..) 13 | 14 | 15 | decodeModuleOfDefs : JsDec.Decoder (Module (List Def)) 16 | decodeModuleOfDefs = 17 | jsonDecModule (JsDec.list jsonDecDef) 18 | --jsonDecModule (jsonDecModuleName) 19 | 20 | 21 | jsonDecFilePath = 22 | JsDec.string 23 | 24 | 25 | jsonDecModule : JsDec.Decoder phase -> JsDec.Decoder ( Module phase ) 26 | jsonDecModule localDecoder_phase = 27 | ("name" := jsonDecCanonicalModuleName) `JsDec.andThen` \pname -> 28 | ("path" := jsonDecFilePath) `JsDec.andThen` \ppath -> 29 | ("info" := localDecoder_phase) `JsDec.andThen` \pinfo -> 30 | JsDec.succeed {name = pname, path = ppath, info = pinfo} 31 | 32 | 33 | jsonDecCanonicalModuleName : JsDec.Decoder ( CanonicalModuleName ) 34 | jsonDecCanonicalModuleName = 35 | ("_package" := jsonDecPackageName) `JsDec.andThen` \p_package -> 36 | ("_module" := jsonDecModuleName) `JsDec.andThen` \p_module -> 37 | JsDec.succeed {package = p_package, modul = p_module} 38 | 39 | 40 | jsonDecPackageName = 41 | JsDec.string 42 | 43 | 44 | jsonDecModuleName = 45 | JsDec.list JsDec.string 46 | 47 | 48 | jsonDecDef : JsDec.Decoder ( Def ) 49 | jsonDecDef = 50 | JsDec.tuple4 Def (jsonDecFacts) jsonDecCanonicalPattern jsonDecExpr (JsDec.maybe (jsonDecLocated (jsonDecCanonicalType))) 51 | 52 | 53 | jsonDecFacts : JsDec.Decoder ( Facts ) 54 | jsonDecFacts = 55 | ("dependencies" := JsDec.list (jsonDecTopLevel)) `JsDec.andThen` \pdependencies -> 56 | JsDec.succeed {dependencies = pdependencies} 57 | 58 | 59 | jsonDecTopLevel : JsDec.Decoder ( TopLevel ) 60 | jsonDecTopLevel = 61 | ("topHome" := jsonDecCanonicalModuleName) `JsDec.andThen` \ptopHome -> 62 | ("topName" := JsDec.string) `JsDec.andThen` \ptopName -> 63 | JsDec.succeed {topHome = ptopHome, topName = ptopName} 64 | 65 | 66 | jsonDecCanonicalVar : JsDec.Decoder ( CanonicalVar ) 67 | jsonDecCanonicalVar = 68 | ("home" := jsonDecHome) `JsDec.andThen` \phome -> 69 | ("name" := JsDec.string) `JsDec.andThen` \pname -> 70 | JsDec.succeed {home = phome, name = pname} 71 | 72 | 73 | jsonDecHome : JsDec.Decoder ( Home ) 74 | jsonDecHome = 75 | let jsonDecDictHome = Dict.fromList 76 | [ ("BuiltIn", JsDec.succeed BuiltIn) 77 | , ("Module", JsDec.map ModuleHome (jsonDecCanonicalModuleName)) 78 | , ("TopLevel", JsDec.map TopLevelHome (jsonDecCanonicalModuleName)) 79 | , ("Local", JsDec.succeed Local) 80 | ] 81 | in decodeSumObjectWithSingleField "Home" jsonDecDictHome 82 | 83 | 84 | jsonDecExpr : JsDec.Decoder Expr 85 | jsonDecExpr = 86 | let 87 | decDef = 88 | lazy (\_ -> jsonDecDef) 89 | in 90 | jsonDecAnnotated jsonDecRegion (jsonDecExpr' jsonDecRegion decDef jsonDecCanonicalVar jsonDecCanonicalType) 91 | 92 | 93 | region = 94 | { 95 | start = { 96 | line = 3, 97 | column = 5 98 | }, 99 | end = { 100 | line = 3, 101 | column = 6 102 | } 103 | } 104 | 105 | 106 | jsonDecParamExpr : JsDec.Decoder ann -> JsDec.Decoder def -> JsDec.Decoder var -> JsDec.Decoder typ -> JsDec.Decoder ( ParamExpr ann def var typ ) 107 | jsonDecParamExpr localDecoder_ann localDecoder_def localDecoder_var localDecoder_typ = 108 | jsonDecAnnotated localDecoder_ann (jsonDecExpr' localDecoder_ann localDecoder_def localDecoder_var localDecoder_typ) 109 | 110 | 111 | jsonDecExpr' : JsDec.Decoder ann -> JsDec.Decoder def -> JsDec.Decoder var -> JsDec.Decoder typ -> JsDec.Decoder ( Expr' ann def var typ ) 112 | jsonDecExpr' localDecoder_ann localDecoder_def localDecoder_var localDecoder_typ = 113 | let decExpr = 114 | lazy (\_ -> jsonDecParamExpr localDecoder_ann localDecoder_def localDecoder_var localDecoder_typ) 115 | decPattern = 116 | jsonDecPattern localDecoder_ann localDecoder_var 117 | jsonDecDictExpr' = Dict.fromList 118 | [ 119 | ("Literal", JsDec.map Literal (jsonDecLiteral)) 120 | , ("Var", JsDec.map Var (localDecoder_var)) 121 | , ("Range", JsDec.tuple2 Range decExpr decExpr) 122 | , ("ExplicitList", JsDec.map ExplicitList (JsDec.list decExpr)) 123 | , ("Binop", JsDec.tuple3 Binop (localDecoder_var) decExpr decExpr) 124 | , ("Lambda", JsDec.tuple2 Lambda decPattern decExpr) 125 | , ("App", JsDec.tuple2 App decExpr decExpr) 126 | , ("If", JsDec.tuple2 If (JsDec.list (JsDec.tuple2 (,) decExpr decExpr)) decExpr) 127 | , ("Let", JsDec.tuple2 Let (JsDec.list (localDecoder_def)) decExpr) 128 | , ("Case", JsDec.tuple2 Case decExpr (JsDec.list (JsDec.tuple2 (,) decPattern decExpr))) 129 | , ("Data", JsDec.tuple2 Data (JsDec.string) (JsDec.list decExpr)) 130 | , ("Access", JsDec.tuple2 Access decExpr (JsDec.string)) 131 | , ("Update", JsDec.tuple2 Update decExpr (JsDec.list (JsDec.tuple2 (,) (JsDec.string) decExpr))) 132 | , ("Record", JsDec.map Record (JsDec.list (JsDec.tuple2 (,) (JsDec.string) decExpr))) 133 | , ("Cmd", JsDec.map Cmd (jsonDecCanonicalModuleName)) 134 | , ("Sub", JsDec.map Sub (jsonDecCanonicalModuleName)) 135 | , ("OutgoingPort", JsDec.tuple2 OutgoingPort (JsDec.string) (localDecoder_typ)) 136 | , ("IncomingPort", JsDec.tuple2 IncomingPort (JsDec.string) (localDecoder_typ)) 137 | , ("Program", JsDec.tuple2 Program (jsonDecMain (localDecoder_typ)) decExpr) 138 | --, ("SaveEnv", JsDec.tuple2 SaveEnv (jsonDecCanonical) (jsonDecCanonical)) 139 | --, ("GLShader", JsDec.tuple3 GLShader (JsDec.string) (JsDec.string) (jsonDecGLShaderTipe)) 140 | ] 141 | in 142 | decodeSumObjectWithSingleField "Expr'" jsonDecDictExpr' 143 | 144 | 145 | lazy : (() -> JsDec.Decoder a) -> JsDec.Decoder a 146 | lazy thunk = 147 | JsDec.customDecoder JsDec.value 148 | (\js -> JsDec.decodeValue (thunk ()) js) 149 | 150 | 151 | jsonDecMain : JsDec.Decoder typ -> JsDec.Decoder ( Main typ ) 152 | jsonDecMain localDecoder_typ = 153 | let jsonDecDictMain = Dict.fromList 154 | [ ("VDom", JsDec.succeed VDom) 155 | , ("NoFlags", JsDec.succeed NoFlags) 156 | , ("Flags", JsDec.map Flags (localDecoder_typ)) 157 | ] 158 | in decodeSumObjectWithSingleField "Main" jsonDecDictMain 159 | 160 | 161 | jsonDecAliased : JsDec.Decoder t -> JsDec.Decoder ( Aliased t ) 162 | jsonDecAliased localDecoder_t = 163 | let jsonDecDictAliased = Dict.fromList 164 | [ ("Holey", JsDec.map Holey (localDecoder_t)) 165 | , ("Filled", JsDec.map Filled (localDecoder_t)) 166 | ] 167 | in decodeSumObjectWithSingleField "Aliased" jsonDecDictAliased 168 | 169 | 170 | jsonDecCanonicalPattern : JsDec.Decoder CanonicalPattern 171 | jsonDecCanonicalPattern = 172 | jsonDecPattern jsonDecRegion jsonDecCanonicalVar 173 | 174 | 175 | jsonDecPattern : JsDec.Decoder ann -> JsDec.Decoder var -> JsDec.Decoder (Pattern ann var) 176 | jsonDecPattern decAnn decVar = 177 | jsonDecAnnotated decAnn (jsonDecPattern' decAnn decVar) 178 | 179 | 180 | jsonDecPattern' : JsDec.Decoder ann -> JsDec.Decoder var -> JsDec.Decoder ( Pattern' ann var ) 181 | jsonDecPattern' localDecoder_ann localDecoder_var = 182 | let 183 | decPattern = 184 | lazy (\_ -> jsonDecPattern localDecoder_ann localDecoder_var) 185 | jsonDecDictPattern' = Dict.fromList 186 | [ ("Data", JsDec.tuple2 DataPattern (localDecoder_var) (JsDec.list decPattern)) 187 | , ("Record", JsDec.map RecordPattern (JsDec.list (JsDec.string))) 188 | , ("Alias", JsDec.tuple2 Alias (JsDec.string) decPattern) 189 | , ("Var", JsDec.map VarPattern (JsDec.string)) 190 | , ("Anything", JsDec.succeed Anything) 191 | , ("Literal", JsDec.map LiteralPattern (jsonDecLiteral)) 192 | ] 193 | in 194 | --decodeSumTaggedObject "Pattern'" "tag" "contents" jsonDecDictPattern' Set.empty 195 | decodeSumObjectWithSingleField "Pattern'" jsonDecDictPattern' 196 | 197 | 198 | jsonDecLiteral : JsDec.Decoder ( Literal ) 199 | jsonDecLiteral = 200 | let jsonDecDictLiteral = Dict.fromList 201 | [ ("IntNum", JsDec.map IntNum (JsDec.int)) 202 | , ("FloatNum", JsDec.map FloatNum (JsDec.float)) 203 | , ("Chr", JsDec.map Chr jsonDecChar) 204 | , ("Str", JsDec.map Str (JsDec.string)) 205 | , ("Boolean", JsDec.map Boolean (JsDec.bool)) 206 | ] 207 | in decodeSumObjectWithSingleField "Literal" jsonDecDictLiteral 208 | 209 | 210 | jsonDecChar : JsDec.Decoder Char 211 | jsonDecChar = 212 | JsDec.string 213 | `JsDec.andThen` (\str -> 214 | case String.uncons str of 215 | Just (chr, "") -> 216 | JsDec.succeed chr 217 | 218 | _ -> 219 | JsDec.fail "didn't see a char" 220 | ) 221 | 222 | 223 | jsonDecCanonicalType : JsDec.Decoder ( CanonicalType ) 224 | jsonDecCanonicalType = 225 | let 226 | decType = 227 | lazy (\_ -> jsonDecCanonicalType) 228 | jsonDecDictCanonical = Dict.fromList 229 | [ ("Lambda", JsDec.tuple2 LambdaType decType decType) 230 | , ("Var", JsDec.map VarType (JsDec.string)) 231 | , ("Type", JsDec.map Type decType) 232 | , ("App", JsDec.tuple2 AppType decType (JsDec.list decType)) 233 | , ("Record", JsDec.tuple2 RecordType (JsDec.list (JsDec.tuple2 (,) (JsDec.string) decType)) (JsDec.maybe decType)) 234 | , ("Aliased", JsDec.tuple3 Aliased decType (JsDec.list (JsDec.tuple2 (,) (JsDec.string) decType)) (jsonDecAliased decType)) 235 | ] 236 | in decodeSumObjectWithSingleField "Canonical" jsonDecDictCanonical 237 | 238 | 239 | jsonDecLocated : JsDec.Decoder a -> JsDec.Decoder ( Located a ) 240 | jsonDecLocated decA = 241 | jsonDecAnnotated jsonDecRegion decA 242 | 243 | 244 | jsonDecAnnotated : JsDec.Decoder annotation -> JsDec.Decoder a -> JsDec.Decoder ( Annotated annotation a ) 245 | jsonDecAnnotated localDecoder_annotation localDecoder_a = 246 | JsDec.tuple2 A (localDecoder_annotation) (localDecoder_a) 247 | 248 | 249 | jsonDecRegion : JsDec.Decoder ( Region ) 250 | jsonDecRegion = 251 | ("start" := jsonDecPosition) `JsDec.andThen` \pstart -> 252 | ("end" := jsonDecPosition) `JsDec.andThen` \pend -> 253 | JsDec.succeed {start = pstart, end = pend} 254 | 255 | 256 | jsonDecPosition : JsDec.Decoder ( Position ) 257 | jsonDecPosition = 258 | ("line" := JsDec.int) `JsDec.andThen` \pline -> 259 | ("column" := JsDec.int) `JsDec.andThen` \pcolumn -> 260 | JsDec.succeed {line = pline, column = pcolumn} 261 | -------------------------------------------------------------------------------- /src/Elm/Interpret.elm: -------------------------------------------------------------------------------- 1 | module Elm.Interpret exposing (..) 2 | 3 | import Dict exposing (Dict) 4 | 5 | import Utils 6 | import Elm.AST as AST exposing (..) 7 | import Elm.Trace as Trace exposing (..) 8 | import Model exposing (..) 9 | 10 | 11 | type InterpError 12 | = NoMainYo 13 | 14 | 15 | interpretMainYo : FuncDict -> Result InterpError (CallTree, TVal) 16 | interpretMainYo funcDict = 17 | case Dict.get ("user/project", ["Main"], "mainYo") funcDict of 18 | Just (Def _ pattern expr _) -> 19 | let 20 | (tVal, finalState) = 21 | interpretExpr funcDict Dict.empty initialState expr 22 | 23 | (A region _) = 24 | expr 25 | 26 | rootCall = 27 | { func = 28 | ( ClosureV 29 | { sourceRegion = region 30 | , closureScope = Dict.empty 31 | , lambda = { varName = "", expr = expr } 32 | } 33 | , LiteralT -1 region -- behind the bubbles of spacetime... 34 | ) 35 | , name = Just "mainYo" 36 | , args = [] 37 | , result = tVal 38 | , subcalls = finalState.subcallsAtThisLevel 39 | , caller = Nothing 40 | } 41 | 42 | stateWithRootCall = 43 | { finalState | callTree = 44 | finalState.callTree 45 | |> Dict.insert 0 rootCall 46 | } 47 | in 48 | Ok (stateWithRootCall.callTree, tVal) 49 | 50 | Nothing -> 51 | Err NoMainYo 52 | 53 | 54 | type alias InterpState = 55 | { currentCallId : CallId 56 | , callTree : CallTree 57 | , subcallsAtThisLevel : List (CallId, AST.Region) 58 | } 59 | 60 | 61 | initialState : InterpState 62 | initialState = 63 | { currentCallId = 0 64 | , callTree = Dict.empty 65 | , subcallsAtThisLevel = [] 66 | } 67 | 68 | 69 | -- whoooo giant case expr 70 | interpretExpr : FuncDict -> Scope -> InterpState -> Expr -> (TVal, InterpState) 71 | interpretExpr funcDict scope state locatedExpr = 72 | let 73 | --d = Debug.log "INTERPRETeXPR" (scope, expr) 74 | sameState tVal = 75 | (tVal, state) 76 | 77 | (A region expr) = 78 | locatedExpr 79 | 80 | interpretSubexpr : InterpState -> Expr -> (TVal, InterpState) 81 | interpretSubexpr stateAlready subExpr = 82 | interpretExpr funcDict scope stateAlready subExpr 83 | 84 | extractDef : FuncIdent -> (TVal, InterpState) 85 | extractDef funcIdent = 86 | funcDict 87 | |> Dict.get funcIdent 88 | |> Utils.getMaybe ("func not found: " ++ toString funcIdent) 89 | |> (\(AST.Def _ _ expr _) -> expr) 90 | |> interpretExpr funcDict Dict.empty state 91 | in 92 | case expr of 93 | AST.Literal literal -> 94 | ( case literal of 95 | IntNum x -> 96 | (IntV x, LiteralT state.currentCallId region) 97 | 98 | Str str -> 99 | (StringV str, LiteralT state.currentCallId region) 100 | 101 | Boolean b -> 102 | (BoolV b, LiteralT state.currentCallId region) 103 | 104 | _ -> 105 | Debug.crash "TODO" 106 | ) 107 | |> sameState 108 | 109 | AST.Var {home, name} -> 110 | case home of 111 | TopLevelHome moduleName -> 112 | extractDef (moduleName.package, moduleName.modul, name) 113 | -- should this cound as a call? urgh 114 | 115 | ModuleHome {package, modul} -> 116 | let 117 | funcIdent = 118 | (package, modul, name) 119 | in 120 | case funcIdent of 121 | ("elm-lang/virtual-dom", ["Native","VirtualDom"], "text") -> 122 | ((BuiltinFun { home = home, name = name }, BuiltinT), state) 123 | 124 | _ -> 125 | extractDef funcIdent 126 | 127 | Local -> 128 | scope 129 | |> Dict.get name 130 | |> Utils.getMaybe "not in scope" 131 | |> sameState 132 | 133 | _ -> 134 | Debug.crash "TODO: more homes" 135 | 136 | AST.Let defs innerExpr -> 137 | let 138 | -- It seems the compiler sorts everything for us 139 | -- although it seems like Canonicalize.Sort is not getting called 140 | -- will have to fix that 141 | saveDefinition : Def -> (Scope, InterpState) -> (Scope, InterpState) 142 | saveDefinition (Def _ (AST.A _ pattern) defExpr _) (scopeStep, stateAlready) = 143 | let 144 | (tVal, newState) = 145 | interpretExpr funcDict scopeStep stateAlready defExpr 146 | 147 | varName = 148 | getVarName pattern 149 | |> Utils.getMaybe "not a var pattern" 150 | 151 | newScope = 152 | scopeStep 153 | |> Dict.insert varName tVal 154 | in 155 | ( newScope, newState ) 156 | 157 | (letScope, letState) = 158 | defs 159 | |> List.foldl saveDefinition (scope, state) 160 | 161 | (result, bodyState) = 162 | interpretExpr funcDict letScope letState innerExpr 163 | in 164 | (result, bodyState) 165 | 166 | AST.If condPairs ifFalseExpr -> 167 | case condPairs of 168 | [(condExpr, ifTrueExpr)] -> 169 | let 170 | (condValue, newState) = 171 | interpretSubexpr state condExpr 172 | 173 | mkResult chosenExpr = 174 | let 175 | ((val, trace), newNewState) = 176 | interpretSubexpr newState chosenExpr 177 | in 178 | ( ( val 179 | , IfT 180 | { callId = state.currentCallId 181 | , ifExpr = locatedExpr 182 | , decidingValue = condValue 183 | , innerTrace = trace 184 | } 185 | ) 186 | , newNewState 187 | ) 188 | in 189 | case condValue of 190 | (BoolV True, _) -> 191 | mkResult ifTrueExpr 192 | 193 | (BoolV False, _) -> 194 | mkResult ifFalseExpr 195 | 196 | _ -> 197 | Debug.crash "cond value not true or false" 198 | 199 | _ -> 200 | Debug.crash "I thought multi-way ifs were no longer a thing" 201 | 202 | AST.App funExpr argExpr -> 203 | let 204 | (fun, newState) = 205 | interpretSubexpr state funExpr 206 | 207 | (arg, newNewState) = 208 | interpretSubexpr newState argExpr 209 | 210 | freshCallId = 211 | newNewState.currentCallId + 1 212 | 213 | d = 214 | Debug.log "freshCallId" freshCallId 215 | in 216 | case fun of 217 | (ClosureV closureAttrs, closureTrace) -> 218 | let 219 | paramScope = 220 | Dict.fromList [(closureAttrs.lambda.varName, arg)] 221 | 222 | totalScope = 223 | Dict.union paramScope closureAttrs.closureScope 224 | 225 | ((result, innerTrace), newNewNewState) = 226 | interpretExpr 227 | funcDict 228 | totalScope 229 | { newNewState | currentCallId = freshCallId, subcallsAtThisLevel = [] } 230 | closureAttrs.lambda.expr 231 | 232 | newCall = 233 | { func = (ClosureV closureAttrs, closureTrace) 234 | , name = Nothing 235 | , args = [arg] 236 | , result = (result, innerTrace) 237 | , subcalls = newNewNewState.subcallsAtThisLevel 238 | , caller = Just state.currentCallId 239 | } 240 | 241 | -- make a new call, return it in subcalls 242 | in 243 | ( (result, FuncCallT freshCallId innerTrace) 244 | , { currentCallId = newNewNewState.currentCallId 245 | , callTree = 246 | newNewNewState.callTree 247 | |> Dict.insert freshCallId newCall 248 | , subcallsAtThisLevel = 249 | newNewState.subcallsAtThisLevel ++ [(freshCallId, region)] 250 | } 251 | ) 252 | 253 | (BuiltinFun {home, name}, trace) -> 254 | case home of 255 | ModuleHome {package, modul} -> 256 | case (package, modul, name) of 257 | ("elm-lang/virtual-dom", ["Native","VirtualDom"], "text") -> 258 | -- TODO: refactor constructing arguments & call node with above 259 | --XXX 260 | --((XXX, XXX), state) 261 | Debug.crash "TODO" 262 | 263 | _ -> 264 | Debug.crash "TODO" 265 | 266 | _ -> 267 | Debug.crash ("uknown builtin: " ++ (fun |> fst |> toString)) 268 | 269 | _ -> 270 | Debug.crash ("unknown function: " ++ (toString fun)) 271 | 272 | AST.Lambda (AST.A _ pattern) bodyExpr -> 273 | ( ClosureV 274 | { sourceRegion = region 275 | , closureScope = scope 276 | , lambda = 277 | { varName = 278 | getVarName pattern |> Utils.getMaybe "not a var pattern" 279 | , expr = bodyExpr 280 | } 281 | } 282 | , LiteralT state.currentCallId region 283 | ) 284 | |> sameState 285 | 286 | Binop { home, name } leftExpr rightExpr -> 287 | case home of 288 | ModuleHome { package, modul } -> 289 | case (package, modul) of 290 | ("elm-lang/core", ["Basics"]) -> 291 | let 292 | (leftTVal, state') = 293 | interpretExpr funcDict scope state leftExpr 294 | 295 | (rightTVal, state'') = 296 | interpretExpr funcDict scope state' rightExpr 297 | 298 | resultVal = 299 | case (name, fst leftTVal, fst rightTVal) of 300 | ("*", IntV leftInt, IntV rightInt) -> 301 | IntV (leftInt * rightInt) 302 | 303 | ("+", IntV leftInt, IntV rightInt) -> 304 | IntV (leftInt + rightInt) 305 | 306 | ("-", IntV leftInt, IntV rightInt) -> 307 | IntV (leftInt - rightInt) 308 | 309 | ("==", leftVal, rightVal) -> 310 | BoolV (leftVal == rightVal) 311 | 312 | ("&&", BoolV leftB, BoolV rightB) -> 313 | BoolV (leftB && rightB) 314 | 315 | ("||", BoolV leftB, BoolV rightB) -> 316 | BoolV (leftB || rightB) 317 | 318 | _ -> 319 | Debug.crash ("unknown binop " ++ toString (name, fst leftTVal, fst rightTVal)) 320 | 321 | freshCallId = 322 | state''.currentCallId + 1 323 | 324 | resultTVal = 325 | (resultVal, FuncCallT freshCallId BuiltinT) 326 | 327 | newCall = 328 | { func = (BuiltinFun { home = home, name = name }, BuiltinT) 329 | , name = Just name 330 | , args = [leftTVal, rightTVal] 331 | , result = (resultVal, BuiltinT) 332 | , subcalls = [] 333 | , caller = Just state.currentCallId 334 | } 335 | in 336 | ( resultTVal 337 | , { state'' 338 | | currentCallId = freshCallId 339 | , subcallsAtThisLevel = state''.subcallsAtThisLevel ++ [(freshCallId, region)] 340 | , callTree = state''.callTree |> Dict.insert freshCallId newCall 341 | } 342 | ) 343 | 344 | _ -> 345 | Debug.crash ("unknown binop" ++ toString { home=home, name=name }) 346 | 347 | _ -> 348 | Debug.crash ("unknown home: " ++ (toString home)) 349 | 350 | _ -> 351 | Debug.crash "TODO" 352 | 353 | 354 | getVarName : AST.Pattern' a b -> Maybe String 355 | getVarName pattern = 356 | case pattern of 357 | VarPattern name -> 358 | Just name 359 | 360 | _ -> 361 | Nothing 362 | 363 | 364 | buildFunctionDict : ModuleDefs -> Dict FuncIdent Def 365 | buildFunctionDict modules = 366 | let 367 | getModuleDefs : Module (List Def) -> List (FuncIdent, Def) 368 | getModuleDefs { name, info } = 369 | info 370 | |> List.map (\def -> 371 | let 372 | funcName = 373 | case def of 374 | Def _ (A _ (VarPattern name)) _ _ -> 375 | name 376 | 377 | _ -> 378 | Debug.crash "couldn't find function name" 379 | 380 | funcIdent = 381 | (name.package, name.modul, funcName) 382 | in 383 | (funcIdent, def) 384 | ) 385 | in 386 | modules 387 | |> List.map getModuleDefs 388 | |> List.concat 389 | |> Dict.fromList 390 | -------------------------------------------------------------------------------- /src/Elm/Trace.elm: -------------------------------------------------------------------------------- 1 | module Elm.Trace exposing (..) 2 | 3 | import Dict exposing (Dict) 4 | 5 | import Utils exposing (getMaybe) 6 | import Elm.AST as AST 7 | 8 | 9 | type alias FuncDict = 10 | Dict FuncIdent AST.Def 11 | 12 | 13 | type alias Scope = 14 | Dict String TVal 15 | 16 | 17 | type alias FuncIdent = 18 | (AST.PackageName, AST.ModuleName, String) 19 | 20 | 21 | type alias CallTree = 22 | Dict CallId Call 23 | 24 | 25 | type alias CallId = 26 | Int 27 | 28 | 29 | type alias TVal = 30 | (Val, Trace) 31 | 32 | 33 | type Val 34 | = IntV Int 35 | | StringV String 36 | | BoolV Bool 37 | | ADTV 38 | { constructorName : String 39 | , args : List TVal 40 | } 41 | | RecordV (Dict String TVal) 42 | | ClosureV ClosureAttrs 43 | | BuiltinFun AST.CanonicalVar 44 | -- DOM special 45 | | VDomNodeV VDomNode 46 | 47 | 48 | type VDomNode 49 | = VDomNode String (List (VDomAttr, Trace)) (List (VDomNode, Trace)) 50 | | VDomText (String, Trace) 51 | 52 | 53 | type alias VDomAttr = 54 | (String, TVal) 55 | 56 | 57 | type alias ClosureAttrs = 58 | { sourceRegion : AST.Region 59 | , closureScope : Scope 60 | , lambda : 61 | { varName : String 62 | , expr : AST.Expr 63 | } 64 | -- , TODO: name 65 | } 66 | 67 | 68 | type Trace 69 | = FuncCallT CallId Trace -- inner trace... 70 | | LiteralT CallId AST.Region -- the call in which the literal was used (?) 71 | | IfT 72 | { callId : CallId 73 | , ifExpr : AST.Expr 74 | , decidingValue : TVal 75 | , innerTrace : Trace 76 | } 77 | | CaseT 78 | { callId : CallId 79 | , caseExpr : AST.Expr 80 | , decidingValue : TVal 81 | , caseIdx : Int 82 | , innerTrace : Trace 83 | } 84 | | BuiltinT 85 | -- TODO: maybe Atom & Data? 86 | 87 | 88 | type alias Call = 89 | { func : TVal 90 | , name : Maybe String -- TODO: could find name based on closure's lambda's expression... 91 | , args : List TVal 92 | , result : TVal 93 | , subcalls : List (CallId, AST.Region) 94 | , caller : Maybe CallId 95 | } 96 | 97 | 98 | type alias FuncName = 99 | String 100 | 101 | 102 | type alias Source = 103 | List String 104 | 105 | 106 | type alias StackFrame = 107 | { call : Call 108 | , selectedSubcall : Maybe CallId 109 | --, valuePath : Maybe ValuePath 110 | } 111 | 112 | 113 | type ValuePath 114 | = ConstructorArg Int 115 | | RecordField String 116 | | ListItem Int 117 | 118 | 119 | -- most recent call last 120 | stackForCall : CallTree -> CallId -> List StackFrame 121 | stackForCall callTree callId = 122 | let 123 | go subcallId theCallId = 124 | let 125 | call = 126 | callTree 127 | |> Dict.get theCallId 128 | |> getMaybe ("no such call " ++ toString theCallId) 129 | 130 | rest = 131 | call.caller 132 | |> Maybe.map (go (Just theCallId)) 133 | |> Maybe.withDefault [] 134 | in 135 | { call = call, selectedSubcall = subcallId } :: rest 136 | in 137 | go Nothing callId 138 | -------------------------------------------------------------------------------- /src/ExampleData.elm: -------------------------------------------------------------------------------- 1 | module ExampleData exposing (..) 2 | 3 | 4 | import Dict exposing (Dict) 5 | 6 | import Model exposing (..) 7 | 8 | 9 | source = 10 | [ "fac n =" 11 | , " if n == 1 then" 12 | , " 1" 13 | , " else" 14 | , " n * (fac (n-1))" 15 | , "" 16 | , "main = fac 3" 17 | ] 18 | 19 | 20 | funcDefinitionSpans = 21 | [ ("main", onOneLine 7 (0, 12)) 22 | , ("fac", { start = { line = 1, col = 0 }, end = { line = 5, col = 19 } }) 23 | ] 24 | |> Dict.fromList 25 | 26 | 27 | onOneLine line (startCol, endCol) = 28 | { start = { line = line, col = startCol } 29 | , end = { line = line, col = endCol } 30 | } 31 | 32 | 33 | literalThree = 34 | (IntV 3, Literal 0 (onOneLine 7 (11, 12))) 35 | 36 | 37 | literalOne callId = 38 | (IntV 1, Literal callId (onOneLine 5 (16, 17))) 39 | 40 | 41 | returnLiteralOne = 42 | (IntV 1, Literal 5 (onOneLine 3 (4, 5))) 43 | 44 | 45 | facCallSpan = 46 | onOneLine 5 (9, 19) 47 | 48 | 49 | timesCallSpan = 50 | onOneLine 5 (9, 19) 51 | 52 | 53 | minusCallSpan = 54 | onOneLine 7 (14, 17) 55 | 56 | 57 | threeMinusOne = 58 | (IntV 2, FuncCall 2) 59 | 60 | 61 | twoMinusOne = 62 | (IntV 1, FuncCall 5) 63 | 64 | 65 | threeTimesTwo = 66 | (IntV 6, FuncCall 7) 67 | 68 | 69 | twoTimesOne = 70 | (IntV 2, FuncCall 6) 71 | 72 | 73 | callTree = 74 | { root = 0 75 | , calls = 76 | [ (0, { name = "main" 77 | , args = [] 78 | , result = threeTimesTwo 79 | , caller = Nothing 80 | , subcalls = [1] 81 | } 82 | ) 83 | -- fac(3) => 6 84 | , (1, { name = "fac" 85 | , args = [ literalThree ] 86 | , result = threeTimesTwo 87 | , caller = Just (0, onOneLine 7 (7, 12)) 88 | , subcalls = [2, 3, 7] 89 | } 90 | ) 91 | -- n - 1 => 2 92 | , (2, { name = "-" 93 | , args = [ literalThree, literalOne 1 ] 94 | , result = threeMinusOne 95 | , caller = Just (1, minusCallSpan) 96 | , subcalls = [] 97 | } 98 | ) 99 | -- fac(2) => 2 100 | , (3, { name = "fac" 101 | , args = [ threeMinusOne ] 102 | , result = twoTimesOne 103 | , caller = Just (1, facCallSpan) 104 | , subcalls = [4, 5, 6] 105 | } 106 | ) 107 | -- 2 - 1 => 1 108 | , (4, { name = "-" 109 | , args = [ threeMinusOne, literalOne 3 ] 110 | , result = twoMinusOne 111 | , caller = Just (3, minusCallSpan) 112 | , subcalls = [] 113 | } 114 | ) 115 | -- fac(1) 116 | , (5, { name = "fac" 117 | , args = [ twoMinusOne ] 118 | , result = returnLiteralOne 119 | , caller = Just (3, facCallSpan) 120 | , subcalls = [] 121 | } 122 | ) 123 | -- 2 * fac 1 124 | , (6, { name = "*" 125 | , args = [ threeMinusOne, returnLiteralOne ] 126 | , result = twoTimesOne 127 | , caller = Just (3, timesCallSpan) 128 | , subcalls = [] 129 | } 130 | ) 131 | -- 3 * fac 2 132 | , (7, { name = "*" 133 | , args = [ literalThree, twoTimesOne ] 134 | , result = threeTimesTwo 135 | , caller = Just (1, timesCallSpan) 136 | , subcalls = [] 137 | } 138 | ) 139 | ] 140 | |> Dict.fromList 141 | } 142 | -------------------------------------------------------------------------------- /src/FlameGraph.elm: -------------------------------------------------------------------------------- 1 | module FlameGraph exposing (..) 2 | 3 | import Color 4 | import Text as T 5 | import Collage exposing (defaultLine) 6 | import String 7 | import Dict exposing (Dict) 8 | import Html exposing (Html) 9 | 10 | import Diagrams.Core as Diagrams exposing (..) 11 | import Diagrams.Geom exposing (Point) 12 | import Diagrams.Envelope as Envelope exposing (..) 13 | import Diagrams.Debug exposing (..) 14 | import Diagrams.Align exposing (..) 15 | import Diagrams.FillStroke exposing (..) 16 | import Diagrams.FullWindow exposing (..) 17 | import Diagrams.Type exposing (..) 18 | import Diagrams.Layout as Layout 19 | import Diagrams.Pad exposing (..) 20 | import Diagrams.Query as Query 21 | import Diagrams.Svg 22 | 23 | import Elm.Trace as Trace 24 | import Viewer 25 | import Utils 26 | 27 | 28 | type CallTree 29 | = CallNode 30 | { name : String 31 | , id : Trace.CallId 32 | , args : List Trace.TVal 33 | , result : Trace.TVal 34 | , subcalls : List CallTree 35 | } 36 | 37 | 38 | type Tag 39 | = ArgTag { callId : Trace.CallId, idx : Int } 40 | | ResultTag Trace.CallId 41 | | LiteralAreaTag Trace.CallId 42 | 43 | 44 | -- TODO hover actions 45 | 46 | 47 | boxHeight = 48 | 20 49 | 50 | spaceBetweenCalls = 51 | 30 52 | 53 | 54 | view : Trace.CallTree -> Html a 55 | view traceCallTree = 56 | let 57 | callTree = 58 | traceCallTree 59 | |> fromTraceCallTree 60 | 61 | flameGraphDia = 62 | callTree 63 | |> flameGraph 64 | 65 | rootTrace = 66 | case callTree of 67 | CallNode attrs -> 68 | Trace.FuncCallT 0 (snd attrs.result) 69 | -- ... this is kinda weird ... 70 | 71 | traceDia = 72 | viewTrace traceCallTree flameGraphDia rootTrace 73 | 74 | fullDia = 75 | alignCenter (zcat [traceDia, flameGraphDia]) 76 | in 77 | Diagrams.Svg.toHtml (Envelope.dims fullDia) fullDia 78 | 79 | 80 | flameGraph : CallTree -> Diagram Tag a 81 | flameGraph (CallNode node) = 82 | let 83 | callSpacer = 84 | hspace spaceBetweenCalls 85 | 86 | subcalls = 87 | hcatA BottomA ([callSpacer] ++ (List.intersperse callSpacer (List.map flameGraph node.subcalls)) ++ [callSpacer]) 88 | |> alignCenter 89 | 90 | argsText = 91 | node.args 92 | |> List.map (fst >> Viewer.valueToString) 93 | 94 | argsDia = 95 | node.args 96 | |> List.indexedMap (\idx (arg, _) -> 97 | arg 98 | |> Viewer.valueToString 99 | |> text T.defaultStyle 100 | |> tag (ArgTag { callId = node.id, idx = idx }) 101 | ) 102 | |> List.intersperse (text T.defaultStyle ", ") 103 | |> hcat 104 | 105 | callTextDia = 106 | hcat 107 | [ text T.defaultStyle (node.name ++ "(") 108 | , argsDia 109 | , text T.defaultStyle ")" 110 | , hspace 5 111 | , tag (LiteralAreaTag node.id) empty 112 | , hspace 5 113 | ] 114 | 115 | resultDia = 116 | node.result 117 | |> fst 118 | |> Viewer.valueToString 119 | |> text T.defaultStyle 120 | |> tag (ResultTag node.id) 121 | 122 | callFlexRow = 123 | [ Layout.block callTextDia 124 | , Layout.spring 125 | , Layout.block (hcat [text T.defaultStyle " => ", resultDia]) 126 | ] 127 | 128 | thisCall = 129 | Layout.layout 130 | [ [Layout.strut (width subcalls)] 131 | , callFlexRow 132 | ] 133 | |> alignCenter 134 | |> background (justSolidFill Color.orange) 135 | in 136 | subcalls `above` thisCall 137 | 138 | 139 | traceColor = 140 | Color.rgba 204 0 0 0.5 -- red 141 | 142 | traceLineWidth = 143 | 3 144 | 145 | 146 | viewTrace : Trace.CallTree -> Diagram Tag a -> Trace.Trace -> Diagram t a 147 | viewTrace callTree flameGraphDia trace = 148 | case (Debug.log "VIEW_TRACE" trace) of 149 | Trace.FuncCallT callId innerTrace -> 150 | let 151 | args = 152 | callTree 153 | |> Dict.get callId 154 | |> Utils.getMaybe ("no such call: " ++ toString callId) 155 | |> .args 156 | 157 | pathToInnerTrace fromTag it = 158 | case it of 159 | Trace.BuiltinT -> 160 | let d = Debug.log "builtin inner trace" () in 161 | empty 162 | 163 | _ -> 164 | path 165 | [ locForTag flameGraphDia fromTag 166 | , locForTrace it flameGraphDia 167 | ] 168 | { defaultLine 169 | | color = traceColor 170 | , width = traceLineWidth 171 | } 172 | 173 | viewArgTrace idx argTrace = 174 | zcat 175 | [ viewTrace callTree flameGraphDia argTrace 176 | , pathToInnerTrace (ArgTag { callId = callId, idx = idx }) argTrace 177 | ] 178 | in 179 | zcat 180 | [ circle 4 (justSolidFill traceColor) 181 | |> move (locForTrace trace flameGraphDia) 182 | , viewTrace callTree flameGraphDia innerTrace 183 | , pathToInnerTrace (ResultTag callId) innerTrace 184 | , args 185 | |> Debug.log "ARGS" 186 | |> List.indexedMap (\idx (_, argT) -> viewArgTrace idx argT) 187 | |> zcat 188 | ] 189 | 190 | Trace.LiteralT callId _ -> 191 | rect 5 5 (justSolidFill traceColor) 192 | |> move (locForTrace trace flameGraphDia) 193 | 194 | Trace.IfT ifAttrs -> 195 | viewTrace callTree flameGraphDia ifAttrs.innerTrace 196 | 197 | Trace.CaseT caseAttrs -> 198 | viewTrace callTree flameGraphDia caseAttrs.innerTrace 199 | 200 | Trace.BuiltinT -> 201 | empty 202 | 203 | 204 | locForTrace : Trace.Trace -> Diagram Tag a -> Point 205 | locForTrace trace flameGraphDia = 206 | case trace of 207 | Trace.FuncCallT callId _ -> 208 | locForTag flameGraphDia (ResultTag callId) 209 | 210 | Trace.LiteralT callId _ -> 211 | locForTag flameGraphDia (LiteralAreaTag callId) 212 | 213 | Trace.IfT ifAttrs -> 214 | locForTrace ifAttrs.innerTrace flameGraphDia 215 | 216 | Trace.CaseT caseAttrs -> 217 | locForTrace caseAttrs.innerTrace flameGraphDia 218 | 219 | Trace.BuiltinT -> 220 | Debug.crash "getting loc of builtin trace" 221 | 222 | 223 | locForTag flameGraphDia tag = 224 | flameGraphDia 225 | |> Query.getCoords [tag] 226 | |> Utils.getMaybe ("tag not found:" ++ toString tag) 227 | 228 | 229 | fromTraceCallTree : Trace.CallTree -> CallTree 230 | fromTraceCallTree trace = 231 | let 232 | recurse callId = 233 | trace 234 | |> Dict.get callId 235 | |> Utils.getMaybe ("no call with id" ++ toString callId) 236 | |> (\call -> 237 | CallNode 238 | { id = callId 239 | , name = 240 | call.name |> Maybe.withDefault (call.func |> fst |> Viewer.valueToString) 241 | , args = call.args 242 | , result = call.result 243 | , subcalls = call.subcalls |> List.map (fst >> recurse) 244 | } 245 | ) 246 | in 247 | Debug.log "fromTraceCallTree" (recurse 0) 248 | -------------------------------------------------------------------------------- /src/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (..) 2 | 3 | import Html exposing (..) 4 | import Html.Attributes exposing (..) 5 | import Html.Events exposing (..) 6 | import Html.App as App 7 | import Json.Decode as JsDec 8 | import Json.Encode as JsEnc 9 | import Dict exposing (Dict) 10 | import Task 11 | import Http 12 | import HttpBuilder exposing (..) 13 | import String 14 | 15 | import Elm.AST exposing (..) 16 | import Elm.Decode exposing (..) 17 | import Elm.Interpret as Interpret 18 | import Elm.Trace exposing (..) 19 | import Model exposing (..) 20 | import Viz 21 | import ViewCompileErrors 22 | import Utils 23 | 24 | 25 | type alias Model = 26 | { code : String 27 | , result : Loading String (Error String) ResultModel 28 | } 29 | 30 | 31 | type alias ResultModel = 32 | { funcDict : FuncDict 33 | , source : Elm.Trace.Source 34 | , interpResult : Result Interpret.InterpError (CallTree, TVal) 35 | , vizModel : Model.Model 36 | } 37 | 38 | 39 | type Loading r a b 40 | = NotStarted 41 | | InProgress r 42 | | Returned (Result a b) 43 | 44 | 45 | type Msg 46 | = UpdateText String 47 | | Compile 48 | | CompileResponse (Result (Error String) FuncDict) 49 | | VizMsg Model.Msg 50 | 51 | 52 | update : Msg -> Model -> (Model, Cmd Msg) 53 | update msg model = 54 | case msg of 55 | UpdateText txt -> 56 | { model | code = txt } ! [] 57 | 58 | Compile -> 59 | let 60 | body = 61 | model.code 62 | |> codeToJsonPayload 63 | |> JsEnc.encode 0 64 | |> Http.string 65 | 66 | decode = 67 | Elm.Decode.decodeModuleOfDefs 68 | |> JsDec.list 69 | |> JsDec.map Interpret.buildFunctionDict 70 | in 71 | ( { model | result = InProgress model.code } 72 | , HttpBuilder.post "/compile_elm" 73 | |> withJsonBody (codeToJsonPayload model.code) 74 | |> withHeader "Content-Type" "application/json" 75 | |> send (jsonReader decode) stringReader 76 | |> Task.perform 77 | (\err -> CompileResponse (Err err)) 78 | (\res -> CompileResponse (Ok res.data)) 79 | ) 80 | 81 | CompileResponse resp -> 82 | case resp of 83 | Err err -> 84 | { model | result = Returned (Err err) } ! [] 85 | 86 | Ok funcDict -> 87 | let 88 | code = 89 | case model.result of 90 | InProgress c -> 91 | c 92 | 93 | _ -> 94 | Debug.crash "should be InProgress" 95 | in 96 | { model | result = 97 | { funcDict = funcDict 98 | , source = String.split "\n" code 99 | , interpResult = Interpret.interpretMainYo funcDict 100 | , vizModel = Model.initialModel 101 | } 102 | |> Ok 103 | |> Returned 104 | } ! [] 105 | 106 | VizMsg msg -> 107 | case msg of 108 | RequestEdit -> 109 | { model | result = NotStarted } ! [] 110 | 111 | _ -> 112 | case model.result of 113 | Returned res -> 114 | case res of 115 | Ok resultModel -> 116 | let 117 | newVizModel = 118 | Viz.update msg resultModel.vizModel 119 | in 120 | { model | result = 121 | { resultModel | vizModel = Debug.log "newVizModel" newVizModel } 122 | |> Ok 123 | |> Returned 124 | } ! [] 125 | 126 | _ -> 127 | model ! [] 128 | 129 | _ -> 130 | model ! [] 131 | 132 | 133 | codeToJsonPayload : String -> JsEnc.Value 134 | codeToJsonPayload code = 135 | JsEnc.object [("code", JsEnc.string code)] 136 | 137 | 138 | view : Model -> Html Msg 139 | view model = 140 | let 141 | editor = 142 | textarea 143 | [ onInput UpdateText 144 | , rows 10 145 | , cols 50 146 | , style [("font-family", "monospace")] 147 | ] 148 | [ text model.code ] 149 | 150 | compileButton = 151 | button [ onClick Compile ] [ text "Compile & Run" ] 152 | in 153 | case model.result of 154 | NotStarted -> 155 | div [] 156 | [ editor 157 | , compileButton 158 | , p [] [ text "Write Elm code & hit 'Compile'" ] 159 | ] 160 | 161 | InProgress _ -> 162 | div [] 163 | [ editor 164 | , compileButton 165 | , p [] [ text "Compiling..." ] 166 | ] 167 | 168 | Returned result -> 169 | case result of 170 | Ok { funcDict, source, interpResult, vizModel } -> 171 | let 172 | astView = 173 | funcDict 174 | |> Dict.toList 175 | |> List.reverse 176 | |> List.map (\item -> li [] [text (toString item)]) 177 | |> ul [ style [("font-family", "monospace")] ] 178 | in 179 | case interpResult of 180 | Ok (callTree, tVal) -> 181 | div [] 182 | [ App.map 183 | VizMsg 184 | (Viz.view vizModel callTree tVal source funcDict) 185 | --, astView 186 | ] 187 | 188 | Err interpErr -> 189 | div [] 190 | [ editor 191 | , compileButton 192 | , p [] 193 | [ text "Error during interpretation: " 194 | , text <| toString interpErr 195 | ] 196 | ] 197 | 198 | Err err -> 199 | div [] 200 | [ editor 201 | , compileButton 202 | , case err of 203 | BadResponse resp -> 204 | case resp.status of 205 | 400 -> 206 | ViewCompileErrors.view resp.data 207 | 208 | _ -> 209 | p [] 210 | [ text "Bad Response:" 211 | , text (toString resp) 212 | ] 213 | 214 | _ -> 215 | p [] [ text (toString err) ] 216 | ] 217 | 218 | 219 | initialModel = 220 | { code = 221 | """fac n = 222 | if n == 1 then 223 | 1 224 | else 225 | n * (fac (n - 1)) 226 | 227 | mainYo = 228 | fac 3 229 | """ 230 | , result = NotStarted 231 | } 232 | 233 | 234 | loggingUpdater : (msg -> model -> (model, Cmd msg)) -> msg -> model -> (model, Cmd msg) 235 | loggingUpdater updater = 236 | \msg model -> 237 | let 238 | after = updater msg model 239 | d = Debug.log "AFTER:" after 240 | c = Debug.log "MSG:" msg 241 | b = Debug.log "BEFORE:" model 242 | a = Debug.log "=====================" () 243 | in 244 | after 245 | 246 | 247 | main = 248 | App.program 249 | { init = (initialModel, Cmd.none) 250 | , view = view 251 | --, update = loggingUpdater update 252 | , update = update 253 | , subscriptions = always Sub.none 254 | } 255 | -------------------------------------------------------------------------------- /src/Model.elm: -------------------------------------------------------------------------------- 1 | module Model exposing (..) 2 | 3 | import Dict exposing (Dict) 4 | 5 | import Utils exposing (..) 6 | import Elm.AST as AST 7 | import Elm.Trace exposing (..) 8 | 9 | 10 | type Msg 11 | = PinCall CallId 12 | | MouseOverTrace Trace 13 | | MouseOutTrace 14 | | NoOp 15 | | RequestEdit 16 | 17 | 18 | type alias Model = 19 | { pinnedCall : CallId 20 | , overTrace : Maybe Trace 21 | } 22 | 23 | 24 | initialModel : Model 25 | initialModel = 26 | { overTrace = Nothing 27 | , pinnedCall = 0 28 | } 29 | -------------------------------------------------------------------------------- /src/Style.elm: -------------------------------------------------------------------------------- 1 | module Style exposing (..) 2 | 3 | 4 | sourceLine = 5 | [] 6 | 7 | 8 | sourceLineText = 9 | [] 10 | 11 | 12 | sourceLines = 13 | [ ("flex-grow", "1") 14 | , ("font-family", "monospace") 15 | , ("white-space", "pre") 16 | ] 17 | 18 | 19 | intV = 20 | [("color", "blue")] 21 | 22 | 23 | stringV = 24 | [("color", "green")] 25 | 26 | 27 | boolV = 28 | [("color", "blue")] 29 | 30 | 31 | constructorName = 32 | [] 33 | 34 | 35 | syntax = 36 | [] 37 | 38 | 39 | recordKey = 40 | [] 41 | 42 | 43 | viewValue = 44 | [ ("font-family", "monospace") 45 | --, ("margin-top", "16px") 46 | --, ("margin-bottom", "16px") 47 | , ("flex-grow", "1") 48 | ] 49 | 50 | 51 | highlightedSource = 52 | [ ("color", "red") ] 53 | 54 | 55 | subcall = 56 | [] 57 | 58 | 59 | selectedSubcall = 60 | [ ("font-weight", "bold") ] 61 | -------------------------------------------------------------------------------- /src/Utils.elm: -------------------------------------------------------------------------------- 1 | module Utils exposing (..) 2 | 3 | 4 | getMaybe : String -> Maybe a -> a 5 | getMaybe msg maybe = 6 | case maybe of 7 | Just x -> 8 | x 9 | 10 | Nothing -> 11 | Debug.crash msg 12 | 13 | 14 | -- TODO: get this into list-extra 15 | -- geez 16 | mapWithIndex : (Int -> a -> b) -> List a -> List b 17 | mapWithIndex f list = 18 | let 19 | go idx items = 20 | case items of 21 | [] -> 22 | [] 23 | 24 | x::xs -> 25 | (f idx x) :: (go (idx + 1) xs) 26 | in 27 | go 0 list 28 | 29 | 30 | -- this is kind of silly 31 | getResult : Result a a -> a 32 | getResult res = 33 | case res of 34 | Ok x -> 35 | x 36 | 37 | Err y -> 38 | y 39 | 40 | 41 | -- @#$%!@# 42 | --withAlpha : Color -> Float -> Color 43 | --withAlpha color alpha = 44 | -- case color of 45 | -- HSLA h s l _ -> 46 | -- HSLA h s l alpha 47 | 48 | -- RGBA r g b _ -> 49 | -- RGBA r g b alpha 50 | -------------------------------------------------------------------------------- /src/ViewCompileErrors.elm: -------------------------------------------------------------------------------- 1 | -- shamelessly liften from https://github.com/elm-lang/elm-reactor/blob/7522d7ef379c5a4ffbba11b1be09ed04add08a63/src/pages/Errors.elm 2 | module ViewCompileErrors exposing (..) -- where 3 | 4 | import Char 5 | import Html exposing (..) 6 | import Html.App as Html 7 | import Html.Attributes exposing (..) 8 | import String 9 | 10 | 11 | (=>) = (,) 12 | 13 | 14 | view : String -> Html msg 15 | view model = 16 | div 17 | [ style 18 | [ "width" => "100%" 19 | , "min-height" => "100%" 20 | , "display" => "flex" 21 | , "flex-direction" => "column" 22 | , "align-items" => "center" 23 | , "background-color" => "black" 24 | , "color" => "rgb(233, 235, 235)" 25 | , "font-family" => "monospace" 26 | ] 27 | ] 28 | [ div 29 | [ style 30 | [ "display" => "block" 31 | , "white-space" => "pre" 32 | , "background-color" => "rgb(39, 40, 34)" 33 | , "padding" => "2em" 34 | ] 35 | ] 36 | (addColors model) 37 | ] 38 | 39 | 40 | addColors : String -> List (Html msg) 41 | addColors message = 42 | message 43 | |> String.lines 44 | |> List.concatMap addColorToLine 45 | 46 | 47 | addColorToLine : String -> List (Html msg) 48 | addColorToLine line = 49 | flip (++) [ text "\n" ] <| 50 | if isBreaker line then 51 | [ colorful "rgb(51, 187, 200)" ("\n\n" ++ line) ] 52 | 53 | else if isBigBreaker line then 54 | [ colorful "rgb(211, 56, 211)" line ] 55 | 56 | else if isUnderline line then 57 | [ colorful "#D5200C" line ] 58 | 59 | else if String.startsWith " " line then 60 | [ colorful "#9A9A9A" line ] 61 | 62 | else 63 | processLine line 64 | 65 | 66 | colorful : String -> String -> Html msg 67 | colorful color msg = 68 | span [ style [ "color" => color ] ] [ text msg ] 69 | 70 | 71 | isBreaker : String -> Bool 72 | isBreaker line = 73 | String.startsWith "-- " line 74 | && 75 | String.contains "----------" line 76 | 77 | 78 | isBigBreaker : String -> Bool 79 | isBigBreaker line = 80 | String.startsWith "===============" line 81 | 82 | 83 | isUnderline : String -> Bool 84 | isUnderline line = 85 | String.all (\c -> c == ' ' || c == '^') line 86 | 87 | 88 | isLineNumber : String -> Bool 89 | isLineNumber string = 90 | String.all (\c -> c == ' ' || Char.isDigit c) string 91 | 92 | 93 | processLine : String -> List (Html msg) 94 | processLine line = 95 | case String.split "|" line of 96 | [] -> 97 | [ text line ] 98 | 99 | starter :: rest -> 100 | if not (isLineNumber starter) then 101 | [ text line ] 102 | 103 | else 104 | let 105 | restOfLine = 106 | String.join "|" rest 107 | 108 | marker = 109 | if String.left 1 restOfLine == ">" then 110 | colorful "#D5200C" ">" 111 | 112 | else 113 | text " " 114 | in 115 | [ colorful "#9A9A9A" (starter ++ "|") 116 | , marker 117 | , colorful "#9A9A9A" (String.dropLeft 1 restOfLine) 118 | ] 119 | -------------------------------------------------------------------------------- /src/Viewer.elm: -------------------------------------------------------------------------------- 1 | module Viewer exposing (..) 2 | 3 | import Dict exposing (Dict) 4 | import String 5 | 6 | import Html exposing (..) 7 | import Html.Attributes exposing (..) 8 | import Html.Events exposing (..) 9 | 10 | import Style 11 | import Model exposing (..) 12 | import Elm.Trace exposing (..) 13 | import Elm.AST exposing (Region) 14 | import Utils exposing (..) 15 | 16 | 17 | -- TODO: source span 18 | viewSource : Maybe (CallId, Region) -> Source -> Html a 19 | viewSource maybeRegion source = 20 | source 21 | |> mapWithIndex (\idx line -> 22 | li [ style Style.sourceLine ] 23 | [viewSourceLine (idx + 1) maybeRegion line] 24 | ) 25 | |> ol [ style Style.sourceLines ] 26 | 27 | 28 | viewSourceLine : Int -> Maybe (CallId, Region) -> String -> Html a 29 | viewSourceLine lineNo maybeRegion line = 30 | let 31 | highlighted txt = 32 | span [style Style.highlightedSource] [text txt] 33 | 34 | normal txt = 35 | text txt 36 | 37 | length = 38 | String.length line 39 | 40 | sliceIt startIdx endIdx = 41 | span [] 42 | [ normal (String.slice 0 startIdx line) 43 | , highlighted (String.slice startIdx endIdx line) 44 | , normal (String.slice endIdx length line) 45 | ] 46 | in 47 | case maybeRegion of 48 | Nothing -> 49 | normal line 50 | 51 | Just (callId, region) -> 52 | case (compare region.start.line lineNo, compare region.end.line lineNo) of 53 | (LT, GT) -> -- XXXXXX 54 | sliceIt 0 length 55 | 56 | (LT, EQ) -> -- XXX... 57 | sliceIt 0 (region.end.column - 1) 58 | 59 | (EQ, EQ) -> -- ..XX.. 60 | sliceIt (region.start.column - 1) (region.end.column - 1) 61 | 62 | (EQ, GT) -> -- ...XXX 63 | sliceIt (region.start.column - 1) length 64 | 65 | _ -> 66 | normal line 67 | 68 | 69 | -- TODO: this'll emit onclick events... 70 | viewValue : Maybe Trace -> TVal -> Html Msg 71 | viewValue overTrace (val, trace) = 72 | let 73 | pinCall = 74 | case trace of 75 | FuncCallT callId innerTrace -> 76 | onClick (PinCall callId) 77 | 78 | LiteralT callId _ -> 79 | onClick (PinCall callId) 80 | 81 | _ -> 82 | Debug.log "TODO: what to pin when they click an if trace?" (onClick NoOp) 83 | 84 | literalAttrs litStyle = 85 | [ pinCall 86 | , onMouseEnter (MouseOverTrace trace) 87 | , onMouseLeave MouseOutTrace 88 | , style litStyle 89 | ] 90 | in 91 | case val of 92 | IntV int -> 93 | span 94 | (literalAttrs Style.intV) 95 | [ text (toString int) ] 96 | 97 | StringV str -> 98 | span 99 | (literalAttrs Style.stringV) 100 | [ text ("\"" ++ str ++ "\"") ] -- TODO escape? 101 | 102 | BoolV bool -> 103 | span 104 | (literalAttrs Style.boolV) 105 | [ text (toString bool) ] 106 | 107 | ADTV { constructorName, args } -> 108 | let 109 | argViews = 110 | args 111 | |> List.map (viewValue overTrace) 112 | |> List.intersperse (text " ") 113 | in 114 | List.concat 115 | [ [ span [style Style.constructorName] [text constructorName] ] 116 | , [ text " " ] 117 | , argViews 118 | ] 119 | |> span [] 120 | 121 | RecordV attrs -> 122 | let 123 | comma = 124 | span [style Style.syntax] [text ", "] 125 | 126 | viewAttr (key, value) = 127 | span [] 128 | [ span [style Style.recordKey] [text key] 129 | , span [style Style.syntax] [text " = "] 130 | , viewValue overTrace value 131 | ] 132 | 133 | attrViews = 134 | attrs 135 | |> Dict.toList 136 | |> List.map viewAttr 137 | |> List.intersperse comma 138 | in 139 | List.concat 140 | [ [ span [style Style.syntax] [text "{"] ] 141 | , attrViews 142 | , [ span [style Style.syntax] [text "}"] ] 143 | ] 144 | |> span [] 145 | 146 | ClosureV attrs -> 147 | span 148 | (literalAttrs []) 149 | [ text " Dict.toList 153 | |> List.map 154 | (\(name, tVal) -> 155 | span [] 156 | [ text name 157 | , text ": " 158 | , viewValue overTrace tVal 159 | ] 160 | ) 161 | |> List.intersperse (text ", ") 162 | ) 163 | , text "}>" 164 | ] 165 | 166 | BuiltinFun {home, name} -> 167 | text ("") 168 | 169 | VDomNodeV node -> 170 | viewVDomNode node 171 | 172 | 173 | viewVDomNode : VDomNode -> Html msg 174 | viewVDomNode node = 175 | case node of 176 | VDomNode name attrs children -> 177 | -- TODO: highlight/click zones for traces 178 | let 179 | attrsDisplay = 180 | attrs 181 | |> List.map (\((attrName, (attrVal, valTrace)), attrTrace) -> 182 | attrName ++ "=\"" ++ valueToString attrVal ++ "\"" 183 | ) 184 | |> String.join " " 185 | 186 | openTag = 187 | text ("<" ++ name ++ " " ++ attrsDisplay ++ ">") 188 | 189 | childrenDisplay = 190 | children 191 | |> List.map (fst >> viewVDomNode) 192 | 193 | closeTag = 194 | text ("") 195 | in 196 | div [] ([openTag] ++ childrenDisplay ++ [closeTag]) 197 | 198 | VDomText (theText, trace) -> 199 | -- TODO: some color 200 | text theText 201 | 202 | 203 | valueToString : Val -> String 204 | valueToString val = 205 | case val of 206 | IntV int -> 207 | toString int 208 | 209 | StringV str -> 210 | "\"" ++ str ++ "\"" -- TODO escape... 211 | 212 | BoolV bool -> 213 | toString bool 214 | 215 | ADTV { constructorName, args } -> 216 | constructorName ++ " " ++ (String.join " " (args |> List.map (fst >> valueToString))) 217 | 218 | RecordV attrs -> 219 | let 220 | attrsString = 221 | attrs 222 | |> Dict.toList 223 | |> List.map (\(k, (val, _)) -> k ++ " = " ++ (valueToString val)) 224 | in 225 | "{" ++ (String.join ", " attrsString) ++ "}" 226 | 227 | ClosureV closureAttrs -> 228 | let 229 | scopeString = 230 | closureAttrs.closureScope 231 | |> Dict.toList 232 | |> List.map (\(name, (val, _)) -> name ++ ": " ++ (valueToString val)) 233 | |> String.join ", " 234 | in 235 | "" 236 | 237 | BuiltinFun {home, name} -> 238 | "" 239 | 240 | VDomNodeV node -> 241 | vDomNodeToString node 242 | 243 | 244 | vDomNodeToString : VDomNode -> String 245 | vDomNodeToString node = 246 | case node of 247 | VDomNode name attrs children -> 248 | let 249 | attrsDisplay = 250 | attrs 251 | |> List.map (\((attrName, (attrVal, valTrace)), attrTrace) -> 252 | attrName ++ "=\"" ++ valueToString attrVal ++ "\"" 253 | ) 254 | |> String.join " " 255 | 256 | openTag = 257 | "<" ++ name ++ " " ++ attrsDisplay ++ ">" 258 | 259 | childrenDisplay = 260 | children 261 | |> List.map (\(child, trace) -> " " ++ vDomNodeToString child) 262 | 263 | closeTag = 264 | "" 265 | in 266 | String.join "\n" ([openTag] ++ childrenDisplay ++ [closeTag]) 267 | 268 | VDomText (theText, trace) -> 269 | theText 270 | -------------------------------------------------------------------------------- /src/Viz.elm: -------------------------------------------------------------------------------- 1 | module Viz exposing (..) 2 | 3 | import Dict exposing (Dict) 4 | 5 | import Html exposing (..) 6 | import Html.Attributes exposing (..) 7 | import Html.Events exposing (..) 8 | import Html.App as App 9 | 10 | import Elm.Trace exposing (..) 11 | import Model exposing (..) 12 | import Viewer exposing (..) 13 | import Style 14 | import Utils exposing (..) 15 | import FlameGraph 16 | --import ExampleData 17 | 18 | 19 | update : Msg -> Model -> Model 20 | update msg model = 21 | case msg of 22 | MouseOverTrace trace -> 23 | { model | overTrace = Just trace } 24 | 25 | MouseOutTrace -> 26 | { model | overTrace = Nothing } 27 | 28 | PinCall callId -> 29 | { model | pinnedCall = callId } 30 | 31 | RequestEdit -> 32 | model 33 | 34 | NoOp -> 35 | model 36 | 37 | 38 | view : Model -> CallTree -> TVal -> Source -> FuncDict -> Html Msg 39 | view model callTree tVal source funcDict = 40 | let 41 | maybeOverSpan = 42 | model.overTrace 43 | `Maybe.andThen` (\trace -> 44 | case trace of 45 | LiteralT callId sourceSpan -> 46 | Just (callId, sourceSpan) 47 | 48 | _ -> 49 | Nothing 50 | ) 51 | in 52 | div [] 53 | [ div [style [("display", "flex")]] 54 | [ div [] 55 | [ div [] [ viewSource maybeOverSpan source ] 56 | , button [ onClick RequestEdit ] [ text "Edit" ] 57 | ] 58 | --, div [] [ viewStack model callTree ] 59 | ] 60 | , FlameGraph.view callTree 61 | ] 62 | 63 | 64 | viewStack : Model -> CallTree -> Html Msg 65 | viewStack model callTree = 66 | model.pinnedCall 67 | |> stackForCall callTree 68 | |> List.map (\stackFrame -> 69 | li [] 70 | [ stackFrame.call.name 71 | |> Maybe.withDefault "" 72 | |> \name -> strong [] [text name] 73 | , viewValue Nothing stackFrame.call.func 74 | , text ": (" 75 | , viewSubcallWidget (List.map fst stackFrame.call.subcalls) stackFrame.selectedSubcall 76 | , text ")" 77 | , viewStackFrame model.overTrace stackFrame 78 | ] 79 | ) 80 | |> ul [] 81 | 82 | 83 | viewStackFrame : Maybe Trace -> StackFrame -> Html Msg 84 | viewStackFrame overTrace stackFrame = 85 | let 86 | viewVal val = 87 | div [style Style.viewValue] [viewValue overTrace val] 88 | in 89 | ul [] 90 | [ li [] 91 | [ text "args:" 92 | , ul [] (stackFrame.call.args |> List.map (\argVal -> li [] [viewVal argVal])) 93 | ] 94 | , li [] 95 | [ text "result:" 96 | , div [style Style.viewValue] [viewVal stackFrame.call.result] 97 | ] 98 | ] 99 | 100 | 101 | viewSubcallWidget : List CallId -> Maybe CallId -> Html Msg 102 | viewSubcallWidget subcallIds maybeSelectedSubcall = 103 | let 104 | viewSubcallMarker subcallId = 105 | let 106 | theStyle = 107 | if (Just subcallId) == maybeSelectedSubcall then 108 | Style.selectedSubcall 109 | else 110 | Style.subcall 111 | in 112 | span 113 | [ style theStyle 114 | , onClick (PinCall subcallId) 115 | ] 116 | [ text "X" ] 117 | in 118 | subcallIds 119 | |> List.map viewSubcallMarker 120 | |> List.intersperse (text " ") 121 | |> span [] 122 | 123 | 124 | --main = 125 | -- App.beginnerProgram 126 | -- { model = 127 | -- initialModel ExampleData.callTree ExampleData.funcDefinitionSpans ExampleData.source 128 | -- , view = view 129 | -- , update = update 130 | -- } 131 | --------------------------------------------------------------------------------