├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── README.md ├── ask.cabal ├── bin └── askt ├── doc ├── ask.pdf └── ask.tex ├── eg ├── BST.ask ├── Basics.ask ├── Degree.ask ├── Highlight.ask ├── Nat.ask ├── Proofs.ask ├── Proofs.asked ├── Trouble.ask └── zoiks.ask ├── emacs └── ask.el ├── lib ├── Language │ └── Ask │ │ ├── Bwd.hs │ │ ├── ChkRaw.hs │ │ ├── Context.hs │ │ ├── Glueing.hs │ │ ├── HalfZip.hs │ │ ├── HardwiredRules.hs │ │ ├── Hide.hs │ │ ├── Lexing.hs │ │ ├── OddEven.hs │ │ ├── Parsing.hs │ │ ├── Printing.hs │ │ ├── Progging.hs │ │ ├── Proving.hs │ │ ├── RawAsk.hs │ │ ├── Thin.hs │ │ ├── Tm.hs │ │ └── Typing.hs ├── Makefile └── Test.html ├── src └── Main.hs └── test └── Main.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '--no-cabal-check' '--no-benchmarks' '--no-haddock' 'ask.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20241202 12 | # 13 | # REGENDATA ("0.19.20241202",["github","--no-cabal-check","--no-benchmarks","--no-haddock","ask.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-latest 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.8.2 32 | compilerKind: ghc 33 | compilerVersion: 9.8.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.6.6 37 | compilerKind: ghc 38 | compilerVersion: 9.6.6 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.4.8 42 | compilerKind: ghc 43 | compilerVersion: 9.4.8 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.2.8 47 | compilerKind: ghc 48 | compilerVersion: 9.2.8 49 | setup-method: ghcup 50 | allow-failure: false 51 | fail-fast: false 52 | steps: 53 | - name: apt-get install 54 | run: | 55 | apt-get update 56 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 57 | - name: Install GHCup 58 | run: | 59 | mkdir -p "$HOME/.ghcup/bin" 60 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 61 | chmod a+x "$HOME/.ghcup/bin/ghcup" 62 | - name: Install cabal-install 63 | run: | 64 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 65 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 66 | - name: Install GHC (GHCup) 67 | if: matrix.setup-method == 'ghcup' 68 | run: | 69 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 70 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 71 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 72 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 73 | echo "HC=$HC" >> "$GITHUB_ENV" 74 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 75 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 76 | env: 77 | HCKIND: ${{ matrix.compilerKind }} 78 | HCNAME: ${{ matrix.compiler }} 79 | HCVER: ${{ matrix.compilerVersion }} 80 | - name: Set PATH and environment variables 81 | run: | 82 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 83 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 84 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 85 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 86 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 87 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 88 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 89 | echo "ARG_BENCH=--disable-benchmarks" >> "$GITHUB_ENV" 90 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 91 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 92 | env: 93 | HCKIND: ${{ matrix.compilerKind }} 94 | HCNAME: ${{ matrix.compiler }} 95 | HCVER: ${{ matrix.compilerVersion }} 96 | - name: env 97 | run: | 98 | env 99 | - name: write cabal config 100 | run: | 101 | mkdir -p $CABAL_DIR 102 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 135 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 136 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 137 | rm -f cabal-plan.xz 138 | chmod a+x $HOME/.cabal/bin/cabal-plan 139 | cabal-plan --version 140 | - name: checkout 141 | uses: actions/checkout@v4 142 | with: 143 | path: source 144 | - name: initial cabal.project for sdist 145 | run: | 146 | touch cabal.project 147 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 148 | cat cabal.project 149 | - name: sdist 150 | run: | 151 | mkdir -p sdist 152 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 153 | - name: unpack 154 | run: | 155 | mkdir -p unpacked 156 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 157 | - name: generate cabal.project 158 | run: | 159 | PKGDIR_ask="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/ask-[0-9.]*')" 160 | echo "PKGDIR_ask=${PKGDIR_ask}" >> "$GITHUB_ENV" 161 | rm -f cabal.project cabal.project.local 162 | touch cabal.project 163 | touch cabal.project.local 164 | echo "packages: ${PKGDIR_ask}" >> cabal.project 165 | echo "package ask" >> cabal.project 166 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 167 | cat >> cabal.project <> cabal.project.local 170 | cat cabal.project 171 | cat cabal.project.local 172 | - name: dump install plan 173 | run: | 174 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 175 | cabal-plan 176 | - name: restore cache 177 | uses: actions/cache/restore@v4 178 | with: 179 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 180 | path: ~/.cabal/store 181 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 182 | - name: install dependencies 183 | run: | 184 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 185 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 186 | - name: build w/o tests 187 | run: | 188 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 189 | - name: build 190 | run: | 191 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 192 | - name: tests 193 | run: | 194 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 195 | - name: unconstrained build 196 | run: | 197 | rm -f cabal.project.local 198 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 199 | - name: save cache 200 | if: always() 201 | uses: actions/cache/save@v4 202 | with: 203 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 204 | path: ~/.cabal/store 205 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ask 2 | being a particular fragment of Haskell, extended to a proof system 3 | -------------------------------------------------------------------------------- /ask.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | -- The cabal-version field refers to the version of the .cabal specification, 3 | -- and can be different from the cabal-install (the tool) version and the 4 | -- Cabal (the library) version you are using. As such, the Cabal (the library) 5 | -- version used must be equal or greater than the version stated in this field. 6 | -- Starting from the specification version 2.2, the cabal-version field must be 7 | -- the first thing in the cabal file. 8 | 9 | -- Initial package description 'ask' generated by 10 | -- 'cabal init'. For further documentation, see: 11 | -- http://haskell.org/cabal/users-guide/ 12 | -- 13 | -- The name of the package. 14 | name: ask 15 | 16 | -- The package version. 17 | -- See the Haskell package versioning policy (PVP) for standards 18 | -- guiding when and how versions should be incremented. 19 | -- https://pvp.haskell.org 20 | -- PVP summary: +-+------- breaking API changes 21 | -- | | +----- non-breaking API additions 22 | -- | | | +--- code changes with no API change 23 | version: 0.1.0.0 24 | 25 | tested-with: GHC ==9.8.2 || ==9.6.6 || ==9.4.8 || ==9.2.8 26 | 27 | -- A short (one-line) description of the package. 28 | -- synopsis: 29 | 30 | -- A longer description of the package. 31 | -- description: 32 | 33 | -- The license under which the package is released. 34 | license: NONE 35 | 36 | -- The package author(s). 37 | author: Conor Mc Bride 38 | 39 | -- An email address to which users can send suggestions, bug reports, and patches. 40 | maintainer: conor.mcbride@strath.ac.uk 41 | 42 | -- A copyright notice. 43 | -- copyright: 44 | category: Language 45 | build-type: Simple 46 | 47 | -- Extra source files to be distributed with the package, such as examples, or a tutorial module. 48 | -- extra-source-files: 49 | 50 | common warnings 51 | ghc-options: -Wall 52 | 53 | library 54 | -- Import common warning flags. 55 | import: warnings 56 | 57 | -- Modules exported by the library. 58 | exposed-modules: Language.Ask.Bwd 59 | , Language.Ask.ChkRaw 60 | , Language.Ask.Context 61 | , Language.Ask.Glueing 62 | , Language.Ask.HalfZip 63 | , Language.Ask.HardwiredRules 64 | , Language.Ask.Hide 65 | , Language.Ask.Lexing 66 | , Language.Ask.OddEven 67 | , Language.Ask.Parsing 68 | , Language.Ask.Printing 69 | , Language.Ask.Progging 70 | , Language.Ask.Proving 71 | , Language.Ask.RawAsk 72 | , Language.Ask.Thin 73 | , Language.Ask.Tm 74 | , Language.Ask.Typing 75 | 76 | 77 | -- Modules included in this library but not exported. 78 | -- other-modules: 79 | 80 | -- LANGUAGE extensions used by modules in this package. 81 | -- other-extensions: 82 | 83 | -- Other library packages from which modules are imported. 84 | build-depends: base >=4.16 && <=4.21 85 | , mtl >=2.2 && <2.4 86 | , containers >= 0.6 && <0.7 87 | 88 | -- Directories containing source files. 89 | hs-source-dirs: lib 90 | 91 | -- Base language which the package is written in. 92 | default-language: Haskell2010 93 | 94 | executable ask 95 | -- Import common warning flags. 96 | import: warnings 97 | 98 | -- .hs or .lhs file containing the Main module. 99 | main-is: Main.hs 100 | 101 | -- Modules included in this executable, other than Main. 102 | -- other-modules: 103 | 104 | -- LANGUAGE extensions used by modules in this package. 105 | -- other-extensions: 106 | 107 | -- Other library packages from which modules are imported. 108 | build-depends: ask 109 | , base >=4.16 && <=4.21 110 | 111 | -- Directories containing source files. 112 | hs-source-dirs: src 113 | 114 | -- Base language which the package is written in. 115 | default-language: Haskell2010 116 | 117 | test-suite ask-test 118 | -- Import common warning flags. 119 | import: warnings 120 | 121 | -- Base language which the package is written in. 122 | default-language: Haskell2010 123 | 124 | -- Modules included in this executable, other than Main. 125 | -- other-modules: 126 | 127 | -- LANGUAGE extensions used by modules in this package. 128 | -- other-extensions: 129 | 130 | -- The interface type and version of the test suite. 131 | type: exitcode-stdio-1.0 132 | 133 | -- Directories containing source files. 134 | hs-source-dirs: test 135 | 136 | -- The entrypoint to the test suite. 137 | main-is: Main.hs 138 | 139 | -- Test dependencies. 140 | build-depends: ask 141 | , base >=4.16 && <=4.21 142 | -------------------------------------------------------------------------------- /bin/askt: -------------------------------------------------------------------------------- 1 | diff <(ask < $1.ask) $1.asked 2 | -------------------------------------------------------------------------------- /doc/ask.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msp-strath/ask/51ee4b6b377685e6ec4bb7bd4b90d3c54b58598f/doc/ask.pdf -------------------------------------------------------------------------------- /doc/ask.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | \usepackage{a4} 3 | 4 | \newcommand{\ask}{\texttt{ask}} 5 | \newcommand{\prop}{\texttt{prop}} 6 | \newcommand{\Prop}{\texttt{Prop}} 7 | \newcommand{\where}{\texttt{where}} 8 | \newcommand{\by}{\leftarrow} 9 | 10 | \begin{document} 11 | \title{\ask} 12 | \author{probably some other people and Conor McBride} 13 | \maketitle 14 | 15 | 16 | \section{Introduction} 17 | 18 | The \ask{} system is a programming language and proof assistant (not) implemented (yet) as an idempotent textfile transducer. You feed your pathetic blethering through \ask{} and it will 19 | build parts of your development which are obviously missing and comment out and upon parts of 20 | your development which are obviously bogus. It must be idempotent in that if you feed it its 21 | own output, there should be nothing new to add or take away. 22 | 23 | The \ask{} programming language is a total fragment of Haskell with strictly positive 24 | unindexed inductive datatypes, higher order function types, and higher rank type schemes. 25 | The \ask{} proof language is some form of predicate logic with configurable rules. 26 | 27 | 28 | \section{Propositions} 29 | 30 | The keyword \prop{} introduces the declaration of a new proposition former. $\Prop$ is the 31 | type of propositions. 32 | 33 | We define a relation as follows 34 | \[ 35 | \begin{array}{l} 36 | \prop \; R\; \tau\;\ldots\;\where\\ 37 | \;\;\mathit{intro} \\ 38 | \;\;\vdots\\ 39 | \end{array} 40 | \] 41 | with each $\mathit{intro}_i$ given as 42 | \[ 43 | \begin{array}{l} 44 | R\;p\;\ldots\;\by\;I\;p'\;\ldots\;\where\\ 45 | \;\;\mathit{condition} \\ 46 | \;\;\vdots\\ 47 | \end{array} 48 | \] 49 | There is no need to name an introduction rule if its conclusion 50 | anti-unifies with the conclusion of all other introduction rules. 51 | 52 | Relation symbols may be Constructor symbols or any infix symbol (like 53 | types when TypeOperators is enabled.) 54 | Intro rules must be Constructor symbols or :infix. 55 | 56 | For examples, 57 | \[ 58 | \begin{array}[t]{l} 59 | \prop\;\Prop\;\texttt{\&\&}\;\Prop\;\where \\ 60 | \;\;a\, \texttt{\&\&}\,b\;\where \\ 61 | \;\;\;\;a\\ 62 | \;\;\;\;b 63 | \end{array} 64 | \qquad 65 | \begin{array}[t]{l} 66 | \prop\;\Prop\;\texttt{||}\;\Prop\;\where \\ 67 | \;\;a\, \texttt{||}\,b \;\by\;\texttt{Left}\;\where \\ 68 | \;\;\;\;a\\ 69 | \;\;a\, \texttt{||}\,b \;\by\;\texttt{Right}\;\where \\ 70 | \;\;\;\;b\\ 71 | \end{array} 72 | \] 73 | 74 | Of course, conditions may themselves have hypotheses. 75 | \[\begin{array}{l} 76 | \prop\;\Prop\;\rightarrow\;\Prop\; \where \\ 77 | \;\; a\,\rightarrow\,b\; \where\\ 78 | \;\;\;\;b\; \where\\ 79 | \;\;\;\;\;\;a 80 | \end{array} 81 | \] 82 | 83 | 84 | 85 | \end{document} -------------------------------------------------------------------------------- /eg/BST.ask: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- Bool and ifthenelse 3 | ------------------------------------------------------------------------------ 4 | 5 | data Bool = True | False 6 | 7 | ifthenelse :: Bool -> t -> t -> t 8 | defined ifthenelse b aye naw from b where 9 | defined ifthenelse True aye naw = aye 10 | defined ifthenelse False aye naw = naw 11 | 12 | 13 | ------------------------------------------------------------------------------ 14 | -- N, prop <=, Bool le 15 | ------------------------------------------------------------------------------ 16 | 17 | data N = Z | S N 18 | 19 | prop N <= N where 20 | prove Z <= n by LeZ 21 | prove S n <= S m by LeSS where 22 | prove n <= m 23 | 24 | le :: N -> N -> Bool 25 | defined le x y inductively x where 26 | defined le x y from x where 27 | defined le Z y = True 28 | defined le (S x') y from y where 29 | defined le (S x') Z = False 30 | defined le (S x') (S y') = le x' y' 31 | 32 | -- The useful thing here is to show that le x y establishes "which way round" 33 | -- x and y should go in an ordered structure. 34 | 35 | proven le x y = True -> x <= y inductively x where 36 | proven le x y = True -> x <= y from x where 37 | given x = Z proven le Z y = True -> Z <= y by ImpI where 38 | given le Z y = True proven Z <= y by LeZ 39 | given x = S x' proven le (S x') y = True -> S x' <= y from y where 40 | given y = Z proven le (S x') Z = True -> S x' <= Z by ImpI where 41 | given le (S x') Z = True proven S x' <= Z from le (S x') Z = True 42 | given y = S y' 43 | proven le (S x') (S y') = True -> S x' <= S y' by ImpI where 44 | given le (S x') (S y') = True proven S x' <= S y' by LeSS where 45 | proven x' <= y' from le x' y' = True -> x' <= y' 46 | 47 | proven le x y = False -> y <= x inductively x where 48 | proven le x y = False -> y <= x from x where 49 | given x = Z proven le Z y = False -> y <= Z by ImpI where 50 | given le Z y = False proven y <= Z from le Z y = False 51 | given x = S x' proven le (S x') y = False -> y <= S x' from y where 52 | given y = Z proven le (S x') Z = False -> Z <= S x' by ImpI where 53 | given le (S x') Z = False proven Z <= S x' by LeZ 54 | given y = S y' 55 | proven le (S x') (S y') = False -> S y' <= S x' by ImpI where 56 | given le (S x') (S y') = False proven S y' <= S x' by LeSS where 57 | proven y' <= x' from le x' y' = False -> y' <= x' 58 | 59 | 60 | ------------------------------------------------------------------------------ 61 | -- Tree, Bnd, BST 62 | ------------------------------------------------------------------------------ 63 | 64 | data Tree = Leaf | Node Tree N Tree 65 | 66 | data Bnd = Bot | Val N | Top 67 | 68 | prop LeB Bnd Bnd where 69 | prove LeB Bot y by LeBot 70 | prove LeB (Val x) (Val y) by LeVal where 71 | prove x <= y 72 | prove LeB x Top by LeTop 73 | 74 | prop BST Bnd Tree Bnd where 75 | prove BST l Leaf u by BSTLeaf where 76 | prove LeB l u 77 | prove BST l (Node lx x xu) u by BSTNode where 78 | prove BST l lx (Val x) 79 | prove BST (Val x) xu u 80 | 81 | 82 | ------------------------------------------------------------------------------ 83 | -- insert 84 | ------------------------------------------------------------------------------ 85 | 86 | insert :: N -> Tree -> Tree 87 | defined insert n t inductively t where 88 | defined insert n t from t where 89 | defined insert n Leaf = Node Leaf n Leaf 90 | defined insert n (Node l x r) = 91 | ifthenelse (le n x) 92 | (Node (insert n l) x r) 93 | (Node l x (insert n r)) 94 | 95 | 96 | ------------------------------------------------------------------------------ 97 | -- the key helper proof to analyse the condition in the step case 98 | ------------------------------------------------------------------------------ 99 | 100 | -- The idea is to make the status of the condition explicit knowledge 101 | -- in the correctness proof for each branch. 102 | 103 | proven 104 | ((b = (True :: Bool) -> BST l aye u) & (b = (False :: Bool) -> BST l naw u)) 105 | -> BST l (ifthenelse b aye naw) u by ImpI where 106 | given (b = True -> BST l aye u) & (b = False -> BST l naw u) 107 | proven BST l (ifthenelse b aye naw) u 108 | from (b = True -> BST l aye u) & (b = False -> BST l naw u) where 109 | given b = True -> BST l aye u 110 | , b = False -> BST l naw u 111 | proven BST l (ifthenelse b aye naw) u from b where 112 | given b = True proven BST l (ifthenelse True aye naw) u 113 | from b = True -> BST l aye u 114 | given b = False proven BST l (ifthenelse False aye naw) u 115 | from b = False -> BST l naw u 116 | 117 | 118 | ------------------------------------------------------------------------------ 119 | -- the main deal 120 | ------------------------------------------------------------------------------ 121 | 122 | proven (LeB l (Val n) & LeB (Val n) u) & BST l t u -> BST l (insert n t) u 123 | inductively t where 124 | proven (LeB l (Val n) & LeB (Val n) u) & BST l t u -> BST l (insert n t) u 125 | from t where 126 | 127 | -- base case 128 | given t = Leaf 129 | proven (LeB l (Val n) & LeB (Val n) u) & BST l Leaf u 130 | -> BST l (insert n Leaf) u by ImpI where 131 | given (LeB l (Val n) & LeB (Val n) u) & BST l Leaf u 132 | proven BST l (insert n Leaf) u 133 | from (LeB l (Val n) & LeB (Val n) u) & BST l Leaf u where 134 | given LeB l (Val n) & LeB (Val n) u, BST l Leaf u 135 | proven BST l (insert n Leaf) u 136 | from LeB l (Val n) & LeB (Val n) u where 137 | given LeB l (Val n), LeB (Val n) u proven BST l (insert n Leaf) u 138 | by BSTNode where 139 | proven BST l Leaf (Val n) by BSTLeaf 140 | proven BST (Val n) Leaf u by BSTLeaf 141 | 142 | -- step case 143 | given t = Node lx x xu 144 | proven (LeB l (Val n) & LeB (Val n) u) & BST l (Node lx x xu) u 145 | -> BST l (insert n (Node lx x xu)) u by ImpI where 146 | given (LeB l (Val n) & LeB (Val n) u) & BST l (Node lx x xu) u 147 | proven BST l (insert n (Node lx x xu)) u 148 | from (LeB l (Val n) & LeB (Val n) u) & BST l (Node lx x xu) u where 149 | given LeB l (Val n) & LeB (Val n) u, BST l (Node lx x xu) u 150 | proven BST l (insert n (Node lx x xu)) u 151 | from LeB l (Val n) & LeB (Val n) u where 152 | given LeB l (Val n), LeB (Val n) u 153 | proven BST l (insert n (Node lx x xu)) u 154 | from BST l (Node lx x xu) u where 155 | given BST l lx (Val x), BST (Val x) xu u 156 | proven BST l (insert n (Node lx x xu)) u from 157 | -- which way did we go, and what do we know? 158 | (le n x = True -> BST l (Node (insert n lx) x xu) u) 159 | & (le n x = False -> BST l (Node lx x (insert n xu)) u) 160 | -> BST l (ifthenelse (le n x) 161 | (Node (insert n lx) x xu) 162 | (Node lx x (insert n xu))) u where 163 | proven (le n x = True -> BST l (Node (insert n lx) x xu) u) 164 | & (le n x = False -> BST l (Node lx x (insert n xu)) u) 165 | by AndI where 166 | 167 | -- left case 168 | proven le n x = True -> BST l (Node (insert n lx) x xu) u 169 | by ImpI where 170 | given le n x = True proven BST l (Node (insert n lx) x xu) u 171 | by BSTNode where 172 | proven BST l (insert n lx) (Val x) from 173 | -- left induction hypothesis 174 | (LeB l (Val n) & LeB (Val n) (Val x)) 175 | & BST l lx (Val x) 176 | -> BST l (insert n lx) (Val x) where 177 | proven (LeB l (Val n) & LeB (Val n) (Val x)) 178 | & BST l lx (Val x) by AndI where 179 | proven LeB l (Val n) & LeB (Val n) (Val x) 180 | by AndI where 181 | proven LeB (Val n) (Val x) by LeVal where 182 | proven n <= x from le n x = True -> n <= x 183 | 184 | -- right case 185 | proven le n x = False -> BST l (Node lx x (insert n xu)) u 186 | by ImpI where 187 | given le n x = False proven BST l (Node lx x (insert n xu)) u 188 | by BSTNode where 189 | proven BST (Val x) (insert n xu) u from 190 | -- right induction hypothesis 191 | (LeB (Val x) (Val n) & LeB (Val n) u) 192 | & BST (Val x) xu u 193 | -> BST (Val x) (insert n xu) u where 194 | proven (LeB (Val x) (Val n) & LeB (Val n) u) 195 | & BST (Val x) xu u by AndI where 196 | proven LeB (Val x) (Val n) & LeB (Val n) u 197 | by AndI where 198 | proven LeB (Val x) (Val n) by LeVal where 199 | proven x <= n from le n x = False -> x <= n 200 | -------------------------------------------------------------------------------- /eg/Basics.ask: -------------------------------------------------------------------------------- 1 | module Basics where 2 | 3 | prop Prop -> Prop where 4 | prove a -> b by ImpI where 5 | given a prove b 6 | infixr 1 -> 7 | 8 | prop Prop & Prop where 9 | prove a & b by AndI where 10 | prove a 11 | prove b 12 | infixr 7 & 13 | 14 | prop Prop | Prop where 15 | prove a | b by OrIL where 16 | prove a 17 | prove a | b by OrIR where 18 | prove b 19 | infixr 6 | 20 | 21 | prop False 22 | 23 | prop True where 24 | prove True by True 25 | 26 | prop Not p where 27 | prove Not p by NotI where 28 | given p prove False 29 | -------------------------------------------------------------------------------- /eg/Degree.ask: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- Degree of a Polynomial in One Variable 3 | ------------------------------------------------------------------------------ 4 | 5 | 6 | -- the data ------------------------------------------------------------------ 7 | 8 | data Number 9 | = Z -- Z for zero is the lemon 10 | | S Number -- S for successor is a spud 11 | 12 | data Formula 13 | = X 14 | | Num Number 15 | | Add Formula Formula 16 | | Mul Formula Formula 17 | 18 | 19 | -- plus ---------------------------------------------------------------------- 20 | 21 | plus :: Number -> Number -> Number 22 | defined plus n m inductively n where 23 | defined plus n m from n where 24 | defined plus Z m = m 25 | defined plus (S x) m = S (plus x m) 26 | 27 | -- plus gives a monoid with Z --------- 28 | 29 | proven plus Z m = m tested 30 | 31 | proven plus n Z = n inductively n where 32 | proven plus n Z = n from n where 33 | given n = S x proven plus (S x) Z = S x tested 34 | 35 | proven plus (plus l n) m = plus l (plus n m) inductively l where 36 | proven plus (plus l n) m = plus l (plus n m) from l where 37 | given l = S x proven plus (plus (S x) n) m = plus (S x) (plus n m) tested 38 | 39 | -- plus is commutative ---------------- 40 | 41 | proven plus m (S y) = S (plus m y) inductively m where 42 | proven plus m (S y) = S (plus m y) from m where 43 | given m = S x proven plus (S x) (S y) = S (plus (S x) y) tested 44 | 45 | proven plus n m = plus m n inductively n where 46 | proven plus n m = plus m n from n where 47 | given n = S x proven plus (S x) m = plus m (S x) tested where 48 | proven S (plus x m) = plus m (S x) by Route (S (plus m x)) 49 | 50 | -- swap middle of four ---------------- 51 | 52 | proven plus (plus a b) (plus c d) = plus (plus a c) (plus b d) 53 | by Route (plus a (plus b (plus c d))) where 54 | proven plus a (plus b (plus c d)) = plus (plus a c) (plus b d) 55 | by Route (plus a (plus c (plus b d))) where 56 | proven plus a (plus b (plus c d)) = plus a (plus c (plus b d)) 57 | under plus where 58 | proven plus b (plus c d) = plus c (plus b d) 59 | by Route (plus (plus b c) d) where 60 | proven plus (plus b c) d = plus c (plus b d) 61 | by Route (plus (plus c b) d) where 62 | proven plus (plus b c) d = plus (plus c b) d 63 | under plus 64 | 65 | 66 | -- mult ---------------------------------------------------------------------- 67 | 68 | mult :: Number -> Number -> Number 69 | defined mult n m inductively m where 70 | defined mult n m from m where 71 | defined mult n Z = Z 72 | defined mult n (S x) = plus n (mult n x) 73 | 74 | -- it should be a monoid map from addition to addition 75 | 76 | proven mult n Z = Z tested 77 | proven mult n (plus a b) = plus (mult n a) (mult n b) inductively a where 78 | proven mult n (plus a b) = plus (mult n a) (mult n b) from a where 79 | given a = S x proven mult n (plus (S x) b) 80 | = plus (mult n (S x)) (mult n b) tested where 81 | proven plus n (mult n (plus x b)) 82 | = plus (plus n (mult n x)) (mult n b) 83 | by Route (plus n (plus (mult n x) (mult n b))) where 84 | proven plus n (mult n (plus x b)) 85 | = plus n (plus (mult n x) (mult n b)) 86 | under plus 87 | 88 | -- mult gives a monoid with (S Z) ----- 89 | 90 | proven mult (S Z) m = m inductively m where 91 | proven mult (S Z) m = m from m where 92 | given m = S x proven mult (S Z) (S x) = S x tested 93 | 94 | proven mult n (S Z) = n tested 95 | 96 | proven mult (mult l n) m = mult l (mult n m) inductively m where 97 | proven mult (mult l n) m = mult l (mult n m) from m where 98 | given m = S x proven mult (mult l n) (S x) = mult l (mult n (S x)) tested where 99 | proven plus (mult l n) (mult (mult l n) x) 100 | = mult l (plus n (mult n x)) 101 | by Route (plus (mult l n) (mult l (mult n x))) where 102 | proven plus (mult l n) (mult (mult l n) x) 103 | = plus (mult l n) (mult l (mult n x)) 104 | under plus 105 | 106 | -- mult distributes from the left ----- 107 | 108 | proven mult Z m = Z inductively m where 109 | proven mult Z m = Z from m 110 | 111 | proven mult (plus l n) m = plus (mult l m) (mult n m) inductively m where 112 | proven mult (plus l n) m = plus (mult l m) (mult n m) from m where 113 | given m = S x proven mult (plus l n) (S x) = plus (mult l (S x)) (mult n (S x)) tested where 114 | proven plus (plus l n) (mult (plus l n) x) 115 | = plus (plus l (mult l x)) (plus n (mult n x)) 116 | by Route (plus (plus l n) (plus (mult l x) (mult n x))) where 117 | proven plus (plus l n) (mult (plus l n) x) = plus (plus l n) (plus (mult l x) (mult n x)) under plus 118 | 119 | 120 | -- max ----------------------------------------------------------------------- 121 | 122 | max :: Number -> Number -> Number 123 | defined max n m inductively n where 124 | defined max n m from n where 125 | defined max Z m = m 126 | defined max (S x) m from m where 127 | defined max (S x) Z = S x 128 | defined max (S x) (S y) = S (max x y) 129 | 130 | -- max gives a monoid with Z ---------- 131 | 132 | proven max Z m = m tested 133 | 134 | proven max n Z = n from n 135 | 136 | proven max (max l n) m = max l (max n m) inductively l where 137 | proven max (max l n) m = max l (max n m) from l where 138 | given l = S x proven max (max (S x) n) m = max (S x) (max n m) 139 | from n where 140 | given n = S y proven max (max (S x) (S y)) m = max (S x) (max (S y) m) 141 | from m where 142 | given m = S z 143 | proven max (max (S x) (S y)) (S z) = max (S x) (max (S y) (S z)) 144 | tested 145 | 146 | -- plus distributes over max ---------- 147 | 148 | proven plus a (max b c) = max (plus a b) (plus a c) inductively a where 149 | proven plus a (max b c) = max (plus a b) (plus a c) from a where 150 | given a = S x 151 | proven plus (S x) (max b c) 152 | = max (plus (S x) b) (plus (S x) c) tested 153 | 154 | proven plus (max a b) c = max (plus a c) (plus b c) 155 | by Route (plus c (max a b)) where 156 | proven plus c (max a b) = max (plus a c) (plus b c) 157 | by Route (max (plus c a) (plus c b)) where 158 | proven max (plus c a) (plus c b) = max (plus a c) (plus b c) under max 159 | 160 | -- mult districutes over max ---------- 161 | 162 | proven mult n (max a b) = max (mult n a) (mult n b) inductively a where 163 | proven mult n (max a b) = max (mult n a) (mult n b) from a where 164 | given a = S x proven mult n (max (S x) b) 165 | = max (mult n (S x)) (mult n b) from b where 166 | given b = S y proven mult n (max (S x) (S y)) 167 | = max (mult n (S x)) (mult n (S y)) tested where 168 | proven plus n (mult n (max x y)) 169 | = max (plus n (mult n x)) (mult n (S y)) 170 | by Route (plus n (max (mult n x) (mult n y))) where 171 | proven plus n (mult n (max x y)) 172 | = plus n (max (mult n x) (mult n y)) 173 | under plus 174 | 175 | 176 | -- substitute ---------------------------------------------------------------- 177 | 178 | substitute :: Formula -> Formula -> Formula 179 | defined substitute r p inductively p where 180 | defined substitute r p from p where 181 | defined substitute r X = r 182 | defined substitute r (Num x) = Num x 183 | defined substitute r (Add s t) = Add (substitute r s) (substitute r t) 184 | defined substitute r (Mul s t) = Mul (substitute r s) (substitute r t) 185 | 186 | -- substitute gives a monoid with X --- 187 | 188 | proven substitute X q = q inductively q where 189 | proven substitute X q = q from q where 190 | given q = Add s t proven substitute X (Add s t) = Add s t tested 191 | given q = Mul s t proven substitute X (Mul s t) = Mul s t tested 192 | 193 | proven substitute p X = p tested 194 | 195 | proven substitute (substitute p q) r = substitute p (substitute q r) 196 | inductively r where 197 | proven substitute (substitute p q) r = substitute p (substitute q r) 198 | from r where 199 | given r = Add s t proven substitute (substitute p q) (Add s t) 200 | = substitute p (substitute q (Add s t)) tested 201 | given r = Mul s t proven substitute (substitute p q) (Mul s t) 202 | = substitute p (substitute q (Mul s t)) tested 203 | 204 | 205 | -- evaluate ------------------------------------------------------------------ 206 | 207 | evaluate :: Formula -> Number -> Number 208 | defined evaluate p n inductively p where 209 | defined evaluate p n from p where 210 | defined evaluate X n = n 211 | defined evaluate (Num m) n = m 212 | defined evaluate (Add q r) n = plus (evaluate q n) (evaluate r n) 213 | defined evaluate (Mul q r) n = mult (evaluate q n) (evaluate r n) 214 | 215 | -- evaluate is a monoid map from susbtitute to function composition 216 | 217 | proven evaluate (substitute r p) n = evaluate p (evaluate r n) 218 | inductively p where 219 | proven evaluate (substitute r p) n = evaluate p (evaluate r n) from p where 220 | given p = Add s t proven evaluate (substitute r (Add s t)) n 221 | = evaluate (Add s t) (evaluate r n) tested where 222 | proven plus (evaluate (substitute r s) n) (evaluate (substitute r t) n) 223 | = plus (evaluate s (evaluate r n)) (evaluate t (evaluate r n)) 224 | under plus 225 | given p = Mul s t proven evaluate (substitute r (Mul s t)) n 226 | = evaluate (Mul s t) (evaluate r n) tested where 227 | proven mult (evaluate (substitute r s) n) (evaluate (substitute r t) n) 228 | = mult (evaluate s (evaluate r n)) (evaluate t (evaluate r n)) 229 | under mult 230 | 231 | 232 | -- degree -------------------------------------------------------------------- 233 | 234 | degree :: Formula -> Number 235 | defined degree p inductively p where 236 | defined degree p from p where 237 | defined degree X = S Z 238 | defined degree (Num c) = Z 239 | defined degree (Add q r) = max (degree q) (degree r) 240 | defined degree (Mul q r) = plus (degree q) (degree r) 241 | 242 | -- degree is a monoid map from substitute to mult 243 | 244 | proven degree (substitute p q) = mult (degree p) (degree q) 245 | inductively q where 246 | proven degree (substitute p q) = mult (degree p) (degree q) from q where 247 | given q = Add s t proven degree (substitute p (Add s t)) 248 | = mult (degree p) (degree (Add s t)) tested where 249 | proven max (degree (substitute p s)) (degree (substitute p t)) 250 | = mult (degree p) (max (degree s) (degree t)) 251 | by Route (max (mult (degree p) (degree s)) 252 | (mult (degree p) (degree t))) where 253 | proven max (degree (substitute p s)) (degree (substitute p t)) 254 | = max (mult (degree p) (degree s)) (mult (degree p) (degree t)) 255 | under max 256 | given q = Mul s t proven degree (substitute p (Mul s t)) 257 | = mult (degree p) (degree (Mul s t)) tested where 258 | proven plus (degree (substitute p s)) (degree (substitute p t)) 259 | = mult (degree p) (plus (degree s) (degree t)) 260 | by Route (plus (mult (degree p) (degree s)) 261 | (mult (degree p) (degree t))) where 262 | proven plus (degree (substitute p s)) (degree (substitute p t)) 263 | = plus (mult (degree p) (degree s)) (mult (degree p) (degree t)) 264 | under plus 265 | 266 | 267 | -- diff ---------------------------------------------------------------------- 268 | 269 | shift :: Formula -> Formula 270 | defined shift p = substitute (Add (Num (S Z)) X) p 271 | 272 | proven evaluate (shift p) n = evaluate p (S n) tested where 273 | proven evaluate (substitute (Add (Num (S Z)) X) p) n = evaluate p (S n) 274 | by Route (evaluate p (evaluate (Add (Num (S Z)) X) n)) 275 | 276 | diff :: Formula -> Formula 277 | defined diff p inductively p where 278 | defined diff p from p where 279 | defined diff X = Num (S Z) 280 | defined diff (Num c) = Num Z 281 | defined diff (Add q r) = Add (diff q) (diff r) 282 | defined diff (Mul q r) = Add (Mul (diff q) (shift r)) (Mul q (diff r)) 283 | 284 | proven evaluate p (S n) = plus (evaluate (diff p) n) (evaluate p n) 285 | inductively p where 286 | proven evaluate p (S n) = plus (evaluate (diff p) n) (evaluate p n) 287 | from p where 288 | given p = Add q r 289 | proven evaluate (Add q r) (S n) 290 | = plus (evaluate (diff (Add q r)) n) (evaluate (Add q r) n) 291 | tested where 292 | proven plus (evaluate q (S n)) (evaluate r (S n)) 293 | = plus (plus (evaluate (diff q) n) (evaluate (diff r) n)) 294 | (plus (evaluate q n) (evaluate r n)) by Route 295 | (plus (plus (evaluate (diff q) n) (evaluate q n)) 296 | (plus (evaluate (diff r) n) (evaluate r n))) where 297 | proven plus (evaluate q (S n)) (evaluate r (S n)) 298 | = plus (plus (evaluate (diff q) n) (evaluate q n)) 299 | (plus (evaluate (diff r) n) (evaluate r n)) 300 | under plus 301 | given p = Mul q r 302 | proven evaluate (Mul q r) (S n) 303 | = plus (evaluate (diff (Mul q r)) n) (evaluate (Mul q r) n) tested where 304 | proven mult (evaluate q (S n)) (evaluate r (S n)) 305 | = plus 306 | (plus (mult (evaluate (diff q) n) (evaluate (shift r) n)) 307 | (mult (evaluate q n) (evaluate (diff r) n))) 308 | (mult (evaluate q n) (evaluate r n)) 309 | by Route (mult (plus (evaluate (diff q) n) (evaluate q n)) 310 | (evaluate r (S n))) where 311 | proven mult (evaluate q (S n)) (evaluate r (S n)) 312 | = mult (plus (evaluate (diff q) n) (evaluate q n)) (evaluate r (S n)) 313 | under mult 314 | proven mult (plus (evaluate (diff q) n) (evaluate q n)) (evaluate r (S n)) 315 | = plus (plus (mult (evaluate (diff q) n) (evaluate (shift r) n)) 316 | (mult (evaluate q n) (evaluate (diff r) n))) 317 | (mult (evaluate q n) (evaluate r n)) 318 | by Route 319 | (plus (mult (evaluate (diff q) n) (evaluate (shift r) n)) 320 | (plus (mult (evaluate q n) (evaluate (diff r) n)) 321 | (mult (evaluate q n) (evaluate r n)))) where 322 | proven mult (plus (evaluate (diff q) n) (evaluate q n)) (evaluate r (S n)) 323 | = plus (mult (evaluate (diff q) n) (evaluate (shift r) n)) 324 | (plus (mult (evaluate q n) (evaluate (diff r) n)) 325 | (mult (evaluate q n) (evaluate r n))) 326 | by Route 327 | (plus (mult (evaluate (diff q) n) (evaluate (shift r) n)) 328 | (mult (evaluate q n) 329 | (plus (evaluate (diff r) n) (evaluate r n)))) where 330 | proven mult (plus (evaluate (diff q) n) (evaluate q n)) (evaluate r (S n)) 331 | = plus (mult (evaluate (diff q) n) (evaluate (shift r) n)) 332 | (mult (evaluate q n) (plus (evaluate (diff r) n) (evaluate r n))) 333 | by Route (plus (mult (evaluate (diff q) n) (evaluate r (S n))) 334 | (mult (evaluate q n) (evaluate r (S n)))) where 335 | proven plus (mult (evaluate (diff q) n) (evaluate r (S n))) 336 | (mult (evaluate q n) (evaluate r (S n))) 337 | = plus (mult (evaluate (diff q) n) (evaluate (shift r) n)) 338 | (mult (evaluate q n) (plus (evaluate (diff r) n) (evaluate r n))) 339 | under plus where 340 | proven mult (evaluate (diff q) n) (evaluate r (S n)) 341 | = mult (evaluate (diff q) n) (evaluate (shift r) n) 342 | under mult 343 | proven mult (evaluate q n) (evaluate r (S n)) 344 | = mult (evaluate q n) (plus (evaluate (diff r) n) (evaluate r n)) 345 | under mult 346 | proven plus (mult (evaluate (diff q) n) (evaluate (shift r) n)) 347 | (mult (evaluate q n) (plus (evaluate (diff r) n) (evaluate r n))) 348 | = plus (mult (evaluate (diff q) n) (evaluate (shift r) n)) 349 | (plus (mult (evaluate q n) (evaluate (diff r) n)) 350 | (mult (evaluate q n) (evaluate r n))) 351 | under plus 352 | 353 | 354 | sumFunBelow :: (Number -> Number) -> (Number -> Number) 355 | defined sumFunBelow f n inductively n where 356 | defined sumFunBelow f n from n where 357 | defined sumFunBelow f Z = Z 358 | defined sumFunBelow f (S x) = plus (f x) (sumFunBelow f x) 359 | 360 | proven evaluate p n = plus (sumFunBelow (evaluate (diff p)) n) (evaluate p Z) 361 | inductively n where 362 | proven evaluate p n = plus (sumFunBelow (evaluate (diff p)) n) (evaluate p Z) 363 | from n where 364 | given n = S x proven evaluate p (S x) 365 | = plus (sumFunBelow (evaluate (diff p)) (S x)) (evaluate p Z) 366 | tested where 367 | proven evaluate p (S x) = 368 | plus (plus (evaluate (diff p) x) (sumFunBelow (evaluate (diff p)) x)) (evaluate p Z) 369 | by Route 370 | (plus (evaluate (diff p) x) 371 | (plus (sumFunBelow (evaluate (diff p)) x) (evaluate p Z))) where 372 | proven evaluate p (S x) 373 | = plus (evaluate (diff p) x) 374 | (plus (sumFunBelow (evaluate (diff p)) x) (evaluate p Z)) 375 | by Route (plus (evaluate (diff p) x) (evaluate p x)) where 376 | proven plus (evaluate (diff p) x) (evaluate p x) 377 | = plus (evaluate (diff p) x) 378 | (plus (sumFunBelow (evaluate (diff p)) x) (evaluate p Z)) 379 | under plus -------------------------------------------------------------------------------- /eg/Highlight.ask: -------------------------------------------------------------------------------- 1 | -- Some examples to exercise the emacs mode syntax highlighting 2 | -- (incomplete, as of 31 Jan 2025) 3 | 4 | proven a -> a by ImpI 5 | proven b -> b given 6 | 7 | proven a -> a & a by ImpI where 8 | given a proven a & a by AndI 9 | -------------------------------------------------------------------------------- /eg/Nat.ask: -------------------------------------------------------------------------------- 1 | module Nat where 2 | 3 | data Nat 4 | = Z 5 | | S Nat 6 | 7 | -- much bikeshedding ahoy 8 | (+) :: Nat -> Nat -> Nat 9 | compute x + y reducing x where 10 | compute x + y from x where 11 | compute Z + y = y 12 | given x' :: Nat, forall y'. x' + y' 13 | compute S x' + y = S (x' + y) 14 | 15 | fib :: Nat -> Nat 16 | compute fib x reducing x where 17 | compute fib x from x where 18 | compute fib Z = Z 19 | compute fib (S x) from x where 20 | compute fib (S Z) = S Z 21 | compute fib (S y@(S x)) = fib y + fib x 22 | 23 | prop Nat <= Nat where 24 | prove Z <= m by LeZ 25 | prove S n <= S m by LeSS where 26 | prove n <= m 27 | 28 | prove p <= n -> n <= m -> p <= m by ImpI where 29 | given p <= n prove n <= m -> p <= m reducing p <= n where 30 | prove n <= m -> p <= m by ImpI where 31 | given n <= m prove p <= m from p <= n where 32 | prove Z <= n by LeZ 33 | given p' :: Nat, n' :: Nat 34 | , p' <= n' 35 | , S n' <= m 36 | , {IH m'} n' <= m' -> p' <= m' 37 | prove S p' <= m from S n' <= m where 38 | given m' :: Nat, n' <= m' prove S p' <= S m' by LeSS where 39 | prove p' <= m' from IH m' 40 | 41 | -------------------------------------------------------------------------------- /eg/Proofs.ask: -------------------------------------------------------------------------------- 1 | proven a & b -> b & a by ImpI where 2 | given a & b proven b & a from a & b where 3 | given a, b proven b & a by AndI 4 | 5 | proven a | (a -> False) by Contradiction where 6 | given Not (a | (a -> False)) proven False from Not (a | (a -> False)) where 7 | proven a | (a -> False) by OrIR where 8 | proven a -> False by ImpI where 9 | given a proven False from Not (a | (a -> False)) where 10 | proven a | (a -> False) by OrIL 11 | -------------------------------------------------------------------------------- /eg/Proofs.asked: -------------------------------------------------------------------------------- 1 | proven a & b -> b & a by ImpI where 2 | given a & b proven b & a from a & b where 3 | given a, b proven b & a by AndI 4 | 5 | prove a | (a -> False) by Contradiction where 6 | {- I don't see why you need this 7 | given (a | (a -> False)) -> False prove False from (a | (a -> False)) -> False where 8 | prove a | (a -> False) by OrIR where 9 | prove a -> False by ImpI where 10 | given a prove False from (a | (a -> False)) -> False where 11 | prove a | (a -> False) by OrIL 12 | -} 13 | given Not (a | (a -> False)) prove False ? 14 | -------------------------------------------------------------------------------- /eg/Trouble.ask: -------------------------------------------------------------------------------- 1 | prove ((a -> c) -> a) & (a & (b -> c) -> b) & (b -> c) -> b by ImpI where 2 | given ((a -> c) -> a) & (a & (b -> c) -> b) & (b -> c) prove b from ((a -> c) -> a) & (a & (b -> c) -> b) & (b -> c) where 3 | given (a -> c) -> a, (a & (b -> c) -> b) & (b -> c) prove b from (a & (b -> c) -> b) & (b -> c) where 4 | given a & (b -> c) -> b, b -> c prove b from (a -> c) -> b where 5 | prove (a -> c) -> b by ImpI where 6 | given a -> c prove b from a & (b -> c) -> b where 7 | prove a & (b -> c) from (a -> c) -> a where 8 | given a prove a & (b -> c) by AndI 9 | prove a -> c by ImpI where 10 | given a prove c from b -> c where 11 | prove b from a & (b -> c) -> b where 12 | prove a & (b -> c) by AndI 13 | -------------------------------------------------------------------------------- /eg/zoiks.ask: -------------------------------------------------------------------------------- 1 | data Boo = Bah 2 | prove f Bah = f ? 3 | -------------------------------------------------------------------------------- /emacs/ask.el: -------------------------------------------------------------------------------- 1 | ;;(require 'compile) 2 | 3 | ;; based on: http://ergoemacs.org/emacs/elisp_syntax_coloring.html 4 | 5 | ;; syntax table 6 | ;;(defvar hacky-syntax-table (make-syntax-table)) 7 | 8 | (defface ask-primary-keyword 9 | '((t :foreground "black" 10 | :background "orange" 11 | :weight bold 12 | )) 13 | "Face for keywords (prove, define)." 14 | :group 'ask ) 15 | 16 | (defface ask-assumption 17 | '((t :foreground "black" 18 | :background "orchid" 19 | :weight bold 20 | )) 21 | "Face for given." 22 | :group 'ask ) 23 | 24 | 25 | (defface ask-secondary-keyword 26 | '((t :foreground "black" 27 | :weight bold 28 | )) 29 | "Face for \"glue\" keywords (by, where, ...)." 30 | :group 'ask ) 31 | 32 | (defface ask-response-success 33 | '((t :foreground "black" 34 | :background "pale green" 35 | :weight bold 36 | )) 37 | "Face for successful directive responses." 38 | :group 'ask ) 39 | 40 | (defvar ask-syntax-table 41 | (let ((st (make-syntax-table))) 42 | ;; comments based on https://stackoverflow.com/questions/20731684/elisp-syntax-table-comments-for-haskell-style-comments 43 | (modify-syntax-entry ?\{ "(}1nb" st) 44 | (modify-syntax-entry ?\} "){4nb" st) 45 | (modify-syntax-entry ?- "_ 123" st) 46 | (modify-syntax-entry ?\n ">" st) 47 | st)) 48 | 49 | ;; define the mode 50 | (define-derived-mode ask-mode fundamental-mode 51 | "ask mode" 52 | ;; handling comments 53 | :syntax-table ask-syntax-table 54 | ;; code for syntax highlighting 55 | (font-lock-add-keywords nil '(("^\s*\\(given.*\\)?\\(proven\\|defined\\)[[:space:]]+" . (2 'ask-response-success)))) 56 | (font-lock-add-keywords nil '(("^\s*\\(given.*\\)?\\(prove\\|define\\)[[:space:]]+" . (2 'ask-primary-keyword)))) 57 | (font-lock-add-keywords nil '(("\\(data\\|prop\\|where\\|from\\|by\\|inductively\\|tested\\|test\\|under\\)" . (1 'ask-secondary-keyword)))) 58 | (font-lock-add-keywords nil '(("^\s*\\(given\\)[[:space:]]+" . (1 'ask-assumption)))) 59 | (font-lock-add-keywords nil '(("[[:space:]]+\\(given\\)\s*$" . (1 'ask-secondary-keyword)))) 60 | 61 | (setq mode-name "ask") 62 | ) 63 | 64 | 65 | 66 | ;; Customisation options 67 | 68 | (defgroup ask nil 69 | "A total fragment of Haskell embedded in a proof system." 70 | :group 'languages) 71 | 72 | (defcustom ask-command "ask" 73 | "The path to the ask command to run." 74 | :type 'string 75 | :group 'ask) 76 | 77 | (defun ask-run-on-file (ask-file) 78 | "Run ask on the current buffer and replace the buffer contents with the ask output." 79 | 80 | (save-some-buffers compilation-ask-about-save 81 | (when (boundp 'compilation-save-buffers-predicate) 82 | compilation-save-buffers-predicate)) 83 | 84 | (let* ((res (with-temp-buffer 85 | (list (call-process ask-command nil 86 | (current-buffer) nil ask-file) 87 | (buffer-string)))) 88 | (exitcode (car res)) 89 | (output (cadr res))) 90 | (if (< exitcode 10) 91 | (with-current-buffer (current-buffer) 92 | (let ((old-point (point))) 93 | (erase-buffer) 94 | (insert output) 95 | (goto-char old-point))) 96 | (message "%s" output)))) 97 | 98 | ;;;###autoload 99 | (defun ask-run (override-options) 100 | "Run ask on the current file." 101 | (interactive "P") 102 | (ask-run-on-file (shell-quote-argument (buffer-file-name))) 103 | ) 104 | 105 | (defun ask-replace-current-word-query (query replace) 106 | "Replace current word with prompted word." 107 | (interactive 108 | (let ((q (current-word))) 109 | (list 110 | q 111 | (read-string (concat "Replace " q " by: "))))) 112 | (save-excursion 113 | (beginning-of-line) 114 | (query-replace query replace t))) 115 | 116 | (define-key ask-mode-map (kbd "") 'ask-run) 117 | (define-key ask-mode-map (kbd "C-c C-r") 'ask-replace-current-word-query) 118 | 119 | (provide 'ask-mode) 120 | -------------------------------------------------------------------------------- /lib/Language/Ask/Bwd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | 3 | module Language.Ask.Bwd where 4 | 5 | infixl 3 :<, <>< 6 | 7 | data Bwd x = B0 | Bwd x :< x deriving (Show, Eq, Ord, Functor, Foldable, Traversable) 8 | 9 | (<>>) :: Bwd x -> [x] -> [x] 10 | B0 <>> ys = ys 11 | (xz :< x) <>> ys = xz <>> (x : ys) 12 | 13 | (<><) :: Bwd x -> [x] -> Bwd x 14 | xz <>< [] = xz 15 | xz <>< (x : xs) = (xz :< x) <>< xs 16 | 17 | instance Monoid (Bwd x) where 18 | mempty = B0 19 | mappend xz B0 = xz 20 | mappend xz (yz :< y) = mappend xz yz :< y 21 | 22 | instance Semigroup (Bwd x) where (<>) = mappend -------------------------------------------------------------------------------- /lib/Language/Ask/ChkRaw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, LambdaCase, PatternSynonyms, RankNTypes, ScopedTypeVariables #-} 2 | 3 | module Language.Ask.ChkRaw where 4 | 5 | import Data.List hiding ((\\)) 6 | import Data.Char 7 | import Control.Arrow ((***)) 8 | import Data.Bifoldable 9 | import Control.Applicative 10 | import Data.Traversable 11 | import Control.Monad 12 | import Data.Foldable 13 | 14 | import Debug.Trace 15 | 16 | import Language.Ask.Hide 17 | import Language.Ask.Thin 18 | import Language.Ask.Bwd 19 | import Language.Ask.OddEven 20 | import Language.Ask.Lexing 21 | import Language.Ask.RawAsk 22 | import Language.Ask.Tm 23 | import Language.Ask.Glueing 24 | import Language.Ask.Context 25 | import Language.Ask.Typing 26 | import Language.Ask.Proving 27 | import Language.Ask.Printing 28 | import Language.Ask.HardwiredRules 29 | import Language.Ask.Progging 30 | 31 | tracy = const id 32 | tripe = const id 33 | 34 | type Anno = 35 | ( Status 36 | , Bool -- is it proven? 37 | ) 38 | 39 | data Status 40 | = Junk Gripe 41 | | Keep 42 | | Need 43 | deriving Show 44 | 45 | passive :: Make () Appl -> Make Anno TmR 46 | passive (Make k g m () ps src) = 47 | Make k (Your g) (fmap Your m) (Keep, False) (fmap subPassive ps) src 48 | 49 | subPassive :: SubMake () Appl -> SubMake Anno TmR 50 | subPassive ((srg, (ds, gs)) ::- p) = (srg, (ds, map (fmap Your) gs)) ::- passive p 51 | subPassive (SubPGuff ls) = SubPGuff ls 52 | 53 | surplus :: Make () Appl -> Make Anno TmR 54 | surplus (Make k g m () ps src) = 55 | Make k (Your g) (fmap Your m) (Junk Surplus, True) (fmap subPassive ps) src 56 | 57 | subSurplus :: SubMake () Appl -> SubMake Anno TmR 58 | subSurplus ((srg, (ds, gs)) ::- p) = (srg, (ds, map (fmap Your) gs)) ::- surplus p 59 | subSurplus (SubPGuff ls) = SubPGuff ls 60 | 61 | chkProg 62 | :: Proglem 63 | -> Appl 64 | -> Method Appl -- the method 65 | -> Bloc (SubMake () Appl) -- the subproofs 66 | -> ([LexL], [LexL]) -- source tokens (head, body) 67 | -> AM (Make Anno TmR) -- the reconstructed proof 68 | chkProg p gr mr ps src@(h,b) = do 69 | push ExpectBlocker 70 | m <- case mr of 71 | Stub b -> pure $ Stub b 72 | Is a -> do 73 | doorStop 74 | True <- tracy ("IS " ++ show a ++ " ?") $ return True 75 | ga <- gamma 76 | for (paranoia ga []) $ \ x -> push $ RecShadow x 77 | traverse push (localCx p) 78 | push RefuseQuantification 79 | a@(Our t _) <- elabTmR (rightTy p) a 80 | pop $ \ x -> case x of 81 | RefuseQuantification -> True 82 | _ -> False 83 | True <- tracy ("IS SO " ++ show t) $ return True 84 | (PC _ ps, sb) <- patify $ TC "" (map fst (leftImpl p ++ leftSatu p ++ leftAppl p)) 85 | True <- tracy ("PATIFIED " ++ show ps ++ show sb) $ return True 86 | de <- doorStep 87 | pushOutDoor $ (fNom p, ps) :=: 88 | rfold e4p sb (discharge de t ::: discharge de (rightTy p)) 89 | pure (Is a) 90 | From a@(_, ((_, _, x) :$$ as)) -> do 91 | doorStop 92 | traverse push (localCx p) 93 | (e, _) <- elabSyn EXP x as 94 | doorStep 95 | TE (TP (xn, Hide ty)) <- return (upTE e) 96 | tels <- conSplit PAT ty 97 | traverse (expect xn ty p) tels 98 | pure (From (Our (TE e) a)) 99 | Ind [] -> gripe EmptyInductively 100 | Ind xs -> do 101 | p <- inductively p xs 102 | push (Expect p) 103 | pure $ Ind xs 104 | _ -> gripe FAIL 105 | (ns, b) <- chkSubProofs ps 106 | pop $ \case {ExpectBlocker -> True; _ -> False} 107 | let defined = case m of {Stub _ -> False; _ -> all happy ns} 108 | return $ Make Def (Your gr) m (Keep, b && defined) ns src 109 | where 110 | paranoia :: Bwd CxE -> [String] -> [String] 111 | paranoia B0 defs = [] 112 | paranoia (ga :< Defined f) defs = paranoia ga (f : defs) 113 | paranoia (ga :< Declare u _ _) defs | not (u `elem` defs) = 114 | u : paranoia ga defs 115 | paranoia (ga :< _) defs = paranoia ga defs 116 | expect :: Nom -> Tm -> Proglem -> (Con, Tel) -> AM () 117 | expect xn ty p (c, tel) = do 118 | (de, sb) <- wrangle (localCx p) 119 | push . Expect $ sbpg sb (p {localCx = de}) 120 | where 121 | wrangle B0 = gripe FAIL 122 | wrangle (ga :< (Bind (yn, _) (User y))) | yn == xn = do 123 | (ga, xs) <- bungle ga [] B0 y tel 124 | return (ga, [(xn, TC c xs ::: ty)]) 125 | wrangle (ga :< z) = do 126 | (ga, sb) <- wrangle ga 127 | case z of 128 | Hyp b h -> return (ga :< Hyp b (rfold e4p sb h), sb) 129 | Bind (yn, Hide ty) k -> do 130 | let yp = (yn, Hide (rfold e4p sb ty)) 131 | return (ga :< Bind yp k, (yn, TP yp) : sb) 132 | z -> return (ga :< z, sb) 133 | bungle ga sch xz y (Pr hs) = do 134 | zs <- for sch $ \ ((x, s), _) -> do 135 | xn <- fresh (y ++ x) 136 | return (x, xn, s) 137 | let m = [ (z, TE (TP (zn, Hide (stan m s)))) 138 | | (z, zn, s) <- zs 139 | ] 140 | return (foldl glom ga m <>< map (Hyp True) (stan m hs), stan m (xz <>> [])) 141 | where 142 | glom ga (z, TE (TP xp)) = ga :< Bind xp (User z) 143 | glom ga _ = ga 144 | bungle ga sch xz y (Ex a b) = do 145 | xn <- fresh "" 146 | let xp = (xn, Hide a) 147 | (ga, xs) <- bungle (ga :< Bind xp (User "")) sch xz y (b // TP xp) 148 | return (ga, TE (TP xp) : xs) 149 | bungle ga sch xz y ((x, s) :*: tel) = 150 | bungle ga (topInsert ((x, s), ()) sch) (xz :< TM x []) y tel 151 | sbpg :: [(Nom, Syn)] -> Proglem -> Proglem 152 | sbpg sb (Proglem de f u li ls la ty) = 153 | Proglem de f u 154 | (rfold e4p sb li) 155 | (rfold e4p sb ls) 156 | (rfold e4p sb la) 157 | (rfold e4p sb ty) 158 | 159 | -- this type is highly provisional 160 | chkProof 161 | :: TmR -- the goal 162 | -> Method Appl -- the method 163 | -> Bloc (SubMake () Appl) -- the subproofs 164 | -> ([LexL], [LexL]) -- source tokens (head, body) 165 | -> AM (Make Anno TmR) -- the reconstructed proof 166 | 167 | chkProof g m ps src = do 168 | ga <- filter (\case {Bind _ _ -> True; _ -> False}) <$> ((<>> []) <$> gamma) 169 | True <- tracy ("OHAI: " ++ show g ++ " " ++ show m ++ "\n" ++ show ga) $ return True 170 | cope go junk $ \ p -> do 171 | ga <- filter (\case {Bind _ _ -> True; _ -> False}) <$> ((<>> []) <$> gamma) 172 | True <- tracy ("KTHXBAI: " ++ show p ++ "\n" ++ show ga) $ return True 173 | return p 174 | where 175 | junk gr = return $ Make Prf g (fmap Your m) (Junk gr, True) 176 | (fmap subPassive ps) src 177 | go = case my g of 178 | Just gt -> do 179 | (m, b0) <- case m of 180 | Stub b -> pure $ (Stub b, False) 181 | By r -> (,True) <$> By <$> (gt `by` r) 182 | From h@(_, (t, _, _) :$$ _) 183 | | elem t [Uid, Sym] -> do 184 | ht <- elabTm EXP Prop h 185 | demand (PROVE ht) 186 | fromSubs gt ht 187 | return (From (Our ht h), True) 188 | From h@(_, (Lid, _, x) :$$ []) -> what's x >>= \case 189 | Right (e@(TP xp), ty) -> do 190 | ty <- hnf ty 191 | cts <- conSplit PAT ty 192 | (From (Our (TE e) h), True) <$ 193 | traverse (splitProof xp ty gt) cts 194 | _ -> gripe $ FromNeedsConnective h 195 | From h -> gripe $ FromNeedsConnective h 196 | Ind [] -> gripe EmptyInductively 197 | Ind xs -> do 198 | indPrf gt xs 199 | return $ (Ind xs, True) 200 | MGiven -> hnf gt >>= \case 201 | TC "=" [ty, lhs, rhs] -> 202 | (MGiven,) <$> (given (TC "=" [ty, rhs, lhs]) 203 | <|> given (TC "=" [ty, lhs, rhs])) 204 | _ -> (MGiven,) <$> given gt 205 | Tested b -> testRun gt >>= \case 206 | TC "=" [ty, lhs, rhs] -> (Tested b, True) <$ tested ty lhs rhs 207 | _ -> do 208 | gt <- norm gt 209 | demand (PROVE gt) 210 | return (Tested b, True) 211 | -- gripe $ TestNeedsEq gt 212 | Under f -> hnf gt >>= \case 213 | TC "=" [ty, lhs, rhs] -> (Under (Your f), True) <$ under lhs rhs f 214 | _ -> gripe $ UnderNeedsEq gt 215 | (ns, b1) <- chkSubProofs ps 216 | let proven = case m of {Stub _ -> False; _ -> all happy ns} 217 | return $ Make Prf g m (Keep, b0 && b1 && proven) ns src 218 | Nothing -> return $ Make Prf g (fmap Your m) (Junk Mardiness, True) 219 | (fmap subPassive ps) src 220 | 221 | happy :: SubMake Anno TmR -> Bool 222 | happy (_ ::- Make _ _ _ (_, b) _ _) = b 223 | happy _ = True 224 | 225 | 226 | -- checking subproofs amounts to validating them, 227 | -- then checking which subgoals are covered, 228 | -- generating stubs for those which are not, 229 | -- and marking as surplus those subproofs which do 230 | -- not form part of the cover 231 | chkSubProofs 232 | :: Bloc (SubMake () Appl) -- subproofs coming from user 233 | -> AM (Bloc (SubMake Anno TmR) 234 | , Bool {-no hidden deps-}) -- reconstruction 235 | chkSubProofs ps = do 236 | ss <- demands 237 | (qs, us) <- traverse (validSubProof ss) ps >>= cover ss 238 | True <- tracy ("COVER " ++ show (qs, us)) $ return True 239 | eps <- gamma >>= sprog 240 | (vs, b) <- extra us 241 | return (glom (fmap squish qs) (eps ++ vs), b) 242 | where 243 | cover 244 | :: [Subgoal] -- subgoals to cover 245 | -> Bloc (Bool, SubMake Anno TmR) -- (used yet?, subproof) 246 | -> AM (Bloc (Bool, SubMake Anno TmR) -- ditto 247 | , [Subgoal] -- undischarged subgoals 248 | ) 249 | cover [] qs = return (qs, []) 250 | cover (t : ts) qs = cope (cover1 t qs) 251 | (\ _ -> cover ts qs >>= \ (qs, ts) -> return (qs, t : ts)) 252 | $ cover ts 253 | cover1 :: Subgoal -> Bloc (Bool, SubMake Anno TmR) 254 | -> AM (Bloc (Bool, SubMake Anno TmR)) 255 | cover1 t (_ :-/ Stop) = gripe FAIL 256 | cover1 t (g :-/ (b, p) :-\ qs) = cope (covers t p) 257 | (\ _ -> ((g :-/) . ((b, p) :-\ )) <$> cover1 t qs) 258 | $ \ _ -> return $ (g :-/ (True, p) :-\ qs) 259 | covers :: Subgoal -> SubMake Anno TmR -> AM () 260 | covers sg sp = do 261 | doorStop 262 | True <- tracy ("COVERS: " ++ show sg ++ " ?\n" ++ show sp) $ return True 263 | go sg sp 264 | True <- tracy ("HAPPY: " ++ show sg ++ " ?\n" ++ show sp) $ return True 265 | doorStep 266 | return () 267 | where 268 | go t ((_, (_, hs)) ::- Make Prf g m (Keep, _) _ _) = subgoal t $ \ t -> do 269 | g <- mayhem $ my g 270 | traverse smegUp (g : [h | Given x <- hs, Just h <- [my x]]) 271 | traverse ensure hs 272 | True <- tracy ("COVERS " ++ show (g, t)) $ return True 273 | cope (unify Prop g t) 274 | (\ gr -> do 275 | True <- tracy "NOPE" $ return True 276 | gripe gr) 277 | return 278 | True <- tracy "YEP" $ return True 279 | return () 280 | go _ _ = gripe FAIL 281 | ensure (Given h) = mayhem (my h) >>= given 282 | squish :: (Bool, SubMake Anno TmR) -> SubMake Anno TmR 283 | squish (False, gs ::- Make k g m (Keep, _) ss src) = 284 | gs ::- Make k g m (Junk Surplus, True) ss src 285 | squish (_, q) = q 286 | sprog :: Context -> AM [SubMake Anno TmR] 287 | sprog ga = do 288 | (ga, ps) <- go ga [] 289 | setGamma ga 290 | return ps 291 | where 292 | go :: Context -> [SubMake Anno TmR] -> AM (Context, [SubMake Anno TmR]) 293 | go B0 ps = return (B0, ps) 294 | go ga@(_ :< ExpectBlocker) ps = return (ga, ps) 295 | go (ga :< Expect p) ps = go ga (blep p : ps) 296 | go (ga :< z) ps = ((:< z) *** id) <$> go ga ps 297 | blep :: Proglem -> SubMake Anno TmR 298 | blep p = ([], ([], [])) ::- -- bad hack on its way! 299 | Make Def (My (TC (uName p) (fst (frob [] (map fst (leftSatu p ++ leftAppl p)))))) 300 | (Stub True) (Need, False) ([] :-/ Stop) ([], []) 301 | where 302 | frob zs [] = ([], zs) 303 | frob zs (TC c ts : us) = case frob zs ts of 304 | (ts, zs) -> case frob zs us of 305 | (us, zs) -> (TC c ts : us, zs) 306 | frob zs (TE (TP (x, _)) : us) = let 307 | y = case foldMap (dubd x) (localCx p) of 308 | [y] -> y 309 | _ -> fst (last x) 310 | z = grob (krob y) Nothing zs 311 | in case frob (z : zs) us of 312 | (us, zs) -> (TC z [] : us, zs) 313 | krob [] = "x" 314 | krob (c : cs) 315 | | isLower c = c : filter isIdTaily cs 316 | | isUpper c = toLower c : filter isIdTaily cs 317 | | otherwise = krob cs 318 | grob x i zs = if elem y zs then grob x j zs else y where 319 | (y, j) = case i of 320 | Nothing -> (x, Just 0) 321 | Just n -> (x ++ show n, Just (n + 1)) 322 | dubd xn (Bind (yn, _) (User y)) | xn == yn = [y] 323 | dubd xn _ = [] 324 | 325 | extra :: [Subgoal] -> AM ([SubMake Anno TmR], Bool) 326 | extra [] = return ([], True) 327 | extra (u : us) = cope (subgoal u obvious) 328 | (\ _ -> do 329 | u <- need u 330 | (us, b') <- extra us 331 | return (u : us, False)) 332 | $ \ b -> do 333 | (us, b') <- extra us 334 | return (us, b && b') 335 | obvious s@(TC "=" [ty, lhs, rhs]) 336 | = given s 337 | <|> given (TC "=" [ty, rhs, lhs]) 338 | <|> True <$ equal ty (lhs, rhs) 339 | <|> given FALSE 340 | obvious s 341 | = given s 342 | <|> given FALSE 343 | <|> True <$ equal Prop (s, TRUE) 344 | 345 | need (PROVE g) = return $ 346 | ([], ([], [])) ::- Make Prf (My g) (Stub True) (Need, False) 347 | ([] :-/ Stop) ([], []) 348 | need (GIVEN h u) = need u >>= \case 349 | (_, (ds, gs)) ::- p -> return $ ([], (ds, Given (My h) : gs)) ::- p 350 | s -> return s 351 | need (EVERY s b) = ("x", s) |:- \ x@(TP (xn, _)) -> 352 | need (b // x) 353 | glom :: Bloc x -> [x] -> Bloc x 354 | glom (g :-/ p :-\ gps) = (g :-/) . (p :-\) . glom gps 355 | glom end = foldr (\ x xs -> [] :-/ x :-\ xs) end 356 | 357 | subgoal :: Subgoal -> (Tm -> AM x) -> AM x 358 | subgoal (GIVEN h g) k = h |- subgoal g k 359 | subgoal (PROVE g) k = k g 360 | subgoal (EVERY t b) k = ("", t) |:- \ e -> subgoal (b // e) k 361 | 362 | validSubProof 363 | :: [Subgoal] -- sneakily peek at what we want 364 | -> SubMake () Appl 365 | -> AM (Bool, SubMake Anno TmR) 366 | validSubProof sgs sps = do 367 | True <- tracy ("VSUB: " ++ show sps) $ return True 368 | push ImplicitQuantifier -- cheeky! 369 | (b, m) <- go sps 370 | ga <- gamma 371 | (ga, ds, us) <- jank ga 372 | True <- tracy ("JANK: " ++ show us) $ return True 373 | setGamma ga 374 | return (b, splott us ds m) 375 | where 376 | go ((srg, (ds, Given h : gs)) ::- p@(Make k sg sm () sps src)) = 377 | cope (elabTm EXP Prop h) 378 | (\ gr -> return $ (False, (srg, (ds, map (fmap Your) (Given h : gs))) ::- 379 | Make k (Your sg) (fmap Your sm) (Junk gr, True) 380 | (fmap subPassive sps) src)) 381 | $ \ ht -> do 382 | (b, (srg, (ds, gs)) ::- p) <- ht |- go ((srg, (ds, gs)) ::- p) 383 | return $ (b, (srg, (ds, Given (Our ht h) : gs)) ::- p) 384 | go ((srg, (ds, [])) ::- Make Prf sg sm () sps src) = 385 | cope (elabTmR Prop sg) 386 | (\ gr -> return $ (False, (srg, (ds, [])) ::- Make Prf (Your sg) (fmap Your sm) 387 | (Junk gr, True) (fmap subPassive sps) src)) 388 | $ \ sg -> (False, ) <$> (((srg, (ds, [])) ::-) <$> chkProof sg sm sps src) 389 | go ((srg, (ds, [])) ::- Make Def sg@(_, (_, _, f) :$$ as) sm () sps src) = do 390 | p <- gamma >>= expected f as 391 | True <- tracy ("FOUND " ++ show p) $ return True 392 | True <- gamma >>= \ ga -> tracy (show ga) $ return True 393 | (True,) <$> (((srg, (ds, [])) ::-) <$> chkProg p sg sm sps src) 394 | where 395 | expected f as B0 = gripe Surplus 396 | expected f as (ga :< z) = do 397 | True <- tracy ("EXP " ++ show f ++ show as ++ show z) $ return True 398 | cope (do 399 | Expect p <- return z 400 | dubStep p f as 401 | ) 402 | (\ gr -> expected f as ga <* push z) 403 | (<$ setGamma ga) 404 | go (SubPGuff ls) = return $ (False, SubPGuff ls) 405 | jank (ga :< ImplicitQuantifier) = return (ga, [], []) 406 | jank (ga :< Bind (x, Hide ty) k) = do 407 | (ga, ds, us) <- jank ga 408 | ty <- norm ty 409 | case k of 410 | Defn t -> do 411 | t <- norm t 412 | return (ga, (x, rfold e4p ds (t ::: ty)) : ds, us) 413 | User y -> return (ga, (x, TP (x, Hide ty)) : ds, (x, y) : us) 414 | _ -> return (ga, (x, TP (x, Hide ty)) : ds, us) 415 | jank (ga :< z) = do 416 | (ga, ds, us) <- jank ga 417 | return (ga :< z, ds, us) 418 | jank ga = return (ga, [], []) 419 | splott us ds ((ls, (vs, hs)) ::- Make mk g me a sps src) = 420 | ((ls, (vs ++ us, [Given (rfold e4p ds h) | Given h <- hs])) ::- 421 | Make mk (rfold e4p ds g) me a sps src) 422 | splott _ _ s = s 423 | 424 | fromSubs 425 | :: Tm -- goal 426 | -> Tm -- fmla 427 | -> AM () 428 | fromSubs g f = hnf f >>= \case 429 | q@(TC "=" [ty, lhs, rhs]) -> do 430 | ty <- norm ty 431 | lhs' <- hnf lhs 432 | rhs' <- hnf rhs 433 | case (ty, lhs', rhs') of 434 | (TC d ss, TC c rs, TC e ts) 435 | | c /= e -> flip (cope (isDataType d)) return $ \ _ -> 436 | fred . GIVEN q $ PROVE g 437 | | otherwise -> ginger B0 [(ty, (lhs, rhs))] g 438 | (_, TE (TP (xn, _)), _) -> 439 | fred $ PROVE (e4p (xn, rhs ::: ty) g) 440 | (_, _, TE (TP (xn, _))) -> 441 | fred $ PROVE (e4p (xn, lhs ::: ty) g) 442 | _ -> fred . GIVEN q $ PROVE g 443 | f -> invert f >>= \case 444 | [([], [s])] -> flop s g 445 | rs -> mapM_ 446 | (\ (de, hs) -> fred . disch de $ foldr (GIVEN . propify) (PROVE g) hs) 447 | rs 448 | where 449 | flop (PROVE p) g = fred . GIVEN p $ PROVE g 450 | flop (GIVEN h s) g = do 451 | fred $ PROVE h 452 | flop s g 453 | propify (GIVEN s t) = s :-> propify t 454 | propify (PROVE p) = p 455 | disch [] g = g 456 | disch (Bind (xn, Hide s) _ : hs) g = 457 | EVERY s (xn \\ disch hs g) 458 | disch (Hyp _ h : hs) g = GIVEN h $ 459 | let g' = disch hs g in case h of 460 | TC "=" [ty, TE (TP (xn, _)), t] | not (pDep xn t) -> 461 | e4p (xn, t ::: ty) g' 462 | _ -> g' 463 | disch (_ : hs) g = disch hs g 464 | 465 | ginger :: Bwd Tm -> [(Tm, (Tm, Tm))] -> Tm -> AM () 466 | ginger qz [] g = fred $ foldr GIVEN (PROVE g) qz 467 | ginger qz ((ty, (l, r)) : qs) g = 468 | flip (cope (equal ty (l, r))) 469 | (\ _ -> ginger qz qs g) 470 | $ \ _ -> do 471 | ty <- norm ty 472 | l' <- hnf l 473 | r' <- hnf r 474 | case (ty, l', r') of 475 | (Prop, _ , _) -> ginger (qz :< (l :-> r) :< (r :-> l)) qs g 476 | (TC d ss, TC c rs, TC e ts) 477 | | c /= e -> flip (cope (isDataType d)) return $ \ _ -> dull 478 | | otherwise -> do 479 | tel <- constructor PAT ty c 480 | plan <- prepareSubQs tel rs ts 481 | ginger qz (glom [] plan ++ qs) g 482 | _ -> dull 483 | where 484 | dull = norm ty >>= \ ty -> ginger (qz :< TC "=" [ty, l, r]) qs g 485 | glom m [] = [] 486 | glom m (((x, s), (a, b)) : plan) = 487 | (stan m s, (a, b)) : glom ((x, a) : m) plan 488 | 489 | 490 | pout :: forall t. PP t => LayKind -> Make Anno t -> AM (Odd String [LexL]) 491 | pout k p@(Make mk g m (s, n) ps (h, b)) = let k' = scavenge b in case s of 492 | Keep -> do 493 | blk <- psout k' ps 494 | return $ (rfold lout (h `tense` n) . jank m . whereFormat b ps 495 | $ format k' blk) 496 | :-/ Stop 497 | Need -> do 498 | g <- ppr g 499 | blk <- psout k' ps 500 | return $ ((show mk ++) . (" " ++) . (g ++) . (" ?" ++) . whereFormat b ps 501 | $ format k' blk) 502 | :-/ Stop 503 | Junk e -> do 504 | e <- ppGripe e 505 | return $ 506 | ("{- " ++ e) :-/ [(Ret, (0,0), "\n")] :-\ 507 | (rfold lout h . rfold lout b $ "") :-/ [(Ret, (0,0), "\n")] :-\ 508 | "-}" :-/ Stop 509 | where 510 | jank (Stub False) = (" ?" ++) 511 | jank (Tested False) = ("ed" ++) 512 | jank _ = id 513 | kws = [done mk b | b <- [False, True]] 514 | ((Key, p, s) : ls) `tense` n | elem s kws = 515 | (Key, p, done mk n) : ls 516 | (x : ls) `tense` n = (x : ls) 517 | (l : ls) `prove` n = l : (ls `prove` n) 518 | [] `prove` n = [] -- should never happen 519 | 520 | psout :: LayKind -> Bloc (SubMake Anno t) -> AM (Bloc String) 521 | psout k (g :-/ Stop) = return $ g :-/ Stop 522 | psout k (g :-/ SubPGuff [] :-\ h :-/ r) = psout k ((g ++ h) :-/ r) 523 | psout k (g :-/ p :-\ gpo) = 524 | (g :-/) <$> (ocato <$> subpout k p <*> psout k gpo) 525 | 526 | subpout :: LayKind -> SubMake Anno t -> AM (Odd String [LexL]) 527 | subpout _ (SubPGuff ls) 528 | | all gappy ls = return $ rfold lout ls "" :-/ Stop 529 | | otherwise = return $ ("{- " ++ rfold lout ls " -}") :-/ Stop 530 | subpout _ ((srg, _) ::- Make m _ _ (Junk e, _) _ (h, b)) = do 531 | e <- ppGripe e 532 | return $ 533 | ("{- " ++ e) :-/ [] :-\ 534 | (rfold lout srg . rfold lout h . rfold lout b $ "") :-/ [] :-\ 535 | "-}" :-/ Stop 536 | subpout k ((srg, (ds, gs)) ::- p) = do 537 | doorStop 538 | for ds $ \ (nom, u) -> push $ Bind (nom, Hide Prop) (User u) -- nasty 539 | z <- fish gs (pout k p) >>= \case 540 | p :-/ b -> (:-/ b) <$> 541 | ((if null srg then givs gs else pure $ rfold lout srg) <*> pure p) 542 | doorStep 543 | return z 544 | where 545 | fish [] p = p 546 | fish (Given h : gs) p = case phy h of 547 | Nothing -> fish gs p 548 | Just h -> h |- fish gs p 549 | givs :: [Given t] -> AM (String -> String) 550 | givs gs = traverse wallop gs >>= \case 551 | [] -> return id 552 | g : gs -> return $ 553 | ("given " ++) . (g ++) . rfold comma gs (" " ++) 554 | where 555 | wallop :: Given t -> AM String 556 | wallop (Given g) = ppr g 557 | comma s f = (", " ++) . (s ++) . f 558 | whereFormat :: [LexL] -> Bloc x -> String -> String 559 | whereFormat ls xs pso = case span gappy ls of 560 | (g, (T (("where", k) :-! _), _, _) : rs) -> 561 | rfold lout g . ("where" ++) . (pso ++) $ rfold lout rs "" 562 | _ -> case xs of 563 | [] :-/ Stop -> "" 564 | _ -> " where" ++ pso 565 | 566 | format :: LayKind -> Bloc String -> String 567 | format k gso@(pre :-/ _) = case k of 568 | Denty d 569 | | not (null pre) && all horiz pre -> 570 | bracy True (";\n" ++ replicate d ' ') (embrace gso) "" 571 | | otherwise -> denty ("\n" ++ replicate (d - 1) ' ') gso "" 572 | Bracy -> bracy True ("; ") gso "" 573 | where 574 | bracy :: Bool {-first?-} -> String -> Bloc String 575 | -> String -> String 576 | bracy b _ (g :-/ Stop) 577 | | null g = (if b then (" {" ++) else id) . ("}" ++) 578 | | otherwise = rfold lout g 579 | bracy b sepa (g :-/ s :-\ r) = 580 | (if null g 581 | then ((if b then " {" else sepa) ++) 582 | else rfold lout g) 583 | . (s ++) 584 | . bracy False (if semic g then rfold lout g "" else sepa) r 585 | denty sepa (g :-/ Stop) = rfold lout g -- which should be empty 586 | denty sepa (g :-/ s :-\ r) = 587 | (if null g then (sepa ++) else rfold lout g) . (s ++) . denty sepa r 588 | 589 | scavenge 590 | :: [LexL] -- first nonspace is "where" if input had one 591 | -> LayKind -- to be used 592 | scavenge ls = case span gappy ls of 593 | (_, (T (("where", k) :-! _), _, _) : _) | k /= Empty -> k 594 | _ -> case k of 595 | Denty d -> Denty (d + 2) 596 | Bracy -> Bracy 597 | 598 | horiz :: LexL -> Bool 599 | horiz (Ret, _, _) = False 600 | horiz (Cmm, _, s) = all (not . (`elem` "\r\n")) s 601 | horiz _ = True 602 | 603 | semic :: [LexL] -> Bool 604 | semic = go False where 605 | go b [] = b 606 | go b ((Cmm, _, _) : _) = False 607 | go b (g : ls) | gappy g = go b ls 608 | go False ((Sym, _, ";") : ls) = go True ls 609 | go _ _ = False 610 | 611 | embrace :: Bloc String -> Bloc String 612 | embrace (g :-/ Stop) = g :-/ Stop 613 | embrace (g :-/ s :-\ r) = mang g (++ [(Sym, (0,0), "{")]) :-/ s :-\ go r 614 | where 615 | go (h :-/ Stop) = mang h clos :-/ Stop 616 | go (g :-/ s :-\ h :-/ Stop) = 617 | mang g sepa :-/ s :-\ mang h clos :-/ Stop 618 | go (g :-/ s :-\ r) = mang g sepa :-/s :-\ go r 619 | mang [] f = [] 620 | mang g f = f g 621 | clos ls = (Sym, (0,0), "}") :ls 622 | sepa ls = (Sym, (0,0), ";") : ls ++ [(Spc, (0,0), " ")] 623 | 624 | 625 | noDuplicate :: Tm -> Con -> AM () 626 | noDuplicate ty con = cope (constructor EXP ty con) 627 | (\ _ -> return ()) 628 | (\ _ -> gripe $ Duplication Prop con) 629 | 630 | chkProp :: Appl -> Bloc RawIntro -> AM () 631 | chkProp (ls, (t, _, rel) :$$ as) intros | elem t [Uid, Sym] = do 632 | noDuplicate Prop rel 633 | doorStop 634 | tel <- elabTel as 635 | pushOutDoor $ ("Prop", []) ::> (rel, tel) 636 | (rus, cxs) <- fold <$> traverse (chkIntro tel) intros 637 | guard $ nodup rus 638 | mapM_ pushOutDoor cxs 639 | de <- doorStep 640 | True <- tracy ("CHKPROP-KILLS: " ++ show de) $ return True 641 | return () 642 | where 643 | chkIntro :: Tel -> RawIntro -> AM ([String], [CxE]) 644 | chkIntro tel (RawIntro aps rp prems) = do 645 | doorStop 646 | push ImplicitQuantifier 647 | (ht, _) <- elabVec EXP rel tel aps 648 | (hp, sb0) <- patify ht 649 | (ru, as) <- case rp of 650 | (_, (t, _, ru) :$$ as) | elem t [Uid, Sym] -> return (ru, as) 651 | _ -> gripe FAIL 652 | return () 653 | (vs, sb1) <- bindParam as 654 | let sb = sb0 ++ sb1 655 | guard $ nodup (map fst sb) 656 | pop $ \case {ImplicitQuantifier -> True; _ -> False} 657 | ps <- traverse chkPrem prems 658 | lox <- doorStep 659 | True <- tracy ("PROP-INTRO-KILL: " ++ show lox) $ return True 660 | tel <- telify vs lox 661 | let pss = subOut lox ps 662 | let (tel', ps') = rfold e4p sb (tel, toList pss) 663 | let byr = ByRule True $ (hp, (ru, tel')) :<= ps' 664 | True <- tracy ("PROP-INTRO: " ++ show byr) $ return True 665 | return ([ru], [byr]) 666 | chkPrem :: ([Appl], Appl) -> AM Subgoal 667 | chkPrem (hs, g) = 668 | rfold GIVEN <$> traverse (elabTm EXP Prop) hs <*> (PROVE <$> elabTm EXP Prop g) 669 | subOut [] ps = ps 670 | subOut (Bind (x, Hide ty) (Defn t) : de) ps = 671 | subOut (e4p (x, t ::: ty) de) (fmap (e4p (x, t ::: ty)) ps) 672 | subOut (_ : de) ps = subOut de ps 673 | chkProp _ intros = gripe FAIL 674 | 675 | patify :: Tm -> AM (Pat, [(Nom, Syn)]) 676 | patify (TC c ts) = do 677 | (ts, sb) <- go ts 678 | return (PC c ts, sb) 679 | where 680 | go [] = return ([], []) 681 | go (t : ts) = do 682 | (t, sb0) <- patify t 683 | (ts, sb1) <- go ts 684 | if null (intersect (map fst sb0) (map fst sb1)) 685 | then return (t : ts, sb0 ++ sb1) 686 | else gripe FAIL 687 | patify (TE (TP (xp, Hide ty))) = do 688 | User x <- nomBKind xp 689 | return (PM x mempty, [(xp, TM x [] ::: ty)]) 690 | patify _ = gripe FAIL 691 | 692 | chkData :: Appl -> [Appl] -> AM () 693 | chkData (_, (t, _, tcon) :$$ as) vcons | elem t [Uid, Sym] = do 694 | noDuplicate Type tcon 695 | doorStop 696 | doorStop 697 | (vs, _) <- bindParam as 698 | fake <- gamma >>= (`fakeTel` Pr []) 699 | push $ ("Type", []) ::> (tcon, fake) 700 | cts <- traverse chkCon vcons 701 | guard $ nodup (map fst cts) 702 | lox <- doorStep 703 | real <- telify vs lox 704 | push $ ("Type", []) ::> (tcon , real) 705 | (ps, sb) <- mkPatsSubs 0 lox 706 | for cts $ \ (c, tel) -> 707 | push $ (tcon, ps) ::> (c, rfold e4p sb tel) 708 | ctors <- doorStep 709 | push $ Data tcon (B0 <>< ctors) 710 | return () 711 | where 712 | fakeTel :: Context -> Tel -> AM Tel 713 | fakeTel B0 tel = return tel -- not gonna happen because... 714 | fakeTel (ga :< DoorStop) tel = return tel -- ...this prevents it 715 | fakeTel (ga :< Bind (_, Hide ty) (User x)) tel = 716 | fakeTel ga ((x, ty) :*: tel) 717 | fakeTel (ga :< _) tel = fakeTel ga tel 718 | chkCon :: Appl -> AM (String, Tel) 719 | chkCon (_, (t, _, vcon) :$$ as) | elem t [Uid, Sym] = do 720 | vtel <- elabTel as 721 | return (vcon, vtel) 722 | chkCon _ = gripe FAIL 723 | mkPatsSubs :: Int -> [CxE] -> AM ([Pat], [(Nom, Syn)]) 724 | mkPatsSubs _ [] = return ([], []) 725 | mkPatsSubs i (Bind (xp, Hide ty) bk : lox) = case bk of 726 | Hole -> let x = '%' : show i in 727 | ((PM x mempty :) *** ((xp, TM x [] ::: ty) :)) <$> mkPatsSubs (i + 1) lox 728 | Defn t -> 729 | (id *** ((xp, t ::: ty) :)) <$> mkPatsSubs i lox 730 | User x -> 731 | ((PM x mempty :) *** ((xp, TM x [] ::: ty) :)) <$> mkPatsSubs (i + 1) lox 732 | mkPatsSubs i (_ : lox) = mkPatsSubs i lox 733 | chkData _ _ = gripe FAIL 734 | 735 | chkSig :: Appl -> Appl -> AM () 736 | chkSig la@(_, (t, _, f@(c : _)) :$$ as) rty 737 | | t == Lid || (t == Sym && c /= ':') 738 | = do 739 | -- cope (what's f) (\ gr -> return ()) (\ _ -> gripe $ AlreadyDeclared f) 740 | doorStop 741 | push ImplicitQuantifier 742 | xts <- placeHolders as 743 | rty <- elabTm EXP Type rty 744 | pop $ \case {ImplicitQuantifier -> True; _ -> False} 745 | lox <- doorStep 746 | sch <- schemify (map fst xts) lox rty 747 | fn <- fresh f 748 | push $ Declare f fn sch 749 | return () 750 | | otherwise = gripe $ BadFName f 751 | 752 | chkTest :: Appl -> Maybe Appl -> AM String 753 | chkTest (ls, (_,_,f) :$$ as) mv = do 754 | (e, sy) <- elabSyn EXP f as 755 | case mv of 756 | Just t@(rs, _) -> do 757 | v <- elabTm EXP sy t 758 | b <- cope (equal sy (TE e, v)) (\ _ -> return False) (\ _ -> return True) 759 | if b 760 | then return . ("tested " ++) . rfold lout ls . (" = " ++) . rfold lout rs $ "" 761 | else do 762 | n <- norm (TE e) 763 | r <- ppTm AllOK n 764 | return . ("tested " ++) . rfold lout ls . (" = " ++) . (r ++) . 765 | ("{- not " ++) . rfold lout rs $ " -}" 766 | Nothing -> do 767 | v <- norm (TE e) 768 | r <- ppTm AllOK v 769 | return . ("tested " ++) . rfold lout ls . (" = " ++) $ r 770 | 771 | 772 | chkParse :: Make () ParseThing -> AM (Make Anno ParseThing) 773 | chkParse (Make Pse (ParseProb c sm) m () ss (ls, rs)) = do 774 | let prods (Gram c' ps) | c == c' = ps 775 | prods _ = [] 776 | visi (Spc, _, _) = [] 777 | visi (Ret, _, _) = [] 778 | visi t = [t] 779 | subs :: [GramBit] -> Bloc (SubMake () ParseThing) 780 | -> AM (Maybe [String],Bloc (SubMake Anno ParseThing)) 781 | subs [] (ns :-/ Stop) = pure (Just [], ns :-/ Stop) 782 | subs (Terminal q : gs) b = do 783 | (qsm, ss) <- subs gs b 784 | pure ((q :) <$> qsm, ss) 785 | subs (NonTerminal c : gs) (ns :-/ (w ::- x) :-\ xs) = do 786 | x <- chkParse x 787 | (psm, x) <- pure $ case x of 788 | Make Pse (ParseProb c' qm) m a _ _ 789 | | c == c' -> case ((lexAll . read) <$> qm, m, a) of 790 | (Just (_ :-/ ys :-\ _), By _, (Keep, True)) -> 791 | (Just (fmap txt (ys >>= unLay >>= visi)), x) 792 | _ -> (Nothing, x) 793 | Make z g m _ ss subs -> 794 | (Nothing, Make z g m (Junk (ParseNotTheWanted c), False) ss subs) 795 | (qsm, xs) <- subs gs xs 796 | pure ((++) <$> psm <*> qsm, ns :-/ (w ::- x) :-\ xs) 797 | subs (NonTerminal c : gs) (ns :-/ Stop) = do 798 | (_, xs) <- subs gs (ns :-/ Stop) 799 | pure $ 800 | (Nothing, 801 | ns :-/ (mempty ::- Make Pse (ParseProb c Nothing) (Stub True) (Need, False) 802 | ([] :-/ Stop) ([], [])) 803 | :-\ xs) 804 | subs _ _ = gripe $ Bland "There's something I don't understand about this parse tree." 805 | ps <- foldMap prods <$> gamma 806 | case m of 807 | Stub b -> case ss of 808 | (ns :-/ Stop) -> 809 | pure $ Make Pse (ParseProb c sm) m (Keep, False) (ns :-/ Stop) (ls, rs) 810 | _ -> gripe $ ParseStubSub 811 | By (ParseProd p) -> case p `elem` ps of 812 | False -> gripe $ NotAProd c p 813 | True -> case sm of 814 | Nothing -> gripe $ ParseNoString 815 | Just s -> case lexAll (read s) of 816 | _ :-/ ys :-\ _ -> do 817 | (qsm, ss) <- subs p ss 818 | pure $ case qsm of 819 | Just qs -> if fmap txt (ys >>= unLay >>= visi) == qs 820 | then Make Pse (ParseProb c sm) m (Keep, True) ss (ls, rs) 821 | else Make Pse (ParseProb c sm) m (Junk (ParseNoMake s), True) ss (ls, rs) 822 | _ -> Make Pse (ParseProb c sm) m (Keep, False) ss (ls, rs) 823 | _ -> gripe $ Mardiness 824 | _ -> gripe $ Mardiness 825 | chkParse _ = gripe $ Mardiness 826 | 827 | blatParse :: Make Anno ParseThing -> AM String 828 | blatParse m = bifoldMap id (($ "") . rfold lout) <$> pout (Denty 1) m 829 | 830 | discharge :: [CxE] -> Tm -> Tm 831 | discharge zs t = go [] zs t where 832 | go sg [] t = rfold e4p sg t 833 | go sg (Bind (nom, Hide ty) k : zs) t = case k of 834 | Defn s -> go ((nom, rfold e4p sg (s ::: ty)) : sg) zs t 835 | _ -> go ((nom, TP (nom, Hide (rfold e4p sg ty))) : sg) zs t 836 | go sg (_ : zs) t = go sg zs t 837 | 838 | askRawDecl :: (RawDecl, [LexL]) -> AM String 839 | askRawDecl (RawProof (Make Prf gr mr () ps src), ls) = id <$ 840 | doorStop <*> 841 | cope (do 842 | g <- impQElabTm Prop gr 843 | gt <- mayhem $ my g 844 | de <- doorStep 845 | let claim = discharge de gt 846 | doorStop 847 | traverse push de 848 | prf <- chkProof g mr ps src 849 | p <- bifoldMap id (($ "") . rfold lout) <$> pout (Denty 1) prf 850 | let nailed = case annotation prf of 851 | (Keep, True) -> True 852 | _ -> False 853 | pushOutDoor . Hyp nailed $ claim 854 | return p) 855 | (\ gr -> do 856 | e <- ppGripe gr 857 | return $ "{- " ++ e ++ "\n" ++ rfold lout ls "\n-}") 858 | return 859 | <* doorStep 860 | askRawDecl (RawProof (Make Def gr@(_, (_, _, f) :$$ as) mr () ps src), ls) = do 861 | doorStop 862 | (b, s) <- cope (do 863 | push (Defined f) 864 | True <- tracy ("pushed Defined " ++ f) $ return True 865 | Left (fn, sch) <- what's f 866 | pop $ \case 867 | Defined g | f == g -> True 868 | _ -> False 869 | True <- tracy ("popped Defined " ++ f) $ return True 870 | p <- proglify fn (f, sch) 871 | p <- dubStep p f as 872 | True <- tracy (show p) $ return True 873 | ((True,) . bifoldMap id (($ "") . rfold lout)) <$> 874 | (chkProg p gr mr ps src >>= pout (Denty 1)) 875 | ) 876 | (\ gr -> do 877 | e <- ppGripe gr 878 | return (False, "{- " ++ e ++ "\n" ++ rfold lout ls "\n-}")) 879 | return 880 | doorStep 881 | if b then push (Defined f) else return () 882 | return s 883 | askRawDecl (RawProp tmpl intros, ls) = cope (chkProp tmpl intros) 884 | (\ gr -> do 885 | e <- ppGripe gr 886 | return $ "{- " ++ e ++ "\n" ++ rfold lout ls "\n-}") 887 | (\ _ -> return $ rfold lout ls "") 888 | askRawDecl (RawData tcon vcons, ls) = cope (chkData tcon vcons) 889 | (\ gr -> do 890 | e <- ppGripe gr 891 | return $ "{- " ++ e ++ "\n" ++ rfold lout ls "\n-}") 892 | (\ _ -> return $ rfold lout ls "") 893 | askRawDecl (RawSig la ra, ls) = 894 | cope (chkSig la ra) 895 | (\ gr -> do 896 | e <- ppGripe gr 897 | return $ "{- " ++ e ++ "\n" ++ rfold lout ls "\n-}") 898 | (\ _ -> return $ rfold lout ls "") 899 | askRawDecl (RawTest e mv, ls) = 900 | cope (chkTest e mv) 901 | (\ gr -> do 902 | e <- ppGripe gr 903 | return $ "{- " ++ e ++ "\n" ++ rfold lout ls "\n-}") 904 | return 905 | askRawDecl (RawGrammar c ps, ls) = do 906 | push $ Gram c ps 907 | return $ rfold lout ls "" 908 | askRawDecl (RawParse m, ls) = cope (chkParse m) 909 | (\ gr -> do 910 | e <- ppGripe gr 911 | return $ "{- " ++ e ++ "\n" ++ rfold lout ls "\n-}") 912 | blatParse 913 | askRawDecl (RawSewage, []) = return "" 914 | askRawDecl (RawSewage, ls) = return $ "{- don't ask\n" ++ rfold lout ls "\n-}" 915 | askRawDecl (_, ls) = return $ rfold lout ls "" 916 | 917 | filth :: String -> String 918 | filth s = case runAM go () initAskState of 919 | Left e -> "OH NO! " ++ show e 920 | Right (s, _) -> s 921 | where 922 | go :: AM String 923 | go = do 924 | fi <- getFixities 925 | let (fo, b) = raw fi s 926 | setFixities fo 927 | bifoldMap (($ "") . rfold lout) id <$> traverse askRawDecl b 928 | 929 | ordure :: String -> String 930 | ordure s = case runAM go () initAskState of 931 | Left e -> "OH NO! " ++ show e 932 | Right (s, as) -> s ++ "\n-------------------------\n" ++ show as 933 | where 934 | go :: AM String 935 | go = do 936 | fi <- getFixities 937 | let (fo, b) = raw fi s 938 | setFixities fo 939 | bifoldMap (($ "") . rfold lout) id <$> traverse askRawDecl b 940 | 941 | initAskState :: AskState 942 | initAskState = AskState 943 | { context = myContext 944 | , root = (B0, 0) 945 | , fixities = myFixities 946 | } 947 | 948 | filthier :: AskState -> String -> (String, AskState) 949 | filthier as s = case runAM go () as of 950 | Left e -> ("OH NO! " ++ show e, as) 951 | Right r -> r 952 | where 953 | go :: AM String 954 | go = do 955 | fi <- getFixities 956 | let (fo, b) = raw fi s 957 | setFixities fo 958 | bifoldMap (($ "") . rfold lout) id <$> traverse askRawDecl b 959 | -------------------------------------------------------------------------------- /lib/Language/Ask/Context.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ---------- ---------- 3 | ---------- Context ---------- 4 | ---------- ---------- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE 8 | CPP 9 | , PatternSynonyms 10 | , TupleSections 11 | , LambdaCase 12 | #-} 13 | 14 | module Language.Ask.Context where 15 | 16 | import Control.Monad 17 | import qualified Control.Monad.Fail as Fail 18 | import qualified Data.Map as M 19 | import Control.Applicative 20 | import Control.Arrow ((***)) 21 | 22 | import Language.Ask.Bwd 23 | import Language.Ask.Hide 24 | import Language.Ask.Tm 25 | import Language.Ask.Lexing 26 | import Language.Ask.RawAsk 27 | 28 | import Debug.Trace 29 | 30 | ------------------------------------------------------------------------------ 31 | -- Contexts 32 | ------------------------------------------------------------------------------ 33 | 34 | type Context = Bwd CxE 35 | 36 | data CxE -- what sort of thing is in the context? 37 | = Hyp Bool{-proven?-} Tm 38 | | Bind (Nom, Hide Tm) BKind 39 | | (Nom, [Pat]) :=: Syn -- computation rule 40 | | Declare String Nom Sch 41 | | Defined String 42 | | RecShadow String 43 | | ImplicitQuantifier 44 | | RefuseQuantification 45 | | (Con, [Pat]) ::> (Con, Tel) -- constructor declaration 46 | | ByRule Bool{- pukka intro?-} Rule 47 | | Demand Subgoal 48 | | ExpectBlocker 49 | | Expect Proglem 50 | | DoorStop 51 | | Data 52 | Con -- name of data type 53 | Context -- constructor declarations 54 | | Gram 55 | Con -- nonterminal symbol 56 | [[GramBit]] -- productions 57 | deriving Show 58 | 59 | data BKind 60 | = User String 61 | | Defn Tm 62 | | Hole 63 | deriving Show 64 | 65 | data Rule = 66 | (Pat, (Con, Tel)) :<= 67 | [ Subgoal 68 | ] 69 | deriving Show 70 | 71 | 72 | ------------------------------------------------------------------------------ 73 | -- Gripes 74 | ------------------------------------------------------------------------------ 75 | 76 | data Gripe 77 | = Surplus 78 | | Duplication Tm Con 79 | | AlreadyDeclared String 80 | | Scope String 81 | | ByBadRule String Tm 82 | | ByAmbiguous String Tm 83 | | EmptyInductively 84 | | InductiveHypsDon'tLike Con 85 | | FromNeedsConnective Appl 86 | | TestNeedsEq Tm 87 | | UnderNeedsEq Tm 88 | | NotGiven Tm 89 | | NotEqual 90 | | InfiniteType 91 | | Terror [LexL] Tm Tm 92 | | NotARule Appl 93 | | BadRec String 94 | | Mardiness 95 | | NoSizedConstruction 96 | | NotADataType Tm 97 | | WrongNumOfArgs Con Int [Appl] 98 | | DoesNotMake Con Tm 99 | | OverOverload Con 100 | | NonCanonicalType Tm Con 101 | | BadFName String 102 | | Unification Con Con 103 | | NotAProd Con [GramBit] 104 | | ParseNoString 105 | | ParseNotTheWanted Con 106 | | ParseNoMake String 107 | | ParseStubSub 108 | | Bland String 109 | | FAIL 110 | deriving Show 111 | 112 | 113 | ------------------------------------------------------------------------------ 114 | -- Mutable AskState -- and Read-Only Setup 115 | ------------------------------------------------------------------------------ 116 | 117 | type Root = (Bwd (String, Int), Int) 118 | 119 | data AskState = AskState 120 | { context :: Context 121 | , root :: Root 122 | , fixities :: FixityTable 123 | } deriving Show 124 | 125 | type Setup = () -- atavism 126 | 127 | 128 | ------------------------------------------------------------------------------ 129 | -- The Ask Monad 130 | ------------------------------------------------------------------------------ 131 | 132 | -- My word is my bond, the only code which needs to know the representation of 133 | -- this very monad is in this very section of this very file. 134 | -- How long until I welch on that? 135 | 136 | data AM x = AM {runAM 137 | :: Setup -- nowt of consequence 138 | -> AskState -- vars and hyps 139 | -> Either Gripe (x, AskState)} 140 | 141 | instance Monad AM where 142 | return x = AM $ \ _ as -> Right (x, as) 143 | AM f >>= k = AM $ \ setup as -> case f setup as of 144 | Left g -> Left g 145 | Right (x, as) -> runAM (k x) setup as 146 | #if !(MIN_VERSION_base(4,13,0)) 147 | -- Monad(fail) will be removed in GHC 8.8+ 148 | fail = Fail.fail 149 | #endif 150 | instance Applicative AM where pure = return; (<*>) = ap 151 | instance Functor AM where fmap = ap . return 152 | 153 | gripe :: Gripe -> AM x 154 | gripe g = AM $ \ _ _ -> Left g 155 | 156 | guardErr :: Bool -> Gripe -> AM () 157 | guardErr True _ = return () 158 | guardErr False err = gripe err 159 | 160 | instance Fail.MonadFail AM where 161 | fail _ = gripe FAIL 162 | 163 | instance Alternative AM where 164 | empty = gripe FAIL 165 | ma <|> mb = cope ma (const mb) return 166 | 167 | cope :: AM x -> (Gripe -> AM y) -> (x -> AM y) -> AM y 168 | cope (AM f) yuk wow = AM $ \ setup as -> case f setup as of 169 | Left g -> runAM (yuk g) setup as 170 | Right (x, as) -> runAM (wow x) setup as 171 | 172 | getFixities :: AM FixityTable 173 | getFixities = AM $ \ _ s -> Right (fixities s, s) 174 | 175 | setFixities :: FixityTable -> AM () 176 | setFixities ft = AM $ \ _ s -> Right ((), s {fixities = ft}) 177 | 178 | fixity :: String -> AM (Int, Assocy) 179 | fixity o = do 180 | ft <- getFixities 181 | return $ case M.lookup o ft of 182 | Nothing -> (9, LAsso) 183 | Just x -> x 184 | 185 | mayhem :: Maybe x -> AM x 186 | mayhem mx = do 187 | Just x <- return mx 188 | return x 189 | 190 | gamma :: AM Context 191 | gamma = AM $ \ setup as -> Right (context as, as) 192 | 193 | setGamma :: Context -> AM () 194 | setGamma ga = AM $ \ setup as -> Right ((), as {context = ga}) 195 | 196 | fresh :: String -> AM Nom 197 | fresh x = AM $ \ setup as -> case root as of 198 | (roo, non) -> Right (roo <>> [(x, non)], as {root = (roo, non + 1)}) 199 | 200 | 201 | ------------------------------------------------------------------------------ 202 | -- Context-Wrangling and Fresh Thingy Generation 203 | ------------------------------------------------------------------------------ 204 | 205 | -- imagine a value of a given type 206 | hole :: Tm -> AM Syn 207 | hole ty = do 208 | x <- fresh "hole" 209 | let xp = (x, Hide ty) 210 | push $ Bind xp Hole 211 | return $ TP xp 212 | 213 | -- push a new context entry 214 | push :: CxE -> AM () 215 | push z = do 216 | ga <- gamma 217 | setGamma (ga :< z) 218 | 219 | -- remove the topmost entry passing a test, leaving those above in place 220 | pop :: (CxE -> Bool) -> AM (Maybe CxE) 221 | pop test = do 222 | ga <- gamma 223 | case go ga of 224 | Nothing -> return Nothing 225 | Just (ga, z) -> setGamma ga >> return (Just z) 226 | where 227 | go B0 = Nothing 228 | go (ga :< z) 229 | | test z = Just (ga, z) 230 | | otherwise = go ga >>= \ (ga, y) -> Just (ga :< z, y) 231 | 232 | -- find one of the user's variables by what they call it 233 | what's :: String -> AM (Either (Nom, Sch) (Syn, Tm)) 234 | what's x = do 235 | ga <- gamma 236 | cope (go ga) 237 | (\case 238 | Scope _ -> do 239 | (e, ga) <- qu ga 240 | setGamma ga 241 | return e 242 | gr -> gripe gr) 243 | $ return 244 | where 245 | go :: Context -> AM (Either (Nom, Sch) (Syn, Tm)) 246 | go B0 = gripe (Scope x) 247 | go (_ :< Bind p@(_, Hide ty) (User y)) | x == y = 248 | return $ Right (TP p, ty) 249 | go (ga :< RecShadow y) | x == y = gripe (BadRec x) 250 | go (ga :< Declare y yn sch) | x == y = return $ Left (yn, sch) 251 | go (ga :< z) = go ga 252 | -- decl (ga :< Declare y yn sch) | x == y = Just (yn, sch) 253 | -- decl (ga :< _) = decl ga 254 | -- decl B0 = Nothing 255 | qu ga@(_ :< RefuseQuantification) = gripe (Scope x) 256 | qu ga@(_ :< ImplicitQuantifier) = do 257 | xTp <- (, Hide Type) <$> fresh "Ty" 258 | let xTy = TE (TP xTp) 259 | xp <- (, Hide xTy) <$> fresh x 260 | return (Right (TP xp, xTy), ga :< Bind xTp Hole :< Bind xp (User x)) 261 | qu B0 = gripe (Scope x) 262 | qu (ga :< z) = do 263 | (e, ga) <- qu ga 264 | return (e, ga :< z) 265 | 266 | -- finding one of ours 267 | nomBKind :: Nom -> AM BKind 268 | nomBKind x = gamma >>= foldl me empty where 269 | me no (Bind (y, _) bk) | x == y = return bk 270 | me no _ = no 271 | 272 | -- wildly incomplete 273 | instance Stan CxE where 274 | stan ms (Bind (x, Hide ty) k) = 275 | Bind (x, Hide (stan ms ty)) (stan ms k) 276 | stan ms z = z 277 | sbst u es (Bind (x, Hide ty) k) = 278 | Bind (x, Hide (sbst u es ty)) (sbst u es k) 279 | sbst u es z = z 280 | abst x i (Bind (n, Hide ty) k) = 281 | Bind <$> ((n,) <$> (Hide <$> abst x i ty)) <*> abst x i k 282 | abst x i z = pure z 283 | 284 | instance Stan BKind where 285 | stan ms (Defn t) = Defn (stan ms t) 286 | stan _ k = k 287 | sbst u es (Defn t) = Defn (sbst u es t) 288 | sbst _ _ k = k 289 | abst x i (Defn t) = Defn <$> abst x i t 290 | abst _ _ k = pure k 291 | 292 | 293 | ------------------------------------------------------------------------------ 294 | -- Demanding! 295 | ------------------------------------------------------------------------------ 296 | 297 | demand :: Subgoal -> AM () 298 | demand sg = push (Demand sg) 299 | 300 | demands :: AM [Subgoal] 301 | demands = do 302 | ga <- gamma 303 | let (ga', ss) = go ga [] 304 | setGamma ga' 305 | return ss 306 | where 307 | go B0 ss = (B0, ss) 308 | go (ga :< Demand s) ss = go ga (s : ss) 309 | go (ga :< z) ss = ((:< z) *** id) (go ga ss) 310 | 311 | 312 | ------------------------------------------------------------------------------ 313 | -- DoorStop 314 | ------------------------------------------------------------------------------ 315 | 316 | -- these should bracket 317 | 318 | doorStop :: AM () 319 | doorStop = push DoorStop 320 | 321 | doorStep :: AM [CxE] 322 | doorStep = do 323 | ga <- gamma 324 | let (ga', de) = go ga [] 325 | setGamma ga' 326 | return de 327 | where 328 | go (ga :< DoorStop) de = (ga, de) 329 | go (ga :< z) de = go ga (z : de) 330 | go B0 de = (B0, de) -- heaven forfend 331 | 332 | pushOutDoor :: CxE -> AM () 333 | pushOutDoor x = (go <$> gamma) >>= setGamma where 334 | go B0 = B0 :< x -- heaven forfend 335 | go (ga :< DoorStop) = ga :< x :< DoorStop 336 | go (ga :< z) = go ga :< z 337 | 338 | 339 | ------------------------------------------------------------------------------ 340 | -- Programming Problems 341 | ------------------------------------------------------------------------------ 342 | 343 | data Proglem = Proglem 344 | { localCx :: Context 345 | , fNom :: Nom 346 | , uName :: String 347 | , leftImpl :: [(Tm, Tm)] -- term-type pairs for implicit arguments 348 | , leftSatu :: [(Tm, Tm)] -- ditto scheme arguments 349 | , leftAppl :: [(Tm, Tm)] -- ditto for application arguments 350 | , rightTy :: Tm -- return type 351 | } deriving Show 352 | -------------------------------------------------------------------------------- /lib/Language/Ask/Glueing.hs: -------------------------------------------------------------------------------- 1 | module Language.Ask.Glueing where 2 | 3 | import Language.Ask.Tm 4 | import Language.Ask.RawAsk 5 | 6 | data TmR 7 | = My Tm 8 | | Our Tm Appl 9 | | Your Appl 10 | 11 | instance Show TmR where 12 | show (My t) = show t 13 | show (Our t _) = show t 14 | show (Your (_, a)) = show a 15 | 16 | instance Stan TmR where 17 | stan m (My t) = My (stan m t) 18 | stan m (Our t a) = Our (stan m t) a 19 | stan m x = x 20 | sbst u es (My t) = My (sbst u es t) 21 | sbst u es (Our t a) = Our (sbst u es t) a 22 | sbst u es x = x 23 | abst x i (My t) = My <$> abst x i t 24 | abst x i (Our t a) = Our <$> abst x i t <*> pure a 25 | abst _ _ x = pure x 26 | 27 | my :: TmR -> Maybe Tm 28 | my (My t) = Just t 29 | my (Our t _) = Just t 30 | my _ = Nothing 31 | -------------------------------------------------------------------------------- /lib/Language/Ask/HalfZip.hs: -------------------------------------------------------------------------------- 1 | module Language.Ask.HalfZip where 2 | 3 | class HalfZippable f where 4 | halfZipWith :: (x -> y -> Maybe z) -> f x -> f y -> Maybe (f z) 5 | 6 | instance HalfZippable [] where 7 | halfZipWith f [] [] = Just [] 8 | halfZipWith f (x : xs) (y : ys) = (:) <$> f x y <*> halfZipWith f xs ys 9 | halfZipWith _ _ _ = Nothing 10 | 11 | halfZip :: HalfZippable f => f x -> f y -> Maybe (f (x, y)) 12 | halfZip = halfZipWith $ \ x y -> Just (x, y) 13 | -------------------------------------------------------------------------------- /lib/Language/Ask/HardwiredRules.hs: -------------------------------------------------------------------------------- 1 | module Language.Ask.HardwiredRules where 2 | 3 | import qualified Data.Map as M 4 | 5 | import Language.Ask.Bwd 6 | import Language.Ask.Tm 7 | import Language.Ask.RawAsk 8 | import Language.Ask.Context 9 | 10 | myFixities :: FixityTable 11 | myFixities = M.fromList 12 | [ ("=", (4, NAsso)) 13 | , ("&", (3, RAsso)) 14 | , ("|", (2, RAsso)) 15 | , ("->", (1, RAsso)) 16 | ] 17 | 18 | myPreamble :: Context 19 | myPreamble = B0 20 | :< (("Type", []) ::> ("Type", Pr [])) -- boo! hiss! 21 | :< (("Type", []) ::> ("Prop", Pr [])) 22 | :< (("Type", []) ::> ("->", ("s", Type) :*: ("t", Type) :*: Pr [])) 23 | :< (("Prop", []) ::> ("->", ("s", Prop) :*: ("t", Prop) :*: Pr [])) 24 | :< (("Prop", []) ::> ("&", ("s", Prop) :*: ("t", Prop) :*: Pr [])) 25 | :< (("Prop", []) ::> ("|", ("s", Prop) :*: ("t", Prop) :*: Pr [])) 26 | :< (("Prop", []) ::> ("Not", ("s", Prop) :*: Pr [])) 27 | :< (("Prop", []) ::> ("False", Pr [])) 28 | :< (("Prop", []) ::> ("True", Pr [])) 29 | :< (("Prop", []) ::> ("=", Ex Type . L $ 30 | ("x", TE (TV 0)) :*: ("y", TE (TV 0)) :*: Pr [])) 31 | 32 | myIntroRules :: [Rule] 33 | myIntroRules = 34 | [ (PC "&" [PM "a" mempty, PM "b" mempty], ("AndI", Pr [])) :<= 35 | [ PROVE $ TM "a" [] 36 | , PROVE $ TM "b" [] 37 | ] 38 | , (PC "|" [PM "a" mempty, PM "b" mempty], ("OrIL", Pr [])) :<= 39 | [ PROVE $ TM "a" [] 40 | ] 41 | , (PC "|" [PM "a" mempty, PM "b" mempty], ("OrIR", Pr [])) :<= 42 | [ PROVE $ TM "b" [] 43 | ] 44 | , (PC "->" [PM "a" mempty, PM "b" mempty], ("ImpI", Pr [])) :<= 45 | [ GIVEN (TM "a" []) . PROVE $ TM "b" [] 46 | ] 47 | , (PC "Not" [PM "a" mempty], ("NotI", Pr [])) :<= 48 | [ GIVEN (TM "a" []) . PROVE $ TC "False" [] 49 | ] 50 | , (PC "True" [], ("TrueI", Pr [])) :<= [] 51 | ] 52 | 53 | myWeirdRules :: [Rule] 54 | myWeirdRules = 55 | [ (PM "x" mempty, ("Contradiction", Pr [])) :<= 56 | [ GIVEN (TC "Not" [TM "x" []]) $ PROVE FALSE 57 | ] 58 | , (PC "=" [PM "T" mempty, PM "r" mempty, PM "t" mempty], 59 | ("Route", ("s", TM "T" mempty) :*: Pr [])) :<= 60 | [ PROVE $ TC "=" [TM "T" [], TM "r" [], TM "s" []] 61 | , PROVE $ TC "=" [TM "T" [], TM "s" [], TM "t" []] 62 | ] 63 | , (PC "=" [PC "->" [PM "S" mempty, PM "T" mempty], PM "f" mempty, PM "g" mempty], 64 | ("Applying", Pr [])) :<= 65 | [ EVERY (TM "S" []) . L . PROVE $ TC "=" 66 | [ TM "T" [] 67 | , TE ((TM "f" mempty ::: TC "->" [TM "S" mempty, TM "T" mempty]) :$ TE (TV 0)) 68 | , TE ((TM "g" mempty ::: TC "->" [TM "S" mempty, TM "T" mempty]) :$ TE (TV 0)) 69 | ] 70 | ] 71 | , (PC "=" [PC "Prop" [], PM "p" mempty, PM "q" mempty], 72 | ("Equivalence", Pr [])) :<= 73 | [ GIVEN (TM "p" []) . PROVE $ TM "q" [] 74 | , GIVEN (TM "q" []) . PROVE $ TM "p" [] 75 | ] 76 | ] 77 | 78 | myContext :: Context 79 | myContext = myPreamble 80 | <>< [ByRule True r | r <- myIntroRules] 81 | <>< [ByRule False r | r <- myWeirdRules] 82 | 83 | -------------------------------------------------------------------------------- /lib/Language/Ask/Hide.hs: -------------------------------------------------------------------------------- 1 | module Language.Ask.Hide where 2 | 3 | newtype Hide x = Hide {peek :: x} 4 | 5 | --instance Show x => Show (Hide x) where show (Hide x) = show x 6 | instance Show (Hide x) where show _ = "" 7 | instance Eq (Hide x) where _ == _ = True 8 | -------------------------------------------------------------------------------- /lib/Language/Ask/Lexing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDeriving, DeriveFunctor #-} 2 | 3 | module Language.Ask.Lexing where 4 | 5 | import Data.Char 6 | import Data.List 7 | import Data.Bifunctor 8 | 9 | import Language.Ask.Bwd 10 | import Language.Ask.OddEven 11 | 12 | lexAll :: String -> Bloc Line 13 | lexAll = lexPhase1 . lexPhase0 14 | 15 | data Tok f 16 | = Lid 17 | | Key 18 | | Uid 19 | | Und 20 | | Sym 21 | | Spc 22 | | Num 23 | | Str 24 | | Chr 25 | | Ret 26 | | Cmm 27 | | Bad 28 | | T (f (Lex f)) 29 | 30 | type Pos = (Int, Int) -- row and column; origin is 1 31 | type Lex f = (Tok f, Pos, String) 32 | txt :: Lex f -> String 33 | txt (_, _, s) = s 34 | 35 | bad :: Lex f -> Lex f 36 | bad (_, p, s) = (Bad, p, s) 37 | 38 | class PShow f where 39 | pshow :: Show x => f x -> String 40 | 41 | instance PShow f => Show (Tok f) where 42 | show Lid = "Lid" 43 | show Key = "Key" 44 | show Uid = "Uid" 45 | show Und = "Und" 46 | show Sym = "Sym" 47 | show Spc = "Spc" 48 | show Num = "Num" 49 | show Str = "Str" 50 | show Chr = "Chr" 51 | show Ret = "Ret" 52 | show Cmm = "Cmm" 53 | show Bad = "Bad" 54 | show (T tf) = pshow tf 55 | 56 | class PEq f where 57 | peq :: Eq x => f x -> f x -> Bool 58 | 59 | instance PEq f => Eq (Tok f) where 60 | Lid == Lid = True 61 | Key == Key = True 62 | Uid == Uid = True 63 | Und == Und = True 64 | Sym == Sym = True 65 | Spc == Spc = True 66 | Num == Num = True 67 | Str == Str = True 68 | Chr == Chr = True 69 | Ret == Ret = True 70 | Cmm == Cmm = True 71 | Bad == Bad = True 72 | T x == T y = peq x y 73 | _ == _ = False 74 | 75 | data K0 x deriving (Show, Eq) 76 | instance PShow K0 where pshow = show 77 | instance PEq K0 where peq = (==) 78 | 79 | type Tok0 = Tok K0 80 | type Lex0 = Lex K0 81 | 82 | tok0 :: Tok0 -> Tok f 83 | tok0 Lid = Lid 84 | tok0 Key = Key 85 | tok0 Uid = Uid 86 | tok0 Und = Und 87 | tok0 Sym = Sym 88 | tok0 Spc = Spc 89 | tok0 Num = Num 90 | tok0 Str = Str 91 | tok0 Chr = Chr 92 | tok0 Ret = Ret 93 | tok0 Cmm = Cmm 94 | tok0 Bad = Bad 95 | 96 | lex0 :: Lex0 -> (Tok f, Pos, String) 97 | lex0 (t, p, s) = (tok0 t, p, s) 98 | 99 | lexPhase0 :: String -> [Lex0] 100 | lexPhase0 = phase0 (1, 1) . untab 1 101 | 102 | untab :: Int -> String -> String 103 | untab i [] = [] 104 | untab i ('\t' : s) = ' ' : skip (i + 1) s where 105 | skip i s | i `mod` 8 == 1 = untab i s 106 | | otherwise = ' ' : skip (i + 1) s 107 | untab i (c : s) = c : untab (if c `elem` newlines then 1 else i + 1) s 108 | 109 | phase0 :: Pos -> String -> [Lex0] 110 | phase0 _ [] = [] 111 | phase0 p@(y, x) ('"' : s) = literal0 Str '"' p (B0 :< '"') (y, x + 1) s 112 | phase0 p@(y, x) ('\'' : s) = literal0 Chr '\'' p (B0 :< '"') (y, x + 1) s 113 | phase0 p@(y, x) ('{' : '-' : s) = brcomm0 p (B0 :< '{' :< '-') 0 (y, x + 2) s 114 | phase0 p@(y, x) ('-' : '-' : s) | commenty s = 115 | more0 Cmm p (B0 :< '-' :< '-') (y, x + 2) (not . (`elem` newlines)) s 116 | where 117 | commenty ('-' : s) = commenty s 118 | commenty (c : _) | c `elem` symbols = False 119 | commenty _ = True 120 | phase0 p@(y, x) ('_' : c : cs) | isIdTaily c 121 | = more0 Lid p (B0 :< '_' :< c)(y, x + 2) isIdTaily cs 122 | phase0 p@(y, x) ('_' : cs) = (Und, p, "_") : phase0 (y, x + 1) cs 123 | phase0 p@(y, x) (c : cs) = case c of 124 | ' ' -> space0 p p 0 (c : cs) 125 | _ | c `elem` specials -> (Sym, p, [c]) : phase0 (y, x + 1) cs 126 | | c `elem` symbols -> more0 Sym p (B0 :< c) (y, x + 1) (`elem` symbols) cs 127 | | c `elem` newlines -> (Ret, p, [c]) : phase0 (y + 1, 1) cs 128 | | isDigit c -> more0 Num p (B0 :< c) (y, x + 1) isDigit cs 129 | | isLower c -> more0 Lid p (B0 :< c) (y, x + 1) isIdTaily cs 130 | | isUpper c -> more0 Uid p (B0 :< c) (y, x + 1) isIdTaily cs 131 | | otherwise -> phase0 (y, x + 1) cs 132 | 133 | more0 :: Tok0 -> Pos -> Bwd Char -> Pos -> (Char -> Bool) -> String -> [Lex0] 134 | more0 t o cz (y, x) f (c : cs) | f c = more0 t o (cz :< c) (y, x + 1) f cs 135 | more0 t o cz p f s = (if b then Key else t, o, w) : phase0 p s where 136 | w = cz <>> "" 137 | b = t == Lid && (w `elem` keywords) 138 | 139 | literal0 :: Tok0 -> Char -> Pos -> Bwd Char -> Pos -> String -> [Lex0] 140 | literal0 t e o cz (y, x) (c : s) | c == e = (t, o, cz <>> [c]) : phase0 (y, x + 1) s 141 | literal0 t e o cz (y, x) ('\\' : c : s) 142 | | c > ' ' = literal0 t e o (cz :< '\\' :< c) (y, x + 2) s 143 | | otherwise = multilit0 t e o (cz :< '\\') (y, x + 1) (c : s) 144 | literal0 t e o cz (y, x) (c : s) = literal0 t e o (cz :< c) (y, x + 1) s 145 | literal0 t e o cz _ [] = [(Bad, o, cz <>> "")] 146 | 147 | multilit0 :: Tok0 -> Char -> Pos -> Bwd Char -> Pos -> String -> [Lex0] 148 | multilit0 t e o cz (y, x) ('\\' : cs) = literal0 t e o (cz :< '\\') (y, x + 1) cs 149 | multilit0 t e o cz (y, x) (' ' : cs) = multilit0 t e o (cz :< ' ') (y, x + 1) cs 150 | multilit0 t e o cz (y, x) (c : cs) | c `elem` newlines = multilit0 t e o (cz :< c) (y + 1, 1) cs 151 | multilit0 t e o cz p s = (Bad, o, cz <>> s) : phase0 p s 152 | 153 | brcomm0 :: Pos -> Bwd Char -> Int -> Pos -> String -> [Lex0] 154 | brcomm0 o cz n (y, x) ('-' : '}' : s) = case n of 155 | 0 -> (Cmm, o, cz <>> "-}") : phase0 (y, x + 2) s 156 | n -> brcomm0 o (cz :< '-' :< '}') (n - 1) (y, x + 2) s 157 | brcomm0 o cz n (y, x) ('{' : '-' : s) = 158 | brcomm0 o (cz :< '{' :< '-') (n + 1) (y, x + 2) s 159 | brcomm0 o cz n (y, x) (c : s) = 160 | brcomm0 o (cz :< c) n (if c `elem` newlines then (y + 1, 1) else (y, x + 1)) s 161 | brcomm0 o cz n _ [] = [(Bad, o, cz <>> "")] 162 | 163 | space0 :: Pos -> Pos -> Int -> String -> [Lex0] 164 | space0 o _ i [] = [] 165 | space0 o p@(y, x) i s@(c : cs) = case c of 166 | ' ' -> space0 o (y, x + 1) (i + 1) cs 167 | _ -> (Spc, o, replicate i ' ') : phase0 p s 168 | 169 | newlines :: String 170 | newlines = "\r\n" 171 | 172 | specials :: String 173 | specials = "(),;[]`{}" 174 | 175 | symbols :: String 176 | symbols = "!#$%&*+./<=>?@\\^|-~:" 177 | 178 | keywords :: [String] 179 | keywords = 180 | [ "case", "class", "instance", "data", "do", "if", "then", "else", "where", "let", "in", "of" 181 | , "module", "import", "deriving", "infix", "infixl", "infixr" 182 | , "prop", "prove", "proven", "by", "from", "given", "inductively", "define", "defined" 183 | , "test", "tested", "under" 184 | , "grammar", "parse", "parsed" 185 | ] 186 | 187 | isIdTaily :: Char -> Bool 188 | isIdTaily c = isAlphaNum c || c `elem` "'_" 189 | 190 | data LayKind = Empty | Denty Int | Bracy deriving (Show, Eq) 191 | 192 | data Lay l 193 | = (String, LayKind) :-! Odd [l] [l] 194 | -- gappy/bracy -^ ^- begins and ends non-gappy 195 | | LB l [l] l 196 | deriving (Show, Eq) 197 | 198 | infixr 5 :-! 199 | 200 | -- an EmptyL layout should have [] :-/ Stop as its body 201 | -- a Dental i layout should be indented at column i (> 0), so 202 | -- all but the last odd entry should either be gappy or contain a semicolon 203 | -- its last odd entry should be empty 204 | -- its even entries should start at column i unless preceded by a ; in 205 | -- which case they may be further right 206 | -- (and all non gappies must be >= i) 207 | -- a Bracy layout will have odd entries 208 | -- starting with gap { gap 209 | -- gap ; gap in the middle 210 | -- gap } at the end 211 | 212 | instance PEq Lay where peq = (==) 213 | instance PShow Lay where pshow = show 214 | 215 | type TokL = Tok Lay 216 | type LexL = Lex Lay 217 | type Line = [LexL] -- signal 218 | type Bloc = Odd [LexL] -- noise 219 | 220 | unLay :: LexL -> [LexL] 221 | unLay (T (_ :-! _), _ , _) = [] -- FIXME! 222 | unLay (T (LB o ls c), _, _) = (o : ls ++ [c]) >>= unLay 223 | unLay l = [l] 224 | 225 | heralds :: [String] 226 | heralds = ["where", "do", "of", "let"] 227 | 228 | layEnders :: [(String, String)] 229 | layEnders = [("do", "where"), ("of","where"), ("let", "in")] 230 | 231 | gappy :: Lex f -> Bool 232 | gappy (t, _, _) = case t of 233 | Spc -> True 234 | Ret -> True 235 | Cmm -> True 236 | _ -> False 237 | 238 | islay :: Lex f -> Bool 239 | islay (T _, _, _) = True 240 | islay _ = False 241 | 242 | pfirst :: [Lex0] -> Pos 243 | pfirst ((_, p, s) : _) = p 244 | pfirst [] = (maxBound, maxBound) 245 | 246 | data Gimmode 247 | = Indenting String Int 248 | | Bracing 249 | deriving Show 250 | 251 | gimme 252 | :: Gimmode -- where are we at? 253 | -> Bool -- have we found a starting token? 254 | -> [Lex0] -- ordinary tokens 255 | -> ( [LexL] -- lead space 256 | , [LexL] -- chunk begins and ends non-gappy or is empty 257 | , [Lex0] -- trailing space 258 | , [Lex0] -- unconsumed 259 | ) -- if chunk empty then lead space must be empty 260 | gimme g b ls = case span gappy ls of 261 | (ss, []) -> ([], [], ss, []) 262 | (ss, l@(t, p@(y, x), s) : ls) 263 | | notMine g b l -> ([], [], ss, l : ls) 264 | | t == Key && s `elem` heralds -> case layout g s ls of 265 | (l, ls) -> case gimme g True ls of 266 | (sl, ch, st, ls) -> (map lex0 ss, (T l, p, "") : sl ++ ch, st, ls) 267 | (ss, l : ls) -> case gimme g True ls of 268 | (sl, ch, st, ls) -> 269 | ( map lex0 ss 270 | , (if b then id else brackety) (lex0 l : sl ++ ch) 271 | , st 272 | , ls) 273 | 274 | notMine :: Gimmode -> Bool -> Lex0 -> Bool 275 | notMine Bracing _ (t, p@(y, x), s) = elem (t, s) [(Sym, ";"), (Sym, "}")] 276 | notMine (Indenting h i) started (t, p@(y, x), s) = 277 | x < i || (started && x == i) || elem (h, s) layEnders 278 | 279 | 280 | layout 281 | :: Gimmode -- what's our enclosing context? 282 | -> String -- the layout herald 283 | -> [Lex0] -- the tokens after the herald 284 | -> ( Lay LexL -- the lump of layout 285 | , [Lex0] -- the unconsumed input 286 | ) 287 | layout g h ls = case span gappy ls of 288 | (ss, []) -> ((h, Empty) :-! [] :-/ Stop, ss) 289 | (ss, l@(Sym, _, "{") : ls) -> case span gappy ls of 290 | (ss', ls) -> case layLines Bracing ls of 291 | (br, ls) -> ((h, Bracy) :-! (map lex0 (ss ++ l : ss')) :-/ br, ls) 292 | (ss, l@(_, (_, x), _) : ls) 293 | | layStart g l -> case layLines (Indenting h x) (l : ls) of 294 | (de, ls) -> ((h, Denty x) :-! map lex0 ss :-/ de, ls) 295 | | otherwise -> ((h, Empty) :-! [] :-/ Stop, ss ++ l : ls) 296 | 297 | layStart :: Gimmode -> Lex0 -> Bool 298 | layStart (Indenting _ i) (_, (_, j), _) = j > i 299 | layStart Bracing _ = True 300 | 301 | layLines 302 | :: Gimmode 303 | -> [Lex0] -- must ensure no leading space 304 | -> (Even [LexL] [LexL], [Lex0]) 305 | layLines g ls = case gimme g False ls of 306 | (_, ch, st, ls) -> case (g, ls) of 307 | (Indenting s i, l@(_, (_, j), _) : ls) 308 | | i == j -> case layLines g (l : ls) of 309 | (de, ls) -> (ch :-\ map lex0 st :-/ de, ls) 310 | | otherwise -> (ch :-\ [] :-/ Stop, st ++ l : ls) 311 | (Bracing, l@(Sym, _, "}") : ls) -> 312 | (ch :-\ map lex0 (st ++ [l]) :-/ Stop, ls) 313 | (Bracing, l@(Sym, _, ";") : ls) -> case span gappy ls of 314 | (su, ls) -> case layLines g ls of 315 | (br, ls) -> (ch :-\ map lex0 (st ++ l : su) :-/ br, ls) 316 | (_, ls) -> (ch :-\ [] :-/ Stop, st ++ ls) 317 | 318 | lexPhase1 :: [Lex0] -> Bloc Line 319 | lexPhase1 ls = case span gappy ls of 320 | (ss, ls) -> map lex0 ss :-/ uncurry trailing (layLines (Indenting "" 1) ls) 321 | where 322 | trailing Stop rs = [] :-\ map lex0 rs :-/ Stop 323 | trailing (a :-\ b :-/ Stop) rs = (a :-\ (b ++ map lex0 rs) :-/ Stop) 324 | trailing (a :-\ b :-/ e) rs = a :-\ b :-/ trailing e rs 325 | 326 | brackety :: [LexL] -> [LexL] 327 | brackety = go B0 B0 where 328 | go bz lz [] = dump bz (lz <>> []) where 329 | dump B0 ls = ls 330 | dump (bz :< (kz, k)) ls = dump bz (kz <>> (bad k : ls)) 331 | go bz lz (l@(Sym, _, [o]) : ls) | o `elem` "([{" = 332 | go (bz :< (lz, l)) B0 ls 333 | go bz lz (l@(Sym, _, [c]) : ls) | c `elem` ")]}" = 334 | blat bz lz where 335 | blat B0 lz = go B0 (lz :< bad l) ls 336 | blat (bz :< (kz, k@(_, p, [o]))) lz 337 | | ma o c 338 | = go bz (kz :< (T (LB k (lz <>> []) l), p, "")) ls 339 | | otherwise -- bad 340 | = blat bz ((kz :< bad k) <> lz) 341 | go bz lz (l : ls) = go bz (lz :< l) ls 342 | 343 | ma '(' ')' = True 344 | ma '[' ']' = True 345 | ma '{' '}' = True 346 | ma _ _ = False 347 | 348 | rfold :: (x -> t -> t) -> [x] -> t -> t 349 | rfold t2t xs t = foldr t2t t xs 350 | 351 | lout :: LexL -> String -> String 352 | lout (T ((h,_) :-! b), _ , _) = (h ++) . bout b 353 | lout (T (LB lo ls lc), _, _) = lout lo . rfold lout ls . lout lc 354 | lout (_, _, s) = (s ++) 355 | 356 | bout :: Bloc Line -> String -> String 357 | bout (ls :-/ e) = rfold lout ls . case e of 358 | Stop -> id 359 | ls :-\ o -> rfold lout ls . bout o 360 | 361 | askTokIn :: String -> String -> Bool 362 | askTokIn a b = go (lexPhase0 a) (lexPhase0 b) where 363 | go as bs | pref as bs = True 364 | go as [] = False 365 | go as (_ : bs) = go as bs 366 | pref ((t, _, _) : as) bs | no t = pref as bs 367 | pref as ((t, _, _) : bs) | no t = pref as bs 368 | pref [] bs = True 369 | pref _ [] = False 370 | pref (a : as) (b : bs) = txt a == txt b && pref as bs 371 | no Spc = True 372 | no Cmm = True 373 | no _ = False -------------------------------------------------------------------------------- /lib/Language/Ask/OddEven.hs: -------------------------------------------------------------------------------- 1 | module Language.Ask.OddEven where 2 | 3 | import Data.Bifunctor 4 | import Data.Bifoldable 5 | import Data.Bitraversable 6 | import Data.Traversable 7 | 8 | data Odd a b = a :-/ Even b a deriving (Show, Eq) 9 | data Even b a = Stop | b :-\ Odd a b deriving (Show, Eq) 10 | infixr 6 :-/ 11 | infixr 6 :-\ 12 | 13 | instance Bitraversable Odd where 14 | bitraverse f g (a :-/ e) = (:-/) <$> f a <*> bitraverse g f e 15 | instance Bitraversable Even where 16 | bitraverse _ _ Stop = pure Stop 17 | bitraverse g f (b :-\ o) = (:-\) <$> g b <*> bitraverse f g o 18 | 19 | instance Bifunctor Odd where bimap = bimapDefault 20 | instance Bifunctor Even where bimap = bimapDefault 21 | 22 | instance Bifoldable Odd where bifoldMap = bifoldMapDefault 23 | instance Bifoldable Even where bifoldMap = bifoldMapDefault 24 | 25 | instance Traversable (Odd a) where traverse = bitraverse pure 26 | instance Traversable (Even b) where traverse = bitraverse pure 27 | 28 | instance Functor (Odd a) where fmap = fmapDefault 29 | instance Functor (Even b) where fmap = fmapDefault 30 | 31 | instance Foldable (Odd a) where foldMap = foldMapDefault 32 | instance Foldable (Even b) where foldMap = foldMapDefault 33 | 34 | instance Monoid (Even b a) where 35 | mempty = Stop 36 | mappend (b :-\ a :-/ bae) bae' = b :-\ a :-/ mappend bae bae' 37 | instance Semigroup (Even b a) where (<>) = mappend 38 | 39 | infixr 6 `ocato`, `ecato`, `ocate` 40 | 41 | ocate :: Odd a b -> Even b a -> Odd a b 42 | ocate (a :-/ bae) bae' = a :-/ bae <> bae' 43 | 44 | ecato :: Even a b -> Odd a b -> Odd a b 45 | ecato Stop abo = abo 46 | ecato (a :-\ bao) abo = a :-/ bao `ocato` abo 47 | 48 | ocato :: Odd b a -> Odd a b -> Even b a 49 | ocato (b :-/ abe) abo = b :-\ abe `ecato` abo 50 | -------------------------------------------------------------------------------- /lib/Language/Ask/Parsing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | GeneralizedNewtypeDeriving 3 | , PatternGuards 4 | , LambdaCase 5 | #-} 6 | 7 | module Language.Ask.Parsing where 8 | 9 | import Control.Monad 10 | import Control.Applicative 11 | import Data.List 12 | 13 | import Language.Ask.OddEven 14 | import Language.Ask.Lexing 15 | 16 | newtype ParTok e x = ParTok {parTok 17 | :: e -- some sort of read-only environment, never mind what 18 | -> [LexL] 19 | -> [([LexL], x, [LexL])] 20 | } deriving (Semigroup, Monoid) 21 | 22 | instance Monad (ParTok e) where 23 | return x = ParTok $ \ _ ls -> [([], x, ls)] 24 | ParTok ps >>= k = ParTok $ \ e ls -> do 25 | (ks, s, ls) <- ps e ls 26 | (kt, t, ls) <- parTok (k s) e ls 27 | return (ks ++ kt, t, ls) 28 | 29 | instance Applicative (ParTok e) where 30 | pure = return 31 | (<*>) = ap 32 | 33 | instance Functor (ParTok e) where 34 | fmap = ap . return 35 | 36 | instance Alternative (ParTok e) where 37 | empty = mempty 38 | (<|>) = (<>) 39 | 40 | (?>) :: ParTok e x -> ParTok e x -> ParTok e x 41 | (?>) (ParTok f) (ParTok g) = ParTok $ \ e ls -> case f e ls of 42 | [] -> g e ls 43 | xs -> xs 44 | 45 | eat :: (LexL -> Maybe x) -> ParTok e x 46 | eat f = ParTok $ \ e ls -> case ls of 47 | l : ls | Just x <- f l -> return ([l], x, ls) 48 | _ -> [] 49 | 50 | penv :: ParTok e e 51 | penv = ParTok $ \ e ls -> [([], e, ls)] 52 | 53 | the :: Tok Lay -> String -> ParTok e () 54 | the t s = eat $ \ (u, _, r) -> guard $ u == t && r == s 55 | 56 | kinda :: Tok Lay -> ParTok e LexL 57 | kinda t = eat $ \ l@(u, _, _) -> do guard $ u == t ; return l 58 | 59 | brk :: Char -> ParTok e x -> ParTok e x 60 | brk c p = ParTok $ \ e ls -> case ls of 61 | (l@(T (LB (Sym, _, [o]) ks _), _, _) : ls) | c == o -> 62 | [([l], x, ls) | (_, x, []) <- parTok (spd p) e ks] 63 | _ -> [] 64 | 65 | spc :: ParTok e () 66 | spc = ParTok $ \ _ ls -> let (ks, ms) = span gappy ls in [(ks, (), ms)] 67 | 68 | spd :: ParTok e x -> ParTok e x 69 | spd p = id <$ spc <*> p <* spc 70 | 71 | sep :: ParTok e x -> ParTok e () -> ParTok e [x] 72 | sep p s = (:) <$> p <*> many (id <$ s <*> p) 73 | <|> pure [] 74 | 75 | eol :: ParTok e () 76 | eol = ParTok $ \ _ ls -> case ls of 77 | [] -> [([], (), [])] 78 | _ -> [] 79 | 80 | lol :: String -> ParTok e x -> ParTok e (Bloc x) 81 | lol k p = ParTok $ \ en ls -> case ls of 82 | l@(T ((h, _) :-! o) , _, _) : ls | h == k -> 83 | grok en o >>= \ x -> [([l], x, ls)] 84 | _ -> [] 85 | where 86 | grok en (ss :-/ e) = (ss :-/) <$> grek en e 87 | grek en Stop = pure Stop 88 | grek en (ls :-\ o) = (:-\) <$> pa en ls <*> grok en o 89 | pa en ls = [x | (_, x, []) <- parTok (p <* eol) en ls] 90 | 91 | ext :: ParTok e x -> ParTok e ([LexL], x) 92 | ext p = ParTok $ \ e ls -> do 93 | (ks, x, us) <- parTok p e ls 94 | return (ks, (ks, x), us) 95 | -------------------------------------------------------------------------------- /lib/Language/Ask/Printing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Language.Ask.Printing where 4 | 5 | import Data.Char 6 | import Data.List 7 | 8 | import Language.Ask.Hide 9 | import Language.Ask.Bwd 10 | import Language.Ask.Lexing 11 | import Language.Ask.RawAsk 12 | import Language.Ask.Tm 13 | import Language.Ask.Glueing 14 | import Language.Ask.Context 15 | import Language.Ask.Typing 16 | 17 | data Spot = AllOK | RadSpot | Infix (Int, Either Assocy Assocy) | Fun | Arg deriving (Show, Eq) 18 | data Wot = Rad | Inf (Int, Assocy) | App deriving (Show, Eq) 19 | instance Ord Wot where 20 | compare Rad Rad = EQ 21 | compare Rad (Inf _) = LT 22 | compare Rad App = LT 23 | compare (Inf _) Rad = GT 24 | compare (Inf (i, _)) (Inf (j, _)) = compare i j 25 | compare (Inf _) App = LT 26 | compare App App = EQ 27 | compare App _ = GT 28 | -- x <= y means you can put a y anywhere you can put an x with no parens 29 | 30 | class PP t where 31 | ppr :: t -> AM String 32 | phy :: t -> Maybe Tm 33 | 34 | pinx :: Int -> AM String 35 | pinx i = return $ "???" 36 | 37 | pnom :: Nom -> AM String 38 | pnom x = cope (nomBKind x) 39 | (\ gr -> if null x then return "boo" else case last x of 40 | (x, i) -> return $ x ++ show i) 41 | $ \case 42 | User x -> return x 43 | _ -> if null x then return "boo" else case last x of 44 | (x, i) -> return $ x ++ show i 45 | 46 | pppa :: Spot -> Wot -> String -> String 47 | pppa x y s = if paren x y then "(" ++ s ++ ")" else s where 48 | paren AllOK _ = False 49 | paren RadSpot w = w <= Rad 50 | paren s@(Infix (i, a)) w@(Inf (j, b)) = 51 | j < i || (j == i && case (a, b) of 52 | (Left LAsso, LAsso) -> False 53 | (Right RAsso, RAsso) -> False 54 | _ -> True) 55 | paren (Infix _) App = False 56 | paren Fun App = False 57 | paren _ _ = True 58 | 59 | readyTmR :: TmR -> Either Tm [LexL] 60 | readyTmR (My t) = Left t 61 | readyTmR (Our _ (ls, _)) = Right ls 62 | readyTmR (Your (ls, _)) = Right ls 63 | 64 | instance PP TmR where 65 | ppr = ppTmR AllOK 66 | phy = my 67 | 68 | ppTmR :: Spot -> TmR -> AM String 69 | ppTmR spot t = case readyTmR t of 70 | Left t -> ppTm spot t 71 | Right ls -> return $ rfold lout ls "" 72 | 73 | ppTy :: Spot -> Tm -> AM String 74 | ppTy spot (Sized t _ Big) = ("big " ++) <$> ppTm spot t 75 | ppTy spot (Sized t _ (Weer _)) = ("wee " ++) <$> ppTm spot t 76 | ppTy spot t = ppTm spot t 77 | 78 | ppTm :: Spot -> Tm -> AM String 79 | ppTm spot (TC f@(c : s) as) 80 | | isAlpha c = go f as 81 | | c == '(' = do 82 | let n = case span (',' ==) s of 83 | ([], _) -> 0 84 | (cs, _) -> 1 + length cs 85 | if n /= length as then go f as else do 86 | as <- traverse (ppTm AllOK) as 87 | return $ "(" ++ intercalate ", " as ++ ")" 88 | | f == "=" = case as of 89 | [ty, lhs, rhs] -> do 90 | ga <- gamma 91 | let cand (_ ::> (c, _)) = [c] 92 | cand (Data _ de) = foldMap cand de 93 | cand _ = [] 94 | let crs = foldMap cand ga 95 | (lhs, rhs) <- case (lhs, rhs) of 96 | (TE _, _) -> return (lhs, rhs) 97 | (_, TE _) -> return (lhs, rhs) 98 | (TC c _, TC d _) 99 | | length (filter (c ==) crs) == 1 || length (filter (d ==) crs) == 1 100 | -> return (lhs, rhs) 101 | _ -> do 102 | ty <- norm ty 103 | return (TE (lhs ::: ty), rhs) 104 | lhs <- ppTm (Infix (4, Left NAsso)) lhs 105 | rhs <- ppTm (Infix (4, Right NAsso)) rhs 106 | return $ pppa spot (Inf (4, NAsso)) (lhs ++ " = " ++ rhs) 107 | _ -> go "(=)" as 108 | | otherwise = case as of 109 | x : y : as -> do 110 | (p, a) <- fixity f 111 | x <- ppTm (Infix (p, Left a)) x 112 | y <- ppTm (Infix (p, Right a)) y 113 | case as of 114 | [] -> return $ pppa spot (Inf (p, a)) (x ++ " " ++ f ++ " " ++ y) 115 | _ -> go ("(" ++ x ++ " " ++ f ++ " " ++ y ++ ")") as 116 | _ -> go ("(" ++ f ++ ")") as 117 | where 118 | go f as = case as of 119 | [] -> return f 120 | _ -> do 121 | as <- traverse (ppTm Arg) as 122 | return $ pppa spot App (f ++ (as >>= (" " ++))) 123 | ppTm spot (TE e) = ppEl spot e [] 124 | ppTm _ t = return $ show t 125 | 126 | ppEl :: Spot -> Syn -> [Tm] -> AM String 127 | ppEl spot (TV i) as = pinx i >>= ppArgs spot as 128 | ppEl spot (TP (x, _)) as = pnom x >>= ppArgs spot as 129 | ppEl spot (t ::: ty) [] = do 130 | t <- ppTm RadSpot t 131 | ty <- ppTm RadSpot ty 132 | return . pppa spot Rad $ t ++ " :: " ++ ty 133 | ppEl spot (t ::: ty) as = do 134 | t <- ppTm RadSpot t 135 | ty <- ppTm RadSpot ty 136 | ppArgs spot as ("(" ++ t ++ " :: " ++ ty ++ ")") 137 | ppEl spot (f :$ s) as = ppEl spot f (s : as) 138 | ppEl spot (TF (f, Hide sch) ss ts) as = do 139 | ss <- return $ dump sch ss 140 | ppArgs spot (ss ++ ts ++ as) (fst (last f)) 141 | -- terrible hack 142 | where 143 | dump (Al a t) (s : ss) = dump (t // (s ::: a)) ss 144 | dump _ ss = ss 145 | 146 | ppArgs :: Spot -> [Tm] -> String -> AM String 147 | ppArgs spot ts f = ppTm spot (TC f ts) -- you dirty so-and-so 148 | 149 | ppGripe :: Gripe -> AM String 150 | ppGripe (Terror ls sy ty) = do 151 | sy <- ppTy AllOK =<< norm sy 152 | ty <- ppTy AllOK =<< norm ty 153 | return $ ("When checking " ++) . rfold lout ls $ 154 | concat [", I found it was a ", sy, " but I needed a ", ty, "."] 155 | ppGripe Surplus = return "I don't see why you need this" 156 | ppGripe (Duplication ty c) = do 157 | ty <- ppTm AllOK =<< norm ty 158 | return $ "I already have something called " ++ c ++ " that makes things in " ++ ty 159 | ppGripe (Scope x) = return $ "I can't find " ++ x ++ " in scope" 160 | ppGripe (ByBadRule r t) = do 161 | t <- ppTm AllOK t 162 | return $ "I can't find a rule called " ++ r ++ " that would prove " ++ t 163 | ppGripe (BadRec r) = return $ 164 | "It's dangerous to use " ++ r ++ " before you know what it means." 165 | ppGripe (ByAmbiguous r t) = do 166 | t <- ppTm AllOK t 167 | return $ "Please report a bug: I have too many rules called " ++ r ++ " that would prove " ++ t 168 | ppGripe EmptyInductively = do 169 | return $ "To work inductively, you need at least one thing to do induction on." 170 | ppGripe (TestNeedsEq g) = do 171 | g <- ppTm AllOK g 172 | return $ "I can only test equations, not " ++ g 173 | ppGripe (UnderNeedsEq g) = do 174 | g <- ppTm AllOK g 175 | return $ "I can only reach under in equations, not " ++ g 176 | ppGripe (FromNeedsConnective (ls, _)) = return $ 177 | rfold lout ls " has no main connective for 'from' to eliminate." 178 | ppGripe (NotGiven p) = do 179 | p <- ppTm AllOK p 180 | return $ "I do not remember being given " ++ p 181 | ppGripe (NotARule (ls, _)) = return $ rfold lout ls " is not the right shape to be a rule." 182 | ppGripe Mardiness = return $ 183 | "I seem to be unhappy but I can't articulate why, except that it's Conor's fault." 184 | ppGripe (NotADataType t) = do 185 | t <- ppTm AllOK t 186 | return $ t ++ " is not a data type and cannot be split into cases" 187 | ppGripe (WrongNumOfArgs c n as) = return $ 188 | c ++ " expects " ++ count n ++ " but you have given it " ++ blat as 189 | where 190 | count 0 = "no arguments" 191 | count 1 = "one argument" 192 | count 2 = "two arguments" 193 | count 3 = "three arguments" 194 | count n = show n ++ " arguments" 195 | blat [] = "none" 196 | blat [(ls, _)] = rfold lout ls "" 197 | blat ((ls, _) : as) = rfold lout ls $ " and " ++ blat as 198 | ppGripe (DoesNotMake c ty) = do 199 | ty <- ppTy AllOK ty 200 | return $ c ++ " cannot make a thing of type " ++ ty 201 | ppGripe (OverOverload c) = return $ 202 | "Please report a bug. " ++ c ++ " has unsafe overloading." 203 | ppGripe (BadFName f) = return $ case f of 204 | [] -> "Please report a bug. Somehow, the empty string is the name of a thing." 205 | c : _ 206 | | isUpper c -> 207 | "You declared " ++ f ++ 208 | " but function names should begin in lowercase. (Did you mean data ... = " 209 | ++ f ++ " ...?)" 210 | _ -> "I'm afraid that " ++ f ++ " is an unsuitable name for a function." 211 | ppGripe (Unification found expected) = 212 | return $ "I was compelled to expect " ++ show expected ++ "but I was given " ++ show found ++ " instead" 213 | ppGripe (NonCanonicalType ty con) = 214 | return $ show con ++ " is a constructor but I am not sure it should be there." 215 | ppGripe (NotAProd c gs) = do 216 | p <- ppr (ParseProd gs) 217 | g <- ppr (ParseProb c Nothing) 218 | return $ "No production " ++ p ++ " for grammar " ++ g 219 | ppGripe ParseNoString = return "I can't check a production unless you tell me the input." 220 | ppGripe (ParseNotTheWanted c) = return $ concat 221 | ["This isn't the ",c," I wanted."] 222 | ppGripe (ParseNoMake s) = return $ concat 223 | ["This doesn't make ", s, "."] 224 | ppGripe ParseStubSub = return "Don't give subtrees until you've chosen a production." 225 | ppGripe (Bland x) = return x 226 | ppGripe InfiniteType = return "Can't make an infinite type!" 227 | 228 | ppGripe FAIL = return $ 229 | "It went wrong but I've forgotten how. Please ask a human for help." 230 | ppGripe g = return $ show g 231 | 232 | instance PP ParseThing where 233 | ppr (ParseProb c m) = pure . concat $ 234 | ["<",c,">"] ++ case m of 235 | Nothing -> [] 236 | Just s -> [" ", s] 237 | ppr (ParseProd gs) = pure . intercalate " " $ fmap gb gs where 238 | gb (Terminal t) = t 239 | gb (NonTerminal c) = concat ["<",c,">"] 240 | phy _ = Nothing 241 | -------------------------------------------------------------------------------- /lib/Language/Ask/Progging.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ---------- ---------- 3 | ---------- Progging ---------- 4 | ---------- ---------- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE 8 | LambdaCase 9 | #-} 10 | 11 | module Language.Ask.Progging where 12 | 13 | import Data.Char 14 | import Data.List hiding ((\\)) 15 | import Control.Monad 16 | import Data.Monoid 17 | import Data.Traversable 18 | import Control.Arrow ((***)) 19 | 20 | import Debug.Trace 21 | 22 | import Language.Ask.Bwd 23 | import Language.Ask.Hide 24 | import Language.Ask.HalfZip 25 | import Language.Ask.Tm 26 | import Language.Ask.Context 27 | import Language.Ask.Typing 28 | import Language.Ask.Lexing 29 | import Language.Ask.RawAsk 30 | 31 | trade = const id 32 | 33 | 34 | ------------------------------------------------------------------------------ 35 | -- From Type Scheme to Programming Problem 36 | ------------------------------------------------------------------------------ 37 | 38 | proglify :: Nom -> (String, Sch) -> AM Proglem 39 | proglify f (u, s) = go B0 B0 s where 40 | go de iz (as :>> t) = do 41 | ysxs <- traverse (\ (x, s) -> fresh x >>= \ y -> return (y, s, x)) as 42 | let m = [(x, TE (TP (y, Hide (stan m s)))) | (y, s, x) <- ysxs] 43 | return $ Proglem 44 | { localCx = de <>< [Bind xp (User x) | (x, TE (TP xp)) <- m] 45 | , fNom = f 46 | , uName = u 47 | , leftImpl = iz <>> [] 48 | , leftSatu = [(tm, ty) | (_, tm@(TE (TP (_, Hide ty)))) <- m] 49 | , leftAppl = [] 50 | , rightTy = stan m t 51 | } 52 | go de iz (Al a s) = do 53 | x <- fresh "" 54 | let xp = (x, Hide a) 55 | go (de :< Bind xp (User "")) (iz :< (TE (TP xp), a)) (s // TP xp) 56 | 57 | 58 | ------------------------------------------------------------------------------ 59 | -- get names from user 60 | ------------------------------------------------------------------------------ 61 | 62 | dubStep :: Proglem -> String -> [Appl] -> AM Proglem 63 | dubStep p f as = do 64 | True <- trade ("DUBSTEP " ++ show p ++ " " ++ show f ++ show as) $ return True 65 | doorStop 66 | push ImplicitQuantifier 67 | push $ Defined f 68 | Left (n, sch) <- what's f 69 | (e, ty) <- elabFun PAT (n, Hide sch) B0 sch as 70 | lox <- doorStep 71 | z@(f, _, is, ss, as) <- mayhem $ fnarg e [] 72 | guard $ f == fNom p 73 | True <- trade ("FNARG " ++ show z) $ return True 74 | p <- tro lox as (leftAppl p) p 75 | True <- trade (show p ++ "\nDUBBING") $ return True 76 | nx <- nub <$> ((++) 77 | <$> dubs lox (map fst $ leftSatu p) ss 78 | <*> dubs lox (map fst $ leftAppl p) as) 79 | True <- trade (show nx) $ return True 80 | guard $ length nx == length (nub (map snd nx)) 81 | return $ p {localCx = fmap (redub nx) (localCx p)} 82 | where 83 | tro :: [CxE] -> [Tm] -> [(Tm, Tm)] -> Proglem -> AM Proglem 84 | tro lox [] [] p = return p 85 | tro lox (_ : as) (_ : la) p = tro lox as la p 86 | tro lox (TE (TP (yn, _)) : as) [] p = case [u | Bind (zn, _) (User u) <- lox , yn == zn] of 87 | [x] -> do 88 | True <- trade (show x ++ " tro " ++ show (rightTy p)) $ return True 89 | TC "->" [dom, ran] <- hnf (rightTy p) 90 | xn <- fresh x 91 | let xp = (xn, Hide dom) 92 | tro lox as [] $ p 93 | { localCx = localCx p :< Bind xp (User x) 94 | , leftAppl = leftAppl p ++ [(TE (TP xp), dom)] 95 | , rightTy = ran 96 | } 97 | _ -> gripe FAIL 98 | tro _ _ _ _ = gripe FAIL 99 | dubs :: [CxE] -> [Tm] -> [Tm] -> AM [(Nom, String)] 100 | dubs lox as bs | trade (show ("DUBS" ++ show as ++ show bs)) False = undefined 101 | dubs lox [] [] = return [] 102 | dubs lox (TC c ts : ts') (TC d us : us') 103 | | c == d = dubs lox (ts ++ ts') (us ++ us') 104 | | otherwise = gripe FAIL 105 | dubs lox (TE (TP (xn, _)) : ts) (TE (TP (un, _)) : us) = 106 | case [u | Bind (yn, _) (User u) <- lox, yn == un] of 107 | [u] -> ((xn, u) :) <$> dubs lox ts us 108 | _ -> gripe FAIL 109 | dubs _ _ _ = gripe FAIL 110 | redub nx (Bind xp@(xn, _) (User y)) = case lookup xn nx of 111 | Just x -> Bind xp (User x) 112 | Nothing -> Bind xp (User (fuzz y)) 113 | redub nx z = z 114 | fuzz "" = ".x" 115 | fuzz (c : cs) | isAlpha c = '.' : c : cs 116 | fuzz x = x 117 | 118 | 119 | ------------------------------------------------------------------------------ 120 | -- inductively 121 | ------------------------------------------------------------------------------ 122 | 123 | inductively :: Proglem -> [String] -> AM Proglem 124 | inductively p@(Proglem de f u li ls la ty) xs = do 125 | True <- trade ("inductively " ++ show p) $ return True 126 | xs <- traverse (chkIsData de) xs 127 | non <- fresh "" -- make a nonce 128 | let nonp = (non, Hide Zone) 129 | let nont = TE (TP nonp) 130 | let size1 (xn, Hide s) 131 | | elem xn xs = TC "$" [s, nont, TC "S" [TC "Z" []]] 132 | | otherwise = s 133 | let disTy [] ty = return ty 134 | disTy ((TE (TP xp), _) : la) t = (size1 xp :->) <$> disTy la t 135 | disTy _ _ = gripe FAIL 136 | aty <- disTy la ty 137 | qs <- for ls $ \case 138 | (TE (TP xp), _) -> case 139 | foldMap (\case {Bind yp (User y) | xp == yp -> [y]; _ -> []}) de of 140 | [x] -> return (xp, (x, size1 xp)) 141 | _ -> gripe Mardiness 142 | _ -> gripe Mardiness 143 | let sa = [(fst xp, (TM x [] ::: rfold e4p sa s)) | (xp, (x, s)) <- qs] 144 | let disch [] = return $ [(x, rfold e4p sa s) | (_, (x, s)) <- qs] :>> aty 145 | disch ((TE (TP xp), _) : li) = 146 | (Al (size1 xp) . (fst xp \\)) <$> disch li 147 | disch _ = gripe FAIL 148 | sch <- disch li 149 | True <- trade (show "INDHYP " ++ show sch) $ return True 150 | let mark B0 = return $ ([], B0 151 | :< Bind (non, Hide Zone) (User "") 152 | :< Declare (uName p) (fNom p) sch 153 | :< Defined (uName p)) 154 | mark (ga :< Bind yp@(yn, Hide ty) (User y)) | elem yn xs = do 155 | ty <- hnf ty 156 | (sb, ga) <- mark ga 157 | let yp' = (yn, Hide (TC "$" [rfold e4p sb ty, nont, TC "Z" []])) 158 | return ((yn, TP yp') : sb, ga :< Bind yp' (User y)) 159 | mark (ga :< z) = do 160 | (sb, ga) <- mark ga 161 | case z of 162 | Hyp b h -> return (sb, ga :< Hyp b (rfold e4p sb h)) 163 | Bind (yn, Hide ty) k -> do 164 | let yp = (yn, Hide (rfold e4p sb ty)) 165 | return ((yn, TP yp) : sb, ga :< Bind yp k) 166 | z -> return (sb, ga :< z) 167 | (sb, de) <- mark de 168 | return $ Proglem de f u 169 | (rfold e4p sb li) 170 | (rfold e4p sb ls) 171 | (rfold e4p sb la) 172 | (rfold e4p sb ty) 173 | 174 | isDataType :: Con -> AM () 175 | isDataType d = do 176 | ga <- gamma 177 | guard . getAny $ foldMap (Any . isda d) ga 178 | where 179 | isda d (Data e _) = d == e 180 | isda _ _ = False 181 | 182 | chkIsData :: Context -> String -> AM Nom 183 | chkIsData de x = case foldMap spot de of 184 | [(xn, Hide ty)] -> do 185 | ty@(TC d _) <- hnf ty 186 | isDataType d 187 | return xn 188 | _ -> gripe $ Scope x 189 | where 190 | spot (Bind xp (User y)) | y == x = [xp] 191 | spot _ = [] 192 | 193 | 194 | indPrf :: Tm -> [String] -> AM () 195 | indPrf g xs = do 196 | de <- doorStep 197 | doorStop 198 | non <- fresh "" -- make a nonce 199 | let nonp = (non, Hide Zone) 200 | let nont = TE (TP nonp) 201 | push $ Bind nonp (User "") 202 | bg <- bigg xs nont [] de g 203 | wg <- weeg xs nont [] de g 204 | push $ Hyp True wg 205 | demand $ PROVE bg 206 | ga <- gamma 207 | True <- trade ("INDPRF: " ++ show ga) $ return True 208 | return () 209 | 210 | weeg :: [String] -- inductively what? 211 | -> Tm -- size zone 212 | -> [(Nom, Syn)] -- substitution 213 | -> [CxE] -- quantifier prefix 214 | -> Tm -- goal 215 | -> AM Tm -- inductive hypothesis 216 | weeg xs z sb [] g = case xs of 217 | x : _ -> gripe $ Scope x 218 | [] -> return (rfold e4p sb g) 219 | weeg xs z sb (Bind (nom, Hide ty) k : de) g = case k of 220 | Defn tm -> weeg xs z ((nom, rfold e4p sb (tm ::: ty)) : sb) de g 221 | Hole -> weeg xs z ((nom, TP (nom, Hide (rfold e4p sb ty))) : sb) de g 222 | User x -> case partition (x ==) xs of 223 | ([], _) -> do 224 | yn <- fresh x 225 | weeg xs z ((nom, TP (yn, Hide (rfold e4p sb ty))) : sb) de g 226 | (_, xs) -> hnf (rfold e4p sb ty) >>= \ ty -> case ty of 227 | TC d ss -> do 228 | cope (isDataType d) (\ _ -> gripe $ NotADataType ty) return 229 | yn <- fresh x 230 | weeg xs z ((nom, TP (yn, Hide (Sized ty z (Weer Big)))) : sb) de g 231 | _ -> gripe $ NotADataType ty 232 | weeg xs z sb (_ : de) g = weeg xs z sb de g 233 | 234 | bigg :: [String] -- inductively what? 235 | -> Tm -- size zone 236 | -> [(Nom, Syn)] -- substitution 237 | -> [CxE] -- quantifier prefix 238 | -> Tm -- goal 239 | -> AM Tm -- induction conclusion 240 | bigg xs z sb [] g = case xs of 241 | x : _ -> gripe $ Scope x 242 | [] -> return $ rfold e4p sb g 243 | bigg xs z sb (Bind (nom, Hide ty) k : de) g = case k of 244 | Defn tm -> bigg xs z ((nom, rfold e4p sb (tm ::: ty)) : sb) de g 245 | Hole -> do 246 | let xp = (nom, Hide (rfold e4p sb ty)) 247 | push $ Bind xp Hole 248 | bigg xs z ((nom, TP xp) : sb) de g 249 | User x -> case partition (x ==) xs of 250 | ([], _) -> do 251 | let xp = (nom, Hide (rfold e4p sb ty)) 252 | push $ Bind xp (User x) 253 | bigg xs z ((nom, TP xp) : sb) de g 254 | (_, xs) -> hnf (rfold e4p sb ty) >>= \ ty -> case ty of 255 | TC d ss -> do 256 | cope (isDataType d) (\ _ -> gripe $ NotADataType ty) return 257 | let xp = (nom, Hide (Sized (rfold e4p sb ty) z Big)) 258 | push $ Bind xp (User x) 259 | bigg xs z ((nom, TP xp) : sb) de g 260 | _ -> gripe $ NotADataType ty 261 | bigg xs z sb (_ : de) g = bigg xs z sb de g 262 | -------------------------------------------------------------------------------- /lib/Language/Ask/Proving.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ---------- ---------- 3 | ---------- Proving ---------- 4 | ---------- ---------- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE 8 | LambdaCase 9 | #-} 10 | 11 | module Language.Ask.Proving where 12 | 13 | import Data.Foldable 14 | import Data.Traversable 15 | 16 | import Language.Ask.Thin 17 | import Language.Ask.Hide 18 | import Language.Ask.Bwd 19 | import Language.Ask.Lexing 20 | import Language.Ask.RawAsk 21 | import Language.Ask.Tm 22 | import Language.Ask.Glueing 23 | import Language.Ask.Context 24 | import Language.Ask.Typing 25 | 26 | import Debug.Trace 27 | 28 | trice = const id 29 | 30 | by :: Tm -> Appl -> AM TmR 31 | by goal a@(_, (t, _, r) :$$ ss) | elem t [Uid, Sym] = do 32 | subses <- fold <$> (gamma >>= traverse backchain) 33 | case subses of 34 | [(tel, subs)] -> do 35 | (t, m) <- elabVec EXP r tel ss 36 | mapM_ fred (stan m subs) 37 | return $ Our t a 38 | [] -> gripe $ ByBadRule r goal 39 | _ -> gripe $ ByAmbiguous r goal 40 | where 41 | backchain :: CxE -> AM [(Tel, [Subgoal])] -- list of successes 42 | backchain (ByRule _ ((gop, (h, tel)) :<= prems)) 43 | | h == r = 44 | cope (do 45 | m <- maAM (gop, goal) 46 | return [(stan m tel, stan m prems)]) 47 | (\ _ -> return []) 48 | return 49 | backchain _ = return [] 50 | by goal r = gripe $ NotARule r 51 | 52 | invert :: Tm -> AM [([CxE], [Subgoal])] 53 | invert hyp = fold <$> (gamma >>= traverse try ) 54 | where 55 | try :: CxE -> AM [([CxE], [Subgoal])] 56 | try (ByRule True ((gop, (h, tel)) :<= prems)) = do 57 | doorStop 58 | m <- prayTel [] tel 59 | True <- trice ("INVERT TRIES: " ++ show ((hyp, gop), (h, tel), prems)) $ return True 60 | gingerly m Prop gop hyp >>= \case 61 | [(_, m)] -> do 62 | let prems' = stan m prems 63 | de <- doorStep 64 | True <- trice ("INVERT: " ++ show m ++ " ===> " ++ 65 | show (de, prems')) $ return True 66 | return [(de, prems')] 67 | _ -> doorStep *> return [] 68 | try _ = return [] 69 | 70 | prayTel :: Matching -> Tel -> AM Matching 71 | prayTel m (Pr hs) = do 72 | for (stan m hs) $ \ h -> push $ Hyp True h 73 | return m 74 | prayTel m (Ex s b) = do 75 | xn <- fresh "x" 76 | let u = "x" ++ show (snd (last xn)) -- BOO! 77 | let xp = (xn, Hide (stan m s)) 78 | push $ Bind xp (User u) 79 | prayTel m (b // TP xp) 80 | prayTel m ((x, s) :*: t) = do 81 | xn <- fresh x 82 | let u = x ++ show (snd (last xn)) -- BOO! 83 | let xp = (xn, Hide (stan m s)) 84 | push $ Bind xp (User u) 85 | prayTel ((x, TE (TP xp)) : m) t 86 | 87 | prayPat :: Matching -> Tm -> Pat -> AM (Syn, Matching) 88 | prayPat m ty (PC c ps) = do 89 | ty <- hnf $ stan m ty 90 | tel <- constructor PAT ty c 91 | (ts, m) <- prayPats m tel ps 92 | return (TC c ts ::: ty, m) 93 | prayPat m ty (PM x _) = do 94 | xn <- fresh x 95 | let u = "x" ++ show (snd (last xn)) -- BOO! 96 | let xp = (xn, Hide (stan m ty)) 97 | push $ Bind xp (User u) 98 | return (TP xp, (x, TE (TP xp)) : m) 99 | 100 | prayPats :: Matching -> Tel -> [Pat] -> AM ([Tm], Matching) 101 | prayPats m (Pr hs) [] = do 102 | for (stan m hs) $ \ h -> push $ Hyp True h 103 | return ([], m) 104 | prayPats m (Ex s b) (p : ps) = do 105 | (e, m) <- prayPat m s p 106 | (ts, m) <- prayPats m (b // e) ps 107 | return (upTE e : ts, m) 108 | prayPats m ((x, s) :*: tel) (p : ps) = do 109 | (e, m) <- prayPat m s p 110 | (ts, m) <- prayPats ((x, upTE e) : m) tel ps 111 | return (upTE e : ts, m) 112 | prayPats _ _ _ = gripe Mardiness 113 | 114 | gingerly :: Matching -> Tm -> Pat -> Tm -> AM [(Syn, Matching)] 115 | gingerly m ty p@(PC gc ps) t = hnf t >>= \case 116 | TC hc ts | gc /= hc -> return [] | otherwise -> do 117 | let ty' = stan m ty 118 | tel <- constructor PAT ty' gc 119 | gingerlies m tel ps ts >>= \case 120 | [(us, m)] -> return [(TC gc us ::: ty', m)] 121 | _ -> return [] 122 | t -> do 123 | let ty' = case t of 124 | TE (TP (_, Hide ty)) -> ty -- would like a size if it's there 125 | _ -> ty 126 | (e, m) <- prayPat m ty' p 127 | push . Hyp True $ TC "=" [ty', t, upTE e] 128 | return [(e, m)] 129 | gingerly m ty (PM x th) t = case trice ("GINGERLY PM: " ++ x) $ thicken th t of 130 | Nothing -> return [] 131 | Just u -> return [(t ::: stan m ty, (x, u) : m)] 132 | gingerly _ _ _ _ = gripe Mardiness 133 | 134 | 135 | gingerlies :: Matching -> Tel -> [Pat] -> [Tm] -> AM [([Tm], Matching)] 136 | gingerlies m (Pr hs) [] [] = do 137 | for (stan m hs) $ \ h -> push $ Hyp True h 138 | return [([], m)] 139 | gingerlies m (Ex s b) (p : ps) (t : ts) = gingerly m s p t >>= \case 140 | [(e, m)] -> gingerlies m (b // e) ps ts >>= \case 141 | [(us, m)] -> return [(upTE e : us, m)] 142 | _ -> return [] 143 | _ -> return [] 144 | gingerlies m ((x, s) :*: tel) (p : ps) (t : ts) = gingerly m s p t >>= \case 145 | [(e, m)] -> let u = upTE e in 146 | gingerlies ((x, u) : m) tel ps ts >>= \case 147 | [(us, m)] -> return [(u : us, m)] 148 | _ -> return [] 149 | _ -> return [] 150 | gingerlies _ _ _ _ = return [] 151 | 152 | given :: Tm -> AM Bool{-proven?-} 153 | given goal = do 154 | ga <- gamma 155 | True <- trice ("GIVEN: " ++ show goal ++ " from?\n" ++ 156 | show (filter (\case {Bind _ _ -> True; Hyp _ _ -> True; _ -> False}) 157 | (ga <>> []))) 158 | $ return True 159 | go ga 160 | where 161 | go B0 = gripe $ NotGiven goal 162 | go (ga :< Hyp b hyp) = cope (hy False) 163 | (\ _ -> cope (hy True) (\gr -> go ga) return) return 164 | where -- this is ghastly 165 | hy heh = do 166 | True <- trice ("TRYING " ++ show hyp) $ return True 167 | doorStop 168 | smegUp hyp 169 | cope (unify' heh (TC "Prop" []) hyp goal) 170 | (\ gr -> trice "OOPS" $ gripe gr) 171 | return 172 | doorStep 173 | True <- trice "BINGO" $ return True 174 | return b 175 | go (ga :< _) = go ga 176 | 177 | 178 | smegUp :: Tm -> AM () 179 | smegUp (TE e) = smegDown e 180 | smegUp (TC _ hs) = () <$ traverse smegUp hs 181 | smegUp (TB (L t)) = smegUp t 182 | smegUp (TB (K t)) = smegUp t 183 | smegUp _ = return () 184 | 185 | smegDown :: Syn -> AM () 186 | smegDown (TP xp@(x, Hide ty)) = 187 | cope (nomBKind x) 188 | (\ _ -> do 189 | ty <- hnf ty 190 | push $ Bind xp Hole 191 | True <- trice ("GUESS: " ++ show x ++ " " ++ show ty) $ return True 192 | return ()) 193 | (\ _ -> return ()) 194 | smegDown (tm ::: ty) = smegUp tm >> smegUp ty 195 | smegDown (f :$ s) = smegDown f >> smegUp s 196 | smegDown (TF _ as bs) = traverse smegUp as >> traverse smegUp bs >> return () 197 | smegDown _ = return () 198 | 199 | (|-) :: Tm -> AM x -> AM x 200 | h |- p = do 201 | h <- normAQTy h 202 | push (Hyp True h) 203 | x <- p 204 | pop $ \case 205 | Hyp _ _ -> True 206 | _ -> False 207 | return x 208 | 209 | splitProof 210 | :: (Nom, Hide Tm) -- thing to split 211 | -> Tm -- its type 212 | -> Tm -- goal 213 | -> (Con, Tel) -- a candidate constructor and its telescope 214 | -> AM () -- generate relevant demands 215 | splitProof xp@(xn, _) ty goal (c, tel) = quan B0 tel >>= demand 216 | where 217 | quan :: Bwd Tm -> Tel -> AM Subgoal 218 | quan sz (Ex s b) = 219 | ("", s) |:- \ e@(TP (yn, _)) -> 220 | (EVERY s . (yn \\)) <$> quan (sz :< TE e) (b // e) 221 | quan sz ((y, s) :*: tel) = 222 | (y, s) |:- \ e@(TP (yn, _)) -> 223 | (EVERY s . (yn \\)) <$> quan (sz :< TE e) (stan [(y, TE e)] tel) 224 | quan sz (Pr hs) = let tm = TC c (sz <>> []) in 225 | return $ foldr GIVEN 226 | (GIVEN (TC "=" [ty, TE (TP xp), tm]) $ 227 | PROVE ((xn \\ goal) // (tm ::: ty))) 228 | hs 229 | 230 | under :: Tm -> Tm -> Appl -> AM () 231 | under (TE lhs) (TE rhs) (_, (_, _, h) :$$ []) = () <$ go lhs rhs where 232 | go (e :$ a) (f :$ b) = do 233 | ty <- go e f 234 | hnf ty >>= \case 235 | TC "->" [dom, ran] -> do 236 | fred . PROVE $ TC "=" [dom, a, b] 237 | return ran 238 | _ -> gripe FAIL 239 | go (TP (xn, Hide ty)) (TP (yn, _)) | xn == yn = nomBKind xn >>= \case 240 | User k | k == h -> return ty 241 | _ -> gripe FAIL 242 | go (TF (f, Hide sch) as bs) (TF (g, _) cs ds) 243 | | fst (last f) == h && fst (last g) == h 244 | = mo sch as bs cs ds 245 | go _ _ = gripe FAIL 246 | mo (Al s t) (a : as) bs (c : cs) ds = do 247 | equal s (a, c) 248 | mo (t // (a ::: s)) as bs cs ds 249 | mo (iss :>> t) [] bs [] ds = so [] iss bs ds where 250 | so m [] [] [] = return $ stan m t 251 | so m ((x, s) : ss) (b : bs) (d : ds) = do 252 | fred . PROVE $ TC "=" [stan m t, b, d] 253 | so ((x, b) : m) ss bs ds 254 | so _ _ _ _ = gripe FAIL 255 | mo _ _ _ _ _ = gripe FAIL 256 | under _ _ f = gripe FAIL 257 | -------------------------------------------------------------------------------- /lib/Language/Ask/RawAsk.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ---------- ---------- 3 | ---------- RawAsk ---------- 4 | ---------- ---------- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE 8 | DeriveFunctor 9 | , FlexibleInstances 10 | , TupleSections 11 | , LambdaCase 12 | #-} 13 | 14 | module Language.Ask.RawAsk where 15 | 16 | import Language.Ask.OddEven 17 | import Language.Ask.Lexing 18 | import Language.Ask.Parsing 19 | import Language.Ask.Tm 20 | 21 | import qualified Data.Map as M 22 | import Control.Applicative 23 | import Control.Monad 24 | 25 | 26 | ------------------------------------------------------------------------------ 27 | -- Raw Syntax Datatypes 28 | ------------------------------------------------------------------------------ 29 | 30 | data RawDecl 31 | = RawHeeHaw 32 | | RawModule String 33 | | RawSewage 34 | | RawFixity FixityTable 35 | | RawProp Appl (Bloc RawIntro) 36 | | RawData Appl [Appl] 37 | | RawSig Appl Appl 38 | | RawTest Appl (Maybe Appl) 39 | | RawProof (Make () Appl) 40 | | RawGrammar Con [[GramBit]] 41 | | RawParse (Make () ParseThing) 42 | deriving Show 43 | 44 | data RawIntro 45 | = RawIntro 46 | { introPats :: [Appl] 47 | , rulePat :: Appl 48 | , rulePrems :: Bloc ([Appl], Appl) 49 | } deriving Show 50 | 51 | data Make a t 52 | = Make 53 | { making :: Making 54 | , goal :: t 55 | , method :: Method t 56 | , annotation :: a 57 | , subproofs :: Bloc (SubMake a t) 58 | , source :: ([LexL], [LexL]) 59 | } 60 | deriving (Functor) 61 | 62 | data SubMake a t 63 | = ([LexL], ([(Nom, String)], [Given t])) ::- Make a t 64 | | SubPGuff [LexL] 65 | deriving (Functor) 66 | 67 | data Making = Prf | Def | Pse deriving Eq 68 | instance Show Making where 69 | show Prf = "prove" 70 | show Def = "define" 71 | show Pse = "parse" 72 | done :: Making -> Bool -> String 73 | done m False = show m 74 | done m True = show m ++ case m of {Prf -> "n"; _ -> "d"} 75 | 76 | data Method t 77 | = Stub Bool -- is there a "?" ? 78 | | By t 79 | | From t 80 | | MGiven 81 | | Is t 82 | | Ind [String] 83 | | Tested Bool -- ed? 84 | | Under t 85 | deriving (Show, Functor) 86 | 87 | data Given t 88 | = Given t 89 | deriving (Show, Functor) 90 | 91 | data Assocy = LAsso | NAsso | RAsso deriving (Show, Eq) 92 | type FixityTable = M.Map String (Int, Assocy) 93 | 94 | data GramBit = Terminal String | NonTerminal Con deriving (Show, Eq) 95 | 96 | data ParseThing 97 | = ParseProb Con (Maybe String) 98 | | ParseProd [GramBit] 99 | deriving Show 100 | 101 | 102 | ------------------------------------------------------------------------------ 103 | -- Show instances which hide 104 | ------------------------------------------------------------------------------ 105 | 106 | instance (Show a, Show t) => Show (Make a t) where 107 | show p = concat 108 | [ show (making p), " " 109 | , show (goal p), " " 110 | , show (method p), " " 111 | , show (annotation p), "\n" 112 | , show (subproofs p) 113 | ] 114 | 115 | instance (Show a, Show t) => Show (SubMake a t) where 116 | show ((_, gs) ::- p) = show gs ++ " |- " ++ show p 117 | show (SubPGuff ls) = "SubPGuff " ++ show ls 118 | 119 | 120 | ------------------------------------------------------------------------------ 121 | -- Lex and Parse 122 | ------------------------------------------------------------------------------ 123 | 124 | raw :: FixityTable -> String -> (FixityTable, Bloc (RawDecl, [LexL])) 125 | raw fi input = (fo, fmap grok ls) where 126 | ls = lexAll input 127 | ft = newFixities ls 128 | fo = fi <> ft 129 | grok l = case parTok pDecl fo l of 130 | [(_, x, [])] -> (x, l) 131 | _ -> (RawSewage, l) 132 | 133 | type PF = ParTok FixityTable 134 | 135 | pDecl :: PF RawDecl 136 | pDecl = good <* eol where 137 | good = RawHeeHaw <$ spc 138 | <|> RawModule <$ the Key "module" <*> spd (txt <$> kinda Uid) 139 | <* lol "where" (pure ()) 140 | <|> RawFixity <$> (((,) <$> penv <*> mkFixity) >>= agree) 141 | <|> uncurry RawProp <$ the Key "prop" <*> pProp 142 | <|> uncurry RawData <$ the Key "data" <*> pData 143 | <|> uncurry RawGrammar <$ the Key "grammar" <*> pGrammar 144 | <|> RawSig <$> pAppl ["::", "="] <* spd (the Sym "::") <*> pAppl [] 145 | <|> RawTest <$ (the Key "test" <|> the Key "tested") <* spc 146 | <*> pAppl ["="] <*> 147 | (Just <$ spd (the Sym "=") <*> pAppl [] <|> pure Nothing) 148 | <|> RawProof <$> pMake pGoal (pAppl []) 149 | <|> RawParse <$> pMake pParseProb pParseProd 150 | agree (ft, at) = at <$ guard (all id $ M.intersectionWith (==) at ft) 151 | 152 | pProp :: PF (Appl, Bloc RawIntro) 153 | pProp = do 154 | r@(_, h :$$ _) <- spd (pAppl []) 155 | is <- lol "where" (pIntro h) <|> pure ([] :-/ Stop) 156 | return (r, is) 157 | 158 | pIntro :: LexL -> PF RawIntro 159 | pIntro h = do 160 | the Key "prove" 161 | (_, g :$$ xs) <- spd (pAppl []) 162 | guard (txt h == txt g) 163 | the Key "by" 164 | r <- spd (pAppl []) 165 | ps <- lol "where" 166 | ((,) <$> (id <$ the Key "given" <* spc <*> sep (pAppl []) (spd (the Sym ",")) 167 | <* spc 168 | <|> pure []) <* 169 | the Key "prove" <* spc <*> pAppl []) 170 | <|> ([] :-/ Stop) <$ spc 171 | return $ RawIntro 172 | { introPats = xs, rulePat = r, rulePrems = ps } 173 | 174 | pData :: PF (Appl, [Appl]) 175 | pData = (,) <$ spc <*> pAppl ["="] <* spd (the Sym "=") <*> sep (pAppl ["|"]) (spd (the Sym "|")) 176 | 177 | pMaking :: PF Making 178 | pMaking = Prf <$ (the Key "prove" <|> the Key "proven") 179 | <|> Def <$ (the Key "define" <|> the Key "defined") 180 | <|> Pse <$ (the Key "parse" <|> the Key "parsed") 181 | 182 | pGoal :: Making -> PF Appl 183 | pGoal Def = pAppl ["="] 184 | pGoal Prf = pAppl [] 185 | pGoal Pse = empty 186 | 187 | pParseProb :: Making -> PF ParseThing 188 | pParseProb Pse 189 | = ParseProb <$> pNonTerminal <*> (Just <$ spc <*> (txt <$> kinda Str) <|> pure Nothing) 190 | pParseProb _ = empty 191 | 192 | pProduction :: PF [GramBit] 193 | pProduction = concat <$> sep pGramBit spc 194 | 195 | pParseProd :: PF ParseThing 196 | pParseProd = ParseProd <$> pProduction 197 | 198 | pMake :: (Making -> PF a) -> PF a -> PF (Make () a) 199 | pMake pg px = do 200 | (top, (mk, go, me)) <- ext $ do 201 | mk <- pMaking 202 | spc 203 | go <- pg mk 204 | spc 205 | me <- pMethod mk 206 | return (mk, go, me) 207 | (body, ps) <- ext (id <$ spc <*> pSubs) 208 | return $ Make 209 | { making = mk 210 | , goal = go 211 | , method = me 212 | , annotation = () 213 | , subproofs = ps 214 | , source = (top, body) 215 | } 216 | where 217 | pMethod mk 218 | = Stub <$> ((True <$ the Sym "?") ?> (False <$ pure ())) 219 | <|> From <$ the Key "from" <* guard (mk /= Pse) <* spc <*> px 220 | <|> By <$ the Key "by" <* spc <*> px 221 | <|> MGiven <$ the Key "given" 222 | <|> Is <$ guard (mk == Def) <* the Sym "=" <* spc <*> px 223 | <|> Ind <$ the Key "inductively" <* guard (mk /= Pse) <* spc <*> 224 | sep (txt <$> kinda Lid) (spd (the Sym ",")) 225 | <|> Tested <$> (False <$ the Key "test" <|> True <$ the Key "tested") 226 | <* guard (mk /= Pse) 227 | <|> Under <$ the Key "under" <* guard (mk /= Pse) <* spc <*> px 228 | pSubs = lol "where" pSub <|> pure ([] :-/ Stop) 229 | pSub = ((::-) <$> ext (([] ,) <$> pGivens <* spc) <*> pMake pg px <* spc <* eol) 230 | ?> ((SubPGuff . fst) <$> ext (many (eat Just) <* eol)) 231 | pGivens 232 | = id <$ the Key "given" <* spc <*> sep (Given <$> px) (spd (the Sym ",")) 233 | <|> pure [] 234 | 235 | newFixities :: Bloc [LexL] -> FixityTable 236 | newFixities = foldMap (glom . parTok mkFixity mempty) where 237 | glom [(_,t,_)] = t 238 | glom _ = M.empty 239 | 240 | mkFixity :: PF FixityTable 241 | mkFixity = actual ?> pure M.empty where 242 | actual = mkTable <$> 243 | (LAsso <$ the Key "infixl" 244 | <|> NAsso <$ the Key "infix" 245 | <|> RAsso <$ the Key "infixr") 246 | <*> spd (eat fixl <|> pure 9) 247 | <*> ((:) <$> spd oppo <*> many (id <$ the Sym "," <*> spd oppo)) 248 | <* eol 249 | fixl :: LexL -> Maybe Int 250 | fixl (Num, _, s) = case read s of 251 | l | 0 <= l && l <= 9 -> Just l 252 | _ -> Nothing 253 | fixl _ = Nothing 254 | oppo :: PF String 255 | oppo = id <$ the Sym "`" <*> eat lust <* the Sym "`" 256 | <|> eat sop 257 | lust :: LexL -> Maybe String 258 | lust (Uid, _, s) = Just s 259 | lust (Lid, _, s) = Just s 260 | lust _ = Nothing 261 | sop :: LexL -> Maybe String 262 | sop (Sym, _, s) | not (s `elem` ["`",","]) = Just s 263 | sop _ = Nothing 264 | mkTable :: Assocy -> Int -> [String] -> FixityTable 265 | mkTable a i xs = M.fromList [(x, (i, a)) | x <- xs] 266 | 267 | type Appl = ([LexL], Appl') 268 | data Appl' = LexL :$$ [Appl] 269 | 270 | instance Show Appl' where 271 | show ((_,_,f) :$$ las) = f ++ show (map snd las) 272 | 273 | ($$) :: Appl' -> [Appl] -> Appl' 274 | (h :$$ as) $$ bs = h :$$ (as ++ bs) 275 | 276 | instance MDep Appl where 277 | mDep x (_, (_, _, y) :$$ as) = x == y || any (mDep x) as 278 | 279 | -- FIXME: support tuples but not by treating comma as infix 280 | pAppl :: [String] -- , and ` are already not allowed to be infix 281 | -- but sometimeswe have other *top-level* exceptions 282 | -- e.g., in data decls 283 | -> PF Appl 284 | pAppl nae = ext $ pAppl' nae 285 | pAppl' :: [String] -> PF Appl' 286 | pAppl' nae = penv >>= gimme where 287 | gimme ftab = go nae where 288 | go :: [String] -> PF Appl' 289 | go nae = start nae (-1, NAsso) 290 | fixity :: LexL -> (Int, Assocy) 291 | fixity (_, _, s) = case M.lookup s ftab of 292 | Nothing -> (9, LAsso) 293 | Just f -> f 294 | start :: [String] -> (Int, Assocy) -> PF Appl' 295 | start nae f = (ext $ (($$) <$> wee nae <*> many (id <$ spc <*> ext (wee nae)))) 296 | >>= more nae f (maxBound, NAsso) 297 | wee :: [String] -> PF Appl' 298 | wee nae = (:$$ []) <$> 299 | (kinda Uid <|> kinda Lid <|> 300 | kinda Num <|> kinda Str <|> kinda Chr <|> 301 | brk '(' (spd (iop []))) 302 | <|> tup <$> ext (brk '(' (sep (ext (go [])) (spd (the Sym ",")))) 303 | iop :: [String] -> PF LexL 304 | iop nae = (kinda Sym >>= \ l@(_, _, s) -> guard (not $ elem s (nae ++ ["`", ","])) >> return l) 305 | <|> id <$ the Sym "`" <*> (kinda Uid <|> kinda Lid) <* the Sym "`" 306 | more :: [String] 307 | -> (Int, Assocy) -- working to the right of this 308 | -> (Int, Assocy) -- we've got this 309 | -> Appl 310 | -> PF Appl' 311 | more nae (i, a) (j, b) (ls, e) = (<|> pure e) $ do 312 | (rs, (kc, e)) <- ext $ do 313 | spc 314 | o <- iop nae 315 | let (k, c) = fixity o 316 | guard (k > i || k == i && a == RAsso && c == RAsso) 317 | guard (k < j || k == j && b == LAsso && c == LAsso) 318 | spc 319 | f <- ext $ start nae (k, c) 320 | return ((k, c), o :$$ [(ls, e), f]) 321 | more nae (i, a) kc (ls ++ rs, e) 322 | tup :: ([LexL], [Appl]) -> Appl' 323 | tup (_, [(_, x)]) = x 324 | tup (ls, las) = (Uid, ptup ls, stup (length las)) :$$ las where 325 | stup 0 = "()" 326 | stup n = "(" ++ replicate (n - 1) ',' ++ ")" 327 | ptup ((_, p, _) : _) = p 328 | ptup [] = (0, 0) -- but this should never happen, right? 329 | 330 | pGrammar :: PF (String, [[GramBit]]) 331 | pGrammar = (,) <$ spc <*> pNonTerminal 332 | <* spc <* (the Sym "::=" <|> the Sym "=") <* spc 333 | <*> sep pProduction (spd (the Sym "|")) 334 | 335 | pNonTerminal :: PF String 336 | pNonTerminal = id <$ the Sym "<" <*> (txt <$> kinda Uid) <* the Sym ">" 337 | 338 | pGramBit :: PF [GramBit] 339 | pGramBit = ((:[]) . Terminal . txt) <$> eat like 340 | <|> ((:[]) . NonTerminal) <$> pNonTerminal 341 | <|> brk '(' (round <$> pGramBit) 342 | <|> brk '[' (squar <$> pGramBit) 343 | <|> brk '{' (curly <$> pGramBit) 344 | where 345 | like t 346 | | txt t == "<" = Nothing 347 | | txt t == "|" = Nothing 348 | | gappy t = Nothing 349 | | islay t = Nothing 350 | | otherwise = Just t 351 | round ss = [Terminal "("] ++ ss ++ [Terminal ")"] 352 | squar ss = [Terminal "["] ++ ss ++ [Terminal "]"] 353 | curly ss = [Terminal "{"] ++ ss ++ [Terminal "}"] -------------------------------------------------------------------------------- /lib/Language/Ask/Thin.hs: -------------------------------------------------------------------------------- 1 | module Language.Ask.Thin where 2 | 3 | import Data.Bits 4 | 5 | newtype Thinning = Th Integer deriving Eq 6 | 7 | instance Show Thinning where 8 | show (Th th) = go th where 9 | go 0 = "...0" 10 | go (-1) = "...1" 11 | go th = case unsnocBit th of 12 | (th, b) -> go th ++ if b then "1" else "0" 13 | 14 | os :: Thinning -> Thinning 15 | os (Th th) = Th (snocBit th True) 16 | 17 | o' :: Thinning -> Thinning 18 | o' (Th th) = Th (snocBit th False) 19 | 20 | snocBit :: Bits a => a -> Bool -> a 21 | snocBit bs True = shiftL bs 1 .|. (bit 0) 22 | snocBit bs False = shiftL bs 1 23 | 24 | unsnocBit :: Bits a => a -> (a, Bool) 25 | unsnocBit bs = (shiftR bs 1, testBit bs 0) 26 | 27 | instance Semigroup Thinning where 28 | (<>) = mappend 29 | 30 | instance Monoid Thinning where 31 | mempty = Th (-1) 32 | Th th `mappend` Th ph = Th (go th ph) where 33 | go th 0 = 0 34 | go th (-1) = th 35 | go th ph = case unsnocBit ph of 36 | (ph, False) -> snocBit (go th ph) False 37 | (ph, True) -> case unsnocBit th of 38 | (th, b) -> snocBit (go th ph) b 39 | 40 | class Thin t where 41 | (<^>) :: t -> Thinning -> t 42 | thicken :: Thinning -> t -> Maybe t 43 | 44 | instance Thin Int where 45 | i <^> Th th = case (th `mod` 2, th `div` 2) of 46 | (0, th) -> 1 + (i <^> Th th) 47 | (1, th) -> case i of 48 | 0 -> 0 49 | _ -> 1 + ((i - 1) <^> Th th) 50 | thicken (Th th) i = go th i where 51 | go 0 i = Nothing 52 | go (-1) i = Just i 53 | go th i = case (unsnocBit th, i) of 54 | ((th, False), 0) -> Nothing 55 | ((th, False), i) -> go th (i-1) 56 | ((th, True), 0) -> Just 0 57 | ((th, True), i) -> (1+) <$> go th (i-1) 58 | 59 | -------------------------------------------------------------------------------- /lib/Language/Ask/Tm.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ---------- ---------- 3 | ---------- Tm ---------- 4 | ---------- ---------- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE 8 | TupleSections 9 | , DeriveTraversable 10 | , TypeSynonymInstances 11 | , FlexibleInstances 12 | , PatternSynonyms 13 | #-} 14 | 15 | module Language.Ask.Tm where 16 | 17 | import Data.Bits 18 | import Data.List hiding ((\\)) 19 | import Control.Applicative 20 | import Control.Arrow ((***)) 21 | import Data.Monoid 22 | import Control.Monad.Writer 23 | 24 | import Language.Ask.Bwd 25 | import Language.Ask.Thin 26 | import Language.Ask.HalfZip 27 | import Language.Ask.Hide 28 | 29 | 30 | ------------------------------------------------------------------------------ 31 | -- Representation of Terms 32 | ------------------------------------------------------------------------------ 33 | 34 | type Tm = Chk Syn 35 | 36 | data Chk s 37 | = TM String [s] -- metavariable instantiation 38 | | TC Con [Chk s] -- canonical form 39 | | TB (Bind (Chk s)) -- binding form 40 | | TE s -- other stuff 41 | deriving (Eq, Show, Functor, Foldable, Traversable) 42 | 43 | data Syn 44 | = TV Int -- de Bruijn index 45 | | TP (Nom, Hide Tm) -- named var, with cached type 46 | | TF (Nom, Hide Sch) [Tm] [Tm] -- declared function, saturated for its scheme 47 | | Tm ::: Tm -- radical 48 | | Syn :$ Tm -- elimination 49 | deriving (Show, Eq) 50 | 51 | data Bind b 52 | = K{-onstant-} b 53 | | L{-ambda-} b 54 | deriving (Eq, Show, Functor, Foldable, Traversable) 55 | 56 | type Con = String -- canonical constructors get to be plain names 57 | -- these are a few of our favourite things 58 | pattern Type = TC "Type" [] 59 | pattern Prop = TC "Prop" [] 60 | pattern TRUE = TC "True" [] 61 | pattern FALSE = TC "False" [] 62 | pattern (:->) s t = TC "->" [s, t] 63 | pattern Zone = TC "$$" [] -- a type which gets hypothetically inhabited 64 | pattern Sized t z i = TC "$" [t, z, i] 65 | pattern Weer i = TC "S" [i] 66 | pattern Big = TC "Z" [] 67 | 68 | 69 | type Nom = [(String, Int)] -- names for parameters are chosen by the system 70 | 71 | 72 | ------------------------------------------------------------------------------ 73 | -- Subterm Checking 74 | ------------------------------------------------------------------------------ 75 | 76 | class SubTm t where 77 | subTm :: Tm -> t -> Bool 78 | 79 | instance SubTm Tm where 80 | subTm s t | s == t = True 81 | subTm s (TM _ ss) = subTm s ss 82 | subTm s (TC _ ts) = subTm s ts 83 | subTm s (TB b) = subTm s b 84 | subTm s (TE e) = subTm s e 85 | 86 | instance SubTm Syn where 87 | subTm s (tm ::: ty) = subTm s tm || subTm s ty 88 | subTm s (e :$ t) = subTm s e || subTm s t 89 | subTm _ _ = False 90 | 91 | instance SubTm t => SubTm [t] where 92 | subTm = any . subTm 93 | 94 | instance SubTm t => SubTm (Bind t) where 95 | subTm s (K b) = subTm s b 96 | subTm s (L b) = subTm (s <^> o' mempty) b 97 | 98 | 99 | 100 | 101 | ------------------------------------------------------------------------------ 102 | -- Patterns 103 | ------------------------------------------------------------------------------ 104 | 105 | data Pat 106 | = PM String Thinning -- metavariable binding site 107 | | PC Con [Pat] -- canonical pattern 108 | | PB Pat -- binding pattern 109 | deriving (Show, Eq) 110 | 111 | 112 | ------------------------------------------------------------------------------ 113 | -- Telescopes, used to give types for constructor argument vectors 114 | ------------------------------------------------------------------------------ 115 | 116 | data Tel 117 | = Ex Tm (Bind Tel) -- implicit existential 118 | | (String, Tm) :*: Tel -- named explicit fields 119 | | Pr [Tm] -- proof obligations 120 | deriving Show 121 | infixr 6 :*: 122 | 123 | 124 | ------------------------------------------------------------------------------ 125 | -- Type Schemes 126 | ------------------------------------------------------------------------------ 127 | 128 | data Sch 129 | = Al Tm (Bind Sch) 130 | | [(String, Tm)] :>> Tm 131 | deriving Show 132 | 133 | 134 | ------------------------------------------------------------------------------ 135 | -- Subgoals 136 | ------------------------------------------------------------------------------ 137 | 138 | data Subgoal 139 | = PROVE Tm -- of type Prop 140 | | GIVEN Tm Subgoal -- the hyp is a Prop 141 | | EVERY Tm (Bind Subgoal) -- universal quantifier 142 | -- more to follow, no doubt 143 | deriving Show 144 | 145 | 146 | ------------------------------------------------------------------------------ 147 | -- Thin all the Things 148 | ------------------------------------------------------------------------------ 149 | 150 | instance Thin s => Thin (Chk s) where 151 | TM m ss <^> th = TM m (ss <^> th) 152 | TC c ts <^> th = TC c (ts <^> th) 153 | TB t <^> th = TB (t <^> th) 154 | TE s <^> th = TE (s <^> th) 155 | thicken th (TM m ss) = TM m <$> thicken th ss 156 | thicken th (TC c ts) = TC c <$> thicken th ts 157 | thicken th (TB t) = TB <$> thicken th t 158 | thicken th (TE s) = TE <$> thicken th s 159 | 160 | instance Thin Syn where 161 | TV i <^> th = TV (i <^> th) 162 | (t ::: _T) <^> th = (t <^> th) ::: (_T <^> th) 163 | (e :$ s) <^> th = (e <^> th) :$ (s <^> th) 164 | TP x <^> th = TP x 165 | TF f is as <^> th = TF f (is <^> th) (as <^> th) 166 | thicken th (TV i) = TV <$> thicken th i 167 | thicken th (t ::: _T) = (:::) <$> thicken th t <*> thicken th _T 168 | thicken th (e :$ s) = (:$) <$> thicken th e <*> thicken th s 169 | thicken th (TP x) = pure (TP x) 170 | thicken th (TF f is as) = TF f <$> thicken th is <*> thicken th as 171 | 172 | instance Thin s => Thin (Bind s) where 173 | K s <^> th = K (s <^> th) 174 | L s <^> th = L (s <^> os th) 175 | thicken th (K s) = K <$> thicken th s 176 | thicken th (L s) = L <$> thicken (os th) s 177 | 178 | instance Thin s => Thin [s] where 179 | ss <^> th = fmap (<^> th) ss 180 | thicken th ss = traverse (thicken th) ss 181 | 182 | instance Thin Tel where 183 | Ex s b <^> th = Ex (s <^> th) (b <^> th) 184 | ((x, s) :*: t) <^> th = (x, s <^> th) :*: (t <^> th) 185 | Pr p <^> th = Pr (p <^> th) 186 | thicken th (Ex s b) = Ex <$> thicken th s <*> thicken th b 187 | thicken th ((x, s) :*: t) = (:*:) <$> ((x,) <$> thicken th s) <*> thicken th t 188 | thicken th (Pr p) = Pr <$> thicken th p 189 | 190 | instance Thin Sch where 191 | Al s t <^> th = Al (s <^> th) (t <^> th) 192 | (ss :>> t) <^> th = map (id *** (<^> th)) ss :>> (t <^> th) 193 | thicken th (Al s t) = Al <$> thicken th s <*> thicken th t 194 | thicken th (ss :>> t) = (:>>) 195 | <$> traverse (\ (x, s) -> (x,) <$> thicken th s) ss 196 | <*> thicken th t 197 | 198 | instance Thin Subgoal where 199 | PROVE g <^> th = PROVE (g <^> th) 200 | GIVEN h g <^> th = GIVEN (h <^> th) (g <^> th) 201 | EVERY t b <^> th = EVERY (t <^> th) (b <^> th) 202 | thicken th (PROVE g) = PROVE <$> thicken th g 203 | thicken th (GIVEN h g) = GIVEN <$> thicken th h <*> thicken th g 204 | thicken th (EVERY t b) = EVERY <$> thicken th t <*> thicken th b 205 | 206 | instance Thin () where _ <^> _ = () ; thicken _ _ = Just () 207 | 208 | 209 | ------------------------------------------------------------------------------ 210 | -- Metavariable Matchings, instantiation, substitution 211 | ------------------------------------------------------------------------------ 212 | 213 | type Matching = [(String, Chk Syn)] 214 | 215 | class Stan t where 216 | stan :: Matching 217 | -> t -> t 218 | sbst :: Int -> [Syn] 219 | -> t -> t 220 | abst :: Nom -> Int 221 | -> t -> Writer Any t 222 | 223 | -- yer ordinary rhythm'n'blues, yer basic rock'n'roll 224 | (//) :: Stan t => Bind t -> Syn -> t 225 | K t // e = t 226 | L t // e = sbst 0 [e] t 227 | 228 | upTE :: Syn -> Tm 229 | upTE (t ::: _) = t 230 | upTE e = TE e 231 | 232 | (\\) :: Stan t => Nom -> t -> Bind t 233 | x \\ t = if getAny b then L t' else K t where 234 | (t', b) = runWriter (abst x 0 t) 235 | 236 | -- premature optimisation and all that, but this is ridiculous 237 | e4p :: Stan t => (Nom, Syn) -> t -> t 238 | e4p (p, e) t = (p \\ t) // e 239 | 240 | 241 | instance Stan s => Stan [s] where 242 | stan ms = fmap (stan ms) 243 | sbst u es = fmap (sbst u es) 244 | abst x i = traverse (abst x i) 245 | 246 | instance (Stan s, Stan t) => Stan (s, t) where 247 | stan ms = stan ms *** stan ms 248 | sbst u es = sbst u es *** sbst u es 249 | abst x i (s, t) = (,) <$> abst x i s <*> abst x i t 250 | 251 | instance Stan Syn where 252 | stan ms (t ::: _T) = stan ms t ::: stan ms _T 253 | stan ms (e :$ s) = stan ms e :$ stan ms s 254 | stan ms (TF f is as) = TF f (stan ms is) (stan ms as) 255 | stan ms e = e 256 | sbst u es (TV i) = sg !! i where 257 | sg = [TV i | i <- [0 .. (u - 1)]] 258 | ++ (es <^> Th (shiftL (-1) u)) ++ 259 | [TV i | i <- [u ..]] 260 | sbst u es (t ::: _T) = sbst u es t ::: sbst u es _T 261 | sbst u es (e :$ s) = sbst u es e :$ sbst u es s 262 | sbst u es (TF f is as) = TF f (sbst u es is) (sbst u es as) 263 | sbst u es e = e 264 | abst x i (TP (y, _)) | x == y = TV i <$ tell (Any True) 265 | abst x i (t ::: _T) = (:::) <$> abst x i t <*> abst x i _T 266 | abst x i (e :$ s) = (:$) <$> abst x i e <*> abst x i s 267 | abst x i (TF f is as) = TF f <$> abst x i is <*> abst x i as 268 | abst x i e = pure e 269 | 270 | instance Stan Tm where 271 | stan ms (TM m es) = case lookup m ms of 272 | Just t -> sbst 0 es' t 273 | Nothing -> TM m es' 274 | where 275 | es' = map (stan ms) es 276 | stan ms (TC c ts) = TC c (stan ms ts) 277 | stan ms (TB b) = TB (stan ms b) 278 | stan ms (TE e) = upTE (stan ms e) 279 | sbst u es (TM m es') = TM m (sbst u es es') 280 | sbst u es (TC c ts) = TC c (sbst u es ts) 281 | sbst u es (TB t) = TB (sbst u es t) 282 | sbst u es (TE e) = upTE (sbst u es e) 283 | abst x i (TM m es) = TM m <$> abst x i es 284 | abst x i (TC c ts) = TC c <$> abst x i ts 285 | abst x i (TB b) = TB <$> abst x i b 286 | abst x i (TE e) = TE <$> abst x i e 287 | 288 | instance Stan b => Stan (Bind b) where 289 | stan ms (K b) = K (stan ms b) 290 | stan ms (L b) = L (stan ms b) 291 | sbst u es (K b) = K (sbst u es b) 292 | sbst u es (L b) = L (sbst (u + 1) es b) 293 | abst x i (K b) = K <$> abst x i b 294 | abst x i (L b) = L <$> abst x (i + 1) b 295 | 296 | instance Stan Tel where 297 | stan ms (Ex s b) = Ex (stan ms s) (stan ms b) 298 | stan ms ((x, s) :*: t) = (x, stan ms s) :*: stan ms t 299 | stan ms (Pr p) = Pr (stan ms p) 300 | sbst u es (Ex s b) = Ex (sbst u es s) (sbst u es b) 301 | sbst u es ((x, s) :*: t) = (x, sbst u es s) :*: sbst u es t 302 | sbst u es (Pr p) = Pr (sbst u es p) 303 | abst x i (Pr p) = Pr <$> abst x i p 304 | abst x i (Ex s b) = Ex <$> abst x i s <*> abst x i b 305 | abst x i ((y, s) :*: t) = (:*:) <$> ((y,) <$> abst x i s) <*> abst x i t 306 | 307 | instance Stan Sch where 308 | stan ms (Al s t) = Al (stan ms s) (stan ms t) 309 | stan ms (ss :>> t) = map (id *** stan ms) ss :>> stan ms t 310 | sbst u es (Al s t) = Al (sbst u es s) (sbst u es t) 311 | sbst u es (ss :>> t) = map (id *** sbst u es) ss :>> sbst u es t 312 | abst x i (Al s t) = Al <$> abst x i s <*> abst x i t 313 | abst x i (ss :>> t) = (:>>) 314 | <$> traverse (\ (y, s) -> (y,) <$> abst x i s) ss 315 | <*> abst x i t 316 | 317 | instance Stan Subgoal where 318 | stan ms (PROVE g) = PROVE (stan ms g) 319 | stan ms (GIVEN h g) = GIVEN (stan ms h) (stan ms g) 320 | stan ms (EVERY t b) = EVERY (stan ms t) (stan ms b) 321 | sbst u es (PROVE g) = PROVE (sbst u es g) 322 | sbst u es (GIVEN h g) = GIVEN (sbst u es h) (sbst u es g) 323 | sbst u es (EVERY t b) = EVERY (sbst u es t) (sbst u es b) 324 | abst x i (PROVE g) = PROVE <$> abst x i g 325 | abst x i (GIVEN h g) = GIVEN <$> abst x i h <*> abst x i g 326 | abst x i (EVERY t b) = EVERY <$> abst x i t <*> abst x i b 327 | 328 | instance Stan () where stan _ _ = () ; sbst _ _ _ = () ; abst _ _ _ = pure () 329 | 330 | instance Stan t => Stan (Hide t) where 331 | stan ms (Hide t) = Hide (stan ms t) 332 | sbst u es (Hide t) = Hide (sbst u es t) 333 | abst x i (Hide t) = Hide <$> abst x i t 334 | 335 | 336 | ------------------------------------------------------------------------------ 337 | -- Metavariable dependency testing and topological insertion 338 | ------------------------------------------------------------------------------ 339 | 340 | class MDep t where 341 | mDep :: String -> t -> Bool 342 | 343 | instance MDep Tm where 344 | mDep x (TM m es) = m == x || mDep x es 345 | mDep x (TC _ ts) = mDep x ts 346 | mDep x (TB t) = mDep x t 347 | mDep x (TE e) = mDep x e 348 | 349 | instance MDep Syn where 350 | mDep x (t ::: ty) = mDep x t || mDep x ty 351 | mDep x (f :$ s) = mDep x f || mDep x s 352 | mDep x (TF _ is as) = mDep x is || mDep x as 353 | mDep x _ = False 354 | 355 | instance MDep x => MDep [x] where 356 | mDep x = any (mDep x) 357 | 358 | instance MDep b => MDep (Bind b) where 359 | mDep x (K t) = mDep x t 360 | mDep x (L t) = mDep x t 361 | 362 | topInsert :: MDep t => 363 | ((String, t), z) -> [((String, t), z)] -> [((String, t), z)] 364 | topInsert b = go (B0 :< b) where 365 | go bz [] = bz <>> [] 366 | go bz (a@((_, t), _) : as) 367 | | any (\ ((x, _), _) -> mDep x t) bz = go (bz :< a) as 368 | | otherwise = a : go bz as 369 | 370 | topSort :: MDep t => [((String, t), z)] -> Maybe [((String, t), z)] 371 | topSort as = if all ok (tails bs) then Just bs else Nothing where 372 | bs = foldl (flip topInsert) [] as 373 | ok [] = True 374 | ok (((_, t), _) : zs) = all (\ ((x, _), _) -> not (mDep x t)) zs 375 | -------------------------------------------------------------------------------- /lib/Language/Ask/Typing.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ---------- ---------- 3 | ---------- Typing ---------- 4 | ---------- ---------- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE 8 | TupleSections 9 | , LambdaCase 10 | , PatternSynonyms 11 | , TypeSynonymInstances 12 | , FlexibleInstances #-} 13 | 14 | module Language.Ask.Typing where 15 | 16 | --import Data.List 17 | import Control.Applicative 18 | import Data.Foldable 19 | import Control.Monad 20 | import Control.Arrow ((***)) 21 | import Data.Traversable 22 | import Data.List hiding ((\\)) 23 | 24 | import Debug.Trace 25 | 26 | import Language.Ask.Bwd 27 | import Language.Ask.Thin 28 | import Language.Ask.Hide 29 | import Language.Ask.HalfZip 30 | import Language.Ask.Lexing 31 | import Language.Ask.RawAsk 32 | import Language.Ask.Tm 33 | import Language.Ask.Glueing 34 | import Language.Ask.Context 35 | 36 | track = const id 37 | 38 | 39 | ------------------------------------------------------------------------------ 40 | -- Head normalisation 41 | ------------------------------------------------------------------------------ 42 | 43 | hnf :: Tm -> AM Tm 44 | hnf t = case t of 45 | TC _ _ -> return t 46 | TB _ -> return t 47 | TE e -> upsilon <$> hnfSyn e 48 | 49 | upsilon :: Syn -> Tm 50 | upsilon (t ::: _) = t 51 | upsilon e = TE e 52 | 53 | fnarg :: Syn -> [Tm] -> Maybe (Nom, Sch, [Tm], [Tm], [Tm]) 54 | fnarg (e :$ s) ss = fnarg e (s : ss) 55 | fnarg (TF (f, Hide sch) is as) ss = Just (f, sch, is, as, ss) 56 | fnarg (TE e ::: _) ss = fnarg e ss 57 | fnarg _ _ = Nothing 58 | 59 | hnfSyn :: Syn -> AM Syn 60 | hnfSyn e | track ("HNFSYN " ++ show e) False = undefined 61 | hnfSyn e = case fnarg e [] of 62 | Nothing -> hnfSyn' e 63 | Just (f, sch, is, as, ss) -> do 64 | let red ((g, ps) :=: e) | f == g = [(ps, e)] 65 | red _ = [] 66 | run :: [([Pat], Syn)] -> [Tm] -> AM Syn 67 | run [] ts = return $ foldl (:$) (TF (f, Hide sch) is' as') ss' where 68 | (is', us) = blump is ts 69 | (as', ss') = blump as us 70 | run ((ps, e) : prog) ts = snarf ps ts >>= \case 71 | Left ts -> run prog ts 72 | Right (m, ts) -> hnfSyn $ foldl (:$) (stan m e) ts 73 | prog <- foldMap red <$> gamma 74 | run prog (is ++ as ++ ss) 75 | where 76 | snarf :: [Pat] -> [Tm] -> AM (Either [Tm] (Matching, [Tm])) 77 | snarf [] ts = return $ Right ([], ts) 78 | snarf (p : ps) [] = return $ Left [] 79 | snarf (p : ps) (t : ts) = maKAM (p, t) >>= \case 80 | (t, Nothing) -> return $ Left (t : ts) 81 | (t, Just m) -> snarf ps ts >>= \case 82 | Left ts -> return $ Left (t : ts) 83 | Right (m', ts) -> return $ Right (m ++ m', ts) 84 | blump [] xs = ([], xs) 85 | blump (_ : ys) [] = ([], []) 86 | blump (_ : ys) (x : xs) = ((x :) *** id) (blump ys xs) 87 | 88 | hnfSyn' :: Syn -> AM Syn 89 | hnfSyn' e@(TP (x, Hide ty)) = cope 90 | (nomBKind x >>= \case 91 | Defn t -> do 92 | t <- hnf t 93 | ty <- hnf ty 94 | return (t ::: ty) 95 | _ -> return e) 96 | (\ _ -> return e) 97 | return 98 | hnfSyn' (t ::: ty) = do 99 | t <- hnf t 100 | ty <- hnf ty 101 | return (t ::: ty) 102 | hnfSyn' (f :$ s) = hnfSyn f >>= \case 103 | (TB b ::: TC "->" [dom, ran]) -> return ((b // (s ::: dom)) ::: ran) 104 | (TE e ::: _) -> return (e :$ s) 105 | f -> return (f :$ s) 106 | hnfSyn' e | track ("HNFSYN " ++ show e) True = return e 107 | 108 | (|:-) :: (String, Tm) -> (Syn -> AM x) -> AM x 109 | (x, s) |:- p = do 110 | xn <- fresh x 111 | let xp = (xn, Hide s) 112 | push $ Bind xp (User x) 113 | y <- p (TP xp) 114 | pop $ \case 115 | Bind (yn, _) _ | xn == yn -> True 116 | _ -> False 117 | return y 118 | 119 | norm :: Tm -> AM Tm -- this is a fake 120 | norm t = hnf t >>= \case 121 | TC c ts -> TC c <$> traverse norm ts 122 | t -> return t 123 | 124 | testRun :: Tm -> AM Tm 125 | testRun t = hnf t >>= \case 126 | TC c ts -> TC c <$> traverse testRun ts 127 | TE s -> TE <$> testSyn s 128 | t -> return t 129 | where 130 | testSyn :: Syn -> AM Syn 131 | testSyn (e :$ s) = (:$) <$> testSyn e <*> testRun s 132 | testSyn t = return t 133 | 134 | 135 | unsize :: Tm -> AM Tm 136 | unsize ty = hnf ty >>= \case 137 | Sized ty _ _ -> return ty 138 | ty -> return ty 139 | 140 | equal :: Tm -> (Tm, Tm) -> AM () 141 | equal ty (x, y) = do 142 | ty <- unsize ty 143 | x <- hnf x 144 | y <- hnf y 145 | case (x, y) of 146 | (TC "$" [a, TE (TP (z, _)), i], TC "$" [b, TE (TP (y, _)), j]) 147 | | y == z && i == j -> equal Type (a, b) 148 | (TC c ss, TC d ts) | c == d -> do 149 | tel <- constructor EXP ty c 150 | equals tel ss ts 151 | (TB a, TB b) -> case ty of 152 | TC "->" [dom, ran] -> do 153 | ("", dom) |:- \ x -> equal ran (a // x, b // x) 154 | _ -> gripe NotEqual 155 | (TE e, TE f) -> eqSyn e f >> return () 156 | _ -> gripe NotEqual 157 | 158 | equals :: Tel -> [Tm] -> [Tm] -> AM () 159 | equals tel ss ts = go [] tel ss ts where 160 | go :: [((String, Tm), (Tm, Tm))] -> Tel -> [Tm] -> [Tm] -> AM () 161 | go acc (Pr _) [] [] = hit [] acc 162 | go acc (Ex a b) (s : ss) (t : ts) = do 163 | equal a (s, t) 164 | go acc (b // (s ::: a)) ss ts 165 | go acc ((x, a) :*: b) (s : ss) (t : ts) = 166 | go (topInsert ((x, a), (s, t)) acc) b ss ts 167 | go _ _ _ _ = gripe NotEqual 168 | hit :: Matching -> [((String, Tm), (Tm, Tm))] -> AM () 169 | hit m [] = return () 170 | hit m (((x, a), (s, t)) : sch) = do 171 | equal (stan m a) (s, t) 172 | hit ((x, s) : m) sch 173 | 174 | eqSyn :: Syn -> Syn -> AM Tm 175 | eqSyn (TP (xn, Hide ty)) (TP (yn, _)) | xn == yn = hnf ty 176 | eqSyn (t ::: ty) e = equal ty (t, upTE e) >> return ty 177 | eqSyn e (t ::: ty) = equal ty (upTE e, t) >> return ty 178 | eqSyn (f :$ s) (g :$ t) = do 179 | TC "->" [dom, ran] <- eqSyn f g 180 | equal dom (s, t) 181 | return ran 182 | eqSyn (TF (f, Hide sch) as bs) (TF (g, _) cs ds) | f == g = 183 | eqFun sch (as, bs) (cs, ds) 184 | eqSyn _ _ = gripe NotEqual 185 | 186 | eqFun :: Sch -> ([Tm], [Tm]) -> ([Tm], [Tm]) -> AM Tm 187 | eqFun (Al s t) (a : as, bs) (c : cs, ds) = do 188 | equal s (a, c) 189 | eqFun (t // (a ::: s)) (as, bs) (cs, ds) 190 | eqFun (iss :>> t) ([], bs) ([], ds) = go [] iss t bs ds where 191 | go m [] t [] [] = return $ stan m t 192 | go m ((x, ty) : iss) t (b : bs) (d : ds) = do 193 | let ty' = stan m ty 194 | equal ty' (b, d) 195 | go ((x, b) : m) iss t bs ds 196 | go _ _ _ _ _ = gripe FAIL 197 | eqFun _ _ _ = gripe FAIL 198 | 199 | 200 | normAQTy :: Tm -> AM Tm 201 | normAQTy (TC "=" [ty, l, r]) = do 202 | ty <- norm ty 203 | l <- normAQTy l 204 | r <- normAQTy r 205 | return $ TC "=" [ty, l, r] 206 | normAQTy (TC c ss) = TC c <$> traverse normAQTy ss 207 | normAQTy t = return t 208 | 209 | 210 | ------------------------------------------------------------------------------ 211 | -- Pattern Matching 212 | ------------------------------------------------------------------------------ 213 | 214 | maAM :: (Pat, Tm) -> AM Matching 215 | maAM (p, t) = go mempty (p, t) where 216 | go :: Thinning -> (Pat, Tm) -> AM Matching 217 | go ph (PM m th, t) = ((:[]) . (m,)) <$> mayhem (thicken th (t <^> ph)) 218 | go ph (PC x ps, t) = do 219 | TC y ts <- hnf t 220 | guard $ x == y 221 | pts <- mayhem $ halfZip ps ts 222 | concat <$> traverse (go ph) pts 223 | go ph (PB p, t) = hnf t >>= \ t -> case t of 224 | TB (K t) -> go (o' ph) (p, t) 225 | TB (L t) -> go (os ph) (p, t) 226 | _ -> gripe FAIL 227 | 228 | maKAM :: (Pat, Tm) -> AM (Tm, Maybe Matching) 229 | maKAM (p, t) = go mempty (p, t) where 230 | go :: Thinning -> (Pat, Tm) -> AM (Tm, Maybe Matching) 231 | go ph (PM m th, t) = (t,) <$> case thicken th (t <^> ph) of 232 | Nothing -> return Nothing 233 | Just t -> return (Just [(m, t)]) 234 | go ph (PC x ps, t) = hnf t >>= \case 235 | t@(TC y ts) | x == y -> case halfZip ps ts of 236 | Nothing -> return (t, Nothing) 237 | Just pts -> traverse (go ph) pts >>= \ tmms -> 238 | return (TC y (map fst tmms), concat <$> traverse snd tmms) 239 | t -> return (t, Nothing) 240 | go ph (PB p, t) = hnf t >>= \ t -> case t of 241 | TB (K t) -> go (o' ph) (p, t) >>= \case 242 | (t, mm) -> return (TB (K t), mm) 243 | TB (L t) -> go (os ph) (p, t) >>= \case 244 | (t, mm) -> return (TB (L t), mm) 245 | t -> return (t, Nothing) 246 | 247 | 248 | ------------------------------------------------------------------------------ 249 | -- Elaboration 250 | ------------------------------------------------------------------------------ 251 | 252 | impQElabTm :: Tm -> Appl -> AM TmR 253 | impQElabTm ty a = do 254 | push ImplicitQuantifier 255 | t <- elabTmR ty a 256 | pop $ \case 257 | ImplicitQuantifier -> True 258 | _ -> False 259 | return t 260 | 261 | elabTmR :: Tm -> Appl -> AM TmR 262 | elabTmR ty a = ((`Our` a)) <$> (elabTm EXP ty a >>= normAQTy) 263 | 264 | synthy :: Context -> LexL -> Bool 265 | synthy ga (Lid, _, _) = True 266 | synthy ga (Sym, _, "::") = True 267 | synthy ga (_, _, f) = any declared ga where 268 | declared (Declare g _ _) = f == g 269 | declared _ = False 270 | 271 | checky :: LexL -> Bool 272 | checky (Uid, _, _) = True 273 | checky (Sym, _, "::") = False 274 | checky (Sym, _, ':':_) = True 275 | checky _ = False 276 | 277 | -- here is some serious chewing gum and string 278 | elabEq :: Appl -> Appl -> AM Tm 279 | {- special case for equations which look like they were 280 | generated by case splitting, where we want to keep size info 281 | in order to confirm the smallness of things 282 | -} 283 | elabEq lhs@(_, (Lid, _, x) :$$ []) rhs@(_, c :$$ ras) 284 | | checky c && all kid ras -- should really check these are out of scope 285 | = do 286 | (e, sy) <- elabSyn EXP x [] 287 | sy <- hnf sy 288 | rhs <- elabTm PAT sy rhs 289 | sy <- norm sy 290 | return $ TC "=" [sy, TE e, rhs] 291 | where 292 | kid (_, (Lid, _ , y) :$$ []) = x /= y 293 | kid _ = False 294 | elabEq lhs rhs = do 295 | ga <- gamma 296 | case lhs of 297 | (_, l@(_, _, f) :$$ as) | synthy ga l -> do 298 | (e, sy) <- elabSyn EXP f as 299 | sy <- unsize sy 300 | rhs <- elabTm EXP sy rhs 301 | sy <- norm sy 302 | return $ TC "=" [sy, TE e, rhs] 303 | _ -> case rhs of 304 | (_, l@(_, _, f) :$$ as) | synthy ga l -> do 305 | (e, sy) <- elabSyn EXP f as 306 | sy <- unsize sy 307 | lhs <- elabTm EXP sy lhs 308 | sy <- norm sy 309 | return $ TC "=" [sy, lhs, TE e] 310 | _ -> do 311 | ty <- TE <$> hole Type 312 | lhs <- cope (elabTm EXP ty lhs) 313 | (\ _ -> elabTm EXP ty rhs >> elabTm EXP ty lhs 314 | ) 315 | return 316 | rhs <- elabTm EXP ty rhs 317 | ty <- norm ty 318 | return $ TC "=" [ty, lhs, rhs] 319 | 320 | elabTm :: ConMode -> Tm -> Appl -> AM Tm 321 | elabTm m ty (_, a) | track (show ty ++ " on " ++ show a) False = undefined 322 | elabTm m ty (ls, (Sym, _, "=") :$$ [lhs, rhs]) = do 323 | unify Type ty Prop 324 | elabEq lhs rhs 325 | elabTm m ty (ls, l@(_, _, y) :$$ ras) = do 326 | ga <- gamma 327 | case l of 328 | _ | synthy ga l -> do 329 | (e, sy) <- elabSyn m y ras 330 | cope (subtype sy ty) (\ _ -> do 331 | True <- track ("SOOTY-SEZ-NO " ++ show sy ++ " " ++ show ty) $ return True 332 | sy <- norm sy 333 | ty <- norm ty 334 | gripe $ Terror ls sy ty 335 | ) return 336 | return $ TE e 337 | (Und, _, _) -> do 338 | guard $ null ras 339 | x <- hole ty 340 | return (TE x) 341 | (t, _, y) | elem t [Uid, Sym] -> do 342 | tel <- constructor m ty y 343 | fst <$> elabVec m y tel ras 344 | _ -> gripe FAIL 345 | where 346 | 347 | 348 | shitSort :: [((String, Tm), Appl)] -> AM [((String, Tm), Appl)] 349 | shitSort [] = return [] 350 | shitSort (a@((_, _), (_, (Lid, _, f) :$$ _)) : as) = cope (what's f) 351 | (\ _ -> topInsert a <$> shitSort as) 352 | $ \case 353 | Right (_, ty) -> hnf ty >>= \case 354 | TC "$" _ -> topInsert a <$> shitSort as 355 | _ -> (a :) <$> shitSort as 356 | _ -> (a :) <$> shitSort as 357 | shitSort (a@((_, _), (_, (_, _, "::") :$$ _)) : as) = (a :) <$> shitSort as 358 | shitSort (a : as) = topInsert a <$> shitSort as 359 | 360 | elabVec :: ConMode -> String -> Tel -> [Appl] -> AM (Tm, Matching) 361 | elabVec cm con tel as = do 362 | (ss, sch, pos) <- cope (specialise tel as) 363 | (\ _ -> gripe (WrongNumOfArgs con (ari tel) as)) 364 | return 365 | sch <- shitSort sch 366 | m <- argChk cm [] sch 367 | traverse (fred . PROVE) pos 368 | return (stan m $ TC con ss, m) 369 | where 370 | specialise :: Tel -> [Appl] -> AM ([Tm], [((String, Tm), Appl)], [Tm]) 371 | specialise (Ex s b) as = do 372 | x <- hole s 373 | (ts, sch, po) <- specialise (b // x) as 374 | return (TE x : ts, sch, po) 375 | specialise ((x, s) :*: tel) (a : as) = do 376 | (ts, sch, po) <- specialise tel as 377 | return (TM x [] : ts, topInsert ((x, s), a) sch, po) 378 | specialise (Pr pos) [] = return ([], [], pos) 379 | specialise _ _ = gripe FAIL 380 | ari :: Tel -> Int 381 | ari (Ex s (K b)) = ari b 382 | ari (Ex s (L b)) = ari b 383 | ari (s :*: tel) = 1 + ari tel 384 | ari (Pr _) = 0 385 | 386 | argChk :: ConMode -> Matching -> [((String, Tm), Appl)] -> AM Matching 387 | argChk cd m [] = return m 388 | argChk cd m (((x, t), a) : bs) = do 389 | s <- elabTm cd (stan m t) a 390 | argChk cd ((x, s) : m) bs 391 | 392 | elabSyn :: ConMode -> String -> [Appl] -> AM (Syn, Tm) 393 | elabSyn cm "::" (tm : ty : as) = do 394 | ty <- elabTm EXP Type ty 395 | tm <- elabTm cm ty tm 396 | elabSpine cm (tm ::: ty, ty) as 397 | elabSyn cm f as = what's f >>= \case 398 | Right ety -> elabSpine cm ety as 399 | Left (n, sch) -> elabFun cm (n, Hide sch) B0 sch as 400 | 401 | elabSpine :: ConMode -> (Syn, Tm) -> [Appl] -> AM (Syn, Tm) 402 | elabSpine cm fsy [] = track (show fsy) $ return fsy 403 | elabSpine cm (f, sy) (a : as) = do 404 | (dom, ran) <- makeFun sy 405 | s <- elabTm cm dom a 406 | elabSpine cm (f :$ s, ran) as 407 | 408 | elabFun :: ConMode -> (Nom, Hide Sch) -> Bwd Tm -> Sch -> [Appl] -> AM (Syn, Tm) 409 | elabFun cm (f, _) B0 sch as 410 | | track ("FUN (" ++ show f ++ " :: " ++ show sch ++ ")" ++ show as) False 411 | = undefined 412 | elabFun cm f az (Al a s) as = do 413 | x <- hole a 414 | elabFun cm f (az :< TE x) (s // x) as 415 | elabFun cm f az (iss :>> t) as = do 416 | (schd, bs) <- snarf iss as 417 | m <- argChk cm [] schd 418 | elabSpine cm (TF f (az <>> []) [t | (i, _) <- iss, (j, t) <- m, i == j], stan m t) bs 419 | where 420 | snarf :: [(String, Tm)] -> [Appl] -> AM ([((String, Tm), Appl)], [Appl]) 421 | snarf [] as = return ([], as) 422 | snarf _ [] = gripe FAIL 423 | snarf (xty : xtys) (a : as) = do 424 | (schd, bs) <- snarf xtys as 425 | return (topInsert (xty, a) schd, bs) 426 | 427 | 428 | ------------------------------------------------------------------------------ 429 | -- Subtyping 430 | ------------------------------------------------------------------------------ 431 | 432 | -- I'm very far from convinced that I'm doing this right. 433 | 434 | subtype :: Tm -> Tm -> AM () 435 | subtype s t = do 436 | s <- hnf s 437 | t <- hnf t 438 | go s t 439 | where 440 | go s t | track ("SOOTY " ++ show s ++ " " ++ show t) False = undefined 441 | go (TC "->" [s0, t0]) u = 442 | if subTm u [s0, t0] 443 | then gripe InfiniteType 444 | else do 445 | (s1, t1) <- makeFun u 446 | subtype s1 s0 447 | subtype t0 t1 448 | go u (TC "->" [s1, t1]) = 449 | if subTm u [s1, t1] 450 | then gripe InfiniteType 451 | else do 452 | (s0, t0) <- makeFun u 453 | subtype s1 s0 454 | subtype t0 t1 455 | go (TC "$" [ty0, non0, num0]) (TC "$" [ty1, non1, num1]) = do 456 | unify Type ty0 ty1 457 | unify Zone non0 non1 458 | greq num0 num1 459 | go (TC "$" [ty0, _, _]) ty1@(TC _ _) = unify Type ty0 ty1 460 | go got want = unify Type got want -- not gonna last 461 | 462 | greq :: Tm -> Tm -> AM () 463 | greq _ (TC "Z" []) = return () 464 | greq (TC "S" [m]) (TC "S" [n]) = greq m n 465 | greq _ _ = gripe FAIL 466 | 467 | makeFun :: Tm -> AM (Tm, Tm) 468 | makeFun (TC "->" [dom, ran]) = return (dom, ran) 469 | makeFun ty = do 470 | dom <- TE <$> hole Type 471 | ran <- TE <$> hole Type 472 | unify Type (dom :-> ran) ty 473 | return (dom, ran) 474 | 475 | 476 | ------------------------------------------------------------------------------ 477 | -- Unification 478 | ------------------------------------------------------------------------------ 479 | 480 | unify = unify' True 481 | unify' :: Bool -> Tm -> Tm -> Tm -> AM () 482 | unify' heh ty a b = do -- pay more attention to types 483 | ty <- unsize ty 484 | a <- if heh then hnf a else pure a 485 | b <- if heh then hnf b else pure b 486 | True <- track (show a ++ " =? " ++ show b) (return True) 487 | case (a, b) of 488 | (TC "$" [a, TE (TP (z, _)), i], TC "$" [b, TE (TP (y, _)), j]) 489 | | z == y && i == j -> unify' heh Type a b 490 | (TC f as, TC g bs) -> do 491 | guardErr (f == g) (Unification f g) 492 | tel <- constructor EXP ty f 493 | unifies' heh tel as bs 494 | (TE (TP xp), t) -> make xp t ty 495 | (s, TE (TP yp)) -> make yp s ty 496 | (TE e, TE f) -> () <$ unifySyn' heh e f 497 | _ -> cope (equal ty (a, b)) 498 | (\ _ -> do 499 | True <- track (show a ++ " /= " ++ show b) $ return True 500 | gripe FAIL) 501 | return 502 | 503 | unfiySyn = unifySyn' True 504 | unifySyn' :: Bool -> Syn -> Syn -> AM Tm --- eeeevil 505 | unifySyn' heh (TP xp@(_, Hide ty)) e = do 506 | ty <- eqSyn e e 507 | ty <$ make xp (TE e) ty 508 | unifySyn' heh e (TP xp@(_, Hide ty)) = do 509 | ty <- eqSyn e e 510 | ty <$ make xp (TE e) ty 511 | unifySyn' heh (e :$ a) (f :$ b) = do 512 | ty <- unifySyn' heh e f >>= hnf 513 | (dom, ran) <- makeFun ty 514 | ran <$ unify' heh dom a b 515 | unifySyn' heh (TF (f, Hide sch) as bs) (TF (g, Hide _) cs ds) | f == g = 516 | unifyFun' heh sch (as , bs) (cs, ds) 517 | unifySyn' heh (a ::: s) (b ::: t) = do 518 | unify' heh Type s t 519 | unify' heh s a b 520 | return s 521 | unifySyn' _ _ _ = gripe FAIL 522 | 523 | unifyFun = unifyFun' True 524 | unifyFun' :: Bool -> Sch -> ([Tm], [Tm]) -> ([Tm], [Tm]) -> AM Tm 525 | unifyFun' heh (Al s t) (a : as, bs) (c : cs, ds) = do 526 | unify' heh s a c 527 | unifyFun' heh (t // (a ::: s)) (as, bs) (cs, ds) 528 | unifyFun' heh (iss :>> t) ([], bs) ([], ds) = go [] iss t bs ds where 529 | go m [] t [] [] = return $ stan m t 530 | go m ((x, ty) : iss) t (b : bs) (d : ds) = do 531 | let ty' = stan m ty 532 | unify' heh ty' b d 533 | go ((x, b) : m) iss t bs ds 534 | go _ _ _ _ _ = gripe FAIL 535 | unifyFun' _ _ _ _ = gripe FAIL 536 | 537 | prepareSubQs = prepareSubQs' True 538 | prepareSubQs' :: Bool -> Tel -> [Tm] -> [Tm] -> AM [((String, Tm), (Tm, Tm))] 539 | prepareSubQs' heh (Pr _) [] [] = return [] 540 | prepareSubQs' heh (Ex s mo) (a : as) (b : bs) = do 541 | unify' heh s a b 542 | prepareSubQs' heh (mo // (a ::: s)) as bs 543 | prepareSubQs' heh (xs :*: tel) (a : as) (b : bs) = do 544 | sch <- prepareSubQs' heh tel as bs 545 | return $ topInsert (xs, (a, b)) sch 546 | 547 | unifies = unifies' True 548 | unifies' :: Bool -> Tel -> [Tm] -> [Tm] -> AM () 549 | unifies' heh tel as bs = prepareSubQs' heh tel as bs >>= execute [] where 550 | execute :: Matching -> [((String, Tm), (Tm, Tm))] -> AM () 551 | execute m [] = return () 552 | execute m (((x, s), (a, b)) : sch) = do 553 | unify' heh (stan m s) a b 554 | execute ((x, a) : m) sch 555 | 556 | make :: (Nom, Hide Tm) -> Tm -> Tm -> AM () 557 | make (x, _) (TE (TP (y, _))) got | x == y = return () 558 | make (x, _) t got | track ("MAKE " ++ show x ++ " = " ++ show t) False = undefined 559 | make xp@(x, Hide ty) t got = do 560 | de <- doorStep 561 | doorStop 562 | traverse push de 563 | True <- track ("seeking " ++ show x ++ "\n" ++ show de) $ return True 564 | k <- nomBKind x 565 | True <- track (show x ++ " is a " ++ show k) $ return True 566 | case k of 567 | User _ -> case t of 568 | TE (TP yp@(y, _)) -> nomBKind y >>= \case 569 | Hole -> make yp (TE (TP xp)) ty 570 | _ -> gripe FAIL 571 | _ -> gripe FAIL 572 | Defn s -> do 573 | True <- track ("BUT " ++ show x ++ " = " ++ show s) $ return True 574 | unify ty s t 575 | Hole -> do 576 | hnf ty >>= \case 577 | Sized _ _ _ -> do 578 | True <- track ("MAKE-SIZED " ++ show x ++ " " ++ show t) $ return True 579 | hnf t >>= \case 580 | TC c _ -> gripe $ InductiveHypsDon'tLike c 581 | TE _ -> return () 582 | _ -> gripe Mardiness 583 | _ -> return () 584 | got <- case t of 585 | TE e -> eqSyn e e 586 | _ -> return got 587 | subtype got ty 588 | ga <- gamma 589 | ga <- go ga [] 590 | setGamma ga 591 | de <- doorStep 592 | doorStop 593 | traverse push de 594 | True <- track ("MADE\n" ++ show de) $ return True 595 | return () 596 | where 597 | go B0 ms = do 598 | True <- track ("AWOL " ++ show x) $ return True 599 | gripe FAIL -- shouldn't happen 600 | go (ga :< z) ms | track ("MAKE-GO: " ++ show z ++ " " ++ show ms) False = undefined 601 | go (ga :< Bind p@(y, _) Hole) ms | x == y = case pDep y (ms, t) of 602 | True -> gripe FAIL 603 | False -> return (ga <>< ms :< Bind p (Defn t)) 604 | go (ga :< Bind (y, _) _) ms | x == y = gripe FAIL 605 | go (ga :< z@(Bind (y, _) k)) ms = case pDep y (ms, t) of 606 | False -> (:< z) <$> go ga ms 607 | True -> case k of 608 | User _ -> gripe FAIL 609 | _ -> go ga (z : ms) 610 | go (ga :< z) ms = (:< z) <$> go ga ms 611 | 612 | 613 | ------------------------------------------------------------------------------ 614 | -- Occur Check 615 | ------------------------------------------------------------------------------ 616 | 617 | class PDep t where 618 | pDep :: Nom -> t -> Bool 619 | 620 | instance PDep Tm where 621 | pDep x t = case t of 622 | TC _ ts -> pDep x ts 623 | TB t -> pDep x t 624 | TE e -> pDep x e 625 | 626 | instance PDep Syn where 627 | pDep x (TP (y, _)) = x == y 628 | pDep x (t ::: ty) = pDep x t || pDep x ty 629 | pDep x (e :$ s) = pDep x e || pDep x s 630 | pDep x (TF _ is as) = pDep x is || pDep x as 631 | pDep x _ = False 632 | 633 | instance PDep t => PDep [t] where 634 | pDep x ts = any id (map (pDep x) ts) 635 | 636 | instance (PDep s, PDep t) => PDep (s, t) where 637 | pDep x (s, t) = pDep x s || pDep x t 638 | 639 | instance PDep t => PDep (Bind t) where 640 | pDep x (K t) = pDep x t 641 | pDep x (L t) = pDep x t 642 | 643 | instance PDep CxE where 644 | pDep x (Hyp _ p) = pDep x p 645 | pDep x (Bind (_, Hide ty) k) = pDep x ty || pDep x k 646 | pDep _ _ = False 647 | 648 | instance PDep BKind where 649 | pDep x (Defn t) = pDep x t 650 | pDep _ _ = False 651 | 652 | 653 | ------------------------------------------------------------------------------ 654 | -- Obtaining a Telescope from a Template 655 | ------------------------------------------------------------------------------ 656 | 657 | elabTel :: [Appl] -> AM Tel 658 | elabTel as = do 659 | doorStop 660 | phs <- placeHolders as 661 | lox <- doorStep 662 | telify (map fst phs) lox 663 | 664 | placeHolders :: [Appl] -> AM [(String, Tm)] 665 | placeHolders as = do 666 | let decolonise i (_, (Sym, _, "::") :$$ [(_, (Lid, _, x) :$$ []) , ty]) = 667 | (x, ty) 668 | decolonise i ty = ("#" ++ show i, ty) 669 | let phs = zipWith decolonise [0..] as 670 | guard $ nodup (map fst phs) 671 | sch <- mayhem $ map fst <$> topSort (map (, ()) phs) 672 | xts <- for sch $ \ (x, a) -> do 673 | ty <- elabTm EXP Type a 674 | xn <- fresh x 675 | push (Bind (xn, Hide ty) (User x)) 676 | return (x, ty) 677 | for phs $ \ (x, _) -> (x,) <$> mayhem (lookup x xts) 678 | 679 | telify :: [String] -- the explicit parameter order 680 | -> [CxE] -- the local context (as returned by doorStep) 681 | -> AM Tel -- the telescope 682 | telify vs lox = go [] lox where 683 | go ps [] = do 684 | xs <- traverse (\ x -> mayhem $ (x,) <$> (snd <$> lookup x ps)) vs 685 | return $ foldr (:*:) (Pr []) xs 686 | go ps (Bind (xp, Hide ty) bk : lox) = case bk of 687 | Defn t -> e4p (xp, t ::: ty) <$> go ps lox 688 | Hole -> do 689 | bs <- traverse (\ (_, (xp, _)) -> return $ pDep xp ty) ps 690 | guard $ all not bs 691 | Ex ty <$> ((xp \\) <$> go ps lox) 692 | User x -> e4p (xp, TM x [] ::: ty) <$> go ((x, (xp, ty)) : ps) lox 693 | go ps ((_ ::> _) : lox) = go ps lox 694 | go _ _ = gripe FAIL 695 | 696 | schemify :: [String] -- the explicit parameter order 697 | -> [CxE] -- the local context (as returned by doorStep) 698 | -> Tm -- the return type 699 | -> AM Sch -- the type scheme 700 | schemify vs lox rt = go [] lox where 701 | go ps [] = do 702 | xs <- traverse (\ x -> mayhem $ (x,) <$> (snd <$> lookup x ps)) vs 703 | return $ xs :>> rt 704 | go ps (Bind (xp, Hide ty) bk : lox) = case bk of 705 | Defn t -> e4p (xp, t ::: ty) <$> go ps lox 706 | Hole -> do 707 | bs <- traverse (\ (_, (xp, _)) -> return $ pDep xp ty) ps 708 | guard $ all not bs 709 | Al ty <$> ((xp \\) <$> go ps lox) 710 | User x 711 | | x `elem` vs -> 712 | e4p (xp, TM x [] ::: ty) <$> go ((x, (xp, ty)) : ps) lox 713 | | otherwise -> do 714 | bs <- traverse (\ (_, (xp, _)) -> return $ pDep xp ty) ps 715 | guard $ all not bs 716 | Al ty <$> ((xp \\) <$> go ps lox) 717 | go ps ((_ ::> _) : lox) = go ps lox 718 | go _ _ = gripe FAIL 719 | 720 | 721 | ------------------------------------------------------------------------------ 722 | -- Binding a Parameter List 723 | ------------------------------------------------------------------------------ 724 | 725 | bindParam :: [Appl] -> AM ([String], [(Nom, Syn)]) 726 | bindParam as = do 727 | push ImplicitQuantifier 728 | (xs, sb) <- fold <$> traverse go as 729 | pop (\case {ImplicitQuantifier -> True; _ -> False}) 730 | guard $ nodup xs 731 | return (xs, sb) 732 | where 733 | go :: Appl -> AM ([String], [(Nom, Syn)]) 734 | go (_, a) = do 735 | (x, ty) <- case a of 736 | (Sym, _, "::") :$$ [(_, (Lid, _, x) :$$ []), ty] -> return (x, ty) 737 | (Lid, _, x) :$$ [] -> return (x, ([], (Und, (0,0), "_") :$$ [])) 738 | _ -> gripe FAIL 739 | ty <- elabTm EXP Type ty 740 | xn <- fresh x 741 | push (Bind (xn, Hide ty) (User x)) 742 | return ([x], [(xn, (TM x [] ::: ty))]) 743 | 744 | 745 | ------------------------------------------------------------------------------ 746 | -- Duplication Freeness 747 | ------------------------------------------------------------------------------ 748 | 749 | nodup :: Eq x => [x] -> Bool 750 | nodup [] = True 751 | nodup (x : xs) 752 | | elem x xs = False 753 | | otherwise = nodup xs 754 | 755 | 756 | ------------------------------------------------------------------------------ 757 | -- Constructor lookup 758 | ------------------------------------------------------------------------------ 759 | 760 | -- it is not safe to allow *construction* in sized types 761 | -- defined foo (n :: Nat) :: Nat induction n 762 | -- given foo (n :: Nat) :: Nat define foo n from n 763 | -- defined foo Z = Z 764 | -- defined foo (S n) = foo (S Z) -- no reason to believe Z is small enough 765 | 766 | data ConMode = PAT | EXP deriving (Show, Eq) 767 | 768 | constructor :: ConMode -> Tm -> Con -> AM Tel 769 | constructor m ty con = cope 770 | (conSplit m ty >>= \ cts -> mayhem $ lookup con cts) 771 | (\ _ -> do 772 | (d, ss) <- hnf ty >>= \case 773 | TC d ss -> return (d, ss) 774 | ty -> (foldMap (conCand con) <$> gamma) >>= \case 775 | [(p, tel)] -> do 776 | (TC d ss, m) <- splat Type p 777 | subtype (TC d ss) ty 778 | return (d, ss) 779 | _ -> gripe $ NonCanonicalType ty con 780 | (fold <$> (gamma >>= traverse (try d ss con))) >>= \case 781 | [] -> gripe (DoesNotMake con ty) 782 | _ : _ : _ -> gripe (OverOverload con) 783 | [tel] -> return tel) 784 | return 785 | where 786 | try :: Con -> [Tm] -> Con -> CxE -> AM [Tel] 787 | try d ss c ((d', ps) ::> (c', tel)) | d == d' && c == c' = do 788 | m <- concat <$> ((mayhem $ halfZip ps ss) >>= traverse maAM) 789 | return [stan m tel] 790 | try d ss c (Data _ de) = 791 | concat <$> traverse (try d ss c) de 792 | try _ _ _ _ = return [] 793 | {- 794 | cand :: CxE -> [(Pat, Tel)] 795 | cand ((c, ps) ::> (k, tel)) | k == con = [(PC c ps, tel)] 796 | cand (Data _ de) = foldMap cand de 797 | cand _ = [] 798 | -} 799 | splat :: Tm -> Pat -> AM (Tm, Matching) 800 | splat ty (PM x _{- er? -}) = do 801 | y <- hole ty 802 | return (TE y, [(x, TE y)]) 803 | splat ty (PC c ps) = do 804 | tel <- constructor PAT ty c 805 | (ts, m) <- splats [] tel ps 806 | return (TC c ts, m) 807 | splat _ _ = gripe FAIL 808 | splats m (Ex s tel) (p : ps) = do 809 | x <- hole s 810 | (ts, m) <- splats m (tel // x) ps 811 | return (TE x : ts, m) 812 | splats m ((x, s) :*: tel) (p : ps) = do 813 | -- this is broken in general 814 | (t, m) <- splat (stan m s) p 815 | (ts, m) <- splats m tel ps 816 | return (t : ts, m) 817 | splats m (Pr _) [] = return ([], m) 818 | splats _ _ _ = gripe FAIL 819 | 820 | conCand :: Con -> CxE -> [(Pat, Tel)] 821 | conCand con ((c, ps) ::> (k, tel)) | k == con = [(PC c ps, tel)] 822 | conCand con (Data _ de) = foldMap (conCand con) de 823 | conCand _ _ = [] 824 | 825 | -- FIXME: don't assume quite so casually that things are covariant functors 826 | weeer :: Con -- type constructor to be monkeyed 827 | -> Tm -- the nonce 828 | -> Tm -- the smaller size 829 | -> Tel -- the telescope of raw constructor arguments 830 | -> Tel -- the telescope of smaller constructor arguments 831 | weeer d non num (Ex a tel) = Ex a (fmap (weeer d non num) tel) 832 | weeer d non num ((x, s) :*: tel) = (x, hit s) :*: weeer d non num tel where 833 | hit ty@(TC c ts) 834 | | c == d = TC "$" [TC c (map hit ts), non, num] 835 | | otherwise = TC c (map hit ts) 836 | hit t = t 837 | weeer d non num (Pr pos) = Pr pos 838 | 839 | conSplit :: ConMode -> Tm -> AM [(Con, Tel)] 840 | conSplit m t = do 841 | t <- hnf t 842 | z@(monkey, d, ts) <- case t of 843 | TC "$" [TC d ts, non, num] -> case m of 844 | PAT -> return (weeer d non (TC "S" [num]), d, ts) 845 | EXP -> gripe NoSizedConstruction 846 | TC d ts -> return (id, d, ts) 847 | _ -> gripe FAIL 848 | (foldMap (\case {Data e de | d == e -> [de]; _ -> []}) <$> gamma) >>= \case 849 | [de] -> concat <$> traverse (refine z) de 850 | _ -> gripe $ NotADataType t 851 | where 852 | refine :: (Tel -> Tel, Con, [Tm]) -> CxE -> AM [(Con, Tel)] 853 | refine (monkey, d, ts) ((e, ps) ::> (c, tel)) | d == e = cope (do 854 | m <- concat <$> ((mayhem $ halfZip ps ts) >>= traverse maAM) 855 | return [(c, stan m (monkey tel))] 856 | ) 857 | (\ _ -> return []) 858 | return 859 | refine _ _ = return [] 860 | 861 | 862 | ------------------------------------------------------------------------------ 863 | -- Fred 864 | ------------------------------------------------------------------------------ 865 | 866 | tested :: Tm -> Tm -> Tm -> AM () 867 | tested ty lhs rhs = flip (cope (equal ty (lhs, rhs))) return $ \ _ -> do 868 | ty <- unsize ty 869 | lhs <- hnf lhs 870 | rhs <- hnf rhs 871 | case (ty, lhs, rhs) of 872 | (TC d _, TC a _, TC b _) 873 | | a /= b && d /= "Prop" -> demand . PROVE $ FALSE 874 | (TC t _, TC c ss, TC d ts) | c == d && t /= "Prop" -> do 875 | tel <- constructor EXP ty c 876 | testSubterms tel ss ts 877 | _ -> do 878 | ga <- gamma 879 | True <- track ("FRED: " ++ show ty ++ " " ++ show lhs ++ " " ++ show rhs ++ "\n" ++ show ga) 880 | $ return True 881 | demand . PROVE $ TC "=" [ty, lhs, rhs] 882 | 883 | testSubterms :: Tel -> [Tm] -> [Tm] -> AM () 884 | testSubterms tel ss ts = go [] tel ss ts where -- cargo cult 885 | go :: [((String, Tm), (Tm, Tm))] -> Tel -> [Tm] -> [Tm] -> AM () 886 | go acc (Pr _) [] [] = hit [] acc 887 | go acc (Ex a b) (s : ss) (t : ts) = do 888 | tested a s t 889 | go acc (b // (s ::: a)) ss ts 890 | go acc ((x, a) :*: b) (s : ss) (t : ts) = 891 | go (topInsert ((x, a), (s, t)) acc) b ss ts 892 | go _ _ _ _ = gripe NotEqual 893 | hit :: Matching -> [((String, Tm), (Tm, Tm))] -> AM () 894 | hit m [] = return () 895 | hit m (((x, a), (s, t)) : sch) = do 896 | tested (stan m a) s t 897 | hit ((x, s) : m) sch 898 | 899 | fred :: Subgoal -> AM () 900 | fred (PROVE g) = hnf g >>= \case 901 | TC "=" [ty, lhs, rhs] -> tested ty lhs rhs 902 | _ -> demand $ PROVE g 903 | fred s = demand s 904 | -------------------------------------------------------------------------------- /lib/Makefile: -------------------------------------------------------------------------------- 1 | default: ../bin/ask 2 | 3 | ../bin/ask: OddEven.hs Bwd.hs HalfZip.hs Lexing.hs Parsing.hs Glueing.hs Printing.hs RawAsk.hs Thin.hs Tm.hs HardwiredRules.hs Typing.hs ChkRaw.hs Main.hs 4 | pushd ../.. ; ghc --make -o ask/bin/ask ask/Src/Main.hs -main-is Ask.Src.Main.main ; popd 5 | -------------------------------------------------------------------------------- /lib/Test.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Testing Testing 1, 2, 3 4 | 5 | 6 | 7 |

Trying a Thing or Two

8 | 9 |
10 |
11 | 15 | 
16 | Pies.
17 | The sky is all pies.
18 |
19 |
20 |
21 | 22 | 23 | 24 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Main where 4 | 5 | import System.Environment 6 | import Data.Traversable 7 | 8 | import Language.Ask.ChkRaw 9 | 10 | main :: IO () 11 | main = getArgs >>= \case 12 | [] -> interact filth 13 | xs -> do 14 | inp <- concat <$> traverse readFile xs 15 | putStr $ filth inp 16 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented." 5 | --------------------------------------------------------------------------------