├── .github └── workflows │ └── static.yml ├── .gitignore ├── LICENSE ├── MainTutorial.purs ├── NOTE.md ├── README.md ├── agda ├── Drv1.agda ├── Drv1.agdai ├── Drv1.agda~ ├── Drv2.agda ├── Drv2.agdai └── Drv2.agda~ ├── assets ├── map-1.png ├── map-2.png ├── map-3.png ├── map-4.png ├── map-5.png └── pantograph-example-1.gif ├── dist ├── Lib │ └── jquery-3.7.1.min.js ├── Tutorial │ ├── sidebar.css │ └── sidebar.js ├── index.html ├── pantograph.css └── standalone │ ├── Lib │ └── jquery-3.7.1.min.js │ ├── index.html │ └── pantograph.css ├── docs ├── Lib │ └── jquery-3.7.1.min.js ├── Tutorial │ ├── sidebar.css │ └── sidebar.js ├── index.html ├── pantograph.css ├── pantograph.js └── standalone │ ├── Lib │ └── jquery-3.7.1.min.js │ ├── index.html │ ├── pantograph.css │ └── pantograph.js ├── index.js ├── notes ├── DerivationUnification.md ├── Design.txt ├── DesignPhilosphy.txt ├── GGG.md ├── IdealDesign.txt └── TODO.md ├── old ├── Expression.purs ├── GenericExpr │ ├── Expression.purs │ ├── TypeCheck.purs │ └── Unification.purs ├── Grammar.purs └── State.purs ├── package.json ├── packages.dhall ├── pnpm-lock.yaml ├── spago.dhall ├── spago.production.dhall ├── src ├── Bug.purs ├── Bug │ └── Assertion.purs ├── Data │ ├── Expr.purs │ ├── List │ │ ├── Rev.purs │ │ └── Zip.purs │ ├── MultiMap.purs │ ├── Rexp.purs │ ├── Rexp │ │ └── Example1.purs │ ├── TotalMap.purs │ └── Zippable.purs ├── Halogen │ ├── Utilities.js │ └── Utilities.purs ├── Hole.js ├── Hole.purs ├── Language │ └── Pantograph │ │ ├── Generic │ │ ├── ChangeAlgebra.purs │ │ ├── Edit.purs │ │ ├── Grammar.purs │ │ ├── Rendering │ │ │ ├── Base.purs │ │ │ ├── Buffer.purs │ │ │ ├── Console.purs │ │ │ ├── Editor.purs │ │ │ ├── Elements.purs │ │ │ ├── Preview.purs │ │ │ ├── Rendering.purs │ │ │ └── RunnableEditor.purs │ │ ├── Smallstep.purs │ │ ├── Unification.purs │ │ └── ZipperMovement.purs │ │ ├── Lib │ │ ├── DefaultEdits.purs │ │ └── GreyedRules.purs │ │ ├── Specific │ │ ├── Currying.purs │ │ ├── CurryingInterpereter.purs │ │ ├── FullyApplied.purs │ │ └── Multary.purs │ │ └── UserStudy │ │ └── Programs.purs ├── Log.js ├── Log.purs ├── Main.purs ├── MainStandalone.purs ├── MainTutorial.purs ├── Text │ └── Pretty.purs ├── Tutorial │ ├── CurriedTutorial.purs │ ├── CurriedTutorial │ │ ├── Common.purs │ │ ├── ProblemLessons.purs │ │ └── TutorialLessons.purs │ ├── EditorTutorial2.purs │ └── Markdown.purs ├── Type │ └── Direction.purs ├── Util.purs └── Utility.purs ├── standalone.js ├── test └── Main.purs └── tutorial.js /.github/workflows/static.yml: -------------------------------------------------------------------------------- 1 | # Simple workflow for deploying static content to GitHub Pages 2 | name: Deploy static content to Pages 3 | 4 | on: 5 | # Runs on pushes targeting the default branch 6 | push: 7 | branches: ["main"] 8 | 9 | # Allows you to run this workflow manually from the Actions tab 10 | workflow_dispatch: 11 | 12 | # Sets permissions of the GITHUB_TOKEN to allow deployment to GitHub Pages 13 | permissions: 14 | contents: read 15 | pages: write 16 | id-token: write 17 | 18 | # Allow only one concurrent deployment, skipping runs queued between the run in-progress and latest queued. 19 | # However, do NOT cancel in-progress runs as we want to allow these production deployments to complete. 20 | concurrency: 21 | group: "pages" 22 | cancel-in-progress: false 23 | 24 | jobs: 25 | # Single deploy job since we're just deploying 26 | deploy: 27 | environment: 28 | name: github-pages 29 | url: https://jeprinz.github.io/pantograph/ 30 | runs-on: ubuntu-latest 31 | steps: 32 | - name: Checkout 33 | uses: actions/checkout@v4 34 | - name: Setup Pages 35 | uses: actions/configure-pages@v4 36 | - name: Upload artifact 37 | uses: actions/upload-pages-artifact@v2 38 | with: 39 | # Upload entire repository 40 | path: '.' 41 | - name: Deploy to GitHub Pages 42 | id: deployment 43 | uses: actions/deploy-pages@v3 44 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | /.spago 11 | /.idea 12 | /.vscode 13 | /dist/assets/fonts/FireCode-Regular.ttf 14 | /dist/**/pantograph.js 15 | .DS_Store 16 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2025 Jacob Prinz and Henry Blanchette 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. 22 | -------------------------------------------------------------------------------- /MainTutorial.purs: -------------------------------------------------------------------------------- 1 | module MainTutorial where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import Effect.Class.Console as Console 6 | import Halogen.Aff as HA 7 | import Halogen.VDom.Driver as VDomDriver 8 | import Language.Pantograph.Generic.Grammar as Grammar 9 | import Language.Pantograph.Generic.Rendering.Base as Base 10 | import Language.Pantograph.Generic.Rendering.Editor (editorComponent) as Rendering 11 | import Language.Pantograph.Generic.Rendering.RunnableEditor as RunnableEditor 12 | import Language.Pantograph.Specific.Currying as Currying 13 | import Language.Pantograph.Specific.CurryingInterpereter as CurryingInterpereter 14 | import Language.Pantograph.Specific.FullyApplied as FullyApplied 15 | import Tutorial.CurriedTutorial as CurriedTutorial 16 | import Tutorial.EditorTutorial2 as EditorTutorial2 17 | 18 | -- Maybe in the future we can make a better way, but for now you can switch which thing gets run by uncommenting the correct main function 19 | -- Some different languages 20 | --main :: Effect Unit 21 | --main = runEditorForLang FullyApplied.editorSpec 22 | main_standalone :: Effect Unit 23 | main_standalone = runEditorForLang { spec: Currying.editorSpec, interpreter: CurryingInterpereter.interpereter } 24 | 25 | --main :: Effect Unit 26 | --main = runEditorForLang Multary.editorSpec 27 | runEditorForLang :: forall l r. Grammar.IsRuleLabel l r => { spec :: Base.EditorSpec l r, interpreter :: Grammar.DerivTerm l r -> String } -> Effect Unit 28 | runEditorForLang { spec, interpreter } = 29 | HA.runHalogenAff do 30 | Console.log "[main]" 31 | body <- HA.awaitBody 32 | VDomDriver.runUI RunnableEditor.component { spec, interpreter } body 33 | 34 | -- Tutorial 35 | main_tutorial :: Effect Unit 36 | main_tutorial = EditorTutorial2.runTutorial Currying.editorSpec CurriedTutorial.lessons CurryingInterpereter.interpereter 37 | -------------------------------------------------------------------------------- /NOTE.md: -------------------------------------------------------------------------------- 1 | cursor movement is in frontend, not backend!!!! -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Pantograph 2 | 3 | ![pantograph-example-1](assets/pantograph-example-1.gif) 4 | 5 | This is the source code for Pantograph, a structure editor. 6 | It was written by [Jacob Prinz](https://jeprinz.github.io/) and [Henry Blanchette](https://rybl.net). 7 | 8 | POPL 2025 paper: [Pantograph: A Fluid and Typed Structure Editor](https://arxiv.org/pdf/2411.16571). 9 | 10 | [Watch the Pantograph presentation](https://www.youtube.com/live/Jff0pIbj8PM?t=6092s). 11 | 12 | [Try Pantograph online](https://pantographeditor.github.io/Pantograph/). 13 | 14 | Table of Contents 15 | - [Pantograph](#pantograph) 16 | - [What is Pantograph](#what-is-pantograph) 17 | - [Well-grammared programming (zipper editing)](#well-grammared-programming-zipper-editing) 18 | - [Well-typed programming](#well-typed-programming) 19 | - [Development](#development) 20 | - [Design](#design) 21 | - [Organization](#organization) 22 | - [Citation](#citation) 23 | 24 | 25 | ## What is Pantograph 26 | 27 | ### Well-grammared programming (zipper editing) 28 | 29 | Unlike a traditional code editor in which text is parsed and then typechecked, Pantograph operates directly on a typed syntax tree. 30 | Users may fill in typed holes to input programs, here by inserting a list `l2`: 31 | 32 | ![image](https://github.com/user-attachments/assets/581c07c3-50e4-4af5-80a7-ea19f060c9ba) 33 | 34 | Many existing structure editors allow the user to fill holes, and manipulate entire terms. 35 | But how can one edit existing programs? In particular, suppose that the programmer realizes that l2 never contains negative numbers, and decides to 36 | optimize the expression by moving the execution of the append operation to after the filter. 37 | 38 | To make this edit by only manipulating entire terms would be difficult. One could imagine various user interfaces, but generally the manipulation would look like this: 39 | 40 | ![image](https://github.com/user-attachments/assets/86cc1dc9-1650-4389-b113-7d723fc3a006) 41 | 42 | Pantograph makes edits to existing program easier by introducing a notion of a *tree selection*. If a text selection goes between two text cursors, and a tree cursor goes on a subtree, 43 | then a tree selection goes between two subtrees. It is the area inside one subtree and outside another, also known as a one-hole context. 44 | Using this notion, the programmer can make the above edit easily: 45 | 46 | ![image](https://github.com/user-attachments/assets/ff2d9a5c-9f00-46d2-ab71-1ba6659c3612) 47 | 48 | Even better, it turns out that nearly all common program edits on functional code have this form: 49 | 50 | ![image](https://github.com/user-attachments/assets/252ffa54-8ac4-40d2-905b-9e4cc65a06f4) 51 | 52 | We call this editing scheme with tree cursors and selection *zipper editing*. 53 | 54 | ### Well-typed programming 55 | 56 | Zipper editing, like the traditional structure editing it extends, preserves the syntactic well-formedness of programs. However, it does not necessarily preserve well-typedness. 57 | 58 | Any system that aims to operate on intrinsically typed terms needs to account for how such an edit changes types in the program. In Pantograph, every edit is a typed refactoring operation. 59 | 60 | When the user inserts a `λ` expression around the body of map, Pantograph automatically makes the edits necessary to keep the program well typed. The system adds an application to a hole at the two call sites, and alters the type signature. 61 | 62 | ![image](assets/map-1.png) 63 | 64 | Pantograph fully takes into account the intrinsically-typed structure of the program, so it can handle more deeply-nested edits, for example, adding a higher-order argument. 65 | 66 | ![image](assets/map-2.png) 67 | 68 | Of course, it is not always desirable for an editor to fix typing issues automatically. Sometimes, Pantograph leaves errors in the program for the user to fix later. For example, suppose that the user deletes the f parameter from a finished map function. 69 | 70 | When the user makes the deletion, it leaves a couple of errors in the program. There is an unbound call to `f`, and an out of place argument at the two call sites to map. While the system could simply replace the former with a hole and remove the latter two from the program, this would likely erase valuable work that the programmer wanted to keep. 71 | 72 | To allow such errors to exist in an otherwise well typed program, Pantograph has three final constructions: 73 | - **free variables** e.g. in the first code example below, the references to `f` after `λ f` is deleted 74 | - **commented applications** e.g. in the first code example below, the argument `not` which is given to `map` even though `map` only takes 1 argument after `λ f` is deleted 75 | - **type error boundaries** e.g. in the second code example below, `(f h)` and `not` no longer have the correct type and Pantograph did not have a canonical way to fix it 76 | 77 | ![image](assets/map-3.png) 78 | 79 | ![image](assets/map-4.png) 80 | 81 | To some extent, type error boundaries are similar to the type errors placed by familiar type checker. But they are actually first-class terms in the program. Below, the user deletes the type error boundary 82 | with a selection, which tell's Pantograph to update the surrounding program to fit the type inside the error boundary. 83 | 84 | ![image](assets/map-5.png) 85 | 86 | In the paper, we describe the math behind this typed refactoring system. 87 | 88 | ## Development 89 | 90 | To develop Pantograph, you need the following command line tools installed: 91 | - [pnpm](https://pnpm.io/installation) 92 | 93 | To build the project: 94 | ```sh 95 | pnpm install 96 | pnpm build 97 | ``` 98 | 99 | To serve the web application: 100 | ```sh 101 | pnpm serve 102 | ``` 103 | 104 | ## Design 105 | 106 | This implementation is designed to be language-generic. 107 | The `Language.Pantograph.Generic.*` modules implement the mechanics of a Pantograph editor given an editor specification. 108 | **To define a new editor**, you must define a term of the type `Language.Pantograph.Generic.Rendering.Base.EditorSpec l r`, where `l` is the type of _sort_ labels, and `r` is the type of _derivation_ labels. 109 | Additionally, `l` and `r` must instantiate `Language.Pantograph.Generic.Grammar.IsRuleLabel l r`. 110 | 111 | One complete specific editor is given in the codebase, and can be found in `Language.Pantograph.Specific.Currying`. 112 | The editor implemented here is the same as the one demonstrated in the Pantograph paper, used in the Pantograph paper's user study, and available in the runnable artifact (and hosted online at `jeprinz.github.com/pantograph`). 113 | This is a good place to start in order to understand how to define a new editor. 114 | Other related editor fragments can be found among the other `Language.Pantograph.Specific.*` modules. 115 | 116 | The general paradigm behind how languages are implemented is described in Section 5 of the paper. 117 | A language consists of a set of _sorts_ (which are encoded trees of _sort labels_; see `Language.Pantograph.Generic.Grammar.Sort`), which are essentially the possible judgements, while a program is a derivation (which are encoded as trees of _derivation labels_, which are pairs of a _derivation rule label_ and a _rule variable substitution_; see `Language.Pantograph.Generic.Grammar.DerivTerm`) of a sort. 118 | 119 | ## Organization 120 | 121 | The implementation in `src/` is organized as follows: 122 | - `Data.*` modules contain miscelleneous generic data types 123 | - `Halogen.*` modules contain extra Halogen-related functionalities 124 | - `Language.Pantograph.Generic.*` modules contain the language-generic implementation of Pantograph 125 | - `Language.Pantograph.Specific.*` modules contain editor instances for specific languages 126 | - in particular, in the current version of the repository, only `Language.Pantograph.Specific.Currying` is fully implemented 127 | - `Language.Pantograph.Lib.*` modules contain useful functionalities for defining specific editor instances (for example, language-generically deriving the propagation rules as mentioned in the paper) 128 | - `Tutorial.*` contains all the functionalities specific to the Pantograph tutorial (e.g. defining the tutorial UI and lessons) 129 | 130 | ## Citation 131 | 132 | To cite the Pantograph paper associated with this repository: 133 | 134 | ```bibtex 135 | @article{pantograph, 136 | author = {Prinz J, Blanchette H, Lampropoulos L}, 137 | title = {Pantograph: Pantograph: A Fluid and Typed Structure Editor}, 138 | journal = {POPL}, 139 | year = {2025}, 140 | doi = {10.1145/3704864} 141 | } 142 | ``` 143 | -------------------------------------------------------------------------------- /agda/Drv1.agda: -------------------------------------------------------------------------------- 1 | module Drv1 where 2 | 3 | import Data.Nat as Nat 4 | open import Data.Nat using (ℕ ; zero ; suc) 5 | import Data.List as List 6 | open import Data.List using (List ; [_] ; _∷_ ; []) 7 | open import Data.Product 8 | open import Data.String 9 | 10 | -- Label 11 | data Label : Set where 12 | -- kinds 13 | BaseKind : Label 14 | -- types 15 | NatType : Label 16 | ArrowType : Label 17 | HoleType : String → Label 18 | -- terms 19 | NatTerm : ℕ → Label 20 | VarTerm : Label 21 | LamTerm : Label 22 | AppTerm : Label 23 | HoleTerm : Label 24 | -- term vars 25 | TermVar : String → Label 26 | 27 | -- Expression 28 | data Exp : Set where 29 | Exp[_,_] : Label → List Exp → Exp 30 | Hole[_] : String → Exp 31 | 32 | -- kinds 33 | 34 | baseKindExp = Exp[ BaseKind , [] ] 35 | 36 | -- types 37 | 38 | natTypeExp = Exp[ NatType , [] ] 39 | 40 | arrowTypeExp : Exp → Exp → Exp 41 | arrowTypeExp A1 A2 = Exp[ NatType , (A1 ∷ A2 ∷ []) ] 42 | 43 | holeTypeExp : String → Exp 44 | holeTypeExp id = Exp[ HoleType id , [] ] 45 | 46 | -- terms 47 | 48 | natTermExp : ℕ → Exp 49 | natTermExp n = Exp[ NatTerm n , [] ] 50 | 51 | varTermExp : Exp → Exp 52 | varTermExp x = Exp[ VarTerm , [ x ] ] 53 | 54 | lamTermExp : Exp → Exp → Exp 55 | lamTermExp x b = Exp[ LamTerm , (x ∷ b ∷ []) ] 56 | 57 | appTermExp : Exp → Exp → Exp 58 | appTermExp f a = Exp[ AppTerm , (f ∷ a ∷ []) ] 59 | 60 | holeTermExp : Exp 61 | holeTermExp = Exp[ HoleTerm , [] ] 62 | 63 | -- term vars 64 | 65 | termVarExp : String → Exp 66 | termVarExp str = Exp[ TermVar str , [] ] 67 | 68 | -- Context 69 | -- Note that variables are also expressions. 70 | Ctx : Set 71 | Ctx = List (String × Exp) 72 | 73 | data _[_]↦_⦂_ : Ctx → ℕ → String → Exp → Set where 74 | here : ∀ {Γ} {x} {A} → 75 | ((x , A) ∷ Γ) [ 0 ]↦ x ⦂ A 76 | there : ∀ {Γ} {x} {n} {A} {y} {B} → 77 | Γ [ suc n ]↦ x ⦂ A → 78 | ((y , B) ∷ Γ) [ n ]↦ x ⦂ A 79 | 80 | -- Derivation 81 | data _⊢_⦂_ : Ctx → Exp → Exp → Set where 82 | -- hole 83 | 84 | hole : ∀ {Γ} e s → Γ ⊢ e ⦂ s 85 | 86 | -- types 87 | 88 | natType : ∀ {Γ} → Γ ⊢ natTypeExp ⦂ baseKindExp 89 | arrowType : ∀ {Γ} {A} {B} → (Γ ⊢ A ⦂ baseKindExp) → (Γ ⊢ B ⦂ baseKindExp) → (Γ ⊢ arrowTypeExp A B ⦂ baseKindExp) 90 | 91 | -- terms 92 | 93 | natTerm : ∀ {Γ} n → Γ ⊢ natTermExp n ⦂ natTypeExp 94 | 95 | varTerm : ∀ {Γ} {A} x {n} → Γ [ n ]↦ x ⦂ A → Γ ⊢ varTermExp (termVarExp x) ⦂ A 96 | 97 | lamTerm : ∀ {Γ} x {A} {B} {b} → Γ ⊢ A ⦂ baseKindExp → ((x , A) ∷ Γ) ⊢ b ⦂ B → Γ ⊢ lamTermExp (termVarExp x) b ⦂ arrowTypeExp A B 98 | 99 | appTerm : ∀ {Γ} {A} {B} {f} {a} → Γ ⊢ f ⦂ arrowTypeExp A B → Γ ⊢ a ⦂ A → Γ ⊢ appTermExp f a ⦂ B 100 | 101 | -- using holes as types 102 | _ : [] ⊢ _ ⦂ _ 103 | _ = 104 | appTerm 105 | (lamTerm "x" (hole (arrowTypeExp (holeTypeExp "?A") (holeTypeExp "?A")) baseKindExp) (varTerm "x" here)) 106 | (lamTerm "y" (hole (holeTypeExp "?A") baseKindExp) (varTerm "y" here)) 107 | 108 | _ : [] ⊢ _ ⦂ _ 109 | _ = 110 | appTerm 111 | (lamTerm "x" (arrowType (hole (holeTypeExp "?A") baseKindExp) (hole (holeTypeExp "?A") baseKindExp)) (varTerm "x" here)) 112 | (lamTerm "y" (hole (holeTypeExp "?A") baseKindExp) (varTerm "y" here)) 113 | 114 | -- using holes as terms 115 | _ : [] ⊢ _ ⦂ _ 116 | _ = appTerm (lamTerm "x" natType (hole holeTermExp natTypeExp)) (natTerm 32) 117 | 118 | _ : [] ⊢ _ ⦂ _ 119 | _ = appTerm (hole holeTermExp (arrowTypeExp natTypeExp natTypeExp)) (natTerm 32) 120 | 121 | -------------------------------------------------------------------------------- /agda/Drv1.agdai: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jeprinz/pantograph/13fc16fa774bc11514e3ef89b5dc6a0634653e20/agda/Drv1.agdai -------------------------------------------------------------------------------- /agda/Drv1.agda~: -------------------------------------------------------------------------------- 1 | module Drv1 where 2 | 3 | import Data.Nat as Nat 4 | open import Data.Nat using (ℕ ; zero ; suc) 5 | import Data.List as List 6 | open import Data.List using (List ; [_] ; _∷_ ; []) 7 | open import Data.Product 8 | open import Data.String 9 | 10 | -- Label 11 | data Label : Set where 12 | -- kinds 13 | BaseKind : Label 14 | -- types 15 | NatType : Label 16 | ArrowType : Label 17 | HoleType : String → Label 18 | -- terms 19 | NatTerm : ℕ → Label 20 | VarTerm : Label 21 | LamTerm : Label 22 | AppTerm : Label 23 | HoleTerm : Label 24 | -- term vars 25 | TermVar : String → Label 26 | 27 | -- Expression 28 | data Exp : Set where 29 | Exp[_,_] : Label → List Exp → Exp 30 | Hole[_] : String → Exp 31 | 32 | -- kinds 33 | 34 | baseKindExp = Exp[ BaseKind , [] ] 35 | 36 | -- types 37 | 38 | natTypeExp = Exp[ NatType , [] ] 39 | 40 | arrowTypeExp : Exp → Exp → Exp 41 | arrowTypeExp A1 A2 = Exp[ NatType , (A1 ∷ A2 ∷ []) ] 42 | 43 | holeTypeExp : String → Exp 44 | holeTypeExp id = Exp[ HoleType id , [] ] 45 | 46 | -- terms 47 | 48 | natTermExp : ℕ → Exp 49 | natTermExp n = Exp[ NatTerm n , [] ] 50 | 51 | varTermExp : Exp → Exp 52 | varTermExp x = Exp[ VarTerm , [ x ] ] 53 | 54 | lamTermExp : Exp → Exp → Exp 55 | lamTermExp x b = Exp[ LamTerm , (x ∷ b ∷ []) ] 56 | 57 | appTermExp : Exp → Exp → Exp 58 | appTermExp f a = Exp[ AppTerm , (f ∷ a ∷ []) ] 59 | 60 | holeTermExp : Exp 61 | holeTermExp = Exp[ HoleTerm , [] ] 62 | 63 | -- term vars 64 | 65 | termVarExp : String → Exp 66 | termVarExp str = Exp[ TermVar str , [] ] 67 | 68 | -- Context 69 | -- Note that variables are also expressions. 70 | Ctx : Set 71 | Ctx = List (String × Exp) 72 | 73 | data _[_]↦_⦂_ : Ctx → ℕ → String → Exp → Set where 74 | here : ∀ {Γ} {x} {A} → 75 | ((x , A) ∷ Γ) [ 0 ]↦ x ⦂ A 76 | there : ∀ {Γ} {x} {n} {A} {y} {B} → 77 | Γ [ suc n ]↦ x ⦂ A → 78 | ((y , B) ∷ Γ) [ n ]↦ x ⦂ A 79 | 80 | -- Derivation 81 | data _⊢_⦂_ : Ctx → Exp → Exp → Set where 82 | -- hole 83 | 84 | hole : ∀ {Γ} e {s} → Γ ⊢ e ⦂ s 85 | 86 | -- types 87 | 88 | natType : ∀ {Γ} → 89 | Γ ⊢ natTypeExp ⦂ baseKindExp 90 | 91 | arrowType : ∀ {Γ} {A} {B} → 92 | (Γ ⊢ A ⦂ baseKindExp) → 93 | (Γ ⊢ B ⦂ baseKindExp) → 94 | (Γ ⊢ arrowTypeExp A B ⦂ baseKindExp) 95 | 96 | holeType : ∀ {Γ} id → 97 | (Γ ⊢ holeTypeExp id ⦂ baseKindExp) 98 | 99 | -- terms 100 | 101 | natTerm : ∀ {Γ} n → 102 | Γ ⊢ natTermExp n ⦂ natTypeExp 103 | 104 | varTerm : ∀ {Γ} {A} x {n} → 105 | Γ [ n ]↦ x ⦂ A → 106 | Γ ⊢ varTermExp (termVarExp x) ⦂ A 107 | 108 | lamTerm : ∀ {Γ} x {A} {B} {b} → 109 | Γ ⊢ A ⦂ baseKindExp → 110 | ((x , A) ∷ Γ) ⊢ b ⦂ B → 111 | Γ ⊢ lamTermExp (termVarExp x) b ⦂ arrowTypeExp A B 112 | 113 | appTerm : ∀ {Γ} {A} {B} {f} {a} → 114 | Γ ⊢ f ⦂ arrowTypeExp A B → 115 | Γ ⊢ a ⦂ A → 116 | Γ ⊢ appTermExp f a ⦂ B 117 | 118 | -- using holes as types 119 | _ : [] ⊢ _ ⦂ arrowTypeExp natTypeExp natTypeExp 120 | _ = 121 | appTerm 122 | (lamTerm "x" hole (varTerm "x" here)) 123 | (lamTerm "y" hole (varTerm "y" here)) 124 | 125 | -- using holes as terms (well) 126 | _ : [] ⊢ _ ⦂ _ 127 | _ = appTerm (lamTerm "x" natType (varTerm "x" here)) (hole holeTermExp) 128 | 129 | -- using holes as terms (badly) 130 | _ : [] ⊢ _ ⦂ _ 131 | _ = appTerm (lamTerm "x" natType (varTerm "x" here)) (hole baseKindExp) 132 | 133 | -------------------------------------------------------------------------------- /agda/Drv2.agda: -------------------------------------------------------------------------------- 1 | module Drv2 where 2 | 3 | import Data.Nat as Nat 4 | open import Data.Nat using (ℕ ; zero ; suc) 5 | import Data.List as List 6 | open import Data.List using (List ; [_] ; _∷_ ; []) 7 | open import Data.Product 8 | open import Data.String 9 | 10 | -- Label 11 | data Label : Set where 12 | -- kinds 13 | BaseKind : Label 14 | -- types 15 | NatType : Label 16 | ArrowType : Label 17 | HoleType : String → Label 18 | -- terms 19 | NatTerm : ℕ → Label 20 | VarTerm : Label 21 | LamTerm : Label 22 | AppTerm : Label 23 | HoleTerm : Label 24 | -- term vars 25 | TermVar : String → Label 26 | 27 | -- Expression 28 | data Exp : Set where 29 | Exp[_,_] : Label → List Exp → Exp 30 | Hole[_] : String → Exp 31 | 32 | -- kinds 33 | 34 | baseKindExp = Exp[ BaseKind , [] ] 35 | 36 | -- types 37 | 38 | natTypeExp = Exp[ NatType , [] ] 39 | 40 | arrowTypeExp : Exp → Exp → Exp 41 | arrowTypeExp A1 A2 = Exp[ NatType , (A1 ∷ A2 ∷ []) ] 42 | 43 | holeTypeExp : String → Exp 44 | holeTypeExp id = Exp[ HoleType id , [] ] 45 | 46 | -- terms 47 | 48 | natTermExp : ℕ → Exp 49 | natTermExp n = Exp[ NatTerm n , [] ] 50 | 51 | varTermExp : Exp → Exp 52 | varTermExp x = Exp[ VarTerm , [ x ] ] 53 | 54 | lamTermExp : Exp → Exp → Exp 55 | lamTermExp x b = Exp[ LamTerm , (x ∷ b ∷ []) ] 56 | 57 | appTermExp : Exp → Exp → Exp 58 | appTermExp f a = Exp[ AppTerm , (f ∷ a ∷ []) ] 59 | 60 | holeTermExp : Exp 61 | holeTermExp = Exp[ HoleTerm , [] ] 62 | 63 | -- term vars 64 | 65 | termVarExp : String → Exp 66 | termVarExp str = Exp[ TermVar str , [] ] 67 | 68 | -- Context 69 | -- Note that variables are also expressions. 70 | Ctx : Set 71 | Ctx = List (String × Exp) 72 | 73 | -- data In : Γ n x A where 74 | data In : Ctx → ℕ → String → Exp → Set where 75 | here : ∀ {x} {A} {Γ} → In ((x , A) ∷ Γ) 0 x A 76 | there : ∀ {y} {B} {x} {A} {Γ} {n} → In Γ n x A → In ((y , B) ∷ Γ) (suc n) x A 77 | 78 | data _⊢_ : Ctx → Exp → Set where 79 | hole : ∀ {Γ} e → Γ ⊢ e 80 | 81 | natType : ∀ {Γ} → Γ ⊢ baseKindExp 82 | arrowType : ∀ {Γ} → Γ ⊢ baseKindExp → Γ ⊢ baseKindExp → Γ ⊢ baseKindExp 83 | 84 | natTerm : ∀ {Γ} → ℕ → Γ ⊢ natTypeExp 85 | varTerm : ∀ {Γ} {n} x {A} → In Γ n x A → Γ ⊢ A 86 | lamTerm : ∀ {Γ} x A {B} → ((x , A) ∷ Γ) ⊢ B → Γ ⊢ arrowTypeExp A B 87 | appTerm : ∀ {Γ} {A} {B} → Γ ⊢ arrowTypeExp A B → Γ ⊢ A → Γ ⊢ B 88 | 89 | 90 | module Examples where 91 | ex1 : [] ⊢ _ 92 | ex1 = lamTerm "x" (holeTypeExp "?A") (varTerm "x" here) 93 | 94 | ex2 : [] ⊢ _ 95 | ex2 = appTerm (hole (arrowTypeExp (holeTypeExp "?A") (holeTypeExp "?B"))) (hole (holeTypeExp "?A")) 96 | 97 | -- PROBLEM: allows you to put the wrong things in the hole 98 | ex3 : [] ⊢ _ 99 | ex3 = lamTerm "x" (holeTypeExp "?A") (hole (natTermExp 1)) 100 | -------------------------------------------------------------------------------- /agda/Drv2.agdai: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jeprinz/pantograph/13fc16fa774bc11514e3ef89b5dc6a0634653e20/agda/Drv2.agdai -------------------------------------------------------------------------------- /agda/Drv2.agda~: -------------------------------------------------------------------------------- 1 | module Drv1 where 2 | 3 | import Data.Nat as Nat 4 | open import Data.Nat using (ℕ ; zero ; suc) 5 | import Data.List as List 6 | open import Data.List using (List ; [_] ; _∷_ ; []) 7 | open import Data.Product 8 | open import Data.String 9 | 10 | -- Label 11 | data Label : Set where 12 | -- kinds 13 | BaseKind : Label 14 | -- types 15 | NatType : Label 16 | ArrowType : Label 17 | HoleType : String → Label 18 | -- terms 19 | NatTerm : ℕ → Label 20 | VarTerm : Label 21 | LamTerm : Label 22 | AppTerm : Label 23 | HoleTerm : Label 24 | -- term vars 25 | TermVar : String → Label 26 | 27 | -- Expression 28 | data Exp : Set where 29 | Exp[_,_] : Label → List Exp → Exp 30 | Hole[_] : String → Exp 31 | 32 | -- kinds 33 | 34 | baseKindExp = Exp[ BaseKind , [] ] 35 | 36 | -- types 37 | 38 | natTypeExp = Exp[ NatType , [] ] 39 | 40 | arrowTypeExp : Exp → Exp → Exp 41 | arrowTypeExp A1 A2 = Exp[ NatType , (A1 ∷ A2 ∷ []) ] 42 | 43 | holeTypeExp : String → Exp 44 | holeTypeExp id = Exp[ HoleType id , [] ] 45 | 46 | -- terms 47 | 48 | natTermExp : ℕ → Exp 49 | natTermExp n = Exp[ NatTerm n , [] ] 50 | 51 | varTermExp : Exp → Exp 52 | varTermExp x = Exp[ VarTerm , [ x ] ] 53 | 54 | lamTermExp : Exp → Exp → Exp 55 | lamTermExp x b = Exp[ LamTerm , (x ∷ b ∷ []) ] 56 | 57 | appTermExp : Exp → Exp → Exp 58 | appTermExp f a = Exp[ AppTerm , (f ∷ a ∷ []) ] 59 | 60 | holeTermExp : Exp 61 | holeTermExp = Exp[ HoleTerm , [] ] 62 | 63 | -- term vars 64 | 65 | termVarExp : String → Exp 66 | termVarExp str = Exp[ TermVar str , [] ] 67 | 68 | -- Context 69 | -- Note that variables are also expressions. 70 | Ctx : Set 71 | Ctx = List (String × Exp) 72 | 73 | data _[_]↦_⦂_ : Ctx → ℕ → String → Exp → Set where 74 | here : ∀ {Γ} {x} {A} → 75 | ((x , A) ∷ Γ) [ 0 ]↦ x ⦂ A 76 | there : ∀ {Γ} {x} {n} {A} {y} {B} → 77 | Γ [ suc n ]↦ x ⦂ A → 78 | ((y , B) ∷ Γ) [ n ]↦ x ⦂ A 79 | 80 | -- Derivation 81 | data _⊢_⦂_ : Ctx → Exp → Exp → Set where 82 | -- hole 83 | 84 | hole : ∀ {Γ} e {s} → Γ ⊢ e ⦂ s 85 | 86 | -- types 87 | 88 | natType : ∀ {Γ} → 89 | Γ ⊢ natTypeExp ⦂ baseKindExp 90 | 91 | arrowType : ∀ {Γ} {A} {B} → 92 | (Γ ⊢ A ⦂ baseKindExp) → 93 | (Γ ⊢ B ⦂ baseKindExp) → 94 | (Γ ⊢ arrowTypeExp A B ⦂ baseKindExp) 95 | 96 | holeType : ∀ {Γ} id → 97 | (Γ ⊢ holeTypeExp id ⦂ baseKindExp) 98 | 99 | -- terms 100 | 101 | natTerm : ∀ {Γ} n → 102 | Γ ⊢ natTermExp n ⦂ natTypeExp 103 | 104 | varTerm : ∀ {Γ} {A} x {n} → 105 | Γ [ n ]↦ x ⦂ A → 106 | Γ ⊢ varTermExp (termVarExp x) ⦂ A 107 | 108 | lamTerm : ∀ {Γ} x {A} {B} {b} → 109 | Γ ⊢ A ⦂ baseKindExp → 110 | ((x , A) ∷ Γ) ⊢ b ⦂ B → 111 | Γ ⊢ lamTermExp (termVarExp x) b ⦂ arrowTypeExp A B 112 | 113 | appTerm : ∀ {Γ} {A} {B} {f} {a} → 114 | Γ ⊢ f ⦂ arrowTypeExp A B → 115 | Γ ⊢ a ⦂ A → 116 | Γ ⊢ appTermExp f a ⦂ B 117 | 118 | -- using holes as types 119 | _ : [] ⊢ _ ⦂ arrowTypeExp natTypeExp natTypeExp 120 | _ = 121 | appTerm 122 | (lamTerm "x" hole (varTerm "x" here)) 123 | (lamTerm "y" hole (varTerm "y" here)) 124 | 125 | -- using holes as terms (well) 126 | _ : [] ⊢ _ ⦂ _ 127 | _ = appTerm (lamTerm "x" natType (varTerm "x" here)) (hole holeTermExp) 128 | 129 | -- using holes as terms (badly) 130 | _ : [] ⊢ _ ⦂ _ 131 | _ = appTerm (lamTerm "x" natType (varTerm "x" here)) (hole baseKindExp) 132 | 133 | -------------------------------------------------------------------------------- /assets/map-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jeprinz/pantograph/13fc16fa774bc11514e3ef89b5dc6a0634653e20/assets/map-1.png -------------------------------------------------------------------------------- /assets/map-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jeprinz/pantograph/13fc16fa774bc11514e3ef89b5dc6a0634653e20/assets/map-2.png -------------------------------------------------------------------------------- /assets/map-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jeprinz/pantograph/13fc16fa774bc11514e3ef89b5dc6a0634653e20/assets/map-3.png -------------------------------------------------------------------------------- /assets/map-4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jeprinz/pantograph/13fc16fa774bc11514e3ef89b5dc6a0634653e20/assets/map-4.png -------------------------------------------------------------------------------- /assets/map-5.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jeprinz/pantograph/13fc16fa774bc11514e3ef89b5dc6a0634653e20/assets/map-5.png -------------------------------------------------------------------------------- /assets/pantograph-example-1.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jeprinz/pantograph/13fc16fa774bc11514e3ef89b5dc6a0634653e20/assets/pantograph-example-1.gif -------------------------------------------------------------------------------- /dist/Tutorial/sidebar.css: -------------------------------------------------------------------------------- 1 | /*I got this from https://codepen.io/Zodiase/pen/qmjyKL*/ 2 | 3 | html { 4 | height: 100%; 5 | } 6 | 7 | @font-face { 8 | font-family: 'Corben'; 9 | font-style: normal; 10 | font-weight: 400; 11 | src: local('Corben Regular'), local('Corben-Regular'); 12 | } 13 | 14 | @font-face { 15 | font-family: 'Neuton'; 16 | font-style: normal; 17 | font-weight: 400; 18 | src: local('Neuton Regular'), local('Neuton-Regular'); 19 | } 20 | 21 | @font-face { 22 | font-family: 'Abril Fatface'; 23 | font-style: normal; 24 | font-weight: 400; 25 | src: local('Abril Fatface'), local('AbrilFatface-Regular'); 26 | } 27 | 28 | 29 | /* 30 | body { 31 | box-sizing: border-box; 32 | height: 100%; 33 | margin: 0; 34 | padding: 30px; 35 | background-color: black; 36 | } 37 | */ 38 | 39 | .sidebar-container { 40 | margin: 0; 41 | padding: 0; 42 | height: 100%; 43 | background-color: white; 44 | display: flex; 45 | flex-direction: row; 46 | flex-wrap: nowrap; 47 | justify-content: flex-start; 48 | align-content: stretch; 49 | align-items: stretch; 50 | 51 | /* 52 | & > aside { 53 | -webkit-order: 0; 54 | -ms-flex-order: 0; 55 | order: 0; 56 | -webkit-flex: 0 0 auto; 57 | -ms-flex: 0 0 auto; 58 | flex: 0 0 auto; 59 | -webkit-align-self: auto; 60 | -ms-flex-item-align: auto; 61 | align-self: auto; 62 | } 63 | 64 | & > main { 65 | -webkit-order: 0; 66 | -ms-flex-order: 0; 67 | order: 0; 68 | -webkit-flex: 1 1 auto; 69 | -ms-flex: 1 1 auto; 70 | flex: 1 1 auto; 71 | -webkit-align-self: auto; 72 | -ms-flex-item-align: auto; 73 | align-self: auto; 74 | } 75 | */ 76 | } 77 | 78 | .sidebar-container>aside, 79 | .sidebar-container>main { 80 | /* padding: 10px; */ 81 | /* overflow: auto; */ 82 | } 83 | 84 | .resize-handle--x { 85 | margin: 0; 86 | padding: 0; 87 | position: relative; 88 | box-sizing: border-box; 89 | width: 3px; 90 | height: 100%; 91 | 92 | 93 | border-left-width: 1px; 94 | border-left-style: solid; 95 | border-left-color: black; 96 | border-right-width: 1px; 97 | border-right-style: solid; 98 | border-right-color: black; 99 | cursor: ew-resize; 100 | 101 | /* 102 | -webkit-flex: 0 0 auto; 103 | -ms-flex: 0 0 auto; 104 | flex: 0 0 auto; 105 | 106 | 107 | -webkit-touch-callout: none; 108 | -webkit-user-select: none; 109 | -khtml-user-select: none; 110 | -moz-user-select: none; 111 | -ms-user-select: none; 112 | user-select: none; 113 | 114 | @handleSize: 18px; 115 | @handleThickness: 1px; 116 | @handleDistance: 2px; 117 | */ 118 | 119 | /* 120 | &:before { 121 | content: ""; 122 | position: absolute; 123 | z-index: 1; 124 | top: 50%; 125 | right: 100%; 126 | height: @handleSize; 127 | width: @handleDistance; 128 | margin-top: -@handleSize/2; 129 | border-left-color: black; 130 | border-left-width: @handleThickness; 131 | border-left-style: solid; 132 | } 133 | &:after { 134 | content: ""; 135 | position: absolute; 136 | z-index: 1; 137 | top: 50%; 138 | left: 100%; 139 | height: @handleSize; 140 | width: @handleDistance; 141 | margin-top: -@handleSize/2; 142 | border-right-color: black; 143 | border-right-width: @handleThickness; 144 | border-right-style: solid; 145 | } 146 | */ 147 | } 148 | 149 | .lessonInstructions { 150 | font-family: 'Corben'; 151 | } 152 | 153 | .lessonInstructions h1 { 154 | font-size: 1.4em; 155 | margin: 0; 156 | margin-bottom: 1em; 157 | border-top: 2px solid black; 158 | padding-top: 1em; 159 | } 160 | -------------------------------------------------------------------------------- /dist/Tutorial/sidebar.js: -------------------------------------------------------------------------------- 1 | /*I got this from https://codepen.io/Zodiase/pen/qmjyKL*/ 2 | 3 | const selectTarget = (fromElement, selector) => { 4 | if (!(fromElement instanceof HTMLElement)) { 5 | return null; 6 | } 7 | 8 | return fromElement.querySelector(selector); 9 | }; 10 | 11 | const resizeData = { 12 | tracking: false, 13 | startWidth: null, 14 | startCursorScreenX: null, 15 | handleWidth: 10, 16 | resizeTarget: null, 17 | parentElement: null, 18 | maxWidth: null, 19 | }; 20 | 21 | $(document.body).on('mousedown', '.resize-handle--x', null, (event) => { 22 | //$(document.body).on('mousedown', (event) => { 23 | if (event.button !== 0) { 24 | return; 25 | } 26 | 27 | event.preventDefault(); 28 | event.stopPropagation(); 29 | 30 | const handleElement = event.currentTarget; 31 | 32 | if (!handleElement.parentElement) { 33 | console.error(new Error("Parent element not found.")); 34 | return; 35 | } 36 | 37 | // Use the target selector on the handle to get the resize target. 38 | const targetSelector = handleElement.getAttribute('data-target'); 39 | const targetElement = selectTarget(handleElement.parentElement, targetSelector); 40 | 41 | if (!targetElement) { 42 | console.error(new Error("Resize target element not found.")); 43 | return; 44 | } 45 | 46 | resizeData.startWidth = $(targetElement).outerWidth(); 47 | resizeData.startCursorScreenX = event.screenX; 48 | resizeData.resizeTarget = targetElement; 49 | resizeData.parentElement = handleElement.parentElement; 50 | resizeData.maxWidth = $(handleElement.parentElement).innerWidth() - resizeData.handleWidth; 51 | resizeData.tracking = true; 52 | }); 53 | 54 | $(window).on('mousemove', null, null, (event) => { 55 | if (resizeData.tracking) { 56 | const cursorScreenXDelta = event.screenX - resizeData.startCursorScreenX; 57 | const newWidth = Math.min(resizeData.startWidth - cursorScreenXDelta, resizeData.maxWidth); 58 | 59 | $(resizeData.resizeTarget).outerWidth(newWidth); 60 | } 61 | }); 62 | 63 | $(window).on('mouseup', null, null, (event) => { 64 | if (resizeData.tracking) { 65 | resizeData.tracking = false; 66 | } 67 | }); -------------------------------------------------------------------------------- /dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Pantograph | Tutorial 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /dist/standalone/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Pantograph 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /docs/Tutorial/sidebar.css: -------------------------------------------------------------------------------- 1 | /*I got this from https://codepen.io/Zodiase/pen/qmjyKL*/ 2 | 3 | html { 4 | height: 100%; 5 | } 6 | 7 | @font-face { 8 | font-family: 'Corben'; 9 | font-style: normal; 10 | font-weight: 400; 11 | src: local('Corben Regular'), local('Corben-Regular'); 12 | } 13 | 14 | @font-face { 15 | font-family: 'Neuton'; 16 | font-style: normal; 17 | font-weight: 400; 18 | src: local('Neuton Regular'), local('Neuton-Regular'); 19 | } 20 | 21 | @font-face { 22 | font-family: 'Abril Fatface'; 23 | font-style: normal; 24 | font-weight: 400; 25 | src: local('Abril Fatface'), local('AbrilFatface-Regular'); 26 | } 27 | 28 | 29 | /* 30 | body { 31 | box-sizing: border-box; 32 | height: 100%; 33 | margin: 0; 34 | padding: 30px; 35 | background-color: black; 36 | } 37 | */ 38 | 39 | .sidebar-container { 40 | margin: 0; 41 | padding: 0; 42 | height: 100%; 43 | background-color: white; 44 | display: flex; 45 | flex-direction: row; 46 | flex-wrap: nowrap; 47 | justify-content: flex-start; 48 | align-content: stretch; 49 | align-items: stretch; 50 | 51 | /* 52 | & > aside { 53 | -webkit-order: 0; 54 | -ms-flex-order: 0; 55 | order: 0; 56 | -webkit-flex: 0 0 auto; 57 | -ms-flex: 0 0 auto; 58 | flex: 0 0 auto; 59 | -webkit-align-self: auto; 60 | -ms-flex-item-align: auto; 61 | align-self: auto; 62 | } 63 | 64 | & > main { 65 | -webkit-order: 0; 66 | -ms-flex-order: 0; 67 | order: 0; 68 | -webkit-flex: 1 1 auto; 69 | -ms-flex: 1 1 auto; 70 | flex: 1 1 auto; 71 | -webkit-align-self: auto; 72 | -ms-flex-item-align: auto; 73 | align-self: auto; 74 | } 75 | */ 76 | } 77 | 78 | .sidebar-container>aside, 79 | .sidebar-container>main { 80 | /* padding: 10px; */ 81 | /* overflow: auto; */ 82 | } 83 | 84 | .resize-handle--x { 85 | margin: 0; 86 | padding: 0; 87 | position: relative; 88 | box-sizing: border-box; 89 | width: 3px; 90 | height: 100%; 91 | 92 | 93 | border-left-width: 1px; 94 | border-left-style: solid; 95 | border-left-color: black; 96 | border-right-width: 1px; 97 | border-right-style: solid; 98 | border-right-color: black; 99 | cursor: ew-resize; 100 | 101 | /* 102 | -webkit-flex: 0 0 auto; 103 | -ms-flex: 0 0 auto; 104 | flex: 0 0 auto; 105 | 106 | 107 | -webkit-touch-callout: none; 108 | -webkit-user-select: none; 109 | -khtml-user-select: none; 110 | -moz-user-select: none; 111 | -ms-user-select: none; 112 | user-select: none; 113 | 114 | @handleSize: 18px; 115 | @handleThickness: 1px; 116 | @handleDistance: 2px; 117 | */ 118 | 119 | /* 120 | &:before { 121 | content: ""; 122 | position: absolute; 123 | z-index: 1; 124 | top: 50%; 125 | right: 100%; 126 | height: @handleSize; 127 | width: @handleDistance; 128 | margin-top: -@handleSize/2; 129 | border-left-color: black; 130 | border-left-width: @handleThickness; 131 | border-left-style: solid; 132 | } 133 | &:after { 134 | content: ""; 135 | position: absolute; 136 | z-index: 1; 137 | top: 50%; 138 | left: 100%; 139 | height: @handleSize; 140 | width: @handleDistance; 141 | margin-top: -@handleSize/2; 142 | border-right-color: black; 143 | border-right-width: @handleThickness; 144 | border-right-style: solid; 145 | } 146 | */ 147 | } 148 | 149 | .lessonInstructions { 150 | font-family: 'Corben'; 151 | } 152 | 153 | .lessonInstructions h1 { 154 | font-size: 1.4em; 155 | margin: 0; 156 | margin-bottom: 1em; 157 | border-top: 2px solid black; 158 | padding-top: 1em; 159 | } 160 | -------------------------------------------------------------------------------- /docs/Tutorial/sidebar.js: -------------------------------------------------------------------------------- 1 | /*I got this from https://codepen.io/Zodiase/pen/qmjyKL*/ 2 | 3 | const selectTarget = (fromElement, selector) => { 4 | if (!(fromElement instanceof HTMLElement)) { 5 | return null; 6 | } 7 | 8 | return fromElement.querySelector(selector); 9 | }; 10 | 11 | const resizeData = { 12 | tracking: false, 13 | startWidth: null, 14 | startCursorScreenX: null, 15 | handleWidth: 10, 16 | resizeTarget: null, 17 | parentElement: null, 18 | maxWidth: null, 19 | }; 20 | 21 | $(document.body).on('mousedown', '.resize-handle--x', null, (event) => { 22 | //$(document.body).on('mousedown', (event) => { 23 | if (event.button !== 0) { 24 | return; 25 | } 26 | 27 | event.preventDefault(); 28 | event.stopPropagation(); 29 | 30 | const handleElement = event.currentTarget; 31 | 32 | if (!handleElement.parentElement) { 33 | console.error(new Error("Parent element not found.")); 34 | return; 35 | } 36 | 37 | // Use the target selector on the handle to get the resize target. 38 | const targetSelector = handleElement.getAttribute('data-target'); 39 | const targetElement = selectTarget(handleElement.parentElement, targetSelector); 40 | 41 | if (!targetElement) { 42 | console.error(new Error("Resize target element not found.")); 43 | return; 44 | } 45 | 46 | resizeData.startWidth = $(targetElement).outerWidth(); 47 | resizeData.startCursorScreenX = event.screenX; 48 | resizeData.resizeTarget = targetElement; 49 | resizeData.parentElement = handleElement.parentElement; 50 | resizeData.maxWidth = $(handleElement.parentElement).innerWidth() - resizeData.handleWidth; 51 | resizeData.tracking = true; 52 | }); 53 | 54 | $(window).on('mousemove', null, null, (event) => { 55 | if (resizeData.tracking) { 56 | const cursorScreenXDelta = event.screenX - resizeData.startCursorScreenX; 57 | const newWidth = Math.min(resizeData.startWidth - cursorScreenXDelta, resizeData.maxWidth); 58 | 59 | $(resizeData.resizeTarget).outerWidth(newWidth); 60 | } 61 | }); 62 | 63 | $(window).on('mouseup', null, null, (event) => { 64 | if (resizeData.tracking) { 65 | resizeData.tracking = false; 66 | } 67 | }); -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Pantograph | Tutorial 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /docs/standalone/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Pantograph 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /index.js: -------------------------------------------------------------------------------- 1 | import { main } from "./output/Main"; 2 | main(); 3 | -------------------------------------------------------------------------------- /notes/DerivationUnification.md: -------------------------------------------------------------------------------- 1 | # Derivation Unification 2 | 3 | Proposal: derivation unification <- Expession unification, typing rules. 4 | 5 | ``` 6 | Ctx : Type 7 | 8 | Exp : Type 9 | ⋆, ℕ : Exp 10 | ?_ : TypeHole -> Exp 11 | 12 | Drv : Ctx -> Exp -> Exp -> Type 13 | _⊢_:_ : ∀ Γ t T -> Drv Γ t T 14 | ``` 15 | 16 | Some typing rules (to construct derivations) 17 | ``` 18 | natType : ∀ {Γ} -> Drv (Γ ⊢ ℕ : ⋆) 19 | holeType : ∀ {Γ} {X} -> (Γ ⊢ ?X : ⋆) 20 | holeTerm : ∀ {Γ} {A} -> (Γ ⊢ A : ⋆) -> (Γ ⊢ A) 21 | ``` 22 | 23 | Suppose we have the derivation 24 | ``` 25 | Γ₁ : Ctx 26 | X₁ : TypeHole 27 | 28 | a : Γ₁ ⊢ ?X 29 | a = holeTerm {Γ₁} holeType 30 | ``` 31 | And we want to apply the type hole substitution (which is over Expessions) 32 | ``` 33 | σ₁ = [X ↦ ℕ] 34 | ``` 35 | We need to know the derivation for `ℕ` here, and `σ` must exist in some context 36 | that respects that derivation. So actually here's the rules for constructing 37 | type hole substitutions (not type var substitutions, since that changes the 38 | context): 39 | ``` 40 | Sub : Ctx -> Type 41 | 42 | idSub : Sub Γ 43 | typeHoleSub : ∀ {Γ} -> TypeHole -> (Γ ⊢ ⋆) -> Sub Γ -> Sub Γ 44 | ``` 45 | (Perhaps this indicates that we should be keeping track of the type hole context 46 | in the signatures as well.) 47 | 48 | So the actual substitution should have been: 49 | ``` 50 | σ₁ : Sub Γ 51 | σ₁ = typeHoleSub X₁ ℕ idSub 52 | ``` 53 | 54 | Applying substitutions: 55 | ``` 56 | subType : ∀ {Γ} -> Sub Γ -> (Γ ⊢ ⋆) -> (Γ ⊢ ⋆) 57 | subTerm : ∀ {Γ} (σ : Sub Γ) -> (Γ ⊢ A) -> (Γ ⊢ subType σ A) 58 | ``` 59 | 60 | -------------------------------------------------------------------------------- /notes/Design.txt: -------------------------------------------------------------------------------- 1 | Here is my plan for designing this repository: 2 | 3 | - Generic concept of a grammar - Tree where each node has a Label 4 | - A grammar has a type of Labels and a type of Sorts 5 | - Generic concept of Changes - Can be derived generically from the Labels as well! 6 | - From any grammar, can derive a grammar with Holes - that is, a grammar with metavariables in it! 7 | - Generic concept of Typing Rules - For each term, we need to relate the Sort and Context of each child to the parent 8 | - You could do this using holes and unification. For example, consider a Lambda. A Lambda has two children, 9 | The type annotation and the body. You can describe the typing of a lambda with the following rule (where every 10 | capital letter represents a metavariable): 11 | 12 | This is the traditional typing rule for lambda: 13 | G |- A : Type G , X : A |- E : Term B 14 | ------------------------------------------------ 15 | G |- lam X . E : A -> B 16 | 17 | We can write this rule in an intrinsic style. 18 | Each piece, (the parent on the bottom and the children on the top), has a context and a sort 19 | (`Term T` is the sort of a term of type T) 20 | 21 | G |- Type G , X : A |- Term B 22 | ------------------------------------------------ 23 | G |- Term (A -> B) 24 | 25 | We can then distill this rule down to a pair of an entry for the term overall, and a list for the children: 26 | 27 | (G |- Term (A -> B), [G |- Type, G , X : A |- Term B]) 28 | 29 | We can generically derive a type-checking algorithm for any grammar from rules like this - 30 | - If we want to check a Term going from top to bottom, we unify the sort of the term with the left part of the pair, to 31 | get the sorts of it's children 32 | - If we want to check a Path going up from bottom to top, we first unify the contexts and sorts of each child with the corresponding 33 | context and sort in the list on the right, and then we can get the resulting context and sort of the parent from the left. 34 | 35 | 36 | 37 | This all works - we can input the rules of our grammar and derive most of the pieces of a structure editor. 38 | However! This is not enough for our purposes - we also need to know about typechanges! 39 | For example, we need to know that the path `lam x : A . []` can be given the context change `?, +x : A` 40 | and the TypeChange `+ A -> B`. 41 | 42 | So, instead we can give Lambda the following rule using Changes (from which the rule above can be derived). We have one entry for 43 | each child, and no entries for the parent. Each child entry is a CHANGE between that child and the parent! 44 | This means that we can derive the typing entries for the parent and children that I wrote above by getting the 45 | change endpoints of these changes - they all have the same left endpoint, namely the context and type of the parent. 46 | 47 | [G |- (Replace (Term (A -> B)) Type), G, + X : A |- Term (+A -> B)] 48 | ^ 49 | | (this means that the parent sort is a Term of type A -> B, while the child sort is Type) 50 | 51 | 52 | Using a grammar of one of these rules for each Label, we can not only derive a typechecker automatically, but 53 | we can also derive various typechange things - for example, we can derive that the change describing 54 | `lam x : A . []` is `+ A -> B`. 55 | 56 | I have encoded this rule as an example in Grammar.purs 57 | 58 | 59 | - Final question to which I don't yet know the answer - using rules like the above for each Label, can we derive 60 | chTerm and chTermPath? 61 | - If yes, then this seems like a great design with as little repetition as possible 62 | - If no, then the whole excersize seems pointless 63 | -------------------------------------------------------------------------------- /notes/DesignPhilosphy.txt: -------------------------------------------------------------------------------- 1 | Here is my (Jacob's) opinions about design from my experience designing the first version of Pantograph: 2 | 3 | -- The answer to the question "what is the right abstraction to use here" is not type-system dependent - the correct solution 4 | is the same in an untyped language as it is in dependent type theory. 5 | -- Never bend your design to fit the type system - instead, accept that the code is (partially) untyped if necessary. 6 | 7 | EXAMPLE: just because Hindley-Millner can't type generic trees doesn't mean generic trees aren't the right design 8 | 9 | 10 | 11 | -- Knowledge should be stored in values, not types, so that you can operate on it programmatically. 12 | 13 | EXAMPLE: Suppose you have an ADT for a grammar with `let : ID -> Term -> Term -> Term`. Here, the knowledge that 14 | let has two Term children is encoded in a type, so that knowledge is inaccessible to the program. 15 | While this might work fine in simple programs, it will cause code duplication eventually. 16 | 17 | 18 | -- Insofar as code repetition is an indication of bad design, using automation to sweep code repetition under the rug 19 | doesn't change this indication. A good design wouldn't have required automation to avoid repetition. -------------------------------------------------------------------------------- /notes/GGG.md: -------------------------------------------------------------------------------- 1 | # GGG 2 | 3 | Quesion: what to generic? 4 | 5 | ## Ungeneric 6 | 7 | What was so annoying about working over specialized data? 8 | - (basically, code repetition) 9 | - typing traversal written for: expressions, paths, and changes 10 | - changing functions became very complicated since there's a bulk of things to 11 | do in many places, using substitutions and recursively changing using the 12 | correctly matched arguments 13 | - formatting traveral written for: expressions, path 14 | - substitution manually defined over everything 15 | - converting between tree-like representation and specialized representation 16 | - cursor movement 17 | - some other places 18 | - generalizing change (associated with path in clipboard) 19 | 20 | ## Extremely Generic 21 | 22 | At the extreme, we can generalize _everything_ to be runtime values -- that is, we 23 | have a couple sum types 24 | ```purs 25 | -- all the sorts of things 26 | data Sort = 27 | -- term type 28 | = TermSort {ty :: Thing} 29 | | TypeSort | PolyTypeSort 30 | | TypeBindSort | TypeVarSort 31 | | TermBindSort | TermVarSort 32 | -- ... other basic sorts ... 33 | -- path 34 | | ToothSort {i :: Int} -- which child the tooth is "around" 35 | -- change 36 | | TypeChangeSort {tyIn :: Thing, tyOut :: Thing} 37 | | CtxChangeSort {ctxIn :: Thing, ctxOut :: Thing} 38 | -- ... other change sorts ... 39 | -- meta 40 | | MetaTermSort {ty :: Thing} -- used in changing rules 41 | | MetaTypeSort -- used in typing rules 42 | -- ... other meta sorts ... 43 | 44 | -- all the things 45 | data Thing ExprLabel = Thing ExprLabel (Array Thing) Sort 46 | ``` 47 | where `ExprLabel` is the type of ExprLabels for the language (variants of types, 48 | variants of terms, variants of typechanges, etc). 49 | 50 | `Thing` is just a tree over `ExprLabel /\ Sort`, so we might prefer to just use a 51 | library-defined tree datatype instead of reinvent the tree. 52 | 53 | The advantage of this form is that it _definitely_ handles everything -- its so 54 | general that any possible operation over grammatical structures is expressible 55 | as a function over `Thing`. 56 | 57 | However, `Thing` combines a bunch of data that is often operated on separately. 58 | So, `Sort` encodes whatever useful grouping information is needed over `Thing`s, 59 | as well as typing information such as the types of terms and the endpoint types 60 | of typechanges. This info can be used for runtime assertions to dynamically 61 | debug. 62 | 63 | ## Less Extremely Generic 64 | 65 | Is there a way to slightly restruct the extremely generic approach to be 66 | slightly less generic, to recover at least _some_ type-safety? There's a lot of 67 | space here to experiment with, as Jacob and Henry have. 68 | 69 | ## Jacob 70 | 71 | One way to generalize, as Jacob has in 72 | 73 | - `/src/Language/Pantograph/Expression.purs` 74 | - `/src/Language/Pantograph/GenericExpr/Expression.purs` (updated version?) 75 | 76 | is to define a datatype for each of: 77 | - Expr 78 | - Tooth 79 | - ExprWithMetaVars 80 | - Change 81 | 82 | There's some similar code that _would_ have to be written over each of (or some of) 83 | these structures, in particular: 84 | - typing traversal 85 | - formatting traveral 86 | - substitution manually defined over everything 87 | - cursor movement 88 | - ... some other things ... 89 | 90 | However, Jacob simplifies this for the typing traversal by defining a datatype 91 | encoding of typing rules, and then requiring only a simple function taht uses an 92 | arbitrary set of rules to do a typing traversal over an Expr, Tooth, Change, 93 | or ExprWithMetaVars. 94 | 95 | You can do a similar thing for the formatting traversal, defining some 96 | "formatting rules" in a way that can be interpreted to apply to both paths and 97 | expressions. 98 | 99 | Cursor movement is possibly more annoying, and begs again for a more general 100 | tree-like structure (such as Jacob's TreeView from Pantograph 1). In Pantograph 101 | 2, cursor movement will be computed over some encoding of an index into the tree 102 | rather than over expressions and paths directly. Some details to work out there. 103 | 104 | What other things would we like to do generically, and does this encoding make 105 | those easy? 106 | 107 | ## Henry 108 | 109 | Another way to generalize, as Henry has, is to define one datatype `Gram`, which 110 | each of the following are special cases of: 111 | - Expr 112 | - MetaExpr (expression with metavars) 113 | - Path 114 | - Change 115 | 116 | There is a function `traverseGram` over `Gram` which gives a generic interface 117 | for traversing over all of these datatypes. So, if you want to traverse over one 118 | of them specifically, you can use the specialized function defined in terms of 119 | `traverseGram`. If you want to work over `Gram` generically, then you can use 120 | `traverseGram` itself. Essentially, `Expr`, `MetaExpr`, `Path`, and `Change` are 121 | each subtypes of `Gram` via polymorphism. 122 | 123 | The idea of encoding the typing rules as data is interesting. And if you can 124 | actually derive the changing rules from just the the data encoding of the typing 125 | rules then that'd be awesome. Haven't fully thought that through. 126 | 127 | The most direct alternative to that in this approach is to define a traversal in 128 | terms of `traverseGram` that handles the typing logic, and then a traversal 129 | that, given the relevant inputs, uses the typing logic traversal to implement 130 | the changing algorithm. 131 | 132 | If the changing algorithm _is_ just derivable from the typing rules, then its 133 | less straightforward to take advantage of that in this approach than with the 134 | data-encoded approach. The data-encoded approach could be used with `Gram` as 135 | well. 136 | 137 | What's nice about the `Gram` approach is that all of these 138 | - typing traversal 139 | - formatting traveral 140 | - substitution manually defined over everything 141 | - cursor movement 142 | - ... some other things ... 143 | 144 | dont require any special interfaces to work over `Gram` and it's subtypes -- you 145 | just get the right interface by instantiating `Gram` enough (or not at all) 146 | until it's as general as you want for your use case. It doesnt require any data 147 | transformation to accomplish this, and so the abstraction has no overhead. 148 | 149 | 150 | -------------------------------------------------------------------------------- /notes/IdealDesign.txt: -------------------------------------------------------------------------------- 1 | A programming language is defined by some inference rules that create some judgements 2 | - Inductive rules, which reference: 3 | - Expressions = the parameters for the inference rules = indices of a deep embedding 4 | 5 | The programs themselves are derivations of these inductive rules. 6 | The user never sees the expressions, they are only for metatheory/computation purposes 7 | 8 | - Expressions 9 | - They are tree structured 10 | - We need to be able to make expr-with-metavars and do unification on them 11 | - There need to be Changes for them (which are also expressions) 12 | - We don't need zippers on these 13 | 14 | - Derivations 15 | - We need zippers on these 16 | - both paths and terms 17 | - We don't need unification or metavariables on these 18 | - Each node within a derivation has a Judgement, which is just an expression -------------------------------------------------------------------------------- /notes/TODO.md: -------------------------------------------------------------------------------- 1 | TODO: 2 | 3 | - use RenderingContext to store isCursor in RenderingStyle, rather than isCursor input to rendering functions -------------------------------------------------------------------------------- /old/Expression.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Expression where 2 | 3 | import Prelude 4 | import Data.Tuple.Nested (type (/\), (/\)) 5 | import Data.Array as Array 6 | import Data.List (List) 7 | import Data.Set as Set 8 | import Data.Set (Set) 9 | import Data.Map (Map) 10 | import Data.Either (Either(..)) 11 | import Effect.Exception.Unsafe (unsafeThrow) 12 | 13 | --type WrappedChild ExprLabel wrap = wrap /\ (Expr ExprLabel wrap) 14 | -- TODO: Do we ever need Expr or just ExprWithMetavars? 15 | data Expr ExprLabel = Expr ExprLabel (Array (Expr ExprLabel)) 16 | 17 | data Tooth ExprLabel = Tooth ExprLabel (Array (Expr ExprLabel)) (Array (Expr ExprLabel)) 18 | 19 | type Path ExprLabel = List (Tooth ExprLabel) 20 | 21 | -- Changes, generically over any grammar! 22 | data GChange ExprLabel = ChangeExpr ExprLabel (Array (GChange ExprLabel)) 23 | | Plus ExprLabel (Array (ExprWithMetavars ExprLabel)) (GChange ExprLabel) (Array (ExprWithMetavars ExprLabel)) 24 | | Minus ExprLabel (Array (ExprWithMetavars ExprLabel)) (GChange ExprLabel) (Array (ExprWithMetavars ExprLabel)) 25 | | Replace (ExprWithMetavars ExprLabel) (ExprWithMetavars ExprLabel) 26 | | MetaVar Int {-figure out UUID or something - this is supposed to be a metavariable -} 27 | 28 | data ExprWithMetavars ExprLabel = ExprWM ExprLabel (Array (ExprWithMetavars ExprLabel)) | EMetaVar Int 29 | 30 | data MapChange ExprLabel = MCPlus (ExprWithMetavars ExprLabel) | MCMinus (ExprWithMetavars ExprLabel) | MCChange (GChange ExprLabel) 31 | 32 | data GTypingRuleEntry ExprLabel id = TypingRuleEntry (Map id (MapChange ExprLabel)) (GChange ExprLabel) 33 | data GTypingRule ExprLabel id = TypingRule (Array (GTypingRuleEntry ExprLabel id)) 34 | 35 | {- 36 | While this isn't dependent type theory so we can't ensure that Exprs, GChanges etc. satisfy typing rules 37 | intrinsically, we can write checking functions: 38 | -} 39 | exprIsTyped :: forall ExprLabel wrap id . 40 | Array (GTypingRule ExprLabel id) -- The typing rules 41 | -> Expr ExprLabel -- The sort (which contains the type) 42 | -> Map id (Expr ExprLabel) -- The context - a mapping from ids to sorts 43 | -> Expr ExprLabel -- The expression to be type-checked 44 | -> Boolean 45 | exprIsTyped = unsafeThrow "todo" 46 | 47 | instance Eq ExprLabel => Eq (ExprWithMetavars ExprLabel) where 48 | eq (ExprWM l1 kids1) (ExprWM l2 kids2) = l1 == l2 && (Array.all identity (eq <$> kids1 <*> kids2)) 49 | eq (EMetaVar x) (EMetaVar y) = x == y 50 | eq _ _ = false 51 | 52 | inject :: forall a . ExprWithMetavars a -> GChange a 53 | inject (ExprWM l kids) = ChangeExpr l (map inject kids) 54 | inject (EMetaVar x) = MetaVar x 55 | 56 | composeChange :: forall ExprLabel. Eq ExprLabel => GChange ExprLabel -> GChange ExprLabel -> GChange ExprLabel 57 | composeChange (ChangeExpr l1 kids1) (ChangeExpr l2 kids2) = 58 | if not (l1 == l2) then unsafeThrow "shouldn't happen: these changes don't line up" else 59 | if not (Array.length kids1 == Array.length kids2) then unsafeThrow "shouldn't happen: should have same number of kids" else 60 | ChangeExpr l1 (composeChange <$> kids1 <*> kids2) 61 | composeChange (MetaVar x) (MetaVar y) | x == y = MetaVar x 62 | composeChange (Minus l1 leftKids1 child1 rightKids1) (Plus l2 leftKids2 child2 rightKids2) 63 | | l1 == l2 64 | && leftKids1 == leftKids2 65 | && Array.length rightKids1 == Array.length rightKids2 66 | = ChangeExpr l1 ((map inject leftKids1) <> [composeChange child1 child2] <> (map inject rightKids1)) 67 | composeChange (Plus l1 leftKids1 child1 rightKids1) (Minus l2 leftKids2 child2 rightKids2) 68 | | l1 == l2 69 | && leftKids1 == leftKids2 70 | && Array.length rightKids1 == Array.length rightKids2 71 | = composeChange child1 child2 72 | composeChange _ _ = unsafeThrow "TODO: not yet defined" 73 | --composeChange a (Plus tooth b) = Plus tooth (composeChange a b) 74 | --composeChange (Minus tooth a) b = Minus tooth (composeChange a b) 75 | --composeChange (Plus t1 a) (Minus t2 b) | t1 == t2 = composeChange a b 76 | --composeChange (Plus t a) (CArrow c b) = 77 | -- if not (tyInject t == c) then unsafeThrow "shouldn't happen in composeChange 1" else 78 | -- Plus t (composeChange a b) 79 | --composeChange (CArrow c a) (Minus t b) = 80 | -- if not (tyInject t == c) then unsafeThrow "shouldn't happen in composeChange 2" else 81 | -- Minus t (composeChange a b) 82 | --composeChange (CNeu x1 args1) (CNeu x2 args2) | x1 == x2 = 83 | -- CNeu x1 (composeParamChanges args1 args2) 84 | ---- TODO: It should be possible to compose changes more generally. Come back to this! 85 | --composeChange c1 c2 = 86 | -- let a /\ b = getEndpoints c1 in 87 | -- let b' /\ c = getEndpoints c2 in 88 | -- if b == b' then Replace a c else 89 | -- unsafeThrow ("composeChange is only valid to call on changes which share a type endpoint. c1 is " <> show c1 <> "and c2 is " <> show c2) 90 | 91 | 92 | {- 93 | Using this generic view of an expression, we can define functions which map over expressions dealing with variables 94 | and binders generically. 95 | 96 | -- The question "what is a variable" is dependent on the context - sometimes term variables, sometimes holes, etc 97 | -- Same with the question "what is a binder" 98 | 99 | So we need our notions of generic mapping to respect this 100 | -} 101 | 102 | 103 | {- 104 | Generic function map over expressions. 105 | At each node, the function can choose if it should pass through to the child nodes, or if it should 106 | replace that node with something else. 107 | -} 108 | type ExprLabelMap l env = (env -> l -> Array (Expr l) -> Either (Expr l) (Array env)) 109 | 110 | -- PROBLEM: ExprLabelMap doesn't really work going UP paths! 111 | exprMap :: forall l env . ExprLabelMap l env -> env -> Expr l -> Expr l 112 | exprMap f env (Expr ExprLabel children) = 113 | case f env ExprLabel children of 114 | Left expr' -> expr' 115 | Right childEnvs -> 116 | let children' = map (\(env' /\ child) -> exprMap f env' child) (Array.zip childEnvs children) in 117 | Expr ExprLabel children' 118 | 119 | data ExprLabelInfo id = IsVar id | Binds (Set id) -- for each child that is bound, update the environment 120 | 121 | expMapFreeVars :: forall l id . Ord id => (l -> ExprLabelInfo id) -> (id -> Expr l) -> Expr l -> Expr l 122 | expMapFreeVars ExprLabelInfo atVar expr = 123 | let mapper bound ExprLabel children = case ExprLabelInfo ExprLabel of 124 | IsVar id -> if Set.member id bound 125 | then (Right (Array.replicate (Array.length children) bound)) 126 | else (Left (atVar id)) 127 | Binds newBinds -> 128 | let newBound = Set.union newBinds bound in 129 | (Right (Array.replicate (Array.length children) newBound)) 130 | in exprMap mapper Set.empty expr 131 | -------------------------------------------------------------------------------- /old/GenericExpr/Expression.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.GenericExpr.Expression where 2 | 3 | import Prelude 4 | import Data.Tuple.Nested (type (/\), (/\)) 5 | import Data.List (List) 6 | import Data.List as List 7 | import Data.Set as Set 8 | import Data.Set (Set) 9 | import Data.Map (Map) 10 | import Data.Either (Either(..)) 11 | import Effect.Exception.Unsafe (unsafeThrow) 12 | import Data.UUID (UUID) 13 | 14 | --type WrappedChild ExprLabel wrap = wrap /\ (Expr ExprLabel wrap) 15 | -- TODO: Do we ever need Expr or just ExprWithMetavars? 16 | 17 | data Expr ExprLabel = Expr ExprLabel (List (Expr ExprLabel)) 18 | 19 | data ExprWMExprLabel ExprLabel = ExprWM ExprLabel | EMetaVar UUID 20 | type ExprWM ExprLabel = Expr (ExprWMExprLabel ExprLabel) 21 | 22 | data ToothExprLabel ExprLabel = Tooth ExprLabel {-List (Expr ExprLabel)-} {-List (Expr ExprLabel)-} 23 | type Tooth ExprLabel = Expr (Either (ToothExprLabel ExprLabel) ExprLabel) 24 | 25 | data ListExprLabel ExprLabel = ConsExprLabel {-x-} {-xs-} | NilExprLabel 26 | type Path ExprLabel = Expr (Either (ListExprLabel ExprLabel) (Either (ToothExprLabel ExprLabel) ExprLabel)) 27 | 28 | -- A Change is just an expression with a few extra possible ExprLabels: namely, Replace, Plus, and Minus. 29 | type GChange ExprLabel = ExprWM (ChangeLabel ExprLabel) 30 | 31 | data ChangeLabel ExprLabel 32 | = ChangeExpr ExprLabel {-whatever kids that ExprLabel had-} 33 | | Plus ExprLabel Int {- has whatever kids that ExprLabel had except one, and the Int tells which one -} 34 | | Minus ExprLabel Int {- same as Plus -} 35 | | Replace {-Expr ExprLabel-} {-Expr ExprLabel-} 36 | 37 | 38 | --data TypingRule ExprLabel = TypingRule 39 | -- (ExprWM ExprLabel) -- The sort of the expression overall 40 | -- (List (ExprWM ExprLabel)) -- The sort of each child 41 | 42 | --data 43 | 44 | --- below this line is garbage 45 | 46 | -- TypingRuleExprLabel 47 | data AnnotatedExprLabel ExprLabel = OfSort {-sort-} {-term-} | ALOther ExprLabel 48 | type Annotated ExprLabel = ExprWM (AnnotatedExprLabel ExprLabel) 49 | 50 | shouldntBeAnnotations :: forall ExprLabel. AnnotatedExprLabel ExprLabel -> ExprLabel 51 | shouldntBeAnnotations (ALOther l) = l 52 | shouldntBeAnnotations _ = unsafeThrow "assumption violated: there was an annotation" 53 | 54 | --data TypingRulesExprLabel ExprLabel = TypingRule {-parent sort-} {-list of children sorts-} | TRCons {-sort-} {-sorts-} | TRNil | TROther ExprLabel 55 | --type TypingRule ExprLabel = Expr (TypingRulesExprLabel ExprLabel) 56 | 57 | -- TODO: design decision: should these be working with annotated terms? 58 | data TypingRule ExprLabel = 59 | TypingRule 60 | (ExprWM ExprLabel) -- The parent's sort 61 | (List (ExprWM ExprLabel)) -- The children node's sorts 62 | 63 | type Language ExprLabel = ExprLabel -> TypingRule ExprLabel 64 | 65 | data MapChange ExprLabel = MCPlus (Expr ExprLabel) | MCMinus (Expr ExprLabel) | MCChange (GChange ExprLabel) 66 | 67 | -------------------------------------------------------------------------------- 68 | 69 | -- Typechange injection is just being a functor! 70 | instance Functor Expr where 71 | map :: forall ExprLabel1 ExprLabel2 . (ExprLabel1 -> ExprLabel2) -> Expr ExprLabel1 -> Expr ExprLabel2 72 | map f (Expr ExprLabel kids) = Expr (f ExprLabel) (map (map f) kids) 73 | 74 | derive instance eqAnnotatedExprLabel :: Eq ExprLabel => Eq (AnnotatedExprLabel ExprLabel) 75 | derive instance eqExprWMExprLabel :: Eq ExprLabel => Eq (ExprWMExprLabel ExprLabel) 76 | --derive instance eqTypingRulesExprLabel :: Eq ExprLabel => Eq (TypingRulesExprLabel ExprLabel) 77 | 78 | derive instance functorExprWMExprLabel :: Functor ExprWMExprLabel 79 | derive instance functorExprAnnotatedExprLabel :: Functor AnnotatedExprLabel 80 | --derive instance functorTypingRuleExprLabel :: Functor TypingRulesExprLabel 81 | 82 | --data GTypingRuleEntry ExprLabel id = TypingRuleEntry (Map id (MapChange ExprLabel)) (GChange ExprLabel) 83 | --data GTypingRule ExprLabel id = TypingRule (List (GTypingRuleEntry ExprLabel id)) 84 | 85 | --{- 86 | --While this isn't dependent type theory so we can't ensure that Exprs, GChanges etc. satisfy typing rules 87 | --intrinsically, we can write checking functions: 88 | ---} 89 | --exprIsTyped :: forall ExprLabel wrap id . 90 | -- List (GTypingRule ExprLabel id) -- The typing rules 91 | -- -> Expr ExprLabel -- The sort (which contains the type) 92 | -- -> Map id (Expr ExprLabel) -- The context - a mapping from ids to sorts 93 | -- -> Expr ExprLabel -- The expression to be type-checked 94 | -- -> Boolean 95 | --exprIsTyped = unsafeThrow "todo" 96 | -- 97 | --instance Eq ExprLabel => Eq (Expr ExprLabel) where 98 | -- eq (Expr l1 kids1) (Expr l2 kids2) = l1 == l2 && (List.all identity (eq <$> kids1 <*> kids2)) 99 | -- eq (EMetaVar x) (EMetaVar y) = x == y 100 | -- eq _ _ = false 101 | -- 102 | --inject :: forall a . Expr a -> GChange a 103 | --inject (Expr l kids) = ChangeExpr l (map inject kids) 104 | --inject (EMetaVar x) = MetaVar x 105 | -------------------------------------------------------------------------------- /old/GenericExpr/TypeCheck.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.GenericExpr.TypeCheck where 2 | 3 | import Prelude 4 | import Language.Pantograph.GenericExpr.Expression 5 | import Data.List (List(..), (:)) 6 | import Data.Map as Map 7 | import Data.Maybe (Maybe(..)) 8 | import Language.Pantograph.GenericExpr.Unification 9 | import Data.Tuple.Nested (type (/\), (/\)) 10 | import Effect.Exception.Unsafe (unsafeThrow) 11 | import Util (union') 12 | 13 | typecheck :: forall l. Eq l => Language l 14 | -- -> Expr l {-the sort-} 15 | -> Annotated l {-the expression-} 16 | -> Boolean 17 | typecheck lang {-sort-} expr = 18 | let go :: Annotated l -> Maybe (Sub l) 19 | go expr = 20 | case expr of 21 | Expr (ExprWM OfSort) 22 | (sort -- (Expr (ExprWM (ALOther s)) skids) 23 | : (Expr (ExprWM (ALOther ExprLabel)) eKids) 24 | : Nil) -> 25 | case lang ExprLabel of 26 | TypingRule parentSort kidSorts -> 27 | do 28 | -- (s' /\ sub1) <- unify parentSort (ExprWM <$> sort) 29 | (s' /\ sub1) <- unify ((map ALOther) <$> parentSort) sort 30 | let unifyEKids :: List (Annotated l) -> List (ExprWM l) -> Maybe (Sub l) 31 | unifyEKids Nil Nil = Just Map.empty 32 | unifyEKids (kid@(Expr (ExprWM OfSort) (actualSort : _kidd : Nil)) : eKids) (expectedSort : kidSorts) = do 33 | _ <- go kid -- Typecheck the kid itself 34 | _ /\ sub1' <- unify ((map ALOther) <$> expectedSort) actualSort 35 | sub2 <- unifyEKids (map (subExpr sub1') eKids) (map (subExpr ((map (map (map shouldntBeAnnotations))) sub1')) kidSorts) 36 | pure $ union' ((map (map (map shouldntBeAnnotations))) sub1') sub2 37 | unifyEKids _ _ = unsafeThrow "lengths of lists were different" 38 | sub2 <- unifyEKids eKids kidSorts 39 | pure $ union' ((map (map (map shouldntBeAnnotations))) sub1) sub2 40 | _ -> unsafeThrow "annotated expression not well formed" 41 | in case go expr of 42 | Just _ -> true 43 | Nothing -> false 44 | --data TRExprLabel ExprLabel = OfSort ExprLabel {-sort-} {-term-} | Other ExprLabel 45 | 46 | {- 47 | 48 | Problem with the `sort is part of expr` idea: how do I know what the children are so that I can check them as well? 49 | How do I carry through knowledge that I got from unification on the parent? 50 | 51 | 52 | A possible solution: 53 | 1) the sort isn't (directly) part of the expr 54 | 2) define: 55 | data ExprWithSortExprLabel ExprLabel = ExprWithSortExprLabel ExprLabel | OfSort 56 | type ExprWithSort ExprLabel = Expr (ExprWithSortExprLabel ExprLabel) 57 | 58 | The idea is that here, a lambda can be represented by: 59 | 60 | (Expr OfSort [Term (A -> B), (Expr Lambda [OfSort [VarName, name], OfSort [Term A, body]])] 61 | 62 | 3) typecheck requires it's input to be of the form (Expr OfSort [sort, (Expr ExprLabel [... kids ...])]) 63 | where it can then use `ExprLabel` to find the corresponding typing rule 64 | 65 | QUESTION: Does this structure have to be an Expr, or can it just be something else? 66 | Answer: yes it has to be an expr so it can be recursive correctly. 67 | 68 | -} -------------------------------------------------------------------------------- /old/GenericExpr/Unification.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.GenericExpr.Unification where 2 | 3 | import Prelude 4 | import Language.Pantograph.GenericExpr.Expression 5 | import Data.Map (Map) 6 | import Data.Map as Map 7 | import Data.List (List(..), (:)) 8 | import Data.List as List 9 | import Data.UUID (UUID) 10 | import Data.Tuple.Nested (type (/\), (/\)) 11 | import Data.Maybe (Maybe(..)) 12 | import Data.Maybe as Maybe 13 | import Effect.Exception.Unsafe (unsafeThrow) 14 | import Util (union') 15 | 16 | 17 | type Sub ExprLabel = Map UUID (ExprWM ExprLabel) 18 | 19 | 20 | subExpr :: forall l . Sub l -> ExprWM l -> ExprWM l 21 | subExpr s ex@(Expr (EMetaVar x) Nil) = case Map.lookup x s of 22 | Nothing -> ex 23 | Just ex' -> ex' 24 | subExpr s (Expr ExprLabel kids) = Expr ExprLabel ((subExpr s) <$> kids) 25 | 26 | -- Its too annoying to do wrapping and unwrapping so its not explicitly a functor 27 | mapSub :: forall ExprLabel1 ExprLabel2 . (ExprLabel1 -> ExprLabel2) -> Sub ExprLabel1 -> Sub ExprLabel2 28 | mapSub f s = map (map (map f)) s -- truly one of the lines of code of all time 29 | 30 | --data Expr ExprLabel = ExprWM ExprLabel (Array (Expr ExprLabel)) | EMetaVar UUID 31 | unify :: forall l . Eq l => ExprWM l -> ExprWM l -> Maybe (ExprWM l /\ Sub l) 32 | unify (Expr (EMetaVar x) Nil) e = Just $ e /\ Map.insert x e Map.empty 33 | unify e1 e2@(Expr (EMetaVar x) Nil) = unify e2 e1 34 | unify (Expr ExprLabel1 kids1) (Expr ExprLabel2 kids2) = 35 | if not (ExprLabel1 == ExprLabel2) then Nothing else do 36 | kids /\ sub <- unifyExprs kids1 kids2 37 | pure $ Expr ExprLabel1 kids /\ sub 38 | 39 | unifyExprs :: forall l . Eq l => List (ExprWM l) -> List (ExprWM l) -> Maybe (List (ExprWM l) /\ Sub l) 40 | unifyExprs Nil Nil = Just $ Nil /\ Map.empty 41 | unifyExprs (e1 : es1) (e2 : es2) = do 42 | e' /\ sub1 <- unify e1 e2 43 | let es1' = map (subExpr sub1) es1 44 | let es2' = map (subExpr sub1) es2 45 | es' /\ sub2 <- unifyExprs es1' es2' 46 | pure $ ((subExpr sub2 e') : es') /\ (union' sub1 sub2) 47 | unifyExprs _ _ = unsafeThrow "kids had different lengths even though ExprLabel was the same in unifyExprs" 48 | -------------------------------------------------------------------------------- /old/Grammar.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Grammar where 2 | 3 | import Prelude 4 | import Prim hiding (Type) 5 | import Language.Pantograph.Expression 6 | import Data.List (List(..), (:)) 7 | import Data.Map (Map) 8 | import Data.Map as Map 9 | import Data.List as List 10 | import Data.Maybe (Maybe) 11 | import Data.Tuple.Nested 12 | 13 | {- 14 | 1) define the grammar 15 | 2) define what terms are using the grammar 16 | 3) define what teeth are using the grammar 17 | -} 18 | 19 | {- 20 | The following is a list of the grammatical sorts within this editor: 21 | Term, Type, TypeBind, TermBind, (List TypeBind) 22 | InnerTermHole, InnerTypeHole 23 | -} 24 | 25 | type UUID = Int 26 | 27 | --data Type x = 28 | 29 | --subType :: (Map HoleId HoleID) -> Type -> Type 30 | 31 | --data Sort 32 | -- = STerm Type -- The Value here is a Type 33 | -- | SType 34 | -- | STermBind 35 | -- | STypeBind 36 | -- | SListTypeBind 37 | -- | SInnerTermHole 38 | -- | SInnerTypeHole 39 | 40 | newtype TermVarID = TermVarID UUID 41 | newtype TypeVarID = TypeVarID UUID 42 | newtype HoleID = HoleID UUID 43 | 44 | --freshTermID :: Unit -> TermVarID 45 | --freshTermID = undefined 46 | --freshTypeID :: Unit -> TypeVarID 47 | --freshTypeID = undefined 48 | --freshHoleID :: Unit -> HoleID 49 | --freshHoleID = undefined 50 | 51 | data TypeVarName = TypeVarName String 52 | 53 | data TypeVar = TypeVar TypeVarID | CtxBoundaryTypeVar Kind TypeVarName TypeVarID -- TypeVar represents a variable in scope, and CtxBoundaryTypeVar represents a variable inside a context boundary Insert, with the given type. 54 | 55 | data PolyType 56 | data Kind 57 | type Type = Value 58 | 59 | {- 60 | Writing all of the code in the most generic way with the correct abstractions appears (at least in a Hindley-Millner system) 61 | to require all kinds of data to just be in a single giant sum type. 62 | Maybe we can at least recover some dynamic type-checking by for example checking the Sort of things with pattern matching? 63 | -} 64 | data ExprLabel 65 | -- Terms 66 | = Var TermVarID 67 | | App {-Term-} {-Term-} 68 | | Lambda {-TermVarID-} {-Term-} 69 | | Let String {-TermBind-} {-List TypeVarID-} {-TermBind-} {-Term-} {-Type-} {-Term-} 70 | | TypeBoundary Change {-Term-} 71 | | ContextBoundary {-Some kind of change TBD-} {-Term-} 72 | | Hole 73 | -- No Buffers? Seems simpler to use TypeBoundaries everywhere? 74 | -- Types 75 | | TNeu TypeVar {-List TypeArg-} 76 | | Arrow {-Type-} {-Type-} 77 | | THole HoleID (Map TypeVarID Type) 78 | -- TypeBind 79 | | TypeBind TermVarID 80 | -- TermBind 81 | | TermBind TermVarID 82 | -- List TypeBind 83 | | ListTypeBindNil 84 | | ListTypeBindCons {-TypeBind-} {-List TypeBind-} 85 | 86 | -- I don't know how to make this a separate grammar...? 87 | -- Sorts 88 | | STerm {-Type-} 89 | | SType 90 | | STermBind 91 | | STypeBind 92 | | SListTypeBind 93 | | SInnerTermHole 94 | | SInnerTypeHole 95 | 96 | {- 97 | G |- E : S 98 | --------------------------------------- 99 | G |- Newline E : S 100 | 101 | -} 102 | 103 | data Tuple a b = Tuple a b 104 | 105 | --data ExprWrap = ExprWrap Boolean Expr Expr 106 | --data Tooth f = Tooth ExprLabel (Array (f (Expr f))) (Array (f (Expr f))) 107 | 108 | --newtype WrapMetadata = WrapMetadata {indented:: Boolean, sort:: Value} 109 | type Value = Expr ExprLabel 110 | type ValuePath = Path ExprLabel 111 | 112 | type Change = GChange ExprLabel 113 | 114 | 115 | type TypingRuleEntry = GTypingRuleEntry ExprLabel UUID 116 | type TypingRule = GTypingRule ExprLabel UUID 117 | 118 | {- 119 | 120 | G, X : A |- E : B 121 | -------------------------------------- 122 | G |- lam X : A . E : A -> B 123 | 124 | -} 125 | 126 | 127 | -- [G |- (Replace (Term (A -> B)) Type), G, + X : A |- Term (+A -> B)] 128 | typingRules :: Array TypingRule 129 | typingRules = [ 130 | -- Lambda 131 | let x = 0 in -- obviously, in reality these should use fresh UUIDs and not just 0, 1, and 2 132 | let a = 1 in 133 | let b = 2 in 134 | TypingRule [ 135 | -- The type annotation - Same context as parent, and totally different Sort, hence Replace 136 | TypingRuleEntry (Map.empty) (Replace (ExprWM STerm [EMetaVar a , EMetaVar b]) (ExprWM SType [])), 137 | -- The body - Context adds `a` relative to parent, and the change is `+ A -> B` (going from bottom to top) 138 | TypingRuleEntry (Map.insert x (MCPlus (EMetaVar a)) Map.empty) (ChangeExpr STerm [Plus Arrow [EMetaVar a] (MetaVar b) []]) 139 | ] 140 | ] 141 | 142 | {- 143 | 144 | --ExprLabelBindVarInfo :: ExprLabel -> ExprLabelInfo 145 | --ExprLabelBindVarInfo (Lambda x) = Binds [[x]] 146 | --ExprLabelBindVarInfo (Var id) = IsVar id 147 | --ExprLabelBindVarInfo _ = Nothing 148 | 149 | -- It should be possible to define typechecking fairly generically like this. 150 | -- This single function should be able to check both terms and paths! 151 | typeCheck :: ExprLabel -> Sort -> Array Sort -> Boolean 152 | typeCheck App (STerm outTy) [(STerm arrTy), (STerm argTy)] = ?h -- Check that arrTy == argTy -> outTy 153 | typeCheck (Let tBind tyBinds) (STerm ty) [STermBind, (STerm defTy), SType, (STerm bodyTy)] 154 | = true -- check if ty == bodyTy, and more stuff I guess 155 | -- ... 156 | typeCheck _ _ _ = false 157 | 158 | 159 | -} -------------------------------------------------------------------------------- /old/State.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.State where 2 | 3 | import Prelude 4 | import Language.Pantograph.Grammar 5 | import Data.Map (Map) 6 | 7 | -- There is only one kind of CursorMode - what grammatical sort you're at is determined by "sort" 8 | type CursorMode = { 9 | value :: Value 10 | , path :: ValuePath 11 | , sort :: Value 12 | , ctx :: Map UUID Value {- this Value is a Sort-} 13 | } 14 | 15 | type SelectMode = { 16 | value :: Value 17 | , sort1 :: Value 18 | , ctx1 :: Map UUID Value {- this Value is a Sort-} 19 | , path1 :: ValuePath 20 | , sort2 :: Value 21 | , ctx2 :: Map UUID Value {- this Value is a Sort-} 22 | , path2 :: ValuePath 23 | } 24 | 25 | data EditorState = CursorMode CursorMode | SelectMode SelectMode -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "pantograph", 3 | "version": "1.0.0", 4 | "description": "A fluid intrinsically-typed structure editor", 5 | "directories": { 6 | "test": "test" 7 | }, 8 | "dependencies": { 9 | "uuid": "^9.0.0" 10 | }, 11 | "devDependencies": { 12 | "esbuild": "^0.17.18", 13 | "purescript": "^0.15.8", 14 | "purs-backend-es": "^1.3.2", 15 | "spago": "^0.20.9" 16 | }, 17 | "scripts": { 18 | "postinstall": "spago install", 19 | "clean": "rm -rf node_modules output .spago *.lock .cache", 20 | "clean-purscript": "rm -rf output .spago .psc-ide-port .psci_modules", 21 | "test": "npx spago test", 22 | "build-old": "npx spago build --purs-args \"--codegen=sourcemaps,js\"", 23 | "build-prod": "spago -x spago.production.dhall build --purs-args \"-o output-prod -g sourcemaps --json-errors\"", 24 | "bundle": "npm run build-prod && purs-backend-es bundle-app --main Main --minify --no-build --to dist/pantograph.js", 25 | "build-tutorial": "spago build && npx esbuild tutorial.js --bundle --outfile=dist/pantograph.js", 26 | "build-standalone": "spago build && npx esbuild standalone.js --bundle --outfile=dist/standalone/pantograph.js", 27 | "build": "npm run build-tutorial && npm run build-standalone", 28 | "serve": "npm run build && npx esbuild standalone.js --bundle --outfile=dist/standalone/pantograph.js --servedir=dist", 29 | "docs": "npm run build && rm -rf docs && cp -r dist docs", 30 | "publish": "npm run docs && git add . && git commit -m\"publish\" && git push" 31 | }, 32 | "repository": { 33 | "type": "git", 34 | "url": "git+https://github.com/jeprinz/pantograph.git" 35 | }, 36 | "keywords": [ 37 | "programm-language", 38 | "type-theory" 39 | ], 40 | "author": "Jacob Prinz, Henry Blanchette", 41 | "license": "MIT", 42 | "bugs": { 43 | "url": "https://github.com/jeprinz/pantograph/issues" 44 | }, 45 | "homepage": "https://github.com/jeprinz/pantograph#readme" 46 | } -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to your new Dhall package-set! 3 | 4 | Below are instructions for how to edit this file for most use 5 | cases, so that you don't need to know Dhall to use it. 6 | 7 | ## Use Cases 8 | 9 | Most will want to do one or both of these options: 10 | 1. Override/Patch a package's dependency 11 | 2. Add a package not already in the default package set 12 | 13 | This file will continue to work whether you use one or both options. 14 | Instructions for each option are explained below. 15 | 16 | ### Overriding/Patching a package 17 | 18 | Purpose: 19 | - Change a package's dependency to a newer/older release than the 20 | default package set's release 21 | - Use your own modified version of some dependency that may 22 | include new API, changed API, removed API by 23 | using your custom git repo of the library rather than 24 | the package set's repo 25 | 26 | Syntax: 27 | where `entityName` is one of the following: 28 | - dependencies 29 | - repo 30 | - version 31 | ------------------------------- 32 | let upstream = -- 33 | in upstream 34 | with packageName.entityName = "new value" 35 | ------------------------------- 36 | 37 | Example: 38 | ------------------------------- 39 | let upstream = -- 40 | in upstream 41 | with halogen.version = "master" 42 | with halogen.repo = "https://example.com/path/to/git/repo.git" 43 | 44 | with halogen-vdom.version = "v4.0.0" 45 | with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies 46 | ------------------------------- 47 | 48 | ### Additions 49 | 50 | Purpose: 51 | - Add packages that aren't already included in the default package set 52 | 53 | Syntax: 54 | where `` is: 55 | - a tag (i.e. "v4.0.0") 56 | - a branch (i.e. "master") 57 | - commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") 58 | ------------------------------- 59 | let upstream = -- 60 | in upstream 61 | with new-package-name = 62 | { dependencies = 63 | [ "dependency1" 64 | , "dependency2" 65 | ] 66 | , repo = 67 | "https://example.com/path/to/git/repo.git" 68 | , version = 69 | "" 70 | } 71 | ------------------------------- 72 | 73 | Example: 74 | ------------------------------- 75 | let upstream = -- 76 | in upstream 77 | with benchotron = 78 | { dependencies = 79 | [ "arrays" 80 | , "exists" 81 | , "profunctor" 82 | , "strings" 83 | , "quickcheck" 84 | , "lcg" 85 | , "transformers" 86 | , "foldable-traversable" 87 | , "exceptions" 88 | , "node-fs" 89 | , "node-buffer" 90 | , "node-readline" 91 | , "datetime" 92 | , "now" 93 | ] 94 | , repo = 95 | "https://github.com/hdgarrood/purescript-benchotron.git" 96 | , version = 97 | "v7.0.0" 98 | } 99 | ------------------------------- 100 | -} 101 | let upstream = 102 | https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20230105/packages.dhall 103 | sha256:3e9fbc9ba03e9a1fcfd895f65e2d50ee2f5e86c4cd273f3d5c841b655a0e1bda 104 | 105 | in upstream 106 | -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | 5 | Need help? See the following resources: 6 | - Spago documentation: https://github.com/purescript/spago 7 | - Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html 8 | 9 | When creating a new Spago project, you can use 10 | `spago init --no-comments` or `spago init -C` 11 | to generate this file without the comments in this block. 12 | -} 13 | { name = "pantograph" 14 | , dependencies = 15 | [ "aff" 16 | , "aff-promise" 17 | , "argonaut" 18 | , "argonaut-codecs" 19 | , "argonaut-core" 20 | , "argonaut-generic" 21 | , "arrays" 22 | , "bifunctors" 23 | , "console" 24 | , "const" 25 | , "control" 26 | , "css" 27 | , "debug" 28 | , "effect" 29 | , "either" 30 | , "enums" 31 | , "exceptions" 32 | , "foldable-traversable" 33 | , "functors" 34 | , "fuzzy" 35 | , "halogen" 36 | , "halogen-css" 37 | , "halogen-hooks" 38 | , "identity" 39 | , "integers" 40 | , "lazy" 41 | , "lists" 42 | , "maybe" 43 | , "newtype" 44 | , "nonempty" 45 | , "ordered-collections" 46 | , "partial" 47 | , "prelude" 48 | , "rationals" 49 | , "record" 50 | , "refs" 51 | , "strings" 52 | , "transformers" 53 | , "tuples" 54 | , "unfoldable" 55 | , "unicode" 56 | , "unsafe-coerce" 57 | , "uuid" 58 | , "variant" 59 | , "web-dom" 60 | , "web-events" 61 | , "web-html" 62 | , "web-uievents" 63 | ] 64 | , packages = ./packages.dhall 65 | , sources = [ "src/**/*.purs", "test/**/*.purs" ] 66 | } 67 | -------------------------------------------------------------------------------- /spago.production.dhall: -------------------------------------------------------------------------------- 1 | ./spago.dhall // { backend = "purs-backend-es build" } -------------------------------------------------------------------------------- /src/Bug.purs: -------------------------------------------------------------------------------- 1 | module Bug where 2 | 3 | import Prelude 4 | 5 | import Data.Array as Array 6 | import Partial.Unsafe (unsafeCrashWith) 7 | 8 | bug :: forall a. String -> a 9 | bug msg = unsafeCrashWith $ Array.intercalate "\n" 10 | [ "" 11 | , "==[ BUG ]=================================================================" 12 | , msg 13 | , "==========================================================================" 14 | , "" 15 | ] 16 | -------------------------------------------------------------------------------- /src/Bug/Assertion.purs: -------------------------------------------------------------------------------- 1 | module Bug.Assertion where 2 | 3 | import Prelude 4 | 5 | import Bug (bug) 6 | import Data.Either (Either(..), either) 7 | import Data.Either.Nested (type (\/)) 8 | import Data.Maybe (Maybe(..), isJust) 9 | import Partial.Unsafe (unsafePartial) 10 | 11 | newtype Assertion a = Assertion 12 | { name :: String 13 | , source :: String 14 | , result :: String \/ a } 15 | 16 | renderFailedAssertion :: forall a. Assertion a -> String -> String 17 | renderFailedAssertion (Assertion ass) msg = "[" <> ass.source <> "] Failed assertion '" <> ass.name <> "': " <> msg 18 | 19 | makeAssertionBoolean :: 20 | { name :: String 21 | , source :: String 22 | , condition :: Boolean 23 | , message :: String } -> 24 | Assertion Unit 25 | makeAssertionBoolean {name, source, condition, message} = Assertion 26 | { name, source 27 | , result: 28 | if condition 29 | then Right unit 30 | else Left message 31 | } 32 | 33 | assert :: forall a b. Assertion a -> (Partial => a -> b) -> b 34 | assert (Assertion ass) = \k -> case ass.result of 35 | Right a -> unsafePartial (k a) 36 | Left msg -> bug $ renderFailedAssertion (Assertion ass) msg 37 | 38 | assertI :: forall a. Assertion a -> a 39 | assertI ass = assert ass identity 40 | 41 | assert_ :: forall a. Assertion a -> Unit 42 | assert_ ass = assert ass \_ -> unit 43 | 44 | assertM :: forall m a. Applicative m => Assertion a -> m a 45 | assertM (Assertion ass) = case ass.result of 46 | Right a -> pure a 47 | Left msg -> bug $ renderFailedAssertion (Assertion ass) msg 48 | 49 | assertM_ :: forall m a. Applicative m => Assertion a -> m Unit 50 | assertM_ ass = void $ assertM ass 51 | 52 | assertInterface_ :: forall a b za zb. (a -> Assertion za) -> (b -> Assertion zb) -> (Partial => a -> b) -> (a -> b) 53 | assertInterface_ ass_a ass_b = \f a -> 54 | assert (ass_a a) \_ -> 55 | let b = f a in 56 | assert (ass_b b) \_ -> 57 | b 58 | 59 | assertInput_ :: forall a b z. (a -> Assertion z) -> (Partial => a -> b) -> (a -> b) 60 | assertInput_ ass_a = \f a -> assert (ass_a a) \_ -> f a 61 | 62 | assertOutput_ :: forall a b z. (b -> Assertion z) -> (Partial => a -> b) -> (a -> b) 63 | assertOutput_ ass_b = \f a -> unsafePartial 64 | let b = f a in 65 | assert (ass_b b) \_ -> 66 | b 67 | 68 | -- assertInterface :: forall a b 69 | 70 | assertInterface :: forall a b c d. (a -> Assertion b) -> (c -> Assertion d) -> (Partial => b -> c) -> a -> d 71 | assertInterface ass_a_b ass_d_e f_b_c a = assert (ass_a_b a) \b -> assert (ass_d_e (f_b_c b)) identity 72 | 73 | try :: forall a. Assertion a -> Maybe a 74 | try (Assertion ass) = ass.result # either (const Nothing) Just 75 | 76 | test :: forall a. Assertion a -> Boolean 77 | test ass = isJust (try ass) 78 | 79 | equal :: forall a. Eq a => String -> (Unit -> String) -> a -> a -> Assertion Unit 80 | equal source msg a1 a2 = Assertion 81 | { name: "equal" 82 | , source 83 | , result: if a1 == a2 then Right unit else Left (msg unit) 84 | } 85 | 86 | 87 | positif :: String -> Int -> Assertion Int 88 | positif source x = Assertion 89 | { name: "positif" 90 | , source 91 | , result: if 0 <= x 92 | then Right x 93 | else Left ("A positif number must be greater than or equal to 0. '" <> show x <> "' is not positif") 94 | } 95 | 96 | just :: forall a. String -> Maybe a -> Assertion a 97 | just source mb_a = Assertion 98 | { name: "just" 99 | , source 100 | , result: case mb_a of 101 | Nothing -> Left "Wasn't 'Just'" 102 | Just a -> Right a 103 | } 104 | 105 | ordered :: forall a. Ord a => String -> String -> a -> a -> Assertion Ordering 106 | ordered source msg a1 a2 = Assertion 107 | { name: "ordered" 108 | , source 109 | , result: case compare a1 a2 of 110 | GT -> Left msg 111 | c -> Right c 112 | } 113 | 114 | strictlyOrdered :: forall a. Ord a => String -> String -> a -> a -> Assertion Ordering 115 | strictlyOrdered source msg a1 a2 = Assertion 116 | { name: "strictlyOrdered" 117 | , source 118 | , result: case compare a1 a2 of 119 | LT -> Right LT 120 | _ -> Left msg 121 | } 122 | -------------------------------------------------------------------------------- /src/Data/List/Rev.purs: -------------------------------------------------------------------------------- 1 | module Data.List.Rev 2 | ( RevList 3 | , toReversedList 4 | , fromReversedList 5 | , reverse 6 | , reverseArray 7 | , unreverse 8 | , snoc, (@@) 9 | , unsnoc 10 | , singleton 11 | , reversed 12 | , unreversed 13 | , length 14 | , null 15 | , unzip 16 | , zipWith 17 | ) where 18 | 19 | import Prelude 20 | 21 | import Data.Array as Array 22 | import Data.Foldable (class Foldable, foldMap, foldl, foldr) 23 | import Data.List as List 24 | import Data.Traversable (class Traversable, sequence, traverse) 25 | import Data.Bifunctor 26 | import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson) 27 | import Data.Argonaut.Decode.Generic (genericDecodeJson) 28 | import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) 29 | import Data.Argonaut.Encode.Generic (genericEncodeJson) 30 | import Data.Generic.Rep (class Generic) 31 | import Data.Tuple (Tuple) 32 | 33 | newtype RevList a = Rev (List.List a) 34 | 35 | -- private 36 | wrap = Rev 37 | unwrap (Rev xs) = xs 38 | over f = unwrap >>> f >>> wrap 39 | 40 | derive newtype instance Show a => Show (RevList a) 41 | derive newtype instance Eq a => Eq (RevList a) 42 | derive newtype instance Ord a => Ord (RevList a) 43 | derive newtype instance Functor RevList 44 | derive newtype instance Apply RevList 45 | derive newtype instance Applicative RevList 46 | derive newtype instance Bind RevList 47 | derive newtype instance Monad RevList 48 | 49 | instance Foldable RevList where 50 | foldr f b = foldr f b <<< unreverse 51 | foldl f b = foldl f b <<< unreverse 52 | foldMap f = foldMap f <<< unreverse 53 | 54 | instance Traversable RevList where 55 | traverse f = map reverse <<< traverse f <<< unreverse 56 | sequence = map reverse <<< sequence <<< unreverse 57 | 58 | derive newtype instance Semigroup (RevList a) 59 | derive newtype instance Monoid (RevList a) 60 | derive instance Generic (RevList a) _ 61 | instance EncodeJson a => EncodeJson (RevList a) where encodeJson a = genericEncodeJson a 62 | instance DecodeJson a => DecodeJson (RevList a) where decodeJson a = genericDecodeJson a 63 | -- derive newtype instance (Applicative m, Plus m, Unify m a) => Unify m (RevList a) 64 | 65 | -- !TODO is this used anywhere? 66 | -- instance FunctorWithIndex Int RevList where mapWithIndex f = unreversed $ mapWithIndex f 67 | -- instance FoldableWithIndex Int RevList where 68 | -- foldMapWithIndex f = unreverse >>> foldMapWithIndex f 69 | -- foldrWithIndex f b = unreverse >>> foldrWithIndex f b 70 | -- foldlWithIndex f b = unreverse >>> foldlWithIndex f b 71 | -- instance TraversableWithIndex Int RevList where traverseWithIndex f = unreverse >>> traverseWithIndex f >>> map reverse 72 | 73 | toReversedList = unwrap 74 | fromReversedList = wrap 75 | 76 | reverse = Rev <<< List.reverse 77 | 78 | reverseArray = Rev <<< List.fromFoldable <<< Array.reverse 79 | 80 | unreverse = List.reverse <<< unwrap 81 | 82 | unreversed f = unreverse >>> f >>> reverse 83 | 84 | reversed f = reverse >>> f >>> unreverse 85 | 86 | unsnoc = unwrap >>> List.uncons >>> map \{ head, tail } -> { init: Rev tail, last: head } 87 | 88 | snoc r_xs x = over (List.Cons x) r_xs 89 | 90 | infixl 6 snoc as @@ 91 | 92 | singleton = reverse <<< List.singleton 93 | 94 | length = unwrap >>> List.length 95 | 96 | null = unwrap >>> List.null 97 | 98 | unzip :: forall t56 t57. RevList (Tuple t56 t57) -> Tuple (RevList t56) (RevList t57) 99 | unzip = (bimap wrap wrap) <<< List.unzip <<< unwrap 100 | 101 | zipWith :: forall a4045 a46 b47. (a46 -> b47 -> a4045) -> RevList a46 -> RevList b47 -> RevList a4045 102 | zipWith f l1 l2 = wrap (List.zipWith f (unwrap l1) (unwrap l2)) 103 | 104 | -------------------------------------------------------------------------------- /src/Data/List/Zip.purs: -------------------------------------------------------------------------------- 1 | module Data.List.Zip where 2 | 3 | import Data.Tuple 4 | import Data.Tuple.Nested 5 | import Prelude 6 | 7 | import Control.Plus (class Plus) 8 | import Data.Foldable (class Foldable, foldMap, foldl, foldr, intercalate) 9 | import Data.FoldableWithIndex (class FoldableWithIndex, foldMapWithIndex, foldlWithIndex, foldrWithIndex) 10 | import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex) 11 | import Data.Generic.Rep (class Generic) 12 | import Data.List (List(..), (:)) 13 | import Data.List as List 14 | import Data.List.Rev (RevList, (@@)) 15 | import Data.List.Rev as Rev 16 | import Data.Maybe (Maybe(..)) 17 | import Data.Newtype (class Newtype, unwrap) 18 | import Data.Show.Generic (genericShow) 19 | import Data.Traversable (class Traversable, traverse) 20 | import Text.Pretty ((<+>)) 21 | import Data.Argonaut.Decode.Class (class DecodeJson, decodeJson) 22 | import Data.Argonaut.Decode.Generic (genericDecodeJson) 23 | import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) 24 | import Data.Argonaut.Encode.Generic (genericEncodeJson) 25 | import Bug 26 | 27 | newtype Tooth a = Zip {path :: Path a, focus :: a} 28 | 29 | toothPath (Zip {path}) = path 30 | toothFocus (Zip {focus}) = focus 31 | 32 | derive instance Generic (Tooth a) _ 33 | instance Show a => Show (Tooth a) where show x = genericShow x 34 | derive instance Eq a => Eq (Tooth a) 35 | derive instance Functor Tooth 36 | instance Foldable Tooth where 37 | foldMap f = foldMap f <<< unzip 38 | foldl f b = foldl f b <<< unzip 39 | foldr f b = foldr f b <<< unzip 40 | instance Traversable Tooth where 41 | traverse f (Zip z) = (\path focus -> Zip {path, focus}) 42 | <$> traverse f z.path 43 | <*> f z.focus 44 | sequence = traverse identity 45 | instance EncodeJson a => EncodeJson (Tooth a) where encodeJson a = genericEncodeJson a 46 | instance DecodeJson a => DecodeJson (Tooth a) where decodeJson a = bug "I hate typeclasses" -- genericDecodeJson a 47 | 48 | unzip (Zip z) = unpathAroundList (pure z.focus) z.path 49 | 50 | -- | The type of a paths into lists. 51 | newtype Path a = Path {left :: RevList a, right :: List.List a} 52 | 53 | derive instance Newtype (Path a) _ 54 | derive instance Generic (Path a) _ 55 | instance Show a => Show (Path a) where show x = genericShow x 56 | derive instance Eq a => Eq (Path a) 57 | derive instance Ord a => Ord (Path a) 58 | derive instance Functor Path 59 | derive instance Foldable Path 60 | derive instance Traversable Path 61 | instance Semigroup (Path a) where append (Path d1) (Path d2) = Path {left: d1.left <> d2.left, right: d1.right <> d2.right} 62 | instance Monoid (Path a) where mempty = Path {left: mempty, right: mempty} 63 | instance EncodeJson a => EncodeJson (Path a) where encodeJson a = genericEncodeJson a 64 | instance DecodeJson a => DecodeJson (Path a) where decodeJson a = genericDecodeJson a 65 | -- instance (Applicative m, Plus m, Unify m a) => Unify m (Path a) where unify (Path {left: l1, right: r1}) (Path {left: l2, right: r2}) = (\left right -> Path {left, right}) <$> unify l1 l2 <*> unify r1 r2 66 | 67 | -- !TODO is this used anywhere? 68 | -- instance FunctorWithIndex Int Path where 69 | -- mapWithIndex f (Path d) = Path d {left = mapWithIndex f d.left, right = mapWithIndex (\i -> f (i + l)) d.right} 70 | -- where l = Rev.length d.left 71 | -- instance FoldableWithIndex Int Path where 72 | -- foldMapWithIndex f = foldMapWithIndex f <<< unpath 73 | -- foldrWithIndex f b = foldrWithIndex f b <<< unpath 74 | -- foldlWithIndex f b = foldlWithIndex f b <<< unpath 75 | -- instance TraversableWithIndex Int Path where 76 | -- traverseWithIndex f (Path d) = 77 | -- let l = Rev.length d.left in 78 | -- (\left right -> Path d {left = left, right = right}) 79 | -- <$> traverseWithIndex f d.left 80 | -- <*> traverseWithIndex (\i -> f (i + l)) d.right 81 | 82 | leftLength (Path p) = Rev.length p.left 83 | rightLength (Path p) = List.length p.right 84 | 85 | appendLeft :: forall a. a -> Path a -> Path a 86 | appendLeft a (Path d) = Path d {left = d.left @@ a} 87 | 88 | appendRight :: forall a. a -> Path a -> Path a 89 | appendRight a (Path d) = Path d {right = a : d.right} 90 | 91 | -- left :: forall a. Path a -> RevList a 92 | -- left = unwrap >>> _.left 93 | 94 | -- right :: forall a. Path a -> List.List a 95 | -- right = unwrap >>> _.right 96 | 97 | unpath :: forall a. Path a -> List.List a 98 | unpath (Path d) = Rev.unreverse d.left <> d.right 99 | 100 | unpathAround :: forall a. a -> Path a -> List.List a 101 | unpathAround x = unpathAroundList (List.singleton x) 102 | 103 | unpathAroundList :: forall a. List.List a -> Path a -> List.List a 104 | unpathAroundList xs (Path d) = Rev.unreverse d.left <> xs <> d.right 105 | 106 | zipAt :: forall a. Int -> List.List a -> Maybe (Path a /\ a) 107 | zipAt = go mempty 108 | where 109 | go _ _ Nil = Nothing 110 | go left 0 (x : right) = Just (Path {left, right} /\ x) 111 | go left n (x : right) = go (Rev.snoc left x) (n - 1) right 112 | 113 | zips :: forall a. List.List a -> Maybe (List (Path a /\ a)) 114 | zips Nil = Nothing 115 | zips (x0 : xs0) = Just $ go mempty x0 xs0 116 | where 117 | go :: RevList a -> a -> List a -> List (Path a /\ a) 118 | go left x right@Nil = List.singleton $ Path {left, right} /\ x 119 | go left x right@(x' : right') = (Path {left, right} /\ x) : go (left @@ x) x' right' 120 | 121 | singletonLeft :: forall a. a -> Path a 122 | singletonLeft a = appendLeft a mempty 123 | 124 | singletonRight :: forall a. a -> Path a 125 | singletonRight a = appendRight a mempty 126 | 127 | unsnocLeft :: forall a. Path a -> Maybe {init :: Path a , last :: a} 128 | unsnocLeft (Path d) = Rev.unsnoc d.left <#> \{init, last} -> {init: Path d {left = init}, last} 129 | 130 | unconsRight :: forall a429. 131 | Path a429 132 | -> Maybe 133 | { head :: a429 134 | , tail :: Path a429 135 | } 136 | unconsRight (Path d) = List.uncons d.right <#> \{head, tail} -> {head, tail: Path d {right = tail}} 137 | 138 | zipLeft :: forall a. (a /\ Path a) -> Maybe (a /\ Path a) 139 | zipLeft (a /\ Path p) = do 140 | {init: left', last: a'} <- Rev.unsnoc p.left 141 | Just $ a' /\ Path {left: left', right: a : p.right} 142 | 143 | zipRight :: forall a. (a /\ Path a) -> Maybe (a /\ Path a) 144 | zipRight (a /\ Path p) = do 145 | {head: a', tail: right'} <- List.uncons p.right 146 | Just $ a' /\ Path {left: Rev.snoc p.left a, right: right'} 147 | 148 | showPath :: Path String -> String -> String 149 | showPath (Path d) str = intercalate " " d.left <+> str <+> intercalate " " d.right 150 | 151 | -- left inside, right outside 152 | foldrAround :: forall a b. (a -> b -> b) -> b -> (b -> b) -> Path a -> b 153 | foldrAround f b mid (Path d) = foldr f (mid (foldr f b d.left)) d.right 154 | 155 | -- left outside, right inside 156 | foldlAround :: forall a b. (b -> a -> b) -> b -> (b -> b) -> Path a -> b 157 | foldlAround f b mid (Path d) = foldl f (mid (foldl f b d.right)) d.left 158 | 159 | zipWith :: forall a4045 a46 b47. (a46 -> b47 -> a4045) -> Path a46 -> Path b47 -> Path a4045 160 | zipWith f (Path {left: left1, right: right1}) (Path {left: left2, right: right2}) 161 | = Path {left: Rev.zipWith f left1 left2, right: List.zipWith f right1 right2} 162 | -------------------------------------------------------------------------------- /src/Data/MultiMap.purs: -------------------------------------------------------------------------------- 1 | module Data.MultiMap where 2 | 3 | import Prelude 4 | import Data.Map as Map 5 | import Data.Map (Map) 6 | import Data.Set as Set 7 | import Data.Set (Set) 8 | import Data.Maybe (Maybe(..)) 9 | import Util as Util 10 | import Data.Foldable 11 | import Data.Traversable (sequence) 12 | 13 | type MultiMap k v = Map k (Set v) 14 | 15 | insert :: forall k v. Ord k => Ord v => k -> v -> MultiMap k v -> MultiMap k v 16 | insert k v m = case Map.lookup k m of 17 | Nothing -> Map.insert k (Set.insert v Set.empty) m 18 | Just s -> Map.insert k (Set.insert v s) m 19 | 20 | empty :: forall k v. MultiMap k v 21 | empty = Map.empty 22 | 23 | union :: forall k v. Ord k => Ord v => MultiMap k v -> MultiMap k v -> MultiMap k v 24 | union m1 m2 = Util.threeCaseUnion (\s -> s) (\s -> s) Set.union m1 m2 25 | 26 | unions :: forall f v k. Ord k => Ord v => Foldable f => f (MultiMap k v) -> MultiMap k v 27 | unions f = foldr union empty f 28 | 29 | -- NOTE: there is a quirk here that if you put two of the same value into multimap then it only goes in the set once... 30 | 31 | -- returns Just if all things happen to map to exactly one element 32 | toMap :: forall k v. MultiMap k v -> Maybe (Map k v) 33 | toMap mm = 34 | -- all (map ?h mm) 35 | let mm' = map (\x -> 36 | let elems :: Array _ 37 | elems = Set.toUnfoldable x in 38 | assertSingleton elems 39 | ) mm in 40 | sequence mm' 41 | 42 | assertSingleton :: forall t. Array t -> Maybe t 43 | assertSingleton [x] = Just x 44 | assertSingleton _ = Nothing 45 | -------------------------------------------------------------------------------- /src/Data/Rexp.purs: -------------------------------------------------------------------------------- 1 | module Data.Rexp where 2 | 3 | import Prelude 4 | 5 | import Data.Variant (Variant) 6 | import Prim.Row as R 7 | import Prim.RowList (class RowToList) 8 | import Prim.RowList as RL 9 | import Type.Proxy (Proxy) 10 | 11 | type FormsRow = Row (Row Type) 12 | class LabelForms (label :: Type) (formsRow :: FormsRow) | label -> formsRow 13 | 14 | type Forms = RL.RowList (Row Type) 15 | class LabelFormsList (label :: Type) (forms :: Forms) | label -> forms 16 | instance (LabelForms label formsRow, RowToList formsRow forms) => LabelFormsList label forms 17 | 18 | class InterpLabel (label :: Type) (enc :: Type) | label -> enc 19 | instance 20 | ( LabelFormsList label forms 21 | , InterpForms forms enc ) 22 | => InterpLabel label enc 23 | 24 | class InterpForms (forms :: Forms) (enc :: Type) | forms -> enc 25 | instance InterpForms RL.Nil (Variant ()) 26 | instance 27 | ( InterpForms forms (Variant vs_) -- forms ==> vs_ 28 | , RowToList fieldsRow fields 29 | , InterpFields fields r -- fields ==> r 30 | , R.Cons x r vs_ vs ) -- (x :: r | vs_) == vs 31 | => InterpForms (RL.Cons x fieldsRow forms) (Variant vs) -- (x :: fields | forms) ==> (x :: r | vs) 32 | 33 | data Literal (literal :: Type) 34 | data Labeled (label :: Type) 35 | 36 | type Fields = RL.RowList Type 37 | 38 | class InterpFields (fields :: Fields) (enc :: Type) | fields -> enc 39 | instance InterpFields RL.Nil (Record ()) 40 | instance 41 | ( InterpFields fields (Record rs_) 42 | , InterpField a b 43 | , R.Cons x b rs_ rs ) 44 | => InterpFields (RL.Cons x a fields) (Record rs) 45 | 46 | class InterpField (a :: Type) (b :: Type) | a -> b 47 | instance InterpField (Literal a) a 48 | instance 49 | ( LabelFormsList label forms 50 | , InterpForms forms a ) 51 | => InterpField (Labeled label) a 52 | 53 | newtype Rexp (label :: Type) (enc :: Type) = Rexp enc 54 | class IsRexp (a :: Type) 55 | instance (InterpLabel label enc) => IsRexp (Rexp label enc) 56 | -------------------------------------------------------------------------------- /src/Data/Rexp/Example1.purs: -------------------------------------------------------------------------------- 1 | module Data.Rexp.Example1 where 2 | 3 | import Prelude 4 | 5 | import Data.Rexp as Rexp 6 | import Data.Variant (Variant, case_, inj, on) 7 | import Type.Proxy (Proxy(..)) 8 | 9 | -- 10 | -- define a new language 11 | -- 12 | 13 | _string = Proxy :: Proxy "string" 14 | _var = Proxy :: Proxy "var" 15 | 16 | data TermLabel_ 17 | instance Rexp.LabelForms TermLabel_ 18 | ( string :: (value :: Rexp.Literal String) 19 | , var :: (var :: Rexp.Labeled VarLabel_) ) 20 | type TermEnc = Variant 21 | ( string :: Record (value :: String) 22 | , var :: Record (var :: Var) ) 23 | type Term = Rexp.Rexp TermLabel_ TermEnc 24 | 25 | data VarLabel_ 26 | instance Rexp.LabelForms VarLabel_ (string :: (name :: String)) 27 | type VarEnc = Variant (string :: Record (name :: String)) 28 | type Var = Rexp.Rexp VarLabel_ VarEnc 29 | 30 | {- 31 | -- 32 | -- required for each language-specific function 33 | -- 34 | 35 | class Rexp.IsRexp label enc <= ShowLabel label enc where 36 | showLabel :: Rexp.Rexp label enc -> String 37 | 38 | -- instance Rexp.InterpLabel TermLabel_ TermEnc => ShowLabel Term where 39 | -- showLabel (Term term) = case_ 40 | -- # on _string (\_ -> "Term") 41 | -- # on _var (\_ -> "Var") 42 | -- $ term 43 | 44 | exampleTerm1 :: Term 45 | exampleTerm1 = Rexp.Rexp (inj _string {value: "example value 1"}) 46 | -} -------------------------------------------------------------------------------- /src/Data/TotalMap.purs: -------------------------------------------------------------------------------- 1 | module Data.TotalMap 2 | ( TotalMap 3 | , makeTotalMap 4 | , lookup 5 | , update 6 | , mapWithKey 7 | , hasKey 8 | , fromMap 9 | ) where 10 | 11 | import Prelude 12 | 13 | import Bug.Assertion (Assertion(..), assert) 14 | import Control.Monad.Error.Class (throwError) 15 | import Data.Enum (class Enum, enumFromTo) 16 | import Data.Foldable (class Foldable) 17 | import Data.Map as Map 18 | import Data.Maybe (Maybe(..), fromJust) 19 | import Data.Newtype as Newtype 20 | import Data.Traversable (class Traversable) 21 | import Data.Tuple.Nested ((/\)) 22 | import Partial.Unsafe (unsafePartial) 23 | import Text.Pretty (quotes) 24 | 25 | newtype TotalMap k v = TotalMap (Map.Map k v) 26 | 27 | derive instance Functor (TotalMap k) 28 | derive instance Foldable (TotalMap k) 29 | derive instance Traversable (TotalMap k) 30 | 31 | over :: forall k v a. (Partial => Map.Map k v -> a) -> TotalMap k v -> a 32 | over = \f (TotalMap m) -> unsafePartial $ f m 33 | 34 | makeTotalMap :: forall k v. Enum k => Bounded k => (k -> v) -> TotalMap k v 35 | makeTotalMap f = TotalMap $ Map.fromFoldable $ ((enumFromTo bottom top <#> \k -> k /\ f k) :: Array _) 36 | 37 | hasKey :: forall k v. Ord k => Show k => String -> k -> Map.Map k v -> Assertion v 38 | hasKey source k m = Assertion 39 | { name: "hasKey" 40 | , source 41 | , result: case Map.lookup k m of 42 | Nothing -> throwError $ "Could not find key " <> quotes (show k) 43 | Just a -> pure a 44 | } 45 | 46 | fromMap :: forall k v. Show k => Enum k => Bounded k => Map.Map k v -> TotalMap k v 47 | fromMap m = makeTotalMap \k -> assert (hasKey "TotalMap.fromMap" k m) identity 48 | 49 | lookup :: forall k v. Ord k => k -> TotalMap k v -> v 50 | lookup k = over $ fromJust <<< Map.lookup k 51 | 52 | update :: forall k v. Ord k => k -> (v -> v) -> TotalMap k v -> TotalMap k v 53 | update k f = over $ Map.alter (fromJust >>> f >>> pure) k >>> TotalMap 54 | 55 | instance (Ord k, Semigroup v) => Semigroup (TotalMap k v) where 56 | append (TotalMap m1) (TotalMap m2) = TotalMap (Map.unionWith append m1 m2) 57 | 58 | instance (Enum k, Bounded k, Monoid v) => Monoid (TotalMap k v) where 59 | mempty = makeTotalMap (const mempty) 60 | 61 | mapWithKey :: forall k v. Ord k => (k -> v -> v) -> TotalMap k v -> TotalMap k v 62 | mapWithKey f = over $ Map.mapMaybeWithKey (\k v -> Just (f k v)) >>> TotalMap 63 | -------------------------------------------------------------------------------- /src/Data/Zippable.purs: -------------------------------------------------------------------------------- 1 | module Data.Zippable where 2 | 3 | import Data.Tuple 4 | import Data.Tuple.Nested 5 | import Prelude 6 | import Data.Array ((!!), last) 7 | import Data.Maybe (Maybe(..)) 8 | 9 | class Zippable a where 10 | zipDowns :: a -> Array a 11 | zipUp' :: a -> Maybe (Int /\ a) 12 | -- !TODO isValidCursor :: a -> Boolean 13 | -- !TODO isValidSelect :: ? -> Boolean 14 | 15 | zipUp :: forall a. Zippable a => a -> Maybe a 16 | zipUp = map snd <<< zipUp' 17 | 18 | zipDown :: forall a. Zippable a => Int -> a -> Maybe a 19 | zipDown i a = zipDowns a !! i 20 | 21 | zipLeft :: forall a. Zippable a => a -> Maybe a 22 | zipLeft a = do 23 | i /\ p <- zipUp' a 24 | zipDowns p !! (i - 1) 25 | 26 | zipRight :: forall a. Zippable a => a -> Maybe a 27 | zipRight a = do 28 | i /\ p <- zipUp' a 29 | zipDowns p !! (i + 1) 30 | 31 | zipNext :: forall a. Zippable a => Int -> a -> Maybe a 32 | zipNext i a = do 33 | let downs = zipDowns a 34 | case downs !! i of 35 | Just a' -> Just a' 36 | Nothing -> case zipUp' a of 37 | Nothing -> Nothing 38 | Just (j /\ p) -> zipNext (j + 1) p 39 | 40 | zipPrev :: forall a. Zippable a => a -> Maybe a 41 | zipPrev a = do 42 | case zipUp' a of 43 | Nothing -> Nothing 44 | Just (j /\ p) -> do 45 | let downs = zipDowns p 46 | case downs !! (j - 1) of 47 | Nothing -> Just p 48 | Just a' -> Just $ lastChild a' 49 | 50 | lastChild :: forall a. Zippable a => a -> a 51 | lastChild a = case last (zipDowns a) of 52 | Nothing -> a 53 | Just a' -> lastChild a' 54 | -------------------------------------------------------------------------------- /src/Halogen/Utilities.js: -------------------------------------------------------------------------------- 1 | export const fromInputEventToTargetValue = (event) => () => event.target.value 2 | 3 | export const get_url_search_param = (name) => () => { 4 | const urlParams = new URLSearchParams(window.location.search); 5 | return urlParams.get(name) ?? ""; 6 | } 7 | 8 | export const encode_uri_string = (str) => encodeURIComponent(str) 9 | 10 | export const navigator_clipboard_text_ = async () => navigator.clipboard.readText() -------------------------------------------------------------------------------- /src/Halogen/Utilities.purs: -------------------------------------------------------------------------------- 1 | module Halogen.Utilities where 2 | 3 | import Prelude 4 | 5 | import Bug as Bug 6 | import Control.Promise (Promise, toAffE) 7 | import Data.Maybe (Maybe(..)) 8 | import Data.Newtype (unwrap) 9 | import Effect (Effect) 10 | import Effect.Aff (Aff) 11 | import Effect.Class (class MonadEffect) 12 | import Halogen as H 13 | import Halogen as HH 14 | import Halogen.HTML.Properties as HP 15 | import Halogen.Hooks as HK 16 | import Log as Log 17 | import Partial.Unsafe (unsafeCrashWith) 18 | import Web.DOM as DOM 19 | import Web.DOM.DOMTokenList as DOMTokenList 20 | import Web.DOM.Document as Document 21 | import Web.DOM.Element as Element 22 | import Web.DOM.NonElementParentNode as NonElementParentNode 23 | import Web.Event.Internal.Types (Event) 24 | import Web.HTML as HTML 25 | import Web.HTML.HTMLDocument as HTMLDocument 26 | import Web.HTML.HTMLElement as HTMLElement 27 | import Web.HTML.Window as Window 28 | 29 | type ElementId 30 | = String 31 | 32 | setClassName ∷ ∀ (m ∷ Type -> Type). MonadEffect m ⇒ Element.Element → String → Boolean → m Unit 33 | setClassName elem className classValue = do 34 | H.liftEffect do 35 | classList <- Element.classList elem 36 | void $ DOMTokenList.toggleForce classList className classValue 37 | 38 | setClassNameByElementId ∷ String → String → Boolean → Effect Unit 39 | setClassNameByElementId elemId className classValue = do 40 | doc <- Window.document =<< HTML.window 41 | NonElementParentNode.getElementById elemId (Document.toNonElementParentNode $ HTMLDocument.toDocument doc) 42 | >>= case _ of 43 | Nothing -> do 44 | Bug.bug $ "[setClassName] There is no element with this element id: " <> elemId 45 | Just elem -> setClassName elem className classValue 46 | 47 | classNames = HP.classes <<< map HH.ClassName 48 | 49 | foreign import fromInputEventToTargetValue :: Event -> Effect String 50 | 51 | -- returns "" if the string if the param is not found 52 | foreign import get_url_search_param :: String -> Effect String 53 | 54 | foreign import encode_uri_string :: String -> String 55 | 56 | foreign import navigator_clipboard_text_ :: Effect (Promise String) 57 | 58 | navigator_clipboard_text :: Aff String 59 | navigator_clipboard_text = toAffE navigator_clipboard_text_ 60 | -------------------------------------------------------------------------------- /src/Hole.js: -------------------------------------------------------------------------------- 1 | export const _hole = a => { 2 | console.log("==[ HOLE ]=================================================================") 3 | console.log(a) 4 | throw new Error("HOLE") 5 | } 6 | 7 | export const realCatchException = (Left) => (Right) => (callback) => { 8 | try{ 9 | var res = callback(); 10 | return Right(res); 11 | }catch(e){ 12 | return Left("error"); 13 | } 14 | } -------------------------------------------------------------------------------- /src/Hole.purs: -------------------------------------------------------------------------------- 1 | module Hole where 2 | 3 | import Prim.TypeError (class Warn, Text) 4 | import Data.Unit (Unit) 5 | import Data.Either (Either) 6 | 7 | class HoleWarning 8 | 9 | instance warnHoleWarning :: Warn (Text "Contains holes") => HoleWarning 10 | 11 | foreign import _hole :: forall a b. a -> b 12 | 13 | foreign import realCatchException :: forall a. (forall x y. x -> Either x y) -> (forall x y. x -> Either y x) 14 | -> (Unit -> a) -> Either String a 15 | 16 | --realCatchException :: forall a. (Unit -> a) -> Either String a 17 | --realCatchException = _realCatchException 18 | 19 | hole :: forall a b. HoleWarning => a -> b 20 | hole a = _hole a 21 | -------------------------------------------------------------------------------- /src/Language/Pantograph/Generic/ChangeAlgebra.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Generic.ChangeAlgebra where 2 | 3 | import Data.Expr 4 | import Language.Pantograph.Generic.Unification 5 | import Prelude 6 | import Util 7 | 8 | import Bug (bug) 9 | import Bug as Bug 10 | import Bug.Assertion (Assertion(..), assert, makeAssertionBoolean) 11 | import Data.Array as Array 12 | import Data.Either (Either(..)) 13 | import Data.Foldable (findMap, foldl, intercalate, and) 14 | import Data.List as List 15 | import Data.List.Rev (unreverse, reverse) 16 | import Data.List.Zip (Path(..)) 17 | import Data.List.Zip as ListZip 18 | import Data.List.Zip as ZipList 19 | import Data.Map (Map) 20 | import Data.Map as Map 21 | import Data.Maybe (Maybe(..)) 22 | import Data.Maybe (Maybe) 23 | import Data.Newtype (unwrap) 24 | import Data.Set (Set) 25 | import Data.Set as Set 26 | import Data.Traversable (sequence) 27 | import Data.Tuple (fst, snd) 28 | import Data.Tuple.Nested (type (/\), (/\)) 29 | import Debug (trace) 30 | import Debug (traceM) 31 | import Effect.Exception.Unsafe (unsafeThrow) 32 | import Halogen.HTML as HH 33 | import Hole as Hole 34 | import Language.Pantograph.Generic.Rendering.Console (logConsole) 35 | import Text.Pretty (pretty) 36 | 37 | inject :: forall l. Expr l -> Change l 38 | inject = map CInj 39 | 40 | -- HENRY: due to generic fixpoint form of `Gram`, don't need to manually recurse 41 | invert :: forall l. Change l -> Change l 42 | invert = map case _ of 43 | Plus th -> Minus th 44 | Minus th -> Plus th 45 | CInj l -> CInj l 46 | Replace e1 e2 -> Replace e2 e1 47 | 48 | -- NOTE: this is NOT the same as asking if the change has equal endpoints (a loop in the groupoid), it computes if its an identity under composition 49 | isId :: forall l. IsExprLabel l => Change l -> Boolean 50 | isId (Expr (CInj _) kids) = Array.all isId kids 51 | isId (Expr (Replace e1 e2) []) = e1 == e2 -- NOTE: I'm not sure if this should be considered an identity, but if not then something needs to be done about (doOperation (Replace a b) ?x) 52 | isId _ = false 53 | 54 | -- Every part of the change is either the identity, or (Replace ?x something) where ?x is a metavariable only. 55 | isMerelyASubstitution :: forall l. IsExprLabel l => MetaChange l -> Boolean 56 | isMerelyASubstitution (Expr (CInj _) kids) = Array.all isMerelyASubstitution kids 57 | isMerelyASubstitution (Expr (Replace (MV _ % []) _) []) = true 58 | isMerelyASubstitution (Expr (Replace e1 e2) []) | e1 == e2 = true 59 | isMerelyASubstitution _ = false 60 | 61 | isIdMaybe :: forall l. IsExprLabel l => Change l -> Maybe (Expr l) 62 | isIdMaybe (Expr (CInj l) kids) = Expr l <$> sequence (map isIdMaybe kids) 63 | isIdMaybe (Expr (Replace e1 e2) []) | e1 == e2 = Just e1 64 | isIdMaybe _ = Nothing 65 | 66 | collectMatches :: forall l. Eq l => Change l -> MetaExpr l -> Maybe (Map MetaVar (Set (Change l))) 67 | collectMatches (Expr (CInj l1) kids1) (Expr (MInj l2) kids2) | l1 == l2 = 68 | let subs = Array.zipWith collectMatches kids1 kids2 in 69 | -- let combine c1 c2 = if isId c1 then Just c2 else if isId c2 then Just c1 else if c1 == c2 then Just c1 else Nothing in 70 | -- let 71 | -- Array.fold subs 72 | Hole.hole "TODO: collectMatches" 73 | collectMatches c (Expr (MV x) []) = Just $ Map.insert x (Set.singleton c) Map.empty 74 | collectMatches _ _ = Bug.bug "base case in collectMatches" 75 | 76 | endpoints :: forall l. IsExprLabel l => Change l -> Expr l /\ Expr l 77 | endpoints ch = 78 | -- assert (wellformedExpr "endpoints" ch) \_ -> 79 | case ch of 80 | Expr (Plus th) [kid] -> do 81 | -- - `leftEp` is the left endpoint of the plus's child, and so it is the 82 | -- plus's left endpoint. 83 | -- - `rightEp` is the right endpoint of the plus's child, so the plus's 84 | -- right endpoint is it wrapped in the plus's tooth. 85 | let leftEp /\ rightEp = endpoints kid 86 | leftEp /\ unTooth th rightEp 87 | Expr (Minus th) [kid] -> do 88 | -- inverse of "plus" case 89 | let leftEp /\ rightEp = endpoints kid 90 | unTooth th leftEp /\ rightEp 91 | Expr (CInj l) kids -> do 92 | -- `zippedKids` are the endpoint tuples for each of the kids. Unzipping 93 | -- them yields the array of the kids' left endpoints and the array of the 94 | -- kids' right endpoints 95 | let zippedKids = endpoints <$> kids 96 | let leftKids /\ rightKids = Array.unzip zippedKids 97 | Expr l leftKids /\ Expr l rightKids 98 | Expr (Replace e1 e2) [] -> e1 /\ e2 99 | _ -> bug "invalid input to endpoints" 100 | 101 | lEndpoint :: forall l. IsExprLabel l => Change l -> Expr l 102 | lEndpoint = fst <<< endpoints 103 | 104 | rEndpoint :: forall l. IsExprLabel l => Change l -> Expr l 105 | rEndpoint = snd <<< endpoints 106 | 107 | lub :: forall l. IsExprLabel l => Change l -> Change l -> Maybe (Change l) 108 | lub c1 c2 = 109 | case c1 /\ c2 of 110 | (CInj l1) % kids1 /\ (CInj l2) % kids2 | l1 == l2 -> Expr (CInj l1) <$> sequence (Array.zipWith lub kids1 kids2) -- Oh no I've become a haskell programmer 111 | _ | isId c1 -> pure c2 112 | _ | isId c2 -> pure c1 113 | _ | c1 == c2 -> pure c1 114 | -- This case is a hack to deal with freevar stuff 115 | Replace t1 _ % [] /\ Replace t1' _ % [] | t1 == t1' -> trace "The hack to cut and paste things with metavariable links happened" \_ -> pure c1 116 | _ -> trace ("WARNING: I think that this case probably shouldn't happen if I figured out the right way to code lub. It was: " <> pretty c1 <> " " <> pretty c2) \_ -> Nothing 117 | 118 | {- 119 | Explanation on the hack case: 120 | Suppose that you have 121 | let f : ?0 -> ?1 122 | let x : ?0 123 | f x 124 | 125 | And you cut and paste f x. Then, in the remaining program, there is nothing to link the metavariable in f and x, 126 | so they get unlinked. But then when you paste the expression, the free variables have linked metavariables. 127 | Surely this is not the right way to solve the problem, but its a hack to get it to work well enough. 128 | -} 129 | 130 | matchingEndpoints :: forall l. IsExprLabel l => String -> String -> Change l -> Change l -> Assertion Unit 131 | matchingEndpoints source message c1 c2 = makeAssertionBoolean 132 | { name: "matchingEndpoints" 133 | , source 134 | , condition: do 135 | let _left1 /\ right1 = endpoints c1 136 | let left2 /\ _right2 = endpoints c2 137 | right1 == left2 138 | , message 139 | } 140 | 141 | compose :: forall l. IsExprLabel l => Change l -> Change l -> Change l 142 | compose c1 c2 = 143 | -- assert (wellformedExpr "compose.c1" c1) \_ -> 144 | -- assert (wellformedExpr "compose.c2" c2) \_ -> 145 | -- assert (matchingEndpoints "ChangeAlgebra.compose" ("Change composition is only defined when endpoints match. Changes are: " <> pretty c1 <> " and " <> pretty c2) c1 c2) \_ -> 146 | case c1 /\ c2 of 147 | (Expr (Plus l1) [c1']) /\ (Expr (Minus l2) [c2']) | l1 == l2 -> compose c1' c2' 148 | (Expr (Minus l1) [c1']) /\ (Expr (Plus l2) [c2']) | l1 == l2 -> 149 | let Tooth l (Path {left, right}) = l1 in 150 | Expr (CInj l) $ 151 | (Array.fromFoldable $ map (map CInj) $ unreverse left) <> 152 | [compose c1' c2'] <> 153 | (Array.fromFoldable $ map (map CInj) $ right) 154 | _ /\ (Expr (Plus l) [c2']) -> Expr (Plus l) [compose c1 c2'] 155 | (Expr (Minus l) [c1']) /\ _ -> Expr (Minus l) [compose c1' c2] 156 | (Expr (Plus th@(Tooth l1 p)) [c1']) /\ (Expr (CInj l2) kids2) 157 | | l1 == l2 158 | , p2 /\ kid <- fromJust' "compose" (ZipList.zipAt (ZipList.leftLength p) (List.fromFoldable kids2)) 159 | , and (List.zipWith (\e c -> inject e == c) (ZipList.unpath p) 160 | (ZipList.unpath p2)) -> 161 | Expr (Plus th) [compose c1' kid] 162 | (Expr (CInj l2) kids1) /\ (Expr (Minus th@(Tooth l1 p)) [c2']) 163 | | l1 == l2 164 | , p1 /\ kid <- fromJust' "compose" (ZipList.zipAt (ZipList.leftLength p) (List.fromFoldable kids1)) 165 | , and (List.zipWith (\e c -> inject e == c) (ZipList.unpath p) 166 | (ZipList.unpath p1)) -> 167 | Expr (Minus th) [compose kid c2'] 168 | -- TODO: The above case isn't actually general enough. See my notes! 169 | -- For example: (-A -> B) -> [C] o - B -> [C] = - (A -> B) -> [C] 170 | -- But this function won't do that! 171 | (Expr (CInj l1) kids1) /\ (Expr (CInj l2) kids2) | l1 == l2 -> 172 | Expr (CInj l1) (Array.zipWith compose kids1 kids2) 173 | _ -> do 174 | let left1 /\ _right1 = endpoints c1 175 | let _left2 /\ right2 = endpoints c2 176 | Expr (Replace left1 right2) [] 177 | 178 | -- (Replace (c x1…) (c x1'…)) = c (Replace x1 x1')… 179 | eliminateReplaces :: forall l. IsExprLabel l => Change l -> Change l 180 | eliminateReplaces c = 181 | case c of 182 | Replace (l1 % kids1) (l2 % kids2) % [] | l1 == l2 -> 183 | CInj l1 % (Array.zipWith (\s1 s2 -> eliminateReplaces (Replace s1 s2 % [])) kids1 kids2) 184 | other % kids -> other % map eliminateReplaces kids 185 | 186 | {- 187 | I don't have a good name for this operation, but what it does is: 188 | input Change c1 and MetaChange c2, and output sub and c3, such that: 189 | c1 o c3 = sub c2 190 | Also, c3 should be orthogonal to c1. If this doesn't exist, it outputs Nothing. 191 | (Note that c2 has metavariables in the change positions, so its (Expr (Meta (ChangeLabel l)))) 192 | -} 193 | 194 | doOperation :: forall l. IsExprLabel l => Change l -> Expr (Meta (ChangeLabel l)) -> Maybe (Map MetaVar (Change l) /\ Change l) 195 | doOperation c1 c2 = 196 | do 197 | matches <- getMatches c2 c1 198 | -- TODO: could this be written better 199 | let sub = map (foldNonempty (\c1 c2 -> do x <- c1 200 | y <- c2 201 | lub x y)) 202 | (map (Set.map Just) matches) 203 | sub2 <- sequence sub 204 | let subc2 = subMetaExpr sub2 c2 205 | let result = (sub2 /\ compose (invert c1) subc2) 206 | pure $ result 207 | 208 | {- 209 | Implementing a real tree diff algorithm is hard, so instead I have one that makes some assumptions about the inputs. 210 | Its also dubious if the notion of "shortest edit sequence" is really what we want anyway. Would that really be the 211 | change that correctly preserves the semantic meaning? 212 | This diff algorithm tries to find an unambiguous diff, and if it doesn't exist just returns Replace. 213 | In other words, the set S of pairs of expressions (e1, e2) on which the algorithm doesn't just return Replace 214 | consists of pairs satisfying any of the following: 215 | - e1 = e2 216 | - e1 is a subexpression of e2 217 | - e2 is a subexpression of e1 218 | - e1 = Expr l1 [a1, ..., an], e2 = Expr l2 [b1, ..., bn], and for each i<=n, (ai, bi) in S. 219 | -} 220 | diff :: forall l. Eq l => Expr l -> Expr l -> Change l 221 | diff e1 e2 | e1 == e2 = map CInj e1 222 | diff e1@(Expr l1 kids1) e2@(Expr l2 kids2) = 223 | case isPostfix e1 e2 of 224 | Just ch -> ch 225 | Nothing -> case isPostfix e2 e1 of 226 | Just ch -> invert ch 227 | Nothing -> if l1 == l2 then Expr (CInj l1) (Array.zipWith diff kids1 kids2) else Expr (Replace e1 e2) [] 228 | 229 | isPostfix :: forall l. Eq l => Expr l -> Expr l -> Maybe (Change l) 230 | isPostfix e1 e2 | e1 == e2 = Just $ map CInj e1 231 | isPostfix (Expr l kids) e2 = 232 | -- TODO: this can probably be rewritten with utilities in Zip.purs like zipAt and zips 233 | let splits = Array.mapWithIndex (\index kid -> Array.take index kids /\ kid /\ Array.drop (index + 1) kids) kids in 234 | findMap (\(leftKids /\ kid /\ rightKids) -> 235 | do 236 | innerCh <- isPostfix kid e2 237 | Just $ Expr (Minus (Tooth l (Path {left: reverse $ List.fromFoldable leftKids, right: List.fromFoldable rightKids}))) [innerCh] 238 | ) splits 239 | 240 | subSomeChangeLabel :: forall l. IsExprLabel l => Sub l -> ChangeLabel (Meta l) -> ChangeLabel (Meta l) 241 | subSomeChangeLabel sub = 242 | let subExpr = subMetaExprPartially sub in 243 | case _ of 244 | Plus (Tooth dir (ZipList.Path {left, right})) -> Plus (Tooth dir (ZipList.Path {left: map subExpr left, right: map subExpr right})) 245 | Minus (Tooth dir (ZipList.Path {left, right})) -> Minus (Tooth dir (ZipList.Path {left: map subExpr left, right: map subExpr right})) 246 | CInj l -> CInj l -- NOTE: if l was a metavar, we wouldn't get here because subSomeMetaChange would have dealt with it. 247 | Replace e1 e2 -> Replace (subExpr e1) (subExpr e2) 248 | 249 | -- TODO: I need to figure out how this function can really be written without repetition relative to other substitution functions we have in Expr 250 | subSomeMetaChange :: forall l. IsExprLabel l => Sub l -> MetaChange l -> MetaChange l 251 | subSomeMetaChange sub (Expr l kids) = 252 | case l of 253 | -- CInj (Meta (Left x)) -> inject $ lookup' x sub 254 | CInj (MV x) | Just s <- Map.lookup x sub 255 | -> inject s 256 | _ -> Expr (subSomeChangeLabel sub l) (map (subSomeMetaChange sub) kids) 257 | -------------------------------------------------------------------------------- /src/Language/Pantograph/Generic/Edit.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Generic.Edit where 2 | 3 | import Language.Pantograph.Generic.Grammar 4 | import Language.Pantograph.Generic.Smallstep 5 | import Language.Pantograph.Generic.Unification 6 | import Prelude 7 | 8 | import Bug (bug) 9 | import Bug.Assertion (assert, assertI, just) 10 | import Control.Plus (empty) 11 | import Data.Array as Array 12 | import Data.Enum (enumFromTo) 13 | import Data.Expr ((%),(%<)) 14 | import Data.Expr as Expr 15 | import Data.Lazy (Lazy, defer) 16 | import Data.List as List 17 | import Data.List.Zip as ZipList 18 | import Data.Map as Map 19 | import Data.Maybe (Maybe(..)) 20 | import Data.Either (Either(..)) 21 | import Data.TotalMap as TotalMap 22 | import Data.Traversable (sequence) 23 | import Data.Tuple (fst) 24 | import Data.Tuple.Nested ((/\), type (/\)) 25 | import Hole (hole) 26 | import Text.Pretty (pretty) 27 | import Type.Direction (Up) 28 | import Debug (traceM) 29 | import Util (fromJust') 30 | 31 | -------------------------------------------------------------------------------- 32 | -- Edit, Action 33 | -------------------------------------------------------------------------------- 34 | 35 | type Edit l r = 36 | { label :: String 37 | , action :: (Either String (Lazy (Action l r))) -- The String is an error message if the edit isn't possible 38 | } 39 | 40 | data Action l r 41 | -- = SetCursorAction (Lazy (DerivZipper l r)) 42 | -- | SetSSTermAction (Lazy (SSTerm l r)) 43 | = FillAction {sub :: Sub (SortLabel l), dterm :: DerivTerm l r} 44 | | ReplaceAction {topChange :: SortChange l, dterm :: DerivTerm l r} 45 | | WrapAction {topChange :: SortChange l, dpath :: DerivPath Up l r, botChange :: SortChange l, 46 | sub :: Sub (SortLabel l), cursorGoesInside :: Boolean} 47 | 48 | newTermFromRule :: forall l r. IsRuleLabel l r => r -> DerivTerm l r 49 | newTermFromRule r = do 50 | let Rule mvars hyps' _con = TotalMap.lookup r language 51 | let sigma = freshenRuleMetaVars mvars 52 | let hyps = Expr.subMetaExprPartially sigma <$> hyps' 53 | let term1 = DerivLabel r sigma % (map (fromJust' "yes" <<< defaultDerivTerm) hyps) 54 | let sub = fromJust' "ntfr" $ infer term1 55 | subDerivTerm sub term1 56 | 57 | newPathFromRule :: forall l r. IsRuleLabel l r => r -> Int -> DerivPath Up l r /\ Sort l 58 | newPathFromRule r kidIx = do 59 | let tooth /\ sub = newToothFromRule r kidIx 60 | Expr.Path (List.singleton tooth) /\ sub 61 | 62 | newToothFromRule :: forall l r. IsRuleLabel l r => r -> Int -> DerivTooth l r /\ Sort l 63 | newToothFromRule r kidIx = do 64 | let Rule mvars hyps' _con = TotalMap.lookup r language 65 | let sigma = freshenRuleMetaVars mvars 66 | let hyps = Expr.subMetaExprPartially sigma <$> hyps' 67 | 68 | -- `hypSort` is the sort of what should got at position `kidIx` 69 | let hypSortPath /\ hypSort = assertI $ just "newPathFromRule.hpySortPath" $ 70 | ZipList.zipAt kidIx (List.fromFoldable hyps) 71 | 72 | -- Each kid of the tooth is a default deriv 73 | let defaultHypDerivPath :: _ (DerivTerm l r) 74 | defaultHypDerivPath = assertI $ just "newPathFromRule.defaultHypDerivPath" $ 75 | sequence (defaultDerivTerm <$> hypSortPath) 76 | 77 | -- Some of the children might have more specialized types, so we need to unify by calling infer. (e.g. in lambda, we call defaultDerivTerm on sort (Name ?x), but we actually get something of sort (Name "")) 78 | let tooth = (DerivLabel r sigma %< defaultHypDerivPath) 79 | let path1 = Expr.Path (List.singleton tooth) 80 | let sub = fromJust' "path didn't typecheck in newPathFromRule" $ inferPath (freshMetaVarSort "pathInside") path1 81 | let toothSubbed = subDerivTooth sub tooth 82 | toothSubbed /\ Expr.subMetaExprPartially sub hypSort 83 | -------------------------------------------------------------------------------- /src/Language/Pantograph/Generic/Rendering/Console.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Generic.Rendering.Console where 2 | 3 | import Data.Tuple.Nested 4 | import Prelude 5 | 6 | import Data.Array as Array 7 | import Effect.Aff (Aff) 8 | import Effect.Ref (Ref) 9 | import Effect.Ref as Ref 10 | import Effect.Unsafe (unsafePerformEffect) 11 | import Halogen as H 12 | import Halogen.HTML as HH 13 | import Halogen.HTML.Events as HE 14 | import Halogen.Hooks as HK 15 | import Halogen.Utilities (classNames) 16 | import Type.Proxy (Proxy(..)) 17 | 18 | _consoleSlot = Proxy :: Proxy "console" 19 | 20 | type Console = Array HH.PlainHTML 21 | 22 | consoleRef :: Ref Console 23 | consoleRef = unsafePerformEffect $ Ref.new [] 24 | 25 | getConsole :: forall a. (Console -> a) -> a 26 | getConsole k = unsafePerformEffect do 27 | k <$> Ref.read consoleRef 28 | 29 | setConsole :: forall a. (Console -> Console) -> (Console -> a) -> a 30 | setConsole f k = unsafePerformEffect do 31 | Ref.modify_ f consoleRef 32 | k <$> Ref.read consoleRef 33 | 34 | logConsole :: forall a. HH.PlainHTML -> (Unit -> a) -> a 35 | logConsole log k = setConsole (Array.cons log) \_ -> k unit 36 | 37 | consoleComponent :: forall q i o. H.Component q i o Aff 38 | consoleComponent = HK.component \tokens spec -> HK.do 39 | 40 | bit /\ bitId <- HK.useState false 41 | 42 | HK.pure $ 43 | HH.div [classNames ["console"]] $ 44 | [HH.div [classNames ["console-header"]] 45 | [HH.text "Console"] 46 | 47 | , HH.div [classNames ["console-controls"]] 48 | [ HH.button 49 | [HE.onClick \event -> 50 | logConsole (HH.text ("[force console update]")) \_ -> 51 | HK.modify_ bitId not] 52 | [HH.text "force update"] 53 | , HH.button 54 | [HE.onClick \event -> 55 | logConsole (HH.text ("[clear console]")) \_ -> 56 | setConsole (\_ -> []) (\_ -> HK.modify_ bitId not)] 57 | [HH.text "clear"] 58 | ] 59 | , HH.div [classNames ["console-logs"]] $ 60 | getConsole \logs -> Array.reverse logs <#> \log -> 61 | HH.div [classNames ["console-log"]] 62 | [HH.fromPlainHTML log] 63 | ] 64 | -------------------------------------------------------------------------------- /src/Language/Pantograph/Generic/Rendering/Elements.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Generic.Rendering.Elements where 2 | 3 | 4 | import Halogen.HTML as HH 5 | import Halogen.Utilities (classNames) 6 | 7 | makePuncElem :: forall w i. String -> String -> HH.HTML w i 8 | makePuncElem className symbol = HH.div [classNames ["subnode", "punctuation", className]] [HH.text symbol] 9 | 10 | spaceElem = makePuncElem "space" " " 11 | lparenElem = makePuncElem "lparen" "(" 12 | -- lparenElem = makePuncElem "lparen" "❰" 13 | rparenElem = makePuncElem "rparen" ")" 14 | -- rparenElem = makePuncElem "rparen" "❱" 15 | lbraceElem = makePuncElem "lbrace" "{" 16 | rbraceElem = makePuncElem "rbrace" "}" 17 | lbracketElem = makePuncElem "lbracket" "[" 18 | rbracketElem = makePuncElem "rbracket" "]" 19 | colonElem = makePuncElem "colon" ":" 20 | commaElem = makePuncElem "comma" "," 21 | turnstileElem = makePuncElem "turnstile" "⊢" 22 | interrogativeElem = makePuncElem "interrogative" "?" 23 | -- squareElem = makePuncElem "square" "☐" 24 | squareElem = makePuncElem "square" "▪" 25 | upArrowElem = makePuncElem "upArrow" "↑" 26 | downArrowElem = makePuncElem "downArrow" "↓" 27 | newlineElem = HH.br_ 28 | fillRightSpace = HH.div [classNames ["fill-right-space"]] [] 29 | indentElem = makePuncElem "indent" " " 30 | 31 | commentBeginElem = makePuncElem "commentBegin" " /* " 32 | commentEndElem = makePuncElem "commentEnd" " */ " 33 | 34 | ibeamElem :: forall w i. HH.HTML w i 35 | ibeamElem = makePuncElem "ibeam" "⌶" 36 | 37 | placeholderCursorNodeElem :: forall w i. HH.HTML w i 38 | placeholderCursorNodeElem = 39 | HH.div [classNames ["node", "placeholderCursor"]] 40 | [ HH.div [classNames ["subnode", "placeholderCursor-inner"]] 41 | -- [ibeamElem] 42 | [spaceElem] 43 | ] 44 | -------------------------------------------------------------------------------- /src/Language/Pantograph/Generic/Rendering/Preview.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Generic.Rendering.Preview where 2 | 3 | import Language.Pantograph.Generic.Edit 4 | import Language.Pantograph.Generic.Rendering.Base 5 | import Prelude 6 | 7 | import Bug (bug) 8 | import Control.Plus (empty) 9 | import Data.Array as Array 10 | import Data.Expr ((%)) 11 | import Data.Expr as Expr 12 | import Data.Lazy (defer, force) 13 | import Data.Maybe (Maybe(..)) 14 | import Data.Rational as Rational 15 | import Data.Tuple (snd) 16 | import Data.Tuple.Nested ((/\)) 17 | import Data.Variant (case_, on) 18 | import Effect.Aff (Aff) 19 | import Effect.Class (liftEffect) 20 | import Halogen as H 21 | import Halogen.HTML (div, input, span, text) as HH 22 | import Halogen.HTML.Events as HE 23 | import Halogen.HTML.Properties as HP 24 | import Halogen.Hooks as HK 25 | import Halogen.Utilities (classNames, fromInputEventToTargetValue) 26 | import Language.Pantograph.Generic.Grammar (class IsRuleLabel, DerivLabel(..), derivTermSort) 27 | import Language.Pantograph.Generic.Rendering.Elements (placeholderCursorNodeElem) 28 | import Type.Direction (HorizontalDir, _down, _left, _right, _up) 29 | import Web.Event.Event as Event 30 | import Web.HTML.HTMLElement as HTMLElement 31 | import Web.HTML.HTMLInputElement as InputElement 32 | import Web.UIEvent.MouseEvent as MouseEvent 33 | import Debug (traceM) 34 | 35 | previewComponent :: forall l r out. H.Component (PreviewQuery l r) HorizontalDir out Aff 36 | previewComponent = HK.component \tokens dir -> HK.do 37 | preview /\ preview_id <- HK.useState $ empty 38 | 39 | HK.useQuery tokens.queryToken case _ of 40 | SetPreviewQuery preview' a -> do 41 | HK.put preview_id preview' 42 | pure $ Just a 43 | 44 | HK.pure do 45 | case preview of 46 | Nothing -> HH.span [classNames ["preview", "empty"]] [] 47 | Just (ReplaceEditPreview elem) -> case_ 48 | # on _left (\_ -> HH.span [classNames ["preview", "replace"]] [elem]) 49 | # on _right (\_ -> HH.span [classNames ["preview", "replace"]] []) 50 | $ dir 51 | Just (FillEditPreview elem) -> case_ 52 | # on _left (\_ -> HH.span [classNames ["preview", "fill"]] [elem]) 53 | # on _right (\_ -> HH.span [classNames ["preview", "empty"]] []) 54 | $ dir 55 | Just (WrapEditPreview {before, after}) -> case_ 56 | # on _left (\_ -> HH.span [classNames ["preview", "wrap", "before"]] before) 57 | # on _right (\_ -> HH.span [classNames ["preview", "wrap", "after"]] after) 58 | $ dir 59 | -------------------------------------------------------------------------------- /src/Language/Pantograph/Generic/Rendering/RunnableEditor.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Generic.Rendering.RunnableEditor where 2 | 3 | import Prelude 4 | 5 | import CSS as CSS 6 | import CSS.Font as CSSFont 7 | import Data.Expr (Expr) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.NonEmpty as NonEmpty 10 | import Effect.Aff (Aff) 11 | import Halogen as H 12 | import Halogen.HTML as HH 13 | import Halogen.HTML.CSS as HCSS 14 | import Halogen.HTML.Events as HE 15 | import Halogen.HTML.Properties as HP 16 | import Language.Pantograph.Generic.Grammar as Grammar 17 | import Language.Pantograph.Generic.Rendering.Base as Base 18 | import Language.Pantograph.Generic.Rendering.Editor as Editor 19 | import Type.Proxy (Proxy(..)) 20 | 21 | type Slots l r 22 | = ( editor :: H.Slot (Editor.EditorQuery l r) (Base.EditorSpec l r) Unit ) 23 | 24 | _editorSlot = Proxy :: Proxy "editor" 25 | 26 | data Action 27 | = RunProgram 28 | 29 | component :: 30 | forall l r query output. 31 | Grammar.IsRuleLabel l r => 32 | H.Component query { spec :: Base.EditorSpec l r, interpreter :: Grammar.DerivTerm l r -> String } output Aff 33 | component = H.mkComponent { initialState, render, eval } 34 | where 35 | initialState :: { spec :: Base.EditorSpec l r, interpreter :: Grammar.DerivTerm l r -> String } -> { spec :: Base.EditorSpec l r, interpreter :: Expr (Grammar.DerivLabel l r) -> String, output :: String } 36 | initialState input = 37 | { spec: input.spec 38 | , interpreter: input.interpreter 39 | , output: "" 40 | } 41 | 42 | eval = 43 | H.mkEval 44 | H.defaultEval 45 | { handleAction = handleAction } 46 | 47 | handleAction = case _ of 48 | RunProgram -> do 49 | mprog <- H.request _editorSlot unit Editor.GetProgram 50 | state <- H.get 51 | case mprog of 52 | Just prog -> H.modify_ _ { output = state.interpreter prog } 53 | Nothing -> pure unit 54 | 55 | render state = 56 | HH.div 57 | [ do 58 | HCSS.style do 59 | CSS.display CSS.flex 60 | CSS.flexDirection CSS.column 61 | ] 62 | [ HH.div 63 | [ HCSS.style do 64 | CSS.height (1.5 # CSS.em) 65 | (let s = 0.5 # CSS.em in CSS.padding s s s s) 66 | CSS.display CSS.flex 67 | CSS.flexDirection CSS.row 68 | CSS.rule $ CSS.Property (CSS.fromString "gap") (CSS.fromString "0.5em") 69 | CSS.backgroundColor (CSS.rgb 0 0 0) 70 | CSS.color (CSS.rgb 255 255 255) 71 | ] 72 | [ HH.button 73 | [ HE.onMouseDown (const RunProgram) ] 74 | [ HH.text "run" ] 75 | , HH.div 76 | [ HP.id "evaluation" 77 | , HCSS.style do 78 | CSS.fontFamily [] $ NonEmpty.singleton $ CSSFont.monospace 79 | ] 80 | [ HH.text state.output ] 81 | ] 82 | , HH.div 83 | [ HCSS.style do 84 | (let s = 1.0 # CSS.em in CSS.padding s s s s) 85 | ] 86 | [ HH.slot_ _editorSlot unit (Editor.editorComponent unit) state.spec ] 87 | ] 88 | -------------------------------------------------------------------------------- /src/Language/Pantograph/Generic/Unification.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Generic.Unification where 2 | 3 | import Prelude 4 | 5 | import Bug as Bug 6 | import Bug.Assertion (Assertion(..), assert, assertInput_) 7 | import Control.Apply (lift2) 8 | import Control.Monad.Error.Class (throwError) 9 | import Data.Array as Array 10 | import Data.Either (Either(..)) 11 | import Data.Either (Either(..)) 12 | import Data.Expr (subMetaExprPartially, (%)) 13 | import Data.Expr as Expr 14 | import Data.Foldable (foldl) 15 | import Data.Foldable as Foldable 16 | import Data.List (List(..), (:)) 17 | import Data.List as List 18 | import Data.Map (Map) 19 | import Data.Map as Map 20 | import Data.Maybe (Maybe(..)) 21 | import Data.MultiMap (MultiMap) 22 | import Data.MultiMap as MultiMap 23 | import Data.Newtype (class Newtype) 24 | import Data.Newtype as Newtype 25 | import Data.Set (Set) 26 | import Data.Set as Set 27 | import Data.Traversable (traverse) 28 | import Data.Tuple.Nested (type (/\), (/\)) 29 | import Text.Pretty (pretty, quotes) 30 | import Util (lookup', union') 31 | import Debug (trace) 32 | import Debug (traceM) 33 | import Data.Traversable (sequence) 34 | import Data.List.Zip as ZipList 35 | import Hole (hole) 36 | import Control.Monad.State (State) 37 | import Control.Monad.State as State 38 | import Control.Monad.Trans.Class (lift) 39 | import Control.Monad.Except.Trans (ExceptT, runExceptT) 40 | import Data.Tuple (fst, snd) 41 | 42 | --QUESTION from Jacob: what is Freshenable for? Do we use any of that? 43 | --we already have an implementation of substitution elsewhere, which is 44 | --much simpler and more general 45 | 46 | type Ren = Expr.MetaVarSub Expr.MetaVar 47 | 48 | genFreshener :: Set Expr.MetaVar -> Ren 49 | genFreshener vars = foldl 50 | (\acc x -> Map.insert x (Expr.freshenMetaVar x) acc) 51 | Map.empty vars 52 | 53 | class Freshenable t where 54 | freshen :: Ren -> t -> t 55 | 56 | instance Freshenable (Expr.Meta l) where 57 | freshen ren (Expr.MV x) = Expr.MV (lookup' x ren) 58 | freshen ren (Expr.MInj l) = Expr.MInj l 59 | 60 | -- TODO: I really want this definition, but then I get an overlapping instances issue 61 | --instance (Functor f, Freshenable l) => Freshenable (f l) where 62 | -- freshen ren x = map (freshen sub) x 63 | 64 | -- TODO: so instead, I have it written manually in some specific cases 65 | 66 | instance Freshenable l => Freshenable (Expr.Expr l) where 67 | freshen sub expr = map (freshen sub) expr 68 | 69 | instance Freshenable l => Freshenable (Expr.ChangeLabel l) where 70 | freshen sub l = map (freshen sub) l 71 | 72 | -------------------------------------------------------------------------------- 73 | -- !HENRY here's a way to get around this, but you still need to write instances 74 | -- for deeply-nested type-class-instance-inferences 75 | 76 | newtype AsFreshenable f (a :: Type) = AsFreshenable (f a) 77 | 78 | derive instance Newtype (AsFreshenable f a) _ 79 | derive instance Functor f => Functor (AsFreshenable f) 80 | 81 | instance (Functor f, Freshenable l) => Freshenable (AsFreshenable f l) where 82 | freshen rho = map (freshen rho) -- beautiful 83 | 84 | freshen' :: forall f l. Functor f => Freshenable l => Ren -> f l -> f l 85 | freshen' rho = AsFreshenable >>> freshen rho >>> Newtype.unwrap 86 | 87 | -------------------------------------------------------------------------------- 88 | 89 | type Sub l = Expr.MetaVarSub (Expr.MetaExpr l) 90 | 91 | -- sub2 after sub1 92 | composeSub :: forall l. Expr.IsExprLabel l => Sub l -> Sub l -> Sub l 93 | composeSub sub1 sub2 = union' (map (Expr.subMetaExprPartially sub2) sub1) sub2 94 | 95 | composeSubs :: forall l f. Foldable.Foldable f => Expr.IsExprLabel l => f (Sub l) -> Sub l 96 | composeSubs subs = foldl composeSub Map.empty subs 97 | 98 | noMetaVars :: forall l. Expr.IsExprLabel l => String -> Expr.MetaExpr l -> Assertion (Expr.Expr l) 99 | noMetaVars source mexpr0 = Assertion 100 | { name: "noMetaVars", source 101 | , result: do 102 | let go = assertInput_ (Expr.wellformedExpr "noMetaVars") \mexpr -> case mexpr of 103 | Expr.MV _ % [] -> throwError $ "Found MetaVar " <> quotes (pretty mexpr) 104 | Expr.MInj l % kids -> (l % _) <$> go `traverse` kids 105 | go mexpr0 106 | } 107 | 108 | ------------- Unification ------------------------------------------------------ 109 | 110 | occurs :: forall l. Expr.IsExprLabel l => Expr.MetaVar -> Expr.MetaExpr l -> Boolean 111 | occurs x e = 112 | case e of 113 | Expr.MV x' % [] -> x' == x 114 | _ % kids -> Array.any (occurs x) kids 115 | 116 | -- we may need a more general notion of unification later, but this is ok for now 117 | -- NOTE: should prefer substituting variables from the left if possible 118 | unify :: forall l. Expr.IsExprLabel l => Expr.MetaExpr l -> Expr.MetaExpr l -> Maybe (Expr.MetaExpr l /\ Sub l) 119 | unify e1@(Expr.Expr l1 kids1) e2@(Expr.Expr l2 kids2) = 120 | case l1 /\ l2 of 121 | Expr.MV x1 /\ Expr.MV x2 | x1 == x2 -> Just (e1 /\ Map.empty) 122 | Expr.MV x /\ _ | not (occurs x e2) -> Just (e2 /\ Map.insert x e2 Map.empty) 123 | _ /\ Expr.MV x -> unify e2 e1 124 | Expr.MInj l /\ Expr.MInj l' | l == l' -> do 125 | kids' /\ sub <- unifyLists (List.fromFoldable kids1) (List.fromFoldable kids2) 126 | pure (Expr.Expr (Expr.MInj l) (Array.fromFoldable kids') /\ sub) 127 | _ /\ _ -> Nothing 128 | 129 | -- TODO: A really simple optimization is to unifyp the rest of the list first and only apply the subs to e1 and e2 130 | unifyLists :: forall l. Expr.IsExprLabel l => List (Expr.MetaExpr l) -> List (Expr.MetaExpr l) -> Maybe (List (Expr.MetaExpr l) /\ Sub l) 131 | unifyLists Nil Nil = Just (Nil /\ Map.empty) 132 | unifyLists (e1 : es1) (e2 : es2) = do 133 | -- e /\ sub <- unify e1 e2 134 | -- let es1' = map (Expr.subMetaExprPartially sub) es1 135 | -- let es2' = map (Expr.subMetaExprPartially sub) es2 136 | -- es /\ sub2 <- unifyLists es1' es2' 137 | -- pure $ (e : es) /\ composeSub sub sub2 138 | es /\ sub <- unifyLists es1 es2 139 | let e1' = Expr.subMetaExprPartially sub e1 140 | let e2' = Expr.subMetaExprPartially sub e2 141 | e /\ sub2 <- unify e1' e2' 142 | pure $ (e : es) /\ composeSub sub sub2 143 | unifyLists _ _ = Bug.bug "[unifyLists] shouldn't happen" 144 | 145 | ------------- Fast Unification ------------------------------------------------------ 146 | 147 | {- 148 | This version of unification is faster than the naive algorithm avoe. 149 | It turns out that the fastest algorithms are very complex, but this is at least faster. 150 | It also has the advantage that it can be composed conveniently in a monadic style. 151 | -} 152 | 153 | flattenHelperInsertVar :: forall l. Expr.IsExprLabel l => Sub l -> Expr.MetaVar -> State (Sub l) (Expr.MetaExpr l) 154 | flattenHelperInsertVar original x = do 155 | sub <- State.get 156 | case Map.lookup x sub of 157 | Just t -> pure t -- If var is already in the new sub, do nothing 158 | Nothing -> do -- Otherwise, if its in the original sub at all, then add it the output sub 159 | value <- case Map.lookup x original of 160 | Nothing -> pure $ Expr.MV x % [] 161 | Just t -> do 162 | value <- flattenHelper original t 163 | _ <- State.modify (Map.insert x value) 164 | pure value 165 | pure value 166 | 167 | flattenHelper :: forall l. Expr.IsExprLabel l => Sub l -> Expr.MetaExpr l -> State (Sub l) (Expr.MetaExpr l) 168 | flattenHelper original {-x-} (Expr.MV x % _) = flattenHelperInsertVar original x 169 | flattenHelper original {-x-} (l % kids) = do 170 | kids' <- sequence $ map (flattenHelper original) kids 171 | pure $ l % kids' 172 | 173 | -- The input is a non-idempotent substitution, and the output in the State is an idempotent subsitution 174 | flattenSubImpl :: forall l. Expr.IsExprLabel l => Sub l -> State (Sub l) Unit 175 | flattenSubImpl original = do 176 | -- traceM ("in flattenSubImpl, original is: " <> pretty original) 177 | _ <- sequence (map (\(key /\ _) -> flattenHelperInsertVar original key) (Map.toUnfoldable original :: List _)) 178 | -- result <- State.get 179 | -- traceM ("in flattenSubImpl, result is: " <> pretty result) 180 | pure unit 181 | 182 | -- makes a substitution idempotent. 183 | flattenSub :: forall l. Expr.IsExprLabel l => Sub l -> Sub l 184 | flattenSub sub = snd $ State.runState (flattenSubImpl sub) Map.empty 185 | 186 | -- occurs check with a non-idempotent sub as an enviroment 187 | recursiveOccurs :: forall l. Expr.IsExprLabel l => Sub l -> Expr.MetaVar -> Expr.MetaExpr l -> Boolean 188 | recursiveOccurs sub x e = 189 | case e of 190 | Expr.MV y % [] | Just e' <- Map.lookup y sub -> recursiveOccurs sub x e' 191 | Expr.MV x' % [] -> x' == x 192 | _ % kids -> Array.any (occurs x) kids -- TODO: should this be recursiveOccurs? 193 | 194 | -- NOTE: it may be confusing that the State in unifyFImpl is a completely different thing to the State in flatten* 195 | -- The (Sub l) in the State is the non-idempotent substitution being built up 196 | unifyFImpl :: forall l. Expr.IsExprLabel l => Expr.MetaExpr l -> Expr.MetaExpr l -> ExceptT Unit (State (Sub l)) (Expr.MetaExpr l) 197 | unifyFImpl e1@(Expr.Expr l1 kids1) e2@(Expr.Expr l2 kids2) = do 198 | sub <- State.get 199 | case l1 /\ l2 of 200 | Expr.MV x /\ _ | Just e1' <- Map.lookup x sub -> unifyFImpl e1' e2 201 | _ /\ Expr.MV x | Just e2' <- Map.lookup x sub -> unifyFImpl e1 e2' 202 | Expr.MV x1 /\ Expr.MV x2 | x1 == x2 -> pure e1 203 | Expr.MV x /\ _ | not (recursiveOccurs sub x e2) -> do 204 | _ <- lift $ State.modify (Map.insert x e2) 205 | pure e2 206 | _ /\ Expr.MV _ -> unifyFImpl e2 e1 207 | Expr.MInj l /\ Expr.MInj l' | l == l' -> do 208 | kids' <- sequence $ Array.zipWith unifyFImpl kids1 kids2 209 | pure ((Expr.MInj l) % kids') 210 | _ /\ _ -> throwError unit 211 | 212 | unifyF :: forall l. Expr.IsExprLabel l => Expr.MetaExpr l -> Expr.MetaExpr l -> Maybe (Expr.MetaExpr l /\ Sub l) 213 | unifyF e1 e2 = 214 | let maybeExpr /\ sub = State.runState (runExceptT (unifyFImpl e1 e2)) Map.empty in 215 | case maybeExpr of 216 | Left _ -> Nothing 217 | Right expr -> 218 | let flatSub = flattenSub sub in 219 | Just (Expr.subMetaExprPartially flatSub expr /\ flatSub) 220 | 221 | runUnifyMonad :: forall l b. Expr.IsExprLabel l => ExceptT Unit (State (Sub l)) b -> Maybe (Sub l /\ b) 222 | runUnifyMonad m = 223 | let maybeExpr /\ sub = State.runState (runExceptT m) Map.empty in 224 | case maybeExpr of 225 | Left _ -> Nothing 226 | Right x -> Just (flattenSub sub /\ x) 227 | 228 | ------------- Another operation I need for typechanges stuff ------------------ 229 | 230 | getMatches :: forall l. Expr.IsExprLabel l => Expr.MetaExpr l -> Expr.Expr l -> Maybe (MultiMap Expr.MetaVar (Expr.Expr l)) 231 | getMatches _e1@(Expr.Expr l1 kids1) e2@(Expr.Expr l2 kids2) = 232 | case l1 of 233 | Expr.MV x -> Just $ MultiMap.insert x e2 (MultiMap.empty) 234 | Expr.MInj l | l == l2 -> foldl (lift2 MultiMap.union) (Just MultiMap.empty) (Array.zipWith getMatches kids1 kids2) 235 | _ -> 236 | Nothing 237 | 238 | --getToothMatches :: forall l. Expr.IsExprLabel l => Expr.Tooth (Expr.Meta l) -> Expr.Tooth l 239 | -- -> Maybe (MultiMap Expr.MetaVar (Expr.Expr l)) 240 | --getToothMatches t1 t2 = ?h 241 | -------------------------------------------------------------------------------- /src/Language/Pantograph/Generic/ZipperMovement.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Generic.ZipperMovement where 2 | 3 | import Data.Either.Nested 4 | import Data.Expr 5 | import Data.Tuple.Nested 6 | import Prelude 7 | import Type.Direction 8 | 9 | import Data.Array as Array 10 | import Data.Either (Either(..)) 11 | import Data.List (List(..)) 12 | import Data.List.Rev as RevList 13 | import Data.List.Zip as ZipList 14 | import Data.Maybe (Maybe(..)) 15 | import Data.Tuple (fst, snd) 16 | import Data.Variant (case_, default, on) 17 | import Data.Zippable as Zippable 18 | import Debug (trace) 19 | import Hole (hole) 20 | import Hole as Hole 21 | import Util (fromJust') 22 | 23 | moveZipper :: forall l. MoveDir -> Zipper l -> Maybe (Zipper l) 24 | moveZipper = case_ 25 | # on _up (\_ -> Zippable.zipUp) 26 | # on _down (\_ -> Zippable.zipDown 0) 27 | # on _left (\_ -> Zippable.zipLeft) 28 | # on _right (\_ -> Zippable.zipRight) 29 | # on _prev (\_ -> Zippable.zipPrev) 30 | # on _next (\_ -> Zippable.zipNext 0) 31 | 32 | moveZipperp :: forall l. MoveDir -> Zipperp l -> Maybe (Zipper l \/ Zipperp l) 33 | moveZipperp dir = map normalizeZipperp <<< (case_ 34 | # on _up (\_ -> Zippable.zipUp) 35 | # on _down (\_ -> Zippable.zipDown 0) 36 | # on _left (\_ -> Zippable.zipLeft) 37 | # on _right (\_ -> Zippable.zipRight) 38 | # on _prev (\_ -> Zippable.zipPrev) 39 | # on _next (\_ -> Zippable.zipNext 0) 40 | $ dir) 41 | 42 | moveZipperpUntil :: forall l. MoveDir -> (Zipperp l -> Boolean) 43 | -> Zipperp l -> Maybe (Zipper l \/ Zipperp l) 44 | moveZipperpUntil dir valid zipperp = 45 | case moveZipperp dir zipperp of 46 | Nothing -> Nothing 47 | Just (Left zipper) -> Just (Left zipper) 48 | res@(Just (Right zipperp)) -> 49 | if valid zipperp then res 50 | else moveZipperpUntil dir valid zipperp 51 | 52 | 53 | 54 | -- {- 55 | -- I think this can be written in terms of ZipList.zipLeft and zipRight instead 56 | -- -} 57 | -- zipNext :: forall l. Int -> Zipper l -> Maybe (Zipper l) 58 | -- zipNext kidSkip zip = 59 | -- let children = zipDowns zip in 60 | -- case Array.index children kidSkip of 61 | -- Just (_ /\ child) -> Just child 62 | -- Nothing -> case zipUp zip of 63 | -- Just ((Tooth _ zipList) /\ parent) -> zipNext (ZipList.leftLength zipList + 1) parent 64 | -- Nothing -> Nothing 65 | 66 | -- zipPrev :: forall l. Zipper l -> Maybe (Zipper l) 67 | -- zipPrev zip@(Zipper _ expr) = 68 | -- case zipUp zip of 69 | -- Nothing -> Nothing 70 | -- Just (Tooth me zipList /\ parent) -> case ZipList.zipLeft (expr /\ zipList) of 71 | -- Nothing -> Just parent 72 | -- Just th -> 73 | -- let prevChild = snd $ fromJust' "zipPrev" $ Array.index (zipDowns parent) (ZipList.leftLength zipList - 1) in -- (Hole.hole "need to use th and parent to get a new position somehow") in 74 | -- Just $ lastChild prevChild 75 | 76 | -- lastChild :: forall l. Zipper l -> Zipper l 77 | -- lastChild zip = 78 | -- let children = zipDowns zip in 79 | -- case Array.index children (Array.length children - 1) of 80 | -- Nothing -> zip 81 | -- Just (_ /\ child) -> lastChild child 82 | 83 | 84 | -- moveZipperp :: forall l. MoveDir -> Zipperp l -> Maybe (Zipper l \/ Zipperp l) 85 | -- moveZipperp dir zipperp = do 86 | -- zipperp' <- moveZipperp' dir zipperp 87 | -- Just $ normalizeZipperp zipperp' 88 | 89 | -- | Normalize a Zipperp by turning it into a Zipper if it has an empty 90 | -- | selection. 91 | normalizeZipperp :: forall l. Zipperp l -> Zipper l \/ Zipperp l 92 | normalizeZipperp zipperp@(Zipperp path selection expr) = case selection of 93 | Left (Path Nil) -> Left (Zipper path expr) 94 | Right (Path Nil) -> Left (Zipper path expr) 95 | _ -> Right zipperp 96 | 97 | -- moveZipperp' :: forall l. MoveDir -> Zipperp l -> Maybe (Zipperp l) 98 | -- moveZipperp' = case_ 99 | -- # on _up (\_ (Zipperp path selection expr) -> case selection of 100 | -- Left downPath -> do 101 | -- th /\ path' <- unstepPath path 102 | -- Just (Zipperp path' (Left (stepPath th downPath)) expr) 103 | -- Right upPath -> do 104 | -- th /\ upPath' <- unstepPath upPath 105 | -- Just (Zipperp path (Right upPath') (unTooth th expr)) 106 | -- ) 107 | -- # on _down (\_ (Zipperp path selection expr) -> 108 | -- case selection of 109 | -- Left downPath -> do 110 | -- th /\ downPath' <- unstepPath downPath 111 | -- Just (Zipperp (stepPath th path) (Left downPath') expr) 112 | -- Right upPath -> do 113 | -- th /\ expr' <- tooth 0 expr 114 | -- Just (Zipperp path (Right (stepPath th upPath)) expr') 115 | -- ) 116 | -- # on _left (\_ (Zipperp path selection expr) -> 117 | -- case selection of 118 | -- Right upPath -> do 119 | -- Tooth l kidsZip /\ upPath' <- unstepPath upPath 120 | -- expr' /\ kidsZip' <- ZipList.zipLeft (expr /\ kidsZip) 121 | -- Just (Zipperp path (Right (stepPath (Tooth l kidsZip') upPath')) expr') 122 | -- Left _ -> Nothing -- can't zip left/right when selecting up 123 | -- ) 124 | -- # on _right (\_ (Zipperp path selection expr) -> 125 | -- case selection of 126 | -- Right upPath -> do 127 | -- Tooth l kidsZip /\ upPath' <- unstepPath upPath 128 | -- expr' /\ kidsZip' <- ZipList.zipRight (expr /\ kidsZip) 129 | -- Just (Zipperp path (Right (stepPath (Tooth l kidsZip') upPath')) expr') 130 | -- Left _ -> Nothing -- can't zip left/right when selecting up 131 | -- ) 132 | -- # on _prev (\_ -> Hole.hole "moveZipperp' prev") 133 | -- # on _next (\_ -> Hole.hole "moveZipperp' next") 134 | -------------------------------------------------------------------------------- /src/Language/Pantograph/Lib/DefaultEdits.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Lib.DefaultEdits where 2 | 3 | import Prelude 4 | 5 | import Language.Pantograph.Generic.Grammar 6 | import Language.Pantograph.Generic.Smallstep 7 | import Language.Pantograph.Generic.Unification 8 | import Prelude 9 | 10 | import Bug (bug) 11 | import Bug.Assertion (assert, assertI, just) 12 | import Control.Plus (empty) 13 | import Data.Array as Array 14 | import Data.Enum (enumFromTo) 15 | import Data.Expr ((%),(%<)) 16 | import Data.Zippable as Zippable 17 | import Data.Expr as Expr 18 | import Data.Lazy (Lazy, defer) 19 | import Data.List as List 20 | import Data.List.Zip as ZipList 21 | import Data.Map as Map 22 | import Data.Maybe (Maybe(..)) 23 | import Data.TotalMap as TotalMap 24 | import Data.Traversable (sequence) 25 | import Data.Tuple (fst) 26 | import Data.Tuple.Nested ((/\), type (/\)) 27 | import Hole (hole) 28 | import Text.Pretty (pretty) 29 | import Type.Direction (Up) 30 | import Debug (traceM) 31 | import Util (fromJust') 32 | import Language.Pantograph.Generic.Grammar as Grammar 33 | import Language.Pantograph.Generic.Smallstep as Smallstep 34 | import Language.Pantograph.Generic.Rendering.Base as Base 35 | import Language.Pantograph.Generic.ChangeAlgebra as ChangeAlgebra 36 | import Language.Pantograph.Generic.Edit as Edit 37 | import Type.Direction as Dir 38 | import Data.Maybe as Maybe 39 | import Data.Either (Either(..)) 40 | import Data.Tuple (uncurry) 41 | 42 | -- Makes edits which around any holes in the given term 43 | makeWrapEdits :: forall l r. Grammar.IsRuleLabel l r => 44 | (Sort l -> Boolean) 45 | -> ({bottom :: Sort l, top :: Sort l} -> Boolean) 46 | -> (DerivLabel l r -> Maybe (DerivLabel l r)) 47 | -> Base.SplitChangeType l 48 | -> String 49 | -> Grammar.Sort l -> Grammar.DerivTerm l r -> List.List (Edit.Edit l r) 50 | makeWrapEdits isValidCursorSort isValidSelectionSorts forgetSorts splitChange name cursorSort dterm = 51 | -- let getPaths dzipper = 52 | -- case Base.moveHDZUntil Dir.nextDir (\hdz -> Base.isValidCursor isValidCursorSort hdz && Base.hdzIsHolePosition hdz) (Base.HoleyDerivZipper dzipper false) of 53 | -- Nothing -> List.Nil 54 | -- Just (Base.HoleyDerivZipper zipper _) -> zipper List.: (getPaths zipper) 55 | -- in 56 | let getPaths dzipper@(Expr.Zipper path term) = 57 | let rest = List.concat $ map getPaths (List.fromFoldable $ Zippable.zipDowns dzipper) in 58 | if isValidCursorSort (derivTermSort term) && Grammar.isHole (Expr.exprLabel term) 59 | then dzipper List.: rest 60 | else rest 61 | in 62 | let edits = (flip List.mapMaybe (getPaths (Expr.Zipper (Expr.Path List.Nil) dterm)) \(Expr.Zipper path inside) -> 63 | do 64 | _ <- case path of -- cancel if the path is empty 65 | Expr.Path List.Nil -> Nothing 66 | _ -> Maybe.Just unit 67 | _ <- if isValidSelectionSorts {bottom: Grammar.derivTermSort inside, top: nonemptyUpPathTopSort path} 68 | then Just unit else Nothing 69 | makeEditFromPath forgetSorts splitChange (path /\ (Grammar.nonemptyPathInnerSort path)) 70 | name cursorSort) 71 | in if List.length edits == 0 then List.singleton { -- If no edits, then output a single error edit 72 | label: name 73 | , action: Left "can't wrap around this type" 74 | } 75 | else edits 76 | 77 | -- Makes an edit that inserts a path, and propagates the context change downwards and type change upwards 78 | makeEditFromPath :: forall l r. Grammar.IsRuleLabel l r => (DerivLabel l r -> Maybe (DerivLabel l r)) -> Base.SplitChangeType l 79 | -> Grammar.DerivPath Up l r /\ Grammar.Sort l -> String -> Grammar.Sort l -> Maybe (Edit.Edit l r) 80 | makeEditFromPath forgetSorts splitChange (path /\ bottomOfPathSort) name cursorSort = do 81 | action <- makeActionFromPath false forgetSorts splitChange path name cursorSort 82 | pure $ { label : name 83 | , action : pure $ defer \_ -> action -- TODO: Maybe I should find a way to use Lazy correctly here? And only the the necessary computation before it? 84 | } 85 | 86 | makeActionFromPath :: forall l r. Grammar.IsRuleLabel l r => 87 | Boolean -> (DerivLabel l r -> Maybe (DerivLabel l r)) -> Base.SplitChangeType l 88 | -> Grammar.DerivPath Up l r -> String -> Grammar.Sort l -> Maybe (Edit.Action l r) 89 | makeActionFromPath cursorGoesInside forgetSorts splitChange path name cursorSort = do 90 | let change = Smallstep.getPathChange2 path forgetSorts 91 | let {upChange: preTopChange, cursorSort: preCursorSort, downChange: preBotChange} = splitChange change 92 | _ /\ sub <- unify preCursorSort cursorSort 93 | let topChange = ChangeAlgebra.subSomeMetaChange sub preTopChange 94 | let botChange = ChangeAlgebra.subSomeMetaChange sub (ChangeAlgebra.invert preBotChange) 95 | let pathSubbed = subDerivPath sub path 96 | pure $ Edit.WrapAction { 97 | topChange 98 | , dpath : pathSubbed -- DerivPath Up l r 99 | , botChange 100 | , sub 101 | , cursorGoesInside 102 | } 103 | 104 | makeSubEditFromTerm :: forall l r. Grammar.IsRuleLabel l r => Grammar.DerivTerm l r -> String -> Grammar.Sort l -> Maybe (Edit.Edit l r) 105 | makeSubEditFromTerm dterm name cursorSort = do 106 | _ /\ sub <- unify (Grammar.derivTermSort dterm) cursorSort 107 | pure $ { label : name 108 | , action : pure $ defer \_ -> Edit.FillAction 109 | { 110 | sub 111 | , dterm : Grammar.subDerivTerm sub dterm 112 | } 113 | } 114 | 115 | makeChangeEditFromTerm :: forall l r. Grammar.IsRuleLabel l r => Grammar.DerivTerm l r -> String -> Grammar.Sort l -> Maybe (Edit.Edit l r) 116 | makeChangeEditFromTerm dterm name cursorSort = do 117 | newCursorSort /\ sub <- unify (Grammar.derivTermSort dterm) cursorSort 118 | pure $ { label : name 119 | , action : pure $ defer \_ -> Edit.ReplaceAction 120 | { 121 | topChange: ChangeAlgebra.diff cursorSort newCursorSort 122 | , dterm : Grammar.subDerivTerm sub dterm 123 | } 124 | } 125 | -------------------------------------------------------------------------------- /src/Language/Pantograph/Specific/CurryingInterpereter.purs: -------------------------------------------------------------------------------- 1 | module Language.Pantograph.Specific.CurryingInterpereter where 2 | 3 | import Prelude 4 | import Language.Pantograph.Generic.Grammar as Grammar 5 | import Data.Expr 6 | import Data.List (List(..), (:)) 7 | import Data.List as List 8 | import Bug (bug) 9 | import Language.Pantograph.Specific.Currying 10 | import Data.Tuple.Nested 11 | import Data.Maybe (Maybe(..)) 12 | import Data.Maybe as Maybe 13 | import Data.Either (Either(..)) 14 | import Data.Either as Either 15 | import Util as Util 16 | import Data.Int (pow) 17 | import Data.Lazy (Lazy, defer, force) 18 | import Hole (realCatchException) 19 | 20 | data Value = IntVal Int | BoolVal Boolean | ListVal (List Value) | FunVal (Value -> Either Error Value) 21 | 22 | eqValue :: Value -> Value -> Boolean 23 | eqValue v1 v2 = case v1 /\ v2 of 24 | IntVal x /\ IntVal y -> x == y 25 | BoolVal x /\ BoolVal y -> x == y 26 | ListVal x /\ ListVal y -> List.all (\x -> x) (List.zipWith eqValue x y) 27 | _ /\ _ -> false 28 | 29 | assertValInt :: Value -> Int 30 | assertValInt = case _ of 31 | IntVal x -> x 32 | _ -> bug "assertValint failed" 33 | assertValBool :: Value -> Boolean 34 | assertValBool = case _ of 35 | BoolVal x -> x 36 | _ -> bug "assertValint failed" 37 | assertValList :: Value -> (List Value) 38 | assertValList = case _ of 39 | ListVal x -> x 40 | _ -> bug "assertValint failed" 41 | assertValFun :: Value -> (Value -> Either Error Value) 42 | assertValFun = case _ of 43 | FunVal x -> x 44 | _ -> bug "assertValint failed" 45 | 46 | data Error = HoleError | BoundaryError | FreeVarError 47 | 48 | eval :: (List (Lazy (Either Error Value))) -> DerivTerm -> Either Error Value 49 | eval env ((Grammar.DerivLabel r _) % kids) = 50 | case r /\ kids of 51 | Zero /\ [] -> force $ Util.fromJust' "eval Zero case" $ List.head env 52 | Suc /\ [x] -> eval (Util.fromJust' "eval suc" (List.tail env)) x 53 | Lam /\ [_name, _ty, t] -> pure $ FunVal (\x -> eval (pure (Right x) : env) t) 54 | Let /\ [_name, _ty, def, body] -> do 55 | let vDef = eval ((defer \_ -> vDef) : env) def 56 | eval (pure vDef : env) body 57 | App /\ [t1, t2] -> do 58 | v1 <- eval env t1 59 | v2 <- eval env t2 60 | assertValFun v1 v2 61 | GreyApp /\ [t, _] -> eval env t 62 | Var /\ [x] -> eval env x 63 | FreeVar /\ [] -> Left FreeVarError 64 | TermHole /\ [_type] -> Left HoleError 65 | -- TypeHole /\ [] -> ?h 66 | -- DataTypeRule dataType /\ [] -> ?h 67 | -- ArrowRule /\ [] -> ?h 68 | -- ListRule /\ [] -> ?h 69 | Newline /\ [t] -> eval env t 70 | If /\ [cond, thenn, elsee] -> do 71 | vCond <- eval env cond 72 | -- vThenn <- eval env thenn 73 | -- vElsee <- eval env elsee 74 | if (assertValBool vCond) then eval env thenn else eval env elsee 75 | ErrorBoundary /\ [_] -> Left BoundaryError 76 | ConstantRule constant /\ [] -> pure $ evalConst constant 77 | InfixRule infixOperator /\ [t1, t2] -> do 78 | v1 <- eval env t1 79 | v2 <- eval env t2 80 | pure $ evalInfix infixOperator v1 v2 81 | EqualsRule /\ [t1, t2] -> do 82 | v1 <- eval env t1 83 | v2 <- eval env t2 84 | pure $ BoolVal (eqValue v1 v2) 85 | NilRule /\ [] -> pure $ ListVal Nil 86 | ConsRule /\ [] -> pure $ FunVal (\x -> pure (FunVal (\xs -> pure (ListVal (x : assertValList xs))))) 87 | LengthRule /\ [] -> pure $ FunVal (\xs -> pure (IntVal (List.length (assertValList xs)))) 88 | AppendRule /\ [] -> pure $ FunVal (\xs -> pure (FunVal (\ys -> pure (ListVal (assertValList xs <> assertValList ys))))) 89 | HeadRule /\ [] -> pure $ FunVal (\xs -> pure (Util.fromJust (List.head (assertValList xs)))) 90 | TailRule /\ [] -> pure $ FunVal (\xs -> pure (ListVal (Util.fromJust (List.tail (assertValList xs))))) 91 | IndexRule /\ [] -> pure $ FunVal (\xs -> pure (FunVal (\n -> pure (Util.fromJust (List.index (assertValList xs) (assertValInt n)))))) 92 | ListMatchRule /\ [li, nilCase, _, _, consCase] -> do 93 | vLi <- eval env li 94 | case assertValList vLi of 95 | Nil -> eval env nilCase 96 | v : vs -> eval (pure (Right v) : pure (Right (ListVal vs)) : env) consCase 97 | IntegerLiteral /\ [Grammar.DerivLiteral (Grammar.DataInt n) % []] -> pure (IntVal n) 98 | Comment /\ [_, a] -> eval env a 99 | _ -> bug ("eval case fail: rule was " <> show r) 100 | eval _ _ = bug "eval case shouldn't happen" 101 | 102 | evalConst :: Constant -> Value 103 | evalConst = case _ of 104 | ConstTrue -> BoolVal true 105 | ConstFalse -> BoolVal false 106 | ConstNot -> FunVal (\b -> pure (BoolVal (not (assertValBool b)))) 107 | 108 | evalInfix :: InfixOperator -> (Value -> Value -> Value) 109 | evalInfix = case _ of 110 | OpPlus -> \x y -> IntVal (assertValInt x + assertValInt y) 111 | OpMinus -> \x y -> IntVal (assertValInt x - assertValInt y) 112 | OpTimes -> \x y -> IntVal (assertValInt x * assertValInt y) 113 | OpDivide -> \x y -> IntVal (assertValInt x / assertValInt y) 114 | OpMod -> \x y -> IntVal (mod (assertValInt x) (assertValInt y)) 115 | OpPow -> \x y -> IntVal (pow (assertValInt x) (assertValInt y)) 116 | OpLess -> \x y -> BoolVal (assertValInt x < assertValInt y) 117 | OpGreater -> \x y -> BoolVal (assertValInt x > assertValInt y) 118 | OpLessEq -> \x y -> BoolVal (assertValInt x <= assertValInt y) 119 | OpGreaterEq -> \x y -> BoolVal (assertValInt x >= assertValInt y) 120 | OpAnd -> \x y -> BoolVal (assertValBool x && assertValBool y) 121 | OpOr -> \x y -> BoolVal (assertValBool x || assertValBool y) 122 | 123 | printValue :: Value -> String 124 | printValue val = case val of 125 | BoolVal x -> show x 126 | IntVal x -> show x 127 | ListVal x -> List.foldr (\x xs -> "(cons " <> (printValue x) <> " " <> xs <> ")") "nil" x 128 | FunVal _ -> "" 129 | 130 | interpereter :: Grammar.DerivTerm PreSortLabel RuleLabel -> String 131 | interpereter dterm = 132 | let res = realCatchException Left Right (\_ -> eval Nil dterm) in 133 | case res of 134 | Right (Left error) -> case error of 135 | HoleError -> "Error: hole" 136 | BoundaryError -> "Error: type boundary" 137 | FreeVarError -> "Error: unbound variable" 138 | Right (Right res) -> printValue res 139 | Left error -> "Error: infinite loop" 140 | -------------------------------------------------------------------------------- /src/Log.js: -------------------------------------------------------------------------------- 1 | export const _log = tag => x => k => { 2 | console.log(`--[ ${tag} ]---------------------------------------------------`) 3 | console.log(x) 4 | return k({}) 5 | } -------------------------------------------------------------------------------- /src/Log.purs: -------------------------------------------------------------------------------- 1 | module Log where 2 | 3 | import Prelude 4 | 5 | _logging :: Boolean 6 | _logging = false 7 | 8 | foreign import _log :: forall x a. String -> x -> (Unit -> a) -> a 9 | 10 | log :: forall x a. String -> x -> (Unit -> a) -> a 11 | log | _logging = _log 12 | log = \_ _ k -> k unit 13 | 14 | logM :: forall m x. Monad m => String -> x -> m Unit 15 | logM | _logging = \tag x -> do 16 | pure unit 17 | log tag x \_ -> pure unit 18 | logM = const <<< const $ pure unit 19 | -------------------------------------------------------------------------------- /src/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import MainStandalone as MainStandalone 6 | import MainTutorial as MainTutorial 7 | 8 | {- 9 | -- Maybe in the future we can make a better way, but for now you can switch which thing gets run by uncommenting the correct main function 10 | 11 | -- Some different languages 12 | --main :: Effect Unit 13 | --main = runEditorForLang FullyApplied.editorSpec 14 | 15 | main_standalone :: Effect Unit 16 | main_standalone = runEditorForLang {spec: Currying.editorSpec, interpreter: CurryingInterpereter.interpereter } 17 | 18 | --main :: Effect Unit 19 | --main = runEditorForLang Multary.editorSpec 20 | 21 | runEditorForLang :: forall l r. Grammar.IsRuleLabel l r => { spec :: Base.EditorSpec l r, interpreter :: Grammar.DerivTerm l r -> String } -> Effect Unit 22 | runEditorForLang {spec, interpreter } = HA.runHalogenAff do 23 | Console.log "[main]" 24 | body <- HA.awaitBody 25 | VDomDriver.runUI RunnableEditor.component {spec, interpreter } body 26 | 27 | -- Tutorial 28 | main_tutorial :: Effect Unit 29 | main_tutorial = EditorTutorial2.runTutorial Currying.editorSpec CurriedTutorial.lessons CurryingInterpereter.interpereter 30 | 31 | data Mode = Standalone | Tutorial 32 | 33 | main :: Effect Unit 34 | main = case Tutorial of 35 | Standalone -> main_standalone 36 | Tutorial -> main_tutorial 37 | -} 38 | data Mode 39 | = Standalone 40 | | Tutorial 41 | 42 | main :: Effect Unit 43 | main = 44 | let 45 | opts = 46 | { active_mode: Tutorial 47 | } 48 | in 49 | case opts.active_mode of 50 | Standalone -> MainStandalone.main 51 | Tutorial -> MainTutorial.main 52 | -------------------------------------------------------------------------------- /src/MainStandalone.purs: -------------------------------------------------------------------------------- 1 | module MainStandalone (main) where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import Effect.Class.Console as Console 6 | import Halogen.Aff as HA 7 | import Halogen.VDom.Driver as VDomDriver 8 | import Language.Pantograph.Generic.Grammar as Grammar 9 | import Language.Pantograph.Generic.Rendering.Base as Base 10 | import Language.Pantograph.Generic.Rendering.RunnableEditor as RunnableEditor 11 | import Language.Pantograph.Specific.Currying as Currying 12 | import Language.Pantograph.Specific.CurryingInterpereter as CurryingInterpereter 13 | 14 | main :: Effect Unit 15 | main = runEditorForLang { spec: Currying.editorSpec, interpreter: CurryingInterpereter.interpereter } 16 | 17 | runEditorForLang :: forall l r. Grammar.IsRuleLabel l r => { spec :: Base.EditorSpec l r, interpreter :: Grammar.DerivTerm l r -> String } -> Effect Unit 18 | runEditorForLang { spec, interpreter } = 19 | HA.runHalogenAff do 20 | Console.log "[main]" 21 | body <- HA.awaitBody 22 | VDomDriver.runUI RunnableEditor.component { spec, interpreter } body 23 | -------------------------------------------------------------------------------- /src/MainTutorial.purs: -------------------------------------------------------------------------------- 1 | module MainTutorial (main) where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import Language.Pantograph.Specific.Currying as Currying 6 | import Language.Pantograph.Specific.CurryingInterpereter as CurryingInterpereter 7 | import Tutorial.CurriedTutorial as CurriedTutorial 8 | import Tutorial.EditorTutorial2 as EditorTutorial2 9 | 10 | main :: Effect Unit 11 | main = 12 | EditorTutorial2.runTutorial 13 | Currying.editorSpec 14 | CurriedTutorial.lessons 15 | CurryingInterpereter.interpereter 16 | -------------------------------------------------------------------------------- /src/Text/Pretty.purs: -------------------------------------------------------------------------------- 1 | module Text.Pretty where 2 | 3 | import Prelude 4 | 5 | import Data.Array (concat, foldMap, intercalate) 6 | import Data.Functor.Compose (Compose(..)) 7 | import Data.List as List 8 | import Data.List.Rev as Rev 9 | import Data.Map as Map 10 | import Data.Set as Set 11 | import Data.Maybe (Maybe, maybe) 12 | import Data.String (Pattern(..)) 13 | import Data.String as String 14 | import Data.Tuple (Tuple(..)) 15 | import Data.Either (Either(..)) 16 | 17 | class Pretty a where pretty :: a -> String 18 | 19 | instance Pretty String where pretty = identity 20 | instance Pretty Int where pretty = show 21 | instance Pretty Boolean where pretty = show 22 | instance Pretty a => Pretty (List.List a) where pretty xs = "[" <> List.intercalate ", " (pretty <$> xs) <> "]" 23 | instance Pretty a => Pretty (Array a) where pretty xs = "[" <> intercalate ", " (pretty <$> xs) <> "]" 24 | instance Pretty a => Pretty (Maybe a) where pretty = maybe "NOTHING" pretty 25 | instance (Pretty a, Pretty b) => Pretty (Tuple a b) where pretty (Tuple a b) = pretty a <> ", " <> pretty b 26 | instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where 27 | pretty m = 28 | "map:" <> 29 | indent (bullets (Map.toUnfoldable m <#> \(Tuple k v) -> pretty k <> " ↦ " <> pretty v)) 30 | instance (Pretty t) => Pretty (Set.Set t) where 31 | pretty s = "{" <> List.intercalate ", " (Set.map pretty s) <> "}" 32 | instance (Pretty a, Pretty b) => Pretty (Either a b) where 33 | pretty (Left a) = "Left " <> pretty a 34 | pretty (Right a) = "Right " <> pretty a 35 | 36 | {- 37 | -- | Pretty `a` that takes an argument of type `b`. 38 | class Pretty' a b | a -> b where 39 | pretty' :: b -> a -> String 40 | 41 | instance Pretty a => Pretty' (List.List a) String where pretty' sep xs = "[" <> List.intercalate sep (pretty <$> xs) <> "]" 42 | instance Pretty a => Pretty' (Rev.RevList a) String where pretty' sep xs = "[" <> List.intercalate sep (pretty <$> Rev.unreverse xs) <> "]" 43 | instance Pretty a => Pretty' (Array a) String where pretty' sep xs = "[" <> intercalate sep (pretty <$> xs) <> "]" 44 | instance Pretty a => Pretty' (Maybe a) String where pretty' nothing = maybe nothing pretty 45 | -} 46 | 47 | {- 48 | class PrettyContainer t where prettyContainer :: forall a. Pretty a => t a -> String 49 | 50 | instance PrettyContainer List.List where prettyContainer xs = "[" <> List.foldMap pretty xs <> "]" 51 | instance PrettyContainer Array where prettyContainer xs = "[" <> foldMap pretty xs <> "]" 52 | instance PrettyContainer Maybe where prettyContainer xs = maybe "NOTHING" pretty xs 53 | 54 | instance (PrettyContainer t1, Functor t1, PrettyContainer t2) => PrettyContainer (Compose t1 t2) where prettyContainer (Compose t12) = prettyContainer (prettyContainer <$> t12) 55 | instance (PrettyContainer t, Functor t, Pretty a) => Pretty (t a) where pretty ta = prettyContainer (pretty <$> ta) 56 | -} 57 | 58 | appendSpaced :: String -> String -> String 59 | appendSpaced str1 str2 | String.null str1 = str2 60 | appendSpaced str1 str2 | String.null str2 = str1 61 | appendSpaced str1 str2 = str1 <> " " <> str2 62 | 63 | infixr 5 appendSpaced as <+> 64 | 65 | indent :: String -> String 66 | indent = intercalate "\n" <<< map (" " <> _) <<< String.split (Pattern "\n") 67 | 68 | surround :: String -> String -> String -> String 69 | surround left right str = left <> str <> right 70 | 71 | quotes = surround "'" "'" 72 | quotes2 = surround "\"" "\"" 73 | parens = surround "(" ")" 74 | brackets = surround "[" "]" 75 | braces = surround "{" "}" 76 | braces2 = surround "{{" "}}" 77 | cursor = surround "⌶{" "}" 78 | angles = surround "<" ">" 79 | ticks = surround "`" "`" 80 | 81 | commas = intercalate ", " 82 | newlines = intercalate "\n" 83 | -- bullets = intercalate "\n - " 84 | bullets :: Array String -> String 85 | bullets = indent <<< foldMap ("\n- " <> _) <<< map (intercalate "\n " <<< String.split (Pattern "\n")) 86 | -------------------------------------------------------------------------------- /src/Tutorial/CurriedTutorial.purs: -------------------------------------------------------------------------------- 1 | module Tutorial.CurriedTutorial where 2 | 3 | import Prelude 4 | import Tutorial.Markdown (HTML, parseMd) 5 | import CSS as CSS 6 | import CSS.Size as CSSSize 7 | import Data.Array as Array 8 | import Data.Bifunctor (bimap) 9 | import Data.Expr as Expr 10 | import Data.Lazy (Lazy, defer, force) 11 | import Data.List (List(..)) 12 | import Halogen.HTML as HH 13 | import Halogen.HTML.CSS as HCSS 14 | import Halogen.Utilities (classNames) 15 | import Language.Pantograph.Generic.Grammar as Grammar 16 | import Language.Pantograph.Generic.Rendering.Base as Base 17 | import Language.Pantograph.Generic.Rendering.Rendering as Rendering 18 | import Language.Pantograph.Specific.Currying as Currying 19 | import Tutorial.CurriedTutorial.ProblemLessons as ProblemLessons 20 | import Tutorial.CurriedTutorial.TutorialLessons as TutorialLessons 21 | import Tutorial.EditorTutorial2 (Lesson) 22 | 23 | {- 24 | A specific tutorial for the Currying.purs language 25 | -} 26 | prog :: String -> Grammar.DerivTerm Currying.PreSortLabel Currying.RuleLabel 27 | prog str = Grammar.decodeSerializedZipper2 Currying.editorSpec.clipboardSort str 28 | 29 | renderProgram :: String -> HH.HTML Unit Unit 30 | renderProgram program = 31 | HH.div [ classNames [ "program" ] ] 32 | $ pure 33 | $ bimap (const unit) (const unit) 34 | $ Rendering.renderDerivTerm 35 | (Base.trivialEditorLocals Currying.editorSpec) 36 | false 37 | false 38 | (Expr.Zipper (Expr.Path Nil) (Grammar.decodeSerializedZipper2 Currying.editorSpec.clipboardSort program)) 39 | (Base.defaultRenderingContext "TEST") 40 | { isInteractive = false } 41 | 42 | makeLesson :: String -> Array String -> Lazy HTML -> Lazy (Lesson Currying.PreSortLabel Currying.RuleLabel) 43 | makeLesson progString paths instructions = 44 | defer \_ -> 45 | let 46 | program = prog progString 47 | in 48 | { program 49 | , paths: map (Grammar.deserializePath program) paths 50 | , instructions: force instructions 51 | } 52 | 53 | makeLesson' :: String -> Array String -> Lazy (HH.HTML Unit Unit) -> Lazy (Lesson Currying.PreSortLabel Currying.RuleLabel) 54 | makeLesson' progString paths instructions = 55 | defer \_ -> 56 | let 57 | program = prog progString 58 | in 59 | { program 60 | , paths: map (Grammar.deserializePath program) paths 61 | , instructions: force instructions 62 | } 63 | 64 | selectionsWarning :: String 65 | selectionsWarning = 66 | if false then 67 | """ 68 | ♯italic⟦Note⟧. 69 | ♯bold⟦Be very precise when making selections!⟧ 70 | If you get stuck, you can ♯button⟦Reset⟧ or undo (ctrl+z). 71 | ♯br♯br 72 | """ 73 | else 74 | "" 75 | 76 | editActions :: Array (HH.HTML Unit Unit) 77 | editActions = 78 | [ HH.div 79 | [ HCSS.style do 80 | CSS.border CSS.inset borderWidth CSS.black 81 | (let s = CSS.em 0.5 in CSS.padding s s s s) 82 | CSS.marginTop $ CSS.em 1.0 83 | (let s = CSS.em 0.5 in CSS.borderRadius s s s s) 84 | ] 85 | [ HH.div 86 | [ HCSS.style do 87 | CSS.rule $ CSS.Property (CSS.fromString "font-variant-caps") (CSS.Value (CSS.fromString "small-caps")) 88 | CSS.rule $ CSS.Property (CSS.fromString "text-align") (CSS.Value (CSS.fromString "center")) 89 | ] 90 | [ HH.text "Pantograph Cheatsheet" ] 91 | , HH.hr 92 | [ HCSS.style do 93 | CSS.rule $ CSS.Property (CSS.fromString "border") (CSS.Value (CSS.fromString "none")) 94 | CSS.borderBottom CSS.inset borderWidth CSS.black 95 | ] 96 | , let 97 | li = 98 | HH.li 99 | [ HCSS.style do 100 | (let s = CSSSize.unitless 0.0 in CSS.margin s s s s) 101 | (let s = CSSSize.unitless 0.0 in CSS.padding s s s s) 102 | CSS.marginLeft (CSS.em (-1.0)) 103 | ] 104 | in 105 | HH.ul 106 | [ HCSS.style do 107 | CSS.display CSS.flex 108 | CSS.flexDirection CSS.column 109 | CSS.rule $ CSS.Property (CSS.fromString "gap") (CSS.value (CSS.em 1.0)) 110 | ] 111 | [ li $ parseMd """ ♯bold⟦Fill in a hole⟧: write the value in the hole """ 112 | , li $ parseMd """ ♯bold⟦Wrap a form around an term⟧: write the value at the term """ 113 | , li $ parseMd """ ♯bold⟦Delete a term or selection⟧: press "Delete" """ 114 | , li $ parseMd """ ♯bold⟦Name a variable⟧: write the variable's new name at the variable """ 115 | , li $ parseMd """ ♯bold⟦Built-in functions⟧: """ 116 | , HH.ul_ 117 | [ li $ parseMd """ ♯code⟦+⟧, ♯code⟦-⟧, ♯code⟦*⟧, ♯code⟦/⟧, ♯code⟦%⟧: integer operations """ 118 | , li $ parseMd """ ♯code⟦if⟧: branch on a boolean condition """ 119 | , li $ parseMd """ ♯code⟦match⟧: pattern-match on the ♯code⟦nil⟧ and ♯code⟦cons⟧ case of a list """ 120 | ] 121 | ] 122 | ] 123 | ] 124 | where 125 | -- borderWidth = CSS.em 0.2 126 | borderWidth = CSS.px 2.0 127 | 128 | divFlexColumn :: forall w i. Array (HH.HTML w i) -> HH.HTML w i 129 | divFlexColumn = 130 | HH.div 131 | [ HCSS.style do 132 | CSS.display CSS.flex 133 | CSS.flexDirection CSS.column 134 | ] 135 | 136 | lessons :: Array (Lazy (Lesson Currying.PreSortLabel Currying.RuleLabel)) 137 | lessons = 138 | Array.concat 139 | [ TutorialLessons.lessons 140 | -- , ProblemLessons.lessons 141 | ] 142 | -------------------------------------------------------------------------------- /src/Tutorial/CurriedTutorial/Common.purs: -------------------------------------------------------------------------------- 1 | module Tutorial.CurriedTutorial.Common where 2 | 3 | import Prelude 4 | import Tutorial.Markdown (HTML, parseMd) 5 | import CSS as CSS 6 | import CSS.Size as CSSSize 7 | import Data.Bifunctor (bimap) 8 | import Data.Expr as Expr 9 | import Data.Lazy (Lazy, defer, force) 10 | import Data.List (List(..)) 11 | import Halogen.HTML as HH 12 | import Halogen.HTML.CSS as HCSS 13 | import Halogen.Utilities (classNames) 14 | import Language.Pantograph.Generic.Grammar as Grammar 15 | import Language.Pantograph.Generic.Rendering.Base as Base 16 | import Language.Pantograph.Generic.Rendering.Rendering as Rendering 17 | import Language.Pantograph.Specific.Currying as Currying 18 | import Tutorial.EditorTutorial2 (Lesson) 19 | 20 | prog :: String -> Grammar.DerivTerm Currying.PreSortLabel Currying.RuleLabel 21 | prog str = Grammar.decodeSerializedZipper2 Currying.editorSpec.clipboardSort str 22 | 23 | renderProgram :: String -> HH.HTML Unit Unit 24 | renderProgram program = 25 | HH.div [ classNames [ "program" ] ] 26 | $ pure 27 | $ bimap (const unit) (const unit) 28 | $ Rendering.renderDerivTerm 29 | (Base.trivialEditorLocals Currying.editorSpec) 30 | false 31 | false 32 | (Expr.Zipper (Expr.Path Nil) (Grammar.decodeSerializedZipper2 Currying.editorSpec.clipboardSort program)) 33 | (Base.defaultRenderingContext "TEST") 34 | { isInteractive = false } 35 | 36 | makeLesson :: String -> Array String -> Lazy HTML -> Lazy (Lesson Currying.PreSortLabel Currying.RuleLabel) 37 | makeLesson progString paths instructions = 38 | defer \_ -> 39 | let 40 | program = prog progString 41 | in 42 | { program 43 | , paths: map (Grammar.deserializePath program) paths 44 | , instructions: force instructions 45 | } 46 | 47 | makeLesson' :: String -> Array String -> Lazy (HH.HTML Unit Unit) -> Lazy (Lesson Currying.PreSortLabel Currying.RuleLabel) 48 | makeLesson' progString paths instructions = 49 | defer \_ -> 50 | let 51 | program = prog progString 52 | in 53 | { program 54 | , paths: map (Grammar.deserializePath program) paths 55 | , instructions: force instructions 56 | } 57 | 58 | selectionsWarning :: String 59 | selectionsWarning = 60 | if false then 61 | """ 62 | ♯italic⟦Note⟧. 63 | ♯bold⟦Be very precise when making selections!⟧ 64 | If you get stuck, you can ♯button⟦Reset⟧ or undo (ctrl+z). 65 | ♯br♯br 66 | """ 67 | else 68 | "" 69 | 70 | editActions :: Array (HH.HTML Unit Unit) 71 | editActions = 72 | [ HH.div 73 | [ HCSS.style do 74 | CSS.border CSS.inset borderWidth CSS.black 75 | (let s = CSS.em 0.5 in CSS.padding s s s s) 76 | CSS.marginTop $ CSS.em 1.0 77 | (let s = CSS.em 0.5 in CSS.borderRadius s s s s) 78 | ] 79 | [ HH.div 80 | [ HCSS.style do 81 | CSS.rule $ CSS.Property (CSS.fromString "font-variant-caps") (CSS.Value (CSS.fromString "small-caps")) 82 | CSS.rule $ CSS.Property (CSS.fromString "text-align") (CSS.Value (CSS.fromString "center")) 83 | ] 84 | [ HH.text "Pantograph Cheatsheet" ] 85 | , HH.hr 86 | [ HCSS.style do 87 | CSS.rule $ CSS.Property (CSS.fromString "border") (CSS.Value (CSS.fromString "none")) 88 | CSS.borderBottom CSS.inset borderWidth CSS.black 89 | ] 90 | , let 91 | li = 92 | HH.li 93 | [ HCSS.style do 94 | (let s = CSSSize.unitless 0.0 in CSS.margin s s s s) 95 | (let s = CSSSize.unitless 0.0 in CSS.padding s s s s) 96 | CSS.marginLeft (CSS.em (-1.0)) 97 | ] 98 | in 99 | HH.ul 100 | [ HCSS.style do 101 | CSS.display CSS.flex 102 | CSS.flexDirection CSS.column 103 | CSS.rule $ CSS.Property (CSS.fromString "gap") (CSS.value (CSS.em 1.0)) 104 | ] 105 | [ li $ parseMd """ ♯bold⟦Fill in a hole⟧: write the value in the hole """ 106 | , li $ parseMd """ ♯bold⟦Wrap a form around an term⟧: write the value at the term """ 107 | , li $ parseMd """ ♯bold⟦Delete a term or selection⟧: press "Delete" """ 108 | , li $ parseMd """ ♯bold⟦Name a variable⟧: write the variable's new name at the variable """ 109 | , li $ parseMd """ ♯bold⟦Built-in functions⟧: """ 110 | , HH.ul_ 111 | [ li $ parseMd """ ♯code⟦+⟧, ♯code⟦-⟧, ♯code⟦*⟧, ♯code⟦/⟧, ♯code⟦%⟧: integer operations """ 112 | , li $ parseMd """ ♯code⟦if⟧: branch on a boolean condition """ 113 | , li $ parseMd """ ♯code⟦match⟧: pattern-match on the ♯code⟦nil⟧ and ♯code⟦cons⟧ case of a list """ 114 | ] 115 | ] 116 | ] 117 | ] 118 | where 119 | -- borderWidth = CSS.em 0.2 120 | borderWidth = CSS.px 2.0 121 | 122 | divFlexColumn :: forall w i. Array (HH.HTML w i) -> HH.HTML w i 123 | divFlexColumn = 124 | HH.div 125 | [ HCSS.style do 126 | CSS.display CSS.flex 127 | CSS.flexDirection CSS.column 128 | ] 129 | -------------------------------------------------------------------------------- /src/Tutorial/EditorTutorial2.purs: -------------------------------------------------------------------------------- 1 | module Tutorial.EditorTutorial2 where 2 | 3 | import Data.Tuple.Nested 4 | import Prelude 5 | 6 | import Bug as Bug 7 | import CSS as CSS 8 | import CSS.Cursor as CSSCursor 9 | import CSS.Font as CSSFont 10 | import Data.Array as Array 11 | import Data.Lazy (Lazy, force, defer) 12 | import Data.Maybe (Maybe(..)) 13 | import Data.NonEmpty as NonEmpty 14 | import Data.Tuple (Tuple(..)) 15 | import Debug (traceM, trace) 16 | import Debug as Debug 17 | import Effect (Effect) 18 | import Effect.Aff (Aff) 19 | import Effect.Class.Console as Console 20 | import Effect.Unsafe (unsafePerformEffect) 21 | import Halogen as H 22 | import Halogen.Aff as HA 23 | import Halogen.Component (ComponentSlot) 24 | import Halogen.HTML as HH 25 | import Halogen.HTML.CSS as HCSS 26 | import Halogen.HTML.Events as HE 27 | import Halogen.HTML.Properties as HP 28 | import Halogen.Utilities (classNames, get_url_search_param) 29 | import Halogen.VDom.Driver as VDomDriver 30 | import Language.Pantograph.Generic.Grammar as Grammar 31 | import Language.Pantograph.Generic.Rendering.Base as Base 32 | import Language.Pantograph.Generic.Rendering.Editor as Editor 33 | import Type.Direction as Dir 34 | import Type.Proxy (Proxy(..)) 35 | import Unsafe.Coerce (unsafeCoerce) 36 | import Util as Util 37 | import Web.HTML.Common (AttrName(..)) 38 | 39 | {- 40 | I was having issues with all the components reading keyboard input at the same time before, so now I'm going to do it 41 | with just a single editor and statefully setting the program 42 | -} 43 | 44 | type Slots l r = ( editor :: H.Slot (Editor.EditorQuery l r) (Base.EditorSpec l r) Unit) 45 | _editorSlot = Proxy :: Proxy "editor" 46 | 47 | --newtype MyHTML = MyHTML (forall w i. HH.HTML w i) 48 | 49 | type Lesson l r = { 50 | program:: Grammar.DerivTerm l r 51 | , paths:: Array (Grammar.DerivPath Dir.Up l r) 52 | , instructions:: HH.HTML Unit Unit -- forall w i. HH.HTML w i 53 | } 54 | 55 | data PantographLessonAction = EditorOutput Unit | Initialize | ResetLesson | PreviousLesson | NextLesson | RunProgram | SetLesson Int 56 | 57 | makePantographTutorial :: forall l r query input output. Grammar.IsRuleLabel l r => 58 | Base.EditorSpec l r 59 | -> Array (Lazy (Lesson l r)) 60 | -> (Grammar.DerivTerm l r -> String) 61 | -> H.Component query input output Aff 62 | makePantographTutorial spec lessons interpereter = 63 | -- let paths = defer \_ -> force markedPaths <#> \path -> (Base.HoleyDerivPath path false) in 64 | 65 | H.mkComponent 66 | { initialState 67 | , render 68 | , eval: H.mkEval H.defaultEval { 69 | handleAction = handleAction, 70 | -- handleQuery = handleQuery, 71 | initialize = Just Initialize 72 | } 73 | } 74 | where 75 | editorComponent = Editor.editorComponent unit 76 | convertPaths markedPaths = markedPaths <#> \path -> (Base.HoleyDerivPath path false) 77 | initialState _ = 78 | { activeLesson : 0 79 | , lessonsSolved : Array.replicate (Array.length lessons) false 80 | , output : "" 81 | } 82 | -- render :: _ -> H.ComponentHTML PantographLessonAction ( editor :: H.Slot (Editor.EditorQuery l r) (Base.EditorSpec l r) Unit) Aff 83 | -- render :: _ -> H.ComponentHTML PantographLessonAction (Slots l r) Aff 84 | render state = 85 | let lesson = force (Util.index' lessons state.activeLesson) in 86 | HH.div [classNames["vertical-container"]] 87 | [ 88 | HH.div [classNames["PantographHeader", "horizontal-container", "padded"], 89 | HP.style "height: 1.4em; justify-content: space-between"] [ 90 | HH.div [ classNames ["PantographTitle"] ] [ 91 | HH.div_ [HH.text "Pantograph"], 92 | HH.div_ [HH.a [HP.style "color:lightblue" , HP.href "https://github.com/jeprinz/pantograph/blob/main/README.md"] [HH.text "[About]"]], 93 | HH.div_ [HH.text "|"], 94 | -- HH.div_ [HH.text $ "Lesson [" <> show (state.activeLesson + 1) <> " / " <> show (Array.length state.lessonsSolved) <> "]"] 95 | HH.div 96 | [ HCSS.style do 97 | CSS.display CSS.flex 98 | CSS.flexDirection CSS.row 99 | CSS.rule $ CSS.Property (CSS.fromString "gap") (CSS.value (CSS.em 0.5)) 100 | ] $ 101 | Array.mapWithIndex Tuple state.lessonsSolved <#> \(Tuple i _) -> 102 | HH.div 103 | [ HCSS.style do 104 | (let s = CSS.em 1.0 in CSS.borderRadius s s s s) 105 | CSS.border CSS.solid (CSS.px 1.0) CSS.white 106 | CSS.width (CSS.em 1.7) 107 | CSS.fontSize (CSS.pt 8.0) 108 | CSS.cursor CSSCursor.pointer 109 | (let s = CSS.em 0.2 in CSS.padding s (CSS.em 0.0) s (CSS.em 0.0)) 110 | CSS.rule $ CSS.Property (CSS.fromString "text-align") (CSS.fromString "center") 111 | CSS.fontFamily [] $ NonEmpty.singleton $ CSSFont.monospace 112 | if (i == state.activeLesson) then do 113 | CSS.background CSS.white 114 | CSS.color CSS.black 115 | else do 116 | CSS.background CSS.black 117 | CSS.color CSS.white 118 | , HE.onClick \_mouseEvent -> SetLesson i 119 | ] 120 | [ HH.text $ show (i + 1) ] 121 | ] 122 | , HH.div [ classNames ["PantographControls"] ] [ 123 | HH.button [ classNames ["TutorialControlButton"], HE.onClick \_ -> ResetLesson ] [ HH.text "Reset" ] 124 | , HH.button [ classNames ["TutorialControlButton"], HP.disabled (state.activeLesson == 0), HE.onClick \_ -> PreviousLesson ] [ HH.text "Previous Lesson" ] 125 | , HH.button [ classNames ["TutorialControlButton"], HP.disabled (state.activeLesson == Array.length lessons - 1) , HE.onClick \_ -> NextLesson ] [ HH.text "Next Lesson" ] 126 | ] 127 | -- , HH.text (if Util.index' state.lessonsSolved state.activeLesson then "SOLVED" else "NOT YET SOLVED") 128 | ] 129 | -- , HH.hr [HP.style "width: 5px"] 130 | , HH.div [ classNames ["horizontal-bar"], HP.style "height: 2px;" ] [] 131 | -- , HH.div [ classNames ["horizontal-container sidebar-container"] ] [ 132 | , HH.div [ classNames ["horizontal-container", "fill-space"], HP.style "height: calc(100vh - 3em - 2px);" ] [ 133 | HH.main [ classNames ["fill-space", "padded"], HP.style "overflow: auto"] [ 134 | HH.div_ 135 | [HH.slot _editorSlot unit editorComponent spec EditorOutput] 136 | ] 137 | -- , HH.div [ classNames ["resize-handle--x"] ] [] 138 | , HH.div [ classNames ["vertical-bar", "resize-handle--x"], HP.attr (AttrName "data-target") "aside"] [] 139 | , HH.aside [ classNames [], HP.style "width: 650px; overflow: auto;"] [ 140 | HH.div [classNames ["vertical-container"]] [ 141 | HH.div [HP.style "height: 3em"] [ 142 | HH.button [ classNames ["TutorialControlButton"], HE.onClick \_ -> RunProgram, HP.style "margin: 10px" ] [ HH.text "Run" ] 143 | , HH.span [HP.style "font-family: monospace; font-size: 12pt"] [HH.text state.output] 144 | ] 145 | -- , HH.div [ classNames ["horizontal-bar"], HP.style "height: 2px;" ] [] 146 | , HH.div [HP.style "float:right", classNames ["padded", "lessonInstructions"]] [unsafeCoerce lesson.instructions] 147 | ] 148 | ] 149 | ] 150 | ] 151 | 152 | setLesson = do 153 | state <- H.get 154 | let lesson = force (Util.index' lessons state.activeLesson) 155 | H.tell _editorSlot unit (Editor.SetProgram (lesson.program) (convertPaths lesson.paths)) 156 | 157 | handleAction = case _ of 158 | EditorOutput _unit2 -> Bug.bug "not yet implemented" 159 | Initialize -> setLesson 160 | NextLesson -> do 161 | H.modify_ \state -> 162 | state {activeLesson= state.activeLesson + 1} 163 | setLesson 164 | PreviousLesson -> do 165 | H.modify_ \state -> 166 | state {activeLesson= state.activeLesson - 1} 167 | setLesson 168 | SetLesson i -> do 169 | H.modify_ \state -> 170 | state {activeLesson = i} 171 | setLesson 172 | ResetLesson -> do 173 | setLesson 174 | RunProgram -> do 175 | mprog <- H.request _editorSlot unit (Editor.GetProgram) 176 | state <- H.get 177 | case mprog of 178 | Just prog -> 179 | H.modify_ \state -> 180 | state {output = interpereter prog} 181 | Nothing -> pure unit 182 | 183 | runTutorial :: forall l r. Grammar.IsRuleLabel l r => Base.EditorSpec l r 184 | -> Array (Lazy (Lesson l r)) -> (Grammar.DerivTerm l r -> String) -> Effect Unit 185 | runTutorial spec lessons interpereter = HA.runHalogenAff do 186 | Console.log "[runTutorial]" 187 | body <- HA.awaitBody 188 | VDomDriver.runUI (makePantographTutorial spec lessons interpereter) unit body 189 | 190 | -------------------------------------------------------------------------------- /src/Tutorial/Markdown.purs: -------------------------------------------------------------------------------- 1 | module Tutorial.Markdown where 2 | 3 | import Prelude 4 | 5 | import Data.Array as Array 6 | import Data.Lazy (defer, force) 7 | import Data.Maybe (Maybe(..)) 8 | import Data.String as String 9 | import Data.String.CodeUnits as CodeUnits 10 | import Data.Tuple.Nested (type (/\), (/\)) 11 | import Halogen.HTML as HH 12 | import Halogen.HTML.Properties as HP 13 | import Halogen.Utilities (classNames) 14 | import Util (fromJust') 15 | 16 | type HTML = HH.HTML Unit Unit 17 | 18 | dummyButton :: forall w2 i3. String -> HH.HTML w2 i3 19 | dummyButton s = HH.button [classNames ["TutorialControlButton TutorialControlButtonDummy"]] [HH.text s] 20 | 21 | dummyDataTyHole :: forall w2 i3. String -> HH.HTML w2 i3 22 | dummyDataTyHole str_dataty = 23 | HH.code_ 24 | [HH.div [classNames ["node"]] 25 | [ HH.div [classNames ["subnode", "punctuation", "lbrace"]] [HH.text "{"] 26 | , HH.div [classNames ["node", "holeInterior"]] [HH.div [classNames ["node", "holeInterior-inner"]] [HH.div [classNames ["subnode", "punctuation", "square"]] [HH.text "□"]]] 27 | , HH.div [classNames ["subnode", "punctuation", "colon"]] [HH.text ":"] 28 | , HH.div [classNames ["node", "typesubscript"]] 29 | [ HH.div [classNames ["node"]] [HH.span [classNames ["datatype"]] [HH.text str_dataty]] ] 30 | , HH.div [classNames ["subnode", "punctuation", "rbrace"]] [HH.text "}"] 31 | ]] 32 | 33 | italic :: forall w i. String -> HH.HTML w i 34 | italic = HH.i_ <<< pure <<< text 35 | 36 | bold :: forall w i. String -> HH.HTML w i 37 | bold = HH.b [] <<< pure <<< text 38 | 39 | text :: forall w i. String -> HH.HTML w i 40 | text = HH.text 41 | 42 | data MatchMd 43 | = ReplaceMatchMd String HTML 44 | | FunctionMatchMd String (String -> HTML) 45 | 46 | tryMatchMd :: MatchMd -> String -> Maybe (HTML /\ String) 47 | tryMatchMd (ReplaceMatchMd label html) str = do 48 | str' <- String.stripPrefix (String.Pattern ("♯" <> label)) str 49 | pure $ html /\ str' 50 | tryMatchMd (FunctionMatchMd label toHtml) str = do 51 | str' <- String.stripPrefix (String.Pattern ("♯" <> label <> "⟦")) str 52 | let i = String.indexOf (String.Pattern "⟧") str' # fromJust' "no closing \"⟧\"" 53 | let {before, after} = String.splitAt i str' 54 | let str'' = String.drop 1 after 55 | pure $ toHtml before /\ str'' 56 | 57 | parseMd :: String -> Array HTML 58 | parseMd = go [] [] 59 | where 60 | go :: Array HTML -> Array Char -> String -> Array HTML 61 | go htmls work str = case matches # map (flip tryMatchMd str) >>> Array.catMaybes >>> Array.head of 62 | Nothing -> case CodeUnits.uncons str of 63 | Nothing -> force htmls_work 64 | Just {head: c, tail: str'} -> go htmls (Array.snoc work c) str' 65 | Just (html /\ str') -> go (force htmls_work `Array.snoc` html) [] str' 66 | where 67 | htmls_work = defer \_ -> htmls # if Array.null work then identity else (_ `Array.snoc` text (CodeUnits.fromCharArray work)) 68 | 69 | matches :: Array MatchMd 70 | matches = 71 | [ ReplaceMatchMd "br" HH.br_ 72 | , ReplaceMatchMd "Pantograph" $ HH.span [classNames ["TutorialWord-Pantograph"]] [text "Pantograph"] 73 | , FunctionMatchMd "bold" $ bold 74 | , FunctionMatchMd "italic" $ italic 75 | , FunctionMatchMd "code" $ HH.code_ <<< pure <<< text 76 | , FunctionMatchMd "button" $ dummyButton 77 | , FunctionMatchMd "dataTyHole" $ dummyDataTyHole 78 | , FunctionMatchMd "greyError" $ HH.div [classNames ["Tutorial-greyError"], HP.style "display: inline-block"] <<< pure <<< HH.div [classNames ["inline", "grey", "error"], HP.style "display: inline-block"] <<< pure <<< HH.span [classNames [], HP.style "display: inline-block"] <<< pure <<< text 79 | , FunctionMatchMd "task" $ HH.div [classNames ["TutorialTask"]] <<< Array.cons (bold "Task:") <<< pure <<< text 80 | ] 81 | 82 | -------------------------------------------------------------------------------- /src/Type/Direction.purs: -------------------------------------------------------------------------------- 1 | module Type.Direction where 2 | 3 | import Prelude 4 | import Prim.Row 5 | 6 | import Control.Plus (empty) 7 | import Data.Maybe (Maybe) 8 | import Data.Variant (Variant, inj) 9 | import Type.Proxy (Proxy(..)) 10 | 11 | -- Jacob To Henry: what is this file? Is this AI generated? Does this code need to use variants and be so repetetive and strange? 12 | 13 | -- proxies 14 | _up = Proxy :: Proxy "up" 15 | _down = Proxy :: Proxy "down" 16 | _left = Proxy :: Proxy "left" 17 | _right = Proxy :: Proxy "right" 18 | _prev = Proxy :: Proxy "prev" 19 | _next = Proxy :: Proxy "next" 20 | 21 | -- symbols 22 | type Up = "up" 23 | type Down = "down" 24 | type Left = "left" 25 | type Right = "right" 26 | type Prev = "prev" 27 | type Next = "next" 28 | 29 | -- atomic 30 | type UpDir dirs = (up :: Proxy Up | dirs) 31 | type DownDir dirs = (down :: Proxy Down | dirs) 32 | type LeftDir dirs = (left :: Proxy Left | dirs) 33 | type RightDir dirs = (right :: Proxy Right | dirs) 34 | type PrevDir dirs = (prev :: Proxy Prev | dirs) 35 | type NextDir dirs = (next :: Proxy Next | dirs) 36 | 37 | -- up, down 38 | type VerticalDirs dirs = UpDir (DownDir dirs) 39 | -- left, right 40 | type HorizontalDirs dirs = LeftDir (RightDir dirs) 41 | -- prev, next 42 | type OrdinalDirs dirs = NextDir (PrevDir dirs) 43 | -- up, down, left, right 44 | type CompassDirs dirs = VerticalDirs (HorizontalDirs dirs) 45 | -- up, down, left, right, prev, next 46 | type MoveDirs dirs = OrdinalDirs (CompassDirs dirs) 47 | 48 | -- dir values 49 | type VerticalDir = Variant (VerticalDirs ()) 50 | type HorizontalDir = Variant (HorizontalDirs ()) 51 | type OrdinalDir = Variant (OrdinalDirs ()) 52 | type CompassDir = Variant (CompassDirs ()) 53 | type MoveDir = Variant (MoveDirs ()) 54 | 55 | class Opposite (dir1 :: Symbol) (dir2 :: Symbol) | dir1 -> dir2 56 | instance Opposite Up Down 57 | instance Opposite Down Up 58 | instance Opposite Left Right 59 | instance Opposite Right Left 60 | instance Opposite Next Prev 61 | instance Opposite Prev Next 62 | 63 | upDir :: forall dirs. Variant (UpDir dirs) 64 | upDir = inj _up (Proxy :: Proxy Up) 65 | 66 | downDir :: forall dirs. Variant (DownDir dirs) 67 | downDir = inj _down (Proxy :: Proxy Down) 68 | 69 | leftDir :: forall dirs. Variant (LeftDir dirs) 70 | leftDir = inj _left (Proxy :: Proxy Left) 71 | 72 | rightDir :: forall dirs. Variant (RightDir dirs) 73 | rightDir = inj _right (Proxy :: Proxy Right) 74 | 75 | prevDir :: forall dirs. Variant (PrevDir dirs) 76 | prevDir = inj _prev (Proxy :: Proxy Prev) 77 | 78 | nextDir :: forall dirs. Variant (NextDir dirs) 79 | nextDir = inj _next (Proxy :: Proxy Next) 80 | 81 | readMoveDir :: String -> Maybe MoveDir 82 | readMoveDir "ArrowLeft" = pure prevDir 83 | readMoveDir "ArrowRight" = pure nextDir 84 | --readMoveDir "ArrowLeft" = pure leftDir 85 | --readMoveDir "ArrowRight" = pure rightDir 86 | readMoveDir "ArrowUp" = pure upDir 87 | readMoveDir "ArrowDown" = pure downDir 88 | readMoveDir _ = empty 89 | 90 | readVerticalDir :: String -> Maybe VerticalDir 91 | readVerticalDir "ArrowUp" = pure upDir 92 | readVerticalDir "ArrowDown" = pure downDir 93 | readVerticalDir _ = empty -------------------------------------------------------------------------------- /src/Util.purs: -------------------------------------------------------------------------------- 1 | module Util where 2 | 3 | import Data.Foldable 4 | import Data.Tuple.Nested 5 | import Prelude 6 | 7 | import Data.Tuple (Tuple(..)) 8 | import Bug as Bug 9 | import Bug.Assertion (assert, just) 10 | import Data.Either (Either(..)) 11 | import Data.List (List) 12 | import Data.List as List 13 | import Data.Map (Map, toUnfoldable, fromFoldable, lookup, member, delete, unionWith, insert) 14 | import Data.Map as Map 15 | import Data.Maybe (Maybe(..)) 16 | import Data.Maybe (maybe) 17 | import Data.Maybe as Maybe 18 | import Data.UUID (UUID) 19 | import Data.UUID as UUID 20 | import Hole as Hole 21 | import Data.Array as Array 22 | import Effect.Unsafe (unsafePerformEffect) 23 | import Effect.Ref as Ref 24 | import Data.Enum (class Enum, succ) 25 | import Data.Unfoldable (unfoldr) 26 | import Debug (trace) 27 | 28 | hole' :: forall a. String -> a 29 | -- hole' msg = unsafeThrow $ "hole: " <> msg 30 | hole' msg = Hole.hole msg 31 | 32 | index' :: forall a. Array a -> Int -> a 33 | index' a i = fromJust $ Array.index a i 34 | 35 | lookup' :: forall k v. Ord k => k -> Map k v -> v 36 | lookup' x m = case lookup x m of 37 | Just v -> v 38 | Nothing -> Bug.bug "lookup failed" 39 | 40 | head' :: forall a . List a -> a 41 | head' l = case List.head l of 42 | Nothing -> Bug.bug "head failed" 43 | Just a -> a 44 | 45 | fromJust :: forall a . Maybe a -> a 46 | fromJust (Just x) = x 47 | fromJust Nothing = Bug.bug "fromJust failed" 48 | 49 | fromJust' :: forall a . String -> Maybe a -> a 50 | fromJust' source mb = assert (just source mb) identity 51 | 52 | fromRight :: forall a b. Either a b -> b 53 | fromRight (Right b) = b 54 | fromRight _ = Bug.bug "error: fromRight failed" 55 | 56 | justWhen :: forall a. Boolean -> (Unit -> a) -> Maybe a 57 | justWhen false _ = Nothing 58 | justWhen true k = Just (k unit) 59 | 60 | delete' :: forall v k . Ord k => k -> Map k v -> Map k v 61 | delete' k m = if member k m then delete k m else Bug.bug "Tried to delete an element not present in the map" 62 | --delete' k m = delete k m 63 | 64 | insert' :: forall v k . Ord k => k -> v -> Map k v -> Map k v 65 | insert' k v m = 66 | if member k m then Bug.bug "Tried to insert an element already present in the map" else 67 | insert k v m 68 | 69 | 70 | mapKeys :: forall k v . Ord k => (k -> k) -> Map k v -> Map k v 71 | mapKeys f m = 72 | -- let bla = toUnfoldable in 73 | let asList :: List (k /\ v) 74 | asList = toUnfoldable m in 75 | fromFoldable (map (\(k /\ v) -> f k /\ v) asList) 76 | 77 | -- disjoint union 78 | union' :: forall v k. Ord k => Map k v -> Map k v -> Map k v 79 | union' m1 m2 = unionWith (\_ _ -> Bug.bug "duplicate key in union'") m1 m2 80 | 81 | ------ disjoint union, or returns Nothing if the same key leads to two different values 82 | --unionCheckConflicts :: forall v k. Ord k => Eq v => Map k v -> Map k v -> Maybe (Map k v) 83 | --unionCheckConflicts m1 m2 = 84 | -- foldl (\macc (k /\ v) -> do 85 | -- acc <- macc 86 | -- case lookup k acc of 87 | -- Just v' | not (v' == v) -> Nothing 88 | -- _ -> pure (Map.insert k v acc)) 89 | -- (Just m1) (toUnfoldable m2 :: List (k /\ v)) 90 | 91 | readUUID :: String -> UUID 92 | readUUID str = fromJust' ("failed to parse UUID: " <> str) <<< UUID.parseUUID $ str 93 | 94 | threeCaseUnion :: forall v1 v2 v3 k . Ord k => 95 | (v1 -> v3) -> (v2 -> v3) -> (v1 -> v2 -> v3) 96 | -> Map k v1 -> Map k v2 -> Map k v3 97 | threeCaseUnion onlyLeft onlyRight both m1 m2 = 98 | let mLeft = Map.filterWithKey (\k _ -> not (member k m2)) m1 in 99 | let mRight = Map.filterWithKey (\k _ -> not (member k m1)) m2 in 100 | union' 101 | (union' (map onlyLeft mLeft) (map onlyRight mRight)) 102 | (Map.mapMaybeWithKey (\k v -> maybe Nothing (\v2 -> Just $ both v v2) (Map.lookup k m2)) m1) 103 | 104 | threeCaseUnionMaybe :: forall v1 v2 v3 k . Ord k => 105 | (Maybe v1 -> Maybe v2 -> Maybe v3) 106 | -> Map k v1 -> Map k v2 -> Map k v3 107 | threeCaseUnionMaybe join m1 m2 = Map.mapMaybe (\x -> x) $ threeCaseUnion (\x -> join (Just x) Nothing) (\y -> join Nothing (Just y)) 108 | (\x y -> join (Just x) (Just y)) m1 m2 109 | 110 | 111 | findWithIndex :: forall t out. (Int -> t -> Maybe out) -> Array t -> Maybe (out /\ Int) 112 | findWithIndex f l = 113 | -- do -- stupid implementation calls f an extra time 114 | -- i <- Array.findIndex (Maybe.isJust <<< (f i)) l 115 | -- res <- Array.findMap f l 116 | -- pure $ res /\ i 117 | let impl :: Int -> Maybe (out /\ Int) 118 | impl i = case Array.index l i of 119 | Nothing -> Nothing 120 | Just x -> case f i x of 121 | Nothing -> impl (i + 1) 122 | Just res -> Just (res /\ i) 123 | in impl 0 124 | 125 | assertSingleton :: forall t. Array t -> t 126 | assertSingleton [x] = x 127 | assertSingleton _ = Bug.bug "assertion failed: was not a singleton" 128 | 129 | -- foldl :: forall a b. (b -> a -> b) -> b -> f a -> b 130 | -- assumes that the thing is nonempty 131 | foldNonempty :: forall a f. Foldable f => (a -> a -> a) -> f a -> a 132 | foldNonempty f l = case foldl (\acc el -> 133 | case acc of 134 | Just a -> Just (f a el) 135 | Nothing -> Just el 136 | ) Nothing l of 137 | Nothing -> Bug.bug "assumption violated in foldNonempty: was empty" 138 | Just res -> res 139 | 140 | -- represents a hole but for types 141 | data Hole 142 | 143 | 144 | type Stateful t = {get :: Unit -> t, set :: t -> Unit} 145 | stateful :: forall t. t -> Stateful t 146 | stateful t = unsafePerformEffect do 147 | tref <- Ref.new t 148 | pure { 149 | get: \_ -> unsafePerformEffect (Ref.read tref) 150 | , set: \tNew -> unsafePerformEffect (Ref.write tNew tref) 151 | } 152 | 153 | inlineMaybeCase :: forall a out. Maybe a -> (a -> out) -> out -> out 154 | inlineMaybeCase cond thenn elsee = case cond of 155 | Nothing -> elsee 156 | Just x -> thenn x 157 | 158 | allPossible :: forall a. -- https://stackoverflow.com/questions/74462784/purescript-data-as-array-of-all-possible-data-inhabitants 159 | Enum a => 160 | Bounded a => 161 | Array a 162 | allPossible = unfoldr (\b -> b >>= next) $ Just bottom 163 | where 164 | next a = Just $ Tuple a $ succ a 165 | 166 | traceAfter :: forall b. String -> (Unit -> b) -> b 167 | traceAfter a k = 168 | let res = k unit in 169 | trace a (\_ -> res) 170 | -------------------------------------------------------------------------------- /src/Utility.purs: -------------------------------------------------------------------------------- 1 | module Utility where 2 | 3 | import Data.Tuple.Nested 4 | import Prelude 5 | 6 | import Bug (bug) 7 | import Data.List (List(..), (:)) 8 | import Data.List as List 9 | import Data.Maybe (Maybe(..)) 10 | 11 | map2 f = map (map f) 12 | infixl 4 map2 as <$$> 13 | 14 | map3 f = map (map (map f)) 15 | infixl 4 map3 as <$$$> 16 | 17 | stripSuffix :: forall a. Eq a => List.Pattern a -> List a -> Maybe (List a) 18 | stripSuffix (List.Pattern Nil) xs = Just xs 19 | stripSuffix (List.Pattern suf) xs0 = go Nil xs0 20 | where 21 | go _ Nil = Nothing 22 | go ys (x : xs) 23 | | suf == xs = Just (List.reverse (x : ys)) 24 | | otherwise = go (x : ys) xs 25 | -------------------------------------------------------------------------------- /standalone.js: -------------------------------------------------------------------------------- 1 | import { main } from "./output/MainStandalone"; 2 | main(); 3 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Data.Expr 4 | import Data.Tuple.Nested 5 | import Prelude 6 | import Type.Direction 7 | 8 | import Data.Generic.Rep (class Generic) 9 | import Data.List as List 10 | import Data.Show.Generic (genericShow) 11 | import Effect (Effect) 12 | import Effect.Class.Console (log) 13 | import Text.Pretty (class Pretty, parens, pretty) 14 | 15 | data L = Base | Wrap String 16 | 17 | derive instance Generic L _ 18 | derive instance Eq L 19 | derive instance Ord L 20 | instance Show L where show x = genericShow x 21 | instance Pretty L where 22 | pretty Base = "base" 23 | pretty (Wrap str) = "wrap " <> str 24 | instance IsExprLabel L where 25 | prettyExprF'_unsafe (Base /\ []) = "point" 26 | prettyExprF'_unsafe (Wrap str /\ [kid]) = parens $ "wrap " <> str <> " " <> kid 27 | expectedKidsCount Base = 0 28 | expectedKidsCount (Wrap _) = 1 29 | 30 | main :: Effect Unit 31 | main = do 32 | -- let 33 | -- pathUp :: Path Up L 34 | -- pathUp = Path $ List.fromFoldable 35 | -- [ Tooth (Wrap "bot") mempty 36 | -- , Tooth (Wrap "top") mempty 37 | -- ] 38 | 39 | -- pathDown :: Path Down L 40 | -- pathDown = Path $ List.fromFoldable 41 | -- [ Tooth (Wrap "top") mempty 42 | -- , Tooth (Wrap "bot") mempty 43 | -- ] 44 | 45 | -- log "pathUp:" 46 | -- log $ pretty pathUp 47 | -- log $ foldMapPath "PathEnd" (\th -> ((pretty th <> " - " )<> _)) pathUp 48 | 49 | -- log "" 50 | 51 | -- log "pathDown:" 52 | -- log $ pretty pathDown 53 | -- log $ foldMapPath "PathEnd" (\th -> ((pretty th <> " - ") <> _)) pathDown 54 | 55 | log $ pretty $ 56 | Expr (CInj (Wrap "A")) [Expr (Plus (Tooth (Wrap "B") mempty)) [Expr (CInj Base) []]] 57 | -------------------------------------------------------------------------------- /tutorial.js: -------------------------------------------------------------------------------- 1 | import { main } from "./output/MainTutorial"; 2 | main(); 3 | --------------------------------------------------------------------------------