├── .github
    └── workflows
    │   └── build.yml
├── .gitignore
├── CHANGELOG.md
├── LICENSE
├── README.md
├── Setup.hs
├── app
    └── Main.hs
├── flake.lock
├── flake.nix
├── frontend
    ├── .gitignore
    ├── .vitepress
    │   ├── config.mts
    │   └── theme
    │   │   ├── index.ts
    │   │   └── style.css
    ├── index.md
    ├── package-lock.json
    ├── package.json
    ├── playground.md
    ├── postcss.config.js
    ├── quick-reference.md
    ├── research.md
    └── tailwind.config.js
├── package.yaml
├── src
    ├── Alg.hs
    ├── Alg
    │   ├── DK.hs
    │   ├── DK
    │   │   ├── Common.hs
    │   │   ├── DK.hs
    │   │   ├── Worklist.hs
    │   │   └── Worklist
    │   │   │   ├── Bounded.hs
    │   │   │   ├── Common.hs
    │   │   │   ├── DK.hs
    │   │   │   ├── Elementary.hs
    │   │   │   └── IU.hs
    │   ├── HDM.hs
    │   ├── HDM
    │   │   ├── AlgR.hs
    │   │   └── AlgW.hs
    │   ├── Local.hs
    │   └── Local
    │   │   ├── Contextual.hs
    │   │   ├── Contextual
    │   │       └── Contextual.hs
    │   │   └── Local.hs
    ├── Lib.hs
    ├── Opt.hs
    ├── Parser.hs
    ├── Print.hs
    └── Syntax.hs
├── stack.yaml
├── stack.yaml.lock
├── test
    └── Spec.hs
└── type-inference-zoo.cabal


/.github/workflows/build.yml:
--------------------------------------------------------------------------------
 1 | name: Build the static website
 2 | on:
 3 |   push:
 4 |     branches:
 5 |       - main
 6 | 
 7 | jobs:
 8 |   build:
 9 |     name: Build the static website
10 |     runs-on: ubuntu-latest
11 | 
12 |     steps:
13 |       - name: Checkout repository
14 |         uses: actions/checkout@v4
15 | 
16 |       - name: Install Nix
17 |         uses: cachix/install-nix-action@v30
18 |         with:
19 |           nix_path: nixpkgs=channel:nixos-unstable
20 | 
21 |       - name: Install GHC-wasm and build
22 |         working-directory: .
23 |         run: nix develop --command bash -c "wasm32-wasi-cabal update && wasm32-wasi-cabal build"
24 | 
25 |       - name: Install Node.js
26 |         uses: actions/setup-node@v4
27 |         with:
28 |           node-version: "22.11"
29 | 
30 |       - name: Compile frontend
31 |         working-directory: ./frontend
32 |         run: |
33 |           npm install
34 |           npm run docs:build
35 | 
36 |       - name: Prepare website
37 |         run: |
38 |           cp -r frontend/.vitepress/dist site
39 |           cp ./dist-newstyle/build/wasm32-wasi/ghc-*/type-inference-zoo-0.1.0.0/x/type-inference-zoo-exe/build/type-inference-zoo-exe/type-inference-zoo-exe.wasm site/bin.wasm
40 | 
41 |       - name: Upload Artifact for GitHub Pages
42 |         uses: actions/upload-pages-artifact@v3
43 |         with:
44 |           path: site/
45 | 
46 |   deploy:
47 |     needs: build
48 | 
49 |     # Grant GITHUB_TOKEN the permissions required to make a Pages deployment
50 |     permissions:
51 |       pages: write      # to deploy to Pages
52 |       id-token: write   # to verify the deployment originates from an appropriate source
53 | 
54 |     # Deploy to the github-pages environment
55 |     environment:
56 |       name: github-pages
57 |       url: ${{ steps.deployment.outputs.page_url }}
58 | 
59 |     # Specify runner + deployment step
60 |     runs-on: ubuntu-latest
61 |     steps:
62 |       - name: Deploy to GitHub Pages
63 |         id: deployment
64 |         uses: actions/deploy-pages@v4
65 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | dist-newstyle/
2 | .stack-work/
3 | *~
4 | 


--------------------------------------------------------------------------------
/CHANGELOG.md:
--------------------------------------------------------------------------------
 1 | # Changelog for `type-inference-zoo`
 2 | 
 3 | All notable changes to this project will be documented in this file.
 4 | 
 5 | The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
 6 | and this project adheres to the
 7 | [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 8 | 
 9 | ## Unreleased
10 | 
11 | ## 0.1.0.0 - YYYY-MM-DD
12 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright 2025 Chen Cui
2 | 
3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
4 | 
5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
6 | 
7 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # Type Inference Zoo
 2 | 
 3 | ![Build Status](https://github.com/cu1ch3n/type-inference-zoo/actions/workflows/build.yml/badge.svg)
 4 | ![License](https://img.shields.io/badge/license-MIT-blue.svg)
 5 | 
 6 | 
 7 | Welcome to **Type Inference Zoo**! This project is dedicated to implementing a variety of type inference algorithms. It serves as a personal project, as I am trying to understand the type inference algorithms well by implmenting them. Considering that it might be helpful for those who are also exploring type inference algoreithms, I am glad to make them avaliable online.
 8 | 
 9 | 🗿🗿🗿 There are indeed animals (**implementations**) in the zoo, not only references to animals.
10 | 
11 | A static online web demo is available for you to try at https://zoo.cuichen.cc/.
12 | 
13 | ## 🚀 Get Started
14 | 
15 | To get started with the project, clone the repository and build the project using [`stack`](https://docs.haskellstack.org/):
16 | 
17 | ```bash
18 | git clone https://github.com/cu1ch3n/type-inference-zoo.git
19 | cd type-inference-zoo
20 | stack build
21 | stack exec type-inference-zoo-exe -- "let id = \x. x in (id 1, id True)" --alg W
22 | ```
23 | 
24 | ## Research Works Implemented
25 | 
26 | - [x] `W`: [`./src/Alg/HDM/AlgW.hs`](./src/Alg/HDM/AlgW.hs)
27 |   - *Robin Milner.* **A Theory of Type Polymorphism in Programming.** Journal of Computer and System Sciences, 1978.
28 |     [[Paper](https://www.sciencedirect.com/science/article/pii/0022000078900144)]
29 | - [x] `DK`: [`./src/Alg/DK/DK.hs`](./src/Alg/DK/DK.hs)
30 |   - *Jana Dunfield and Neelakantan R. Krishnaswami.* **Complete and Easy Bidirectional Typechecking for Higher-rank Polymorphism.** ICFP 2013. 
31 |     [[Paper](https://dl.acm.org/doi/10.1145/2500365.2500582)]
32 | - [x] `Worklist`: [`./src/Alg/DK/Worklist/DK.hs`](./src/Alg/DK/Worklist/DK.hs)
33 |   - *Jinxu Zhao, Bruno C. d. S. Oliveira, and Tom Schrijvers.* **A Mechanical Formalization of Higher-Ranked Polymorphic Type Inference.** ICFP 2019.
34 |     [[Paper](https://dl.acm.org/doi/10.1145/3341716)]
35 | - [x] `Elementary`: [`./src/Alg/DK/Worklist/Elementary.hs`](./src/Alg/DK/Worklist/Elementary.hs)
36 |   - *Jinxu Zhao and Bruno C. d. S. Oliveira.* **Elementary Type Inference.** ECOOP 2022.
37 |     [[Paper](https://drops.dagstuhl.de/entities/document/10.4230/LIPIcs.ECOOP.2022.2)]
38 | - [x] `R`: [`./src/Alg/HDM/AlgR.hs`](./src/Alg/HDM/AlgR.hs)
39 |   - *Roger Bosman, Georgios Karachalias, Tom Schrijvers.* **No Unification Variable Left Behind: Fully Grounding Type Inference for the HDM System.** ITP 2023.
40 |     [[Paper](https://drops.dagstuhl.de/entities/document/10.4230/LIPIcs.ITP.2023.8)]
41 | - [x] `Bounded`: [`./src/Alg/DK/Worklist/Bounded.hs`](./src/Alg/DK/Worklist/Bounded.hs)
42 |   - *Chen Cui, Shengyi Jiang, and Bruno C. d. S. Oliveira.* **Greedy Implicit Bounded Quantification.** OOPSLA 2023.
43 |     [[Paper](https://dl.acm.org/doi/10.1145/3622871)]
44 | - [x] `Contextual`: [`./src/Alg/Local/Contextual/Contextual.hs`](./src/Alg/Local/Contextual/Contextual.hs)
45 |   - *Xu Xue and Bruno C. d. S. Oliveira.* **Contextual Typing.** ICFP 2024.
46 |     [[Paper](https://dl.acm.org/doi/10.1145/3674655)]
47 | - [x] `IU`: [`./src/Alg/DK/Worklist/IU.hs`](./src/Alg/DK/Worklist/IU.hs)
48 |   - *Shengyi Jiang, Chen Cui and Bruno C. d. S. Oliveira.* **Bidirectional Higher-Rank Polymorphism with Intersection and Union Types.** POPL 2025.
49 |     [[Paper](https://i.cs.hku.hk/~bruno/papers/popl25_hrp.pdf)]
50 | 
51 | ## Contribution
52 | 
53 | Contributions are welcome! If you're interested in improving this project, please feel free to open an issue or submit a pull request.
54 | 
55 | ## License
56 | 
57 | This project is licensed under the MIT License.
58 | 
59 | ## Disclaim
60 | 
61 | This project is still in its early stages, and I am not an expert in either type inference or Haskell :) Please use it at your own risk (Some of the code was assisted by GitHub Copilot or ChatGPT). If you spot any issues or have suggestions, please open an issue to help improve the project.


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/app/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE LambdaCase #-}
 2 | 
 3 | module Main (main) where
 4 | 
 5 | import Alg
 6 | import Data.Foldable (find)
 7 | import Data.Tree.View (showTree)
 8 | import Opt (Option (..), options)
 9 | import Parser (parseTrm)
10 | import Print (showTreeHtml, toNodeInfoTree)
11 | import Syntax (Trm)
12 | import System.Console.GetOpt (ArgOrder (Permute), getOpt)
13 | import System.Environment (getArgs)
14 | 
15 | runAlg :: Bool -> String -> Trm -> String
16 | runAlg html algName = case algName of
17 |   "W" -> outTree runAlgW
18 |   "DK" -> outTree runDK
19 |   "Worklist" -> outStr runWorklist
20 |   "Elementary" -> outStr runElementary
21 |   "Bounded" -> outStr runBounded
22 |   "IU" -> outStr runIU
23 |   "Contextual" -> outTree runContextual
24 |   "R" -> outTree runAlgR
25 |   _ -> error $ "Invalid algorithm: " ++ algName
26 |   where
27 |     outStr alg tm = case alg tm of
28 |       Left err -> unlines err
29 |       Right msgs -> unlines msgs
30 |     outTree alg tm = case alg tm of
31 |       Left err -> err
32 |       Right tree -> (if html then showTreeHtml . toNodeInfoTree else showTree) tree
33 | 
34 | main :: IO ()
35 | main = do
36 |   args <- getArgs
37 |   case getOpt Permute options args of
38 |     (flags, [code], [])
39 |       | Just (Alg algName) <- find (\case Alg _ -> True; _ -> False) flags -> do
40 |           case parseTrm code of
41 |             Left err -> putStrLn err
42 |             Right tm -> putStrLn $ runAlg (Html `elem` flags) algName tm
43 |     (_, _, errs) -> print errs
44 | 


--------------------------------------------------------------------------------
/flake.lock:
--------------------------------------------------------------------------------
 1 | {
 2 |   "nodes": {
 3 |     "flake-utils": {
 4 |       "inputs": {
 5 |         "systems": "systems"
 6 |       },
 7 |       "locked": {
 8 |         "lastModified": 1731533236,
 9 |         "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
10 |         "owner": "numtide",
11 |         "repo": "flake-utils",
12 |         "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
13 |         "type": "github"
14 |       },
15 |       "original": {
16 |         "owner": "numtide",
17 |         "repo": "flake-utils",
18 |         "type": "github"
19 |       }
20 |     },
21 |     "ghc-wasm-meta": {
22 |       "inputs": {
23 |         "flake-utils": "flake-utils",
24 |         "nixpkgs": "nixpkgs"
25 |       },
26 |       "locked": {
27 |         "host": "gitlab.haskell.org",
28 |         "lastModified": 1734354225,
29 |         "narHash": "sha256-c7uY4XcZNO0krdOXtaoE/ZW7w38BjC3o9pQjrwfQrO8=",
30 |         "owner": "ghc",
31 |         "repo": "ghc-wasm-meta",
32 |         "rev": "f0faac335c6f5e967d1bdbfca5768232483fd2a8",
33 |         "type": "gitlab"
34 |       },
35 |       "original": {
36 |         "host": "gitlab.haskell.org",
37 |         "owner": "ghc",
38 |         "repo": "ghc-wasm-meta",
39 |         "type": "gitlab"
40 |       }
41 |     },
42 |     "nixpkgs": {
43 |       "locked": {
44 |         "lastModified": 1734119587,
45 |         "narHash": "sha256-AKU6qqskl0yf2+JdRdD0cfxX4b9x3KKV5RqA6wijmPM=",
46 |         "owner": "NixOS",
47 |         "repo": "nixpkgs",
48 |         "rev": "3566ab7246670a43abd2ffa913cc62dad9cdf7d5",
49 |         "type": "github"
50 |       },
51 |       "original": {
52 |         "owner": "NixOS",
53 |         "ref": "nixos-unstable",
54 |         "repo": "nixpkgs",
55 |         "type": "github"
56 |       }
57 |     },
58 |     "root": {
59 |       "inputs": {
60 |         "ghc-wasm-meta": "ghc-wasm-meta"
61 |       }
62 |     },
63 |     "systems": {
64 |       "locked": {
65 |         "lastModified": 1681028828,
66 |         "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
67 |         "owner": "nix-systems",
68 |         "repo": "default",
69 |         "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
70 |         "type": "github"
71 |       },
72 |       "original": {
73 |         "owner": "nix-systems",
74 |         "repo": "default",
75 |         "type": "github"
76 |       }
77 |     }
78 |   },
79 |   "root": "root",
80 |   "version": 7
81 | }
82 | 


--------------------------------------------------------------------------------
/flake.nix:
--------------------------------------------------------------------------------
 1 | {
 2 |   inputs = {
 3 |     ghc-wasm-meta.url = "gitlab:ghc/ghc-wasm-meta?host=gitlab.haskell.org";
 4 |   };
 5 |   outputs = inputs: inputs.ghc-wasm-meta.inputs.flake-utils.lib.eachDefaultSystem (system:
 6 |     let pkgs = inputs.ghc-wasm-meta.inputs.nixpkgs.legacyPackages.${system};
 7 |     in
 8 |     {
 9 |       devShells.default = pkgs.mkShell {
10 |         packages = [
11 |           inputs.ghc-wasm-meta.packages.${system}.all_9_6
12 |           (pkgs.haskell-language-server.override { supportedGhcVersions = ["96"]; })
13 |           pkgs.haskell.compiler.ghc96
14 |         ];
15 |       };
16 |     });
17 | }
18 | 


--------------------------------------------------------------------------------
/frontend/.gitignore:
--------------------------------------------------------------------------------
 1 | *.log
 2 | *.tgz
 3 | .DS_Store
 4 | .idea
 5 | .temp
 6 | .vite_opt_cache
 7 | .vscode
 8 | dist
 9 | cache
10 | temp
11 | examples-temp
12 | node_modules
13 | pnpm-global
14 | *.timestamp-*.mjs
15 | 


--------------------------------------------------------------------------------
/frontend/.vitepress/config.mts:
--------------------------------------------------------------------------------
 1 | import { defineConfig } from 'vitepress'
 2 | 
 3 | // https://vitepress.dev/reference/site-config
 4 | export default defineConfig({
 5 |   title: "Type Inference Zoo",
 6 |   description: "Type Inference Algorithm Collections",
 7 |   themeConfig: {
 8 |     // https://vitepress.dev/reference/default-theme-config
 9 |     nav: [
10 |       { text: 'Home', link: '/' },
11 |       { text: 'Playground', link: '/playground' },
12 |       { text: 'Reference', link: '/quick-reference' },
13 |       { text: 'Research', link: '/research' },
14 |     ],
15 | 
16 |     sidebar: [],
17 | 
18 |     socialLinks: [
19 |       { icon: 'github', link: 'https://github.com/cu1ch3n/type-inference-zoo' }
20 |     ],
21 | 
22 |     footer: {
23 |       message: 'Released under the <a href="https://github.com/cu1ch3n/type-inference-zoo/blob/main/LICENSE">MIT License</a>.',
24 |       copyright: 'Copyright © 2025 <a href="https://cuichen.cc/">Chen Cui</a>'
25 |     }
26 |   },
27 |   cleanUrls: true
28 | })
29 | 


--------------------------------------------------------------------------------
/frontend/.vitepress/theme/index.ts:
--------------------------------------------------------------------------------
 1 | // https://vitepress.dev/guide/custom-theme
 2 | import { h } from 'vue'
 3 | import type { Theme } from 'vitepress'
 4 | import DefaultTheme from 'vitepress/theme'
 5 | import './style.css'
 6 | import 'primeicons/primeicons.css';
 7 | import "@fontsource/iosevka";
 8 | import PrimeVue from 'primevue/config';
 9 | import Button from "primevue/button";
10 | import AutoComplete from "primevue/autocomplete";
11 | import SelectButton from 'primevue/selectbutton';
12 | import Textarea from 'primevue/textarea';
13 | import { definePreset } from '@primevue/themes';
14 | import Aura from '@primevue/themes/aura';
15 | 
16 | const MyPreset = definePreset(Aura, {
17 |   semantic: {
18 |     primary: {
19 |       50: '{blue.50}',
20 |       100: '{blue.100}',
21 |       200: '{blue.200}',
22 |       300: '{blue.300}',
23 |       400: '{blue.400}',
24 |       500: '{blue.500}',
25 |       600: '{blue.600}',
26 |       700: '{blue.700}',
27 |       800: '{blue.800}',
28 |       900: '{blue.900}',
29 |       950: '{blue.950}'
30 |     }
31 |   }
32 | });
33 | 
34 | 
35 | export default {
36 |   extends: DefaultTheme,
37 |   Layout: () => {
38 |     return h(DefaultTheme.Layout, null, {
39 |       // https://vitepress.dev/guide/extending-default-theme#layout-slots
40 |     })
41 |   },
42 |   enhanceApp({ app, router, siteData }) {
43 |     app.use(PrimeVue, {
44 |       theme: {
45 |         preset: MyPreset,
46 |         options: {
47 |           prefix: 'p',
48 |           darkModeSelector: '.dark',
49 |           cssLayer: false
50 |         }
51 |       }
52 |     });
53 |     app.component('Button', Button);
54 |     app.component('AutoComplete', AutoComplete);
55 |     app.component('SelectButton', SelectButton);
56 |     app.component('Textarea', Textarea);
57 |   }
58 | } satisfies Theme
59 | 


--------------------------------------------------------------------------------
/frontend/.vitepress/theme/style.css:
--------------------------------------------------------------------------------
  1 | /**
  2 |  * Customize default theme styling by overriding CSS variables:
  3 |  * https://github.com/vuejs/vitepress/blob/main/src/client/theme-default/styles/vars.css
  4 |  */
  5 | 
  6 | @tailwind base;
  7 | @tailwind components;
  8 | @tailwind utilities;
  9 | 
 10 | /**
 11 |  * Colors
 12 |  *
 13 |  * Each colors have exact same color scale system with 3 levels of solid
 14 |  * colors with different brightness, and 1 soft color.
 15 |  *
 16 |  * - `XXX-1`: The most solid color used mainly for colored text. It must
 17 |  *   satisfy the contrast ratio against when used on top of `XXX-soft`.
 18 |  *
 19 |  * - `XXX-2`: The color used mainly for hover state of the button.
 20 |  *
 21 |  * - `XXX-3`: The color for solid background, such as bg color of the button.
 22 |  *   It must satisfy the contrast ratio with pure white (#ffffff) text on
 23 |  *   top of it.
 24 |  *
 25 |  * - `XXX-soft`: The color used for subtle background such as custom container
 26 |  *   or badges. It must satisfy the contrast ratio when putting `XXX-1` colors
 27 |  *   on top of it.
 28 |  *
 29 |  *   The soft color must be semi transparent alpha channel. This is crucial
 30 |  *   because it allows adding multiple "soft" colors on top of each other
 31 |  *   to create a accent, such as when having inline code block inside
 32 |  *   custom containers.
 33 |  *
 34 |  * - `default`: The color used purely for subtle indication without any
 35 |  *   special meanings attached to it such as bg color for menu hover state.
 36 |  *
 37 |  * - `brand`: Used for primary brand colors, such as link text, button with
 38 |  *   brand theme, etc.
 39 |  *
 40 |  * - `tip`: Used to indicate useful information. The default theme uses the
 41 |  *   brand color for this by default.
 42 |  *
 43 |  * - `warning`: Used to indicate warning to the users. Used in custom
 44 |  *   container, badges, etc.
 45 |  *
 46 |  * - `danger`: Used to show error, or dangerous message to the users. Used
 47 |  *   in custom container, badges, etc.
 48 |  * -------------------------------------------------------------------------- */
 49 | 
 50 | :root {
 51 |   --vp-c-default-1: var(--vp-c-gray-1);
 52 |   --vp-c-default-2: var(--vp-c-gray-2);
 53 |   --vp-c-default-3: var(--vp-c-gray-3);
 54 |   --vp-c-default-soft: var(--vp-c-gray-soft);
 55 | 
 56 |   --vp-c-brand-1: var(--vp-c-indigo-1);
 57 |   --vp-c-brand-2: var(--vp-c-indigo-2);
 58 |   --vp-c-brand-3: var(--vp-c-indigo-3);
 59 |   --vp-c-brand-soft: var(--vp-c-indigo-soft);
 60 | 
 61 |   --vp-c-tip-1: var(--vp-c-brand-1);
 62 |   --vp-c-tip-2: var(--vp-c-brand-2);
 63 |   --vp-c-tip-3: var(--vp-c-brand-3);
 64 |   --vp-c-tip-soft: var(--vp-c-brand-soft);
 65 | 
 66 |   --vp-c-warning-1: var(--vp-c-yellow-1);
 67 |   --vp-c-warning-2: var(--vp-c-yellow-2);
 68 |   --vp-c-warning-3: var(--vp-c-yellow-3);
 69 |   --vp-c-warning-soft: var(--vp-c-yellow-soft);
 70 | 
 71 |   --vp-c-danger-1: var(--vp-c-red-1);
 72 |   --vp-c-danger-2: var(--vp-c-red-2);
 73 |   --vp-c-danger-3: var(--vp-c-red-3);
 74 |   --vp-c-danger-soft: var(--vp-c-red-soft);
 75 | }
 76 | 
 77 | /**
 78 |  * Component: Button
 79 |  * -------------------------------------------------------------------------- */
 80 | 
 81 | :root {
 82 |   --vp-button-brand-border: transparent;
 83 |   --vp-button-brand-text: var(--vp-c-white);
 84 |   --vp-button-brand-bg: var(--vp-c-brand-3);
 85 |   --vp-button-brand-hover-border: transparent;
 86 |   --vp-button-brand-hover-text: var(--vp-c-white);
 87 |   --vp-button-brand-hover-bg: var(--vp-c-brand-2);
 88 |   --vp-button-brand-active-border: transparent;
 89 |   --vp-button-brand-active-text: var(--vp-c-white);
 90 |   --vp-button-brand-active-bg: var(--vp-c-brand-1);
 91 | }
 92 | 
 93 | /**
 94 |  * Component: Home
 95 |  * -------------------------------------------------------------------------- */
 96 | 
 97 | :root {
 98 |   --vp-home-hero-name-color: transparent;
 99 |   --vp-home-hero-name-background: -webkit-linear-gradient(
100 |     120deg,
101 |     #bd34fe 30%,
102 |     #41d1ff
103 |   );
104 | 
105 |   --vp-home-hero-image-background-image: linear-gradient(
106 |     -45deg,
107 |     #bd34fe 50%,
108 |     #47caff 50%
109 |   );
110 |   --vp-home-hero-image-filter: blur(44px);
111 | }
112 | 
113 | @media (min-width: 640px) {
114 |   :root {
115 |     --vp-home-hero-image-filter: blur(56px);
116 |   }
117 | }
118 | 
119 | @media (min-width: 960px) {
120 |   :root {
121 |     --vp-home-hero-image-filter: blur(68px);
122 |   }
123 | }
124 | 
125 | /**
126 |  * Component: Custom Block
127 |  * -------------------------------------------------------------------------- */
128 | 
129 | :root {
130 |   --vp-custom-block-tip-border: transparent;
131 |   --vp-custom-block-tip-text: var(--vp-c-text-1);
132 |   --vp-custom-block-tip-bg: var(--vp-c-brand-soft);
133 |   --vp-custom-block-tip-code-bg: var(--vp-c-brand-soft);
134 | }
135 | 
136 | /**
137 |  * Component: Algolia
138 |  * -------------------------------------------------------------------------- */
139 | 
140 | .DocSearch {
141 |   --docsearch-primary-color: var(--vp-c-brand-1) !important;
142 | }
143 | 
144 | .cm-content, .cm-gutter { min-height: 100px !important; }
145 | .cm-gutters { margin: 1px; }
146 | .cm-scroller { overflow: auto; }
147 | .cm-wrap { border: 1px solid silver }
148 | 
149 | .code {
150 |   font-size: 1.5em !important;
151 |   font-family: 'Iosevka', monospace !important;
152 | }
153 | 
154 | .output {
155 |   font-size: 0.9em !important;
156 |   font-family: 'Iosevka', monospace !important;
157 | }
158 | 


--------------------------------------------------------------------------------
/frontend/index.md:
--------------------------------------------------------------------------------
 1 | ---
 2 | # https://vitepress.dev/reference/default-theme-home-page
 3 | layout: home
 4 | 
 5 | hero:
 6 |   name: "Type Inference Zoo"
 7 |   tagline: Explore with Type Inference Algorithms
 8 |   actions:
 9 |     - theme: brand
10 |       text: Playground
11 |       link: /playground
12 |     - theme: alt
13 |       text: Research
14 |       link: /research
15 |     - theme: alt
16 |       text: Github
17 |       link: https://github.com/cu1ch3n/type-inference-zoo
18 | 
19 | features:
20 |   - icon: 🕹️
21 |     title: Interactive Playground
22 |     details: Try out type inference examples and explore various algorithms directly in the browser. Hands-on experience made simple.
23 |   - icon: 🧩
24 |     title: Unified Syntax and Implmentation
25 |     details: A consistent syntax across multiple type inference algorithms—no need to waste time building new parsers or pretty printers.
26 |   - icon: 👩‍💻
27 |     title: Friendly to Language Implementers
28 |     details: Code is probably less ambiguous than the notation used in the paper and more approachable.
29 | 


--------------------------------------------------------------------------------
/frontend/package.json:
--------------------------------------------------------------------------------
 1 | {
 2 |   "devDependencies": {
 3 |     "autoprefixer": "^10.4.20",
 4 |     "postcss": "^8.4.49",
 5 |     "tailwindcss": "^3.4.17",
 6 |     "vitepress": "^1.5.0"
 7 |   },
 8 |   "scripts": {
 9 |     "docs:dev": "vitepress dev",
10 |     "docs:build": "vitepress build",
11 |     "docs:preview": "vitepress preview"
12 |   },
13 |   "dependencies": {
14 |     "@bjorn3/browser_wasi_shim": "^0.3.0",
15 |     "@fontsource/iosevka": "^5.1.0",
16 |     "@primevue/themes": "^4.2.5",
17 |     "primeicons": "^7.0.0",
18 |     "primevue": "^4.2.5",
19 |     "vue": "^3.5.13"
20 |   }
21 | }
22 | 


--------------------------------------------------------------------------------
/frontend/playground.md:
--------------------------------------------------------------------------------
  1 | <script setup>
  2 | import {onMounted, ref} from 'vue';
  3 | import {ConsoleStdout, WASI} from "@bjorn3/browser_wasi_shim";
  4 | 
  5 | const algorithms = ref(null);
  6 | const selectedAlgorithm = ref(null);
  7 | const autoFilteredAlg = ref([]);
  8 | 
  9 | const selectButtonValue = ref({ name: 'Paper' });
 10 | const selectButtonValues = ref([{ name: 'Paper' }, { name: 'Extended' }]);
 11 | 
 12 | const examples = ref(null);
 13 | const selectedExample = ref(null);
 14 | const autoFilteredEx = ref([]);
 15 | 
 16 | const code = ref('');
 17 | const output = ref('');
 18 | const loading = ref(false);
 19 | 
 20 | let wasmModule = null;
 21 | const outputBuffer = ref('');
 22 | 
 23 | async function loadWasmModule() {
 24 |     if (!wasmModule) {
 25 |         try {
 26 |             const response = await fetch('/bin.wasm');
 27 |             const bytes = await response.arrayBuffer();
 28 |             wasmModule = await WebAssembly.compile(bytes);
 29 |         } catch (error) {
 30 |             console.error('WASM module loading failed:', error);
 31 |             output.value = `WASM module loading failed: ${error.message}`;
 32 |         }
 33 |     }
 34 | }
 35 | 
 36 | async function runWasm(args) {
 37 |     loading.value = true;
 38 |     output.value = '';
 39 | 
 40 |     try {
 41 |         await loadWasmModule();
 42 | 
 43 |         const env = [];
 44 |         const fds = [
 45 |             null, // stdin
 46 |             ConsoleStdout.lineBuffered((msg) => {
 47 |                 outputBuffer.value += `${msg}\n`;
 48 |             }),
 49 |         ];
 50 | 
 51 |         const wasi = new WASI(args, env, fds);
 52 |         const instance = await WebAssembly.instantiate(wasmModule, {
 53 |             wasi_snapshot_preview1: wasi.wasiImport,
 54 |         });
 55 | 
 56 |         wasi.start(instance);
 57 |         output.value = outputBuffer.value;
 58 |         outputBuffer.value = '';
 59 |     } catch (error) {
 60 |         console.error('error running WASM:', error);
 61 |         output.value = `error running WASM: ${error.message}`;
 62 |     } finally {
 63 |         loading.value = false;
 64 |     }
 65 | }
 66 | 
 67 | function infer() {
 68 |     if (!selectedAlgorithm.value || !selectedAlgorithm.value.code) {
 69 |         output.value = 'Please select an algorithm';
 70 |         return;
 71 |     }
 72 | 
 73 |     const currentCode = code.value;
 74 |     const args = generateArgs(selectedAlgorithm.value.code, currentCode);
 75 |     runWasm(args);
 76 | }
 77 | 
 78 | function generateArgs(algorithmCode, inputCode) {
 79 |     switch (algorithmCode) {
 80 |         default:
 81 |             return ['infer', '--alg', algorithmCode, inputCode];
 82 |     }
 83 | }
 84 | 
 85 | onMounted(() => {
 86 |     algorithms.value = [
 87 |         { name: 'Algorithm W', code: 'W' },
 88 |         { name: 'Complete and Easy Bidirectional Typechecking for Higher-rank Polymorphism', code: 'DK' },
 89 |         { name: 'A Mechanical Formalization of Higher-Ranked Polymorphic Type Inference', code: 'Worklist' },
 90 |         { name: 'Elementary Type Inference', code: 'Elementary' },
 91 |         { name: 'Fully Grounding Type Inference for the HDM System', code: 'R' },
 92 |         { name: 'Greedy Implicit Bounded Quantification', code: 'Bounded' },
 93 |         { name: 'Contextual Typing', code: 'Contextual' },
 94 |         { name: 'Bidirectional Higher-Rank Polymorphism with Intersection and Union Types', code: 'IU' }
 95 |     ];
 96 |     examples.value = [
 97 |         { name: 'trivial application', code: '(\\x. x) 1' },
 98 |         { name: 'let', code: 'let id = \\x. x in id 1' },
 99 |         { name: 'let-polymorphism', code: 'let id = \\x. x in (id 1, id True)' },
100 |         { name: 'higher-rank', code: '(\\f. \\x. f x) : (forall a. a -> a) -> Int -> Int' },
101 |         { name: 'higher-rank bounded', code: '(\\f. \\x. f x) : (forall (a <: Int). a -> a) -> Int -> Int' },
102 |         { name: 'explicit type application', code: '(/\\a. (\\x. x) : a -> a) @ (forall a. a -> a)' },
103 |         { name: 'intersection types', code: '(\\f. f True) : ((Int -> Int) & (Bool -> Bool)) -> Bool' },
104 |     ];
105 | });
106 | 
107 | function searchAlgorithm(event) {
108 |     if (!event.query.trim().length) {
109 |         autoFilteredAlg.value = [...algorithms.value];
110 |     } else {
111 |         autoFilteredAlg.value = algorithms.value.filter((alg) => {
112 |             return alg.name.toLowerCase().startsWith(event.query.toLowerCase());
113 |         });
114 |     }
115 | }
116 | 
117 | function searchExample(event) {
118 |     if (!event.query.trim().length) {
119 |         autoFilteredEx.value = [...examples.value];
120 |     } else {
121 |         autoFilteredEx.value = examples.value.filter((ex) => {
122 |             return ex.name.toLowerCase().startsWith(event.query.toLowerCase());
123 |         });
124 |     }
125 | }
126 | 
127 | function handleExampleSelect(event) {
128 |   const selected = event.value;
129 |   if (selected && selected.code) {
130 |     code.value = selected.code;
131 |   }
132 | }
133 | 
134 | function handleCodeChange(event) {
135 |   code.value = event.target.value;
136 |   selectedExample.value = null;
137 | }
138 | 
139 | function toggle(e) {
140 |   var node = e.srcElement == undefined ? e.target : e.srcElement;
141 |   var id = node.getAttribute("id");
142 |   var children = document.getElementById("children_" + id),
143 |     cstyle = window.getComputedStyle(children),
144 |     cdispay = cstyle.getPropertyValue("display");
145 |   if (cdispay == "inline") {
146 |     document.getElementById("children_" + id).className = "hidden";
147 |     document.getElementById(id).className = "node interactive collapsed";
148 |   } else {
149 |     document.getElementById("children_" + id).className = "shown";
150 |     document.getElementById(id).className = "node interactive expanded";
151 |   }
152 | }
153 | 
154 | window.toggle = toggle;
155 | </script>
156 | 
157 | <style>
158 |   .node {
159 |   }
160 | /* 
161 |   .interactive:hover {
162 |     background-color: #CCC;
163 |   }
164 | 
165 |   .collapsed {
166 |     cursor: pointer;
167 |     color: grey;
168 |     font-weight: bold;
169 |   }
170 | 
171 |   .expanded {
172 |     cursor: pointer;
173 |     color: #009;
174 |     font-weight: bold;
175 |   }
176 | 
177 |   .fixed {
178 |     position: static !important;
179 |     color: black;
180 |   }
181 |  */
182 |   .shown {
183 |     display: inline;
184 |   }
185 | 
186 |   .hidden {
187 |     display: none;
188 |   }
189 | </style>
190 | 
191 | 
192 | <div class="flex flex-col gap-2 mb-4">
193 |     <label>Type Inference Algorithm</label>
194 |     <AutoComplete v-model="selectedAlgorithm" :suggestions="autoFilteredAlg" optionLabel="name"
195 |         placeholder="Select Algorithm" dropdown display="chip" @complete="searchAlgorithm($event)" />
196 | </div>
197 | 
198 | <div class="flex flex-col gap-2 mb-2">
199 |     <label>Example Program</label>
200 |     <div class="flex flex-wrap justify-between items-start gap-4 mb-4">
201 |         <AutoComplete v-model="selectedExample" :suggestions="autoFilteredEx" display="chip"
202 |                       dropdown optionLabel="name" placeholder="(Optional) Load Example"
203 |                       @complete="searchExample($event)"
204 |                       @option-select="handleExampleSelect"/>
205 |     </div>
206 | </div>
207 | 
208 | <div class="flex flex-col gap-2 mb-4">
209 |     <label>Input Program</label>
210 |     <Textarea v-model="code" class="code" rows="2" spellcheck="false" @input="handleCodeChange"/>
211 |     <div class="flex justify-end mb-4">
212 |         <Button :loading="loading" icon="pi pi-caret-right" label="Infer" type="button" @click="infer"/>
213 |     </div>
214 | </div>
215 | 
216 | <div class="flex flex-col gap-2 mb-4">
217 |     <label>Inference Output</label>
218 |     <pre class="output" v-html="output"></pre>
219 | </div>
220 | 


--------------------------------------------------------------------------------
/frontend/postcss.config.js:
--------------------------------------------------------------------------------
1 | module.exports = {
2 |   plugins: {
3 |     tailwindcss: {},
4 |     autoprefixer: {},
5 |   },
6 | }
7 | 


--------------------------------------------------------------------------------
/frontend/quick-reference.md:
--------------------------------------------------------------------------------
 1 | # Quick Reference
 2 | 
 3 | - Types:
 4 |   - `Int`
 5 |   - `Bool`
 6 |   - `Top`
 7 |   - `Bot`
 8 |   - `forall a. Type`
 9 |   - `forall (a <: Type). Type`
10 |   - `Type -> Type`
11 |   - `Type & Type`
12 |   - `Type | Type`
13 |   - `(Type, Type)`
14 | - Terms:
15 |   - Int literals: `0`, `1`, `2` ...
16 |   - Bool literals: `True` / `False`
17 |   - Lambda: `\x. x`
18 |   - Application: `(\x -> x) 1`
19 |   - Type annotation: `1 : Int`
20 |   - Type abstraction: `/\a. (\x -> x) : a -> a`
21 |   - Type application: `(\a. (\x -> x) : a -> a) @Int 3`
22 |   - Let: `let id = \x. x in id 1`
23 | 


--------------------------------------------------------------------------------
/frontend/research.md:
--------------------------------------------------------------------------------
 1 | # Research Works
 2 | 
 3 | The research works currently implemented in the [Type Inference Zoo](https://zoo.cuichen.cc/) are listed below. More will be added soon—stay tuned! The implementations are available in the project's GitHub repository. You can find the correspondence between the research papers and their implementations in the project’s [README](https://github.com/cu1ch3n/type-inference-zoo).
 4 | 
 5 | - *Robin Milner.* **A Theory of Type Polymorphism in Programming.** Journal of Computer and System Sciences, 1978.
 6 |     [[Paper](https://www.sciencedirect.com/science/article/pii/0022000078900144)]
 7 | - *Jana Dunfield and Neelakantan R. Krishnaswami.* **Complete and Easy Bidirectional Typechecking for Higher-rank Polymorphism.** ICFP 2013. 
 8 |     [[Paper](https://dl.acm.org/doi/10.1145/2500365.2500582)]
 9 | - *Jinxu Zhao, Bruno C. d. S. Oliveira, and Tom Schrijvers.* **A Mechanical Formalization of Higher-Ranked Polymorphic Type Inference.** ICFP 2019.
10 |     [[Paper](https://dl.acm.org/doi/10.1145/3341716)]
11 | - *Jinxu Zhao and Bruno C. d. S. Oliveira.* **Elementary Type Inference.** ECOOP 2022.
12 |     [[Paper](https://drops.dagstuhl.de/entities/document/10.4230/LIPIcs.ECOOP.2022.2)]
13 | - *Roger Bosman, Georgios Karachalias, Tom Schrijvers.* **No Unification Variable Left Behind: Fully Grounding Type Inference for the HDM System.** ITP 2023.
14 |     [[Paper](https://drops.dagstuhl.de/entities/document/10.4230/LIPIcs.ITP.2023.8)]
15 | - *Chen Cui, Shengyi Jiang, and Bruno C. d. S. Oliveira.* **Greedy Implicit Bounded Quantification.** OOPSLA 2023.
16 |     [[Paper](https://dl.acm.org/doi/10.1145/3622871)]
17 | - *Xu Xue and Bruno C. d. S. Oliveira.* **Contextual Typing.** ICFP 2024.
18 |     [[Paper](https://dl.acm.org/doi/10.1145/3674655)]
19 | - *Shengyi Jiang, Chen Cui and Bruno C. d. S. Oliveira.* **Bidirectional Higher-Rank Polymorphism with Intersection and Union Types.** POPL 2025.
20 |     [[Paper](https://i.cs.hku.hk/~bruno/papers/popl25_hrp.pdf)]
21 | 


--------------------------------------------------------------------------------
/frontend/tailwind.config.js:
--------------------------------------------------------------------------------
 1 | /** @type {import('tailwindcss').Config} */
 2 | module.exports = {
 3 |   content: [
 4 |     "./*.{vue,md}"
 5 |   ],
 6 |   theme: {
 7 |     extend: {},
 8 |   },
 9 |   plugins: [],
10 | }
11 | 
12 | 


--------------------------------------------------------------------------------
/package.yaml:
--------------------------------------------------------------------------------
 1 | name:                type-inference-zoo
 2 | version:             0.1.0.0
 3 | github:              "cu1ch3n/type-inference-zoo"
 4 | license:             MIT
 5 | author:              "Chen Cui"
 6 | maintainer:          "i@cuichen.cc"
 7 | copyright:           "2025 Chen Cui"
 8 | 
 9 | extra-source-files:
10 | - README.md
11 | - CHANGELOG.md
12 | 
13 | # Metadata used when publishing your package
14 | # synopsis:            Short description of your package
15 | # category:            Web
16 | 
17 | # To avoid duplicated efforts in documentation and dealing with the
18 | # complications of embedding Haddock markup inside cabal files, it is
19 | # common to point users to the README.md file.
20 | description:         Please see the README on GitHub at <https://github.com/cu1ch3n/type-inference-zoo#readme>
21 | 
22 | dependencies:
23 | - base >= 4.7 && < 5
24 | - containers
25 | - hspec
26 | - logict
27 | - megaparsec
28 | - mtl
29 | - parser-combinators
30 | - transformers
31 | - tree-view
32 | - unbound-generics
33 | 
34 | ghc-options:
35 | - -Wall
36 | - -Wcompat
37 | - -Widentities
38 | - -Wincomplete-record-updates
39 | - -Wincomplete-uni-patterns
40 | - -Wmissing-export-lists
41 | - -Wmissing-home-modules
42 | - -Wpartial-fields
43 | - -Wredundant-constraints
44 | 
45 | library:
46 |   source-dirs: src
47 | 
48 | executables:
49 |   type-inference-zoo-exe:
50 |     main:                Main.hs
51 |     source-dirs:         app
52 |     # ghc-options:
53 |     # - -threaded
54 |     # - -rtsopts
55 |     # - -with-rtsopts=-N
56 |     dependencies:
57 |     - type-inference-zoo
58 | 
59 | tests:
60 |   type-inference-zoo-test:
61 |     main:                Spec.hs
62 |     source-dirs:         test
63 |     # ghc-options:
64 |     # - -threaded
65 |     # - -rtsopts
66 |     # - -with-rtsopts=-N
67 |     dependencies:
68 |     - type-inference-zoo
69 | 


--------------------------------------------------------------------------------
/src/Alg.hs:
--------------------------------------------------------------------------------
 1 | module Alg
 2 |   ( module Alg.DK,
 3 |     module Alg.HDM,
 4 |     module Alg.Local,
 5 |   )
 6 | where
 7 | 
 8 | import Alg.DK
 9 | import Alg.HDM
10 | import Alg.Local
11 | 


--------------------------------------------------------------------------------
/src/Alg/DK.hs:
--------------------------------------------------------------------------------
1 | module Alg.DK
2 |   ( module Alg.DK.DK,
3 |     module Alg.DK.Worklist,
4 |   )
5 | where
6 | 
7 | import Alg.DK.DK
8 | import Alg.DK.Worklist
9 | 


--------------------------------------------------------------------------------
/src/Alg/DK/Common.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE PatternSynonyms #-}
 2 | 
 3 | module Alg.DK.Common (isAll, isAllB, isLam) where
 4 | 
 5 | import Syntax (Trm (..), Typ (..), pattern TAll)
 6 | 
 7 | isAll :: Typ -> Bool
 8 | isAll (TAll _) = True
 9 | isAll _ = False
10 | 
11 | isAllB :: Typ -> Bool
12 | isAllB (TAllB _ _) = True
13 | isAllB _ = False
14 | 
15 | isLam :: Trm -> Bool
16 | isLam (Lam _) = True
17 | isLam _ = False
18 | 


--------------------------------------------------------------------------------
/src/Alg/DK/DK.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances #-}
  2 | {-# LANGUAGE InstanceSigs #-}
  3 | {-# LANGUAGE LambdaCase #-}
  4 | {-# LANGUAGE PatternSynonyms #-}
  5 | 
  6 | module Alg.DK.DK (runDK) where
  7 | 
  8 | import Alg.DK.Common (isAll)
  9 | import Control.Monad.Error.Class (MonadError (throwError))
 10 | import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell))
 11 | import Data.Foldable (find)
 12 | import Data.List (intercalate)
 13 | import Data.Tree (Tree (..))
 14 | import Lib (InferMonad, break3, freshTVar, runInferMonad)
 15 | import Syntax (TmVar, Trm (..), TyVar, Typ (..), pattern TAll)
 16 | import Unbound.Generics.LocallyNameless (bind, fv, subst, unbind)
 17 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf)
 18 | 
 19 | data Entry
 20 |   = VarBnd TmVar Typ
 21 |   | TVarBnd TyVar
 22 |   | ETVarBnd TyVar
 23 |   | SETVarBnd TyVar Typ
 24 |   | Mark TyVar
 25 | 
 26 | type Ctx = [Entry]
 27 | 
 28 | instance Show Entry where
 29 |   show :: Entry -> String
 30 |   show (VarBnd x ty) = show x ++ ": " ++ show ty
 31 |   show (TVarBnd a) = show a
 32 |   show (ETVarBnd a) = "^" ++ show a
 33 |   show (SETVarBnd a ty) = "^" ++ show a ++ " = " ++ show ty
 34 |   show (Mark a) = "$" ++ show a
 35 | 
 36 | instance {-# OVERLAPPING #-} Show [Entry] where
 37 |   show :: [Entry] -> String
 38 |   show = intercalate ", " . map show . reverse
 39 | 
 40 | mono :: Typ -> Bool
 41 | mono TInt = True
 42 | mono TBool = True
 43 | mono (TVar _) = True
 44 | mono (ETVar _) = True
 45 | mono (TArr ty1 ty2) = mono ty1 && mono ty2
 46 | mono (TAll _) = False
 47 | mono ty = error $ "mono: not implemented for " ++ show ty
 48 | 
 49 | appCtxTyp :: Ctx -> Typ -> InferMonad Typ
 50 | appCtxTyp ctx ty = do
 51 |   lift $ tell ["Substituting: " ++ showAppCtxTypIn]
 52 |   case ty of
 53 |     TVar a -> ret $ TVar a
 54 |     TInt -> ret TInt
 55 |     TBool -> ret TBool
 56 |     ETVar a
 57 |       | Just (SETVarBnd _ ty') <- find (\case SETVarBnd a' _ -> a == a'; _ -> False) ctx -> ret ty'
 58 |       | otherwise -> ret $ ETVar a
 59 |     TArr ty1 ty2 -> do
 60 |       ty1' <- appCtxTyp ctx ty1
 61 |       ty2' <- appCtxTyp ctx ty2
 62 |       ret $ TArr ty1' ty2'
 63 |     TAll bnd -> do
 64 |       (a, ty') <- unbind bnd
 65 |       ty'' <- appCtxTyp ctx ty'
 66 |       ret $ TAll (bind a ty'')
 67 |     _ -> throwError $ "appCtxTyp: not implemented for " ++ show ty
 68 |   where
 69 |     showAppCtxTypIn = "[" ++ show ctx ++ "](" ++ show ty ++ ")"
 70 |     showAppCtxTyp ty' = "[" ++ show ctx ++ "](" ++ show ty ++ ") = " ++ show ty'
 71 | 
 72 |     ret :: Typ -> InferMonad Typ
 73 |     ret ty' = do
 74 |       lift $ tell ["Substituted: " ++ showAppCtxTyp ty']
 75 |       return ty'
 76 | 
 77 | before :: Ctx -> TyVar -> TyVar -> Bool
 78 | before ws a b =
 79 |   let (ws1, _) = break (\case ETVarBnd a' -> a == a'; _ -> False) ws
 80 |       (ws1', _) = break (\case ETVarBnd b' -> b == b'; _ -> False) ws
 81 |    in length ws1 > length ws1'
 82 | 
 83 | instL :: Ctx -> TyVar -> Typ -> InferMonad (Ctx, Tree String)
 84 | instL ctx a ty = do
 85 |   lift $ tell ["InstL: " ++ showInstLIn]
 86 |   case ty of
 87 |     ETVar b | before ctx a b -> do
 88 |       let (ctx1, _, ctx2) = break3 (\case ETVarBnd b' -> b == b'; _ -> False) ctx
 89 |       ret "InstLReach" (ctx1 ++ SETVarBnd b (ETVar a) : ctx2) []
 90 |     TArr ty1 ty2 -> do
 91 |       a1 <- freshTVar
 92 |       a2 <- freshTVar
 93 |       let (ctx1, _, ctx2) = break3 (\case ETVarBnd a' -> a == a'; _ -> False) ctx
 94 |           ctx' = ctx1 ++ SETVarBnd a (TArr (ETVar a1) (ETVar a2)) : ETVarBnd a1 : ETVarBnd a2 : ctx2
 95 |       (ctx'', tree1) <- instR ctx' ty1 a1
 96 |       ty2' <- appCtxTyp ctx'' ty2
 97 |       (ctx''', tree2) <- instL ctx'' a2 ty2'
 98 |       ret "InstLArr" ctx''' [tree1, tree2]
 99 |     TAll bnd -> do
100 |       (b, ty') <- unbind bnd
101 |       (ctx', tree) <- instL (TVarBnd b : ctx) a ty'
102 |       let (_, _, ctx2) = break3 (\case TVarBnd b' -> b == b'; _ -> False) ctx'
103 |       ret "InstLAllR" ctx2 [tree]
104 |     _ | mono ty -> do
105 |       let (ctx1, _, ctx2) = break3 (\case ETVarBnd a' -> a == a'; _ -> False) ctx
106 |       ret "InstLSolve" (ctx1 ++ SETVarBnd a ty : ctx2) []
107 |     _ -> throwError $ "No rule matching: " ++ showInstLIn
108 |   where
109 |     showInstLIn = show ctx ++ " |- ^" ++ show a ++ " :=< " ++ show ty
110 |     showInstL ctx' = showInstLIn ++ " -| " ++ show ctx'
111 | 
112 |     ret :: String -> Ctx -> [Tree String] -> InferMonad (Ctx, Tree String)
113 |     ret rule ctx' tree = do
114 |       lift $ tell ["InstL[" ++ rule ++ "]: " ++ showInstL ctx']
115 |       return (ctx', Node (rule ++ ": " ++ showInstL ctx') tree)
116 | 
117 | instR :: Ctx -> Typ -> TyVar -> InferMonad (Ctx, Tree String)
118 | instR ctx ty a = do
119 |   lift $ tell ["InstR: " ++ showInstRIn]
120 |   case ty of
121 |     ETVar b | before ctx a b -> do
122 |       let (ctx1, _, ctx2) = break3 (\case ETVarBnd b' -> b == b'; _ -> False) ctx
123 |       ret "InstRReach" (ctx1 ++ SETVarBnd b (ETVar a) : ctx2) []
124 |     TArr ty1 ty2 -> do
125 |       a1 <- freshTVar
126 |       a2 <- freshTVar
127 |       let (ctx1, _, ctx2) = break3 (\case ETVarBnd a' -> a == a'; _ -> False) ctx
128 |           ctx' = ctx1 ++ SETVarBnd a (TArr (ETVar a1) (ETVar a2)) : ETVarBnd a1 : ETVarBnd a2 : ctx2
129 |       (ctx'', tree1) <- instL ctx' a1 ty1
130 |       ty2' <- appCtxTyp ctx'' ty2
131 |       (ctx''', tree2) <- instR ctx'' ty2' a2
132 |       ret "InstRArr" ctx''' [tree1, tree2]
133 |     TAll bnd -> do
134 |       (b, ty') <- unbind bnd
135 |       let ty'' = subst b (ETVar b) ty'
136 |       (ctx', tree) <- instR (ETVarBnd b : Mark b : ctx) ty'' a
137 |       let (_, _, ctx2) = break3 (\case Mark b' -> b == b'; _ -> False) ctx'
138 |       ret "InstRAllL" ctx2 [tree]
139 |     _ | mono ty -> do
140 |       let (ctx1, _, ctx2) = break3 (\case ETVarBnd a' -> a == a'; _ -> False) ctx
141 |       ret "InstRSolve" (ctx1 ++ SETVarBnd a ty : ctx2) []
142 |     _ -> throwError $ "No rule matching: " ++ showInstRIn
143 |   where
144 |     showInstRIn = show ctx ++ " |- " ++ show ty ++ " :=< ^" ++ show a
145 |     showInstR ctx' = showInstRIn ++ " -| " ++ show ctx'
146 | 
147 |     ret :: String -> Ctx -> [Tree String] -> InferMonad (Ctx, Tree String)
148 |     ret rule ctx' tree = do
149 |       lift $ tell ["InstR[" ++ rule ++ "]: " ++ showInstR ctx']
150 |       return (ctx', Node (rule ++ ": " ++ showInstR ctx') tree)
151 | 
152 | sub :: Ctx -> Typ -> Typ -> InferMonad (Ctx, Tree String)
153 | sub ctx ty1 ty2 = do
154 |   lift $ tell ["Subtyping: " ++ showSubIn]
155 |   case (ty1, ty2) of
156 |     (TInt, TInt) -> ret "SubInt" ctx []
157 |     (TBool, TBool) -> ret "SubBool" ctx []
158 |     (TVar a, TVar b) | a == b -> ret "SubReflTVar" ctx []
159 |     (ETVar a, ETVar b) | a == b -> ret "SubReflETVar" ctx []
160 |     (TArr ty1' ty2', TArr ty1'' ty2'') -> do
161 |       (ctx1, tree1) <- sub ctx ty1'' ty1'
162 |       (ctx2, tree2) <- sub ctx1 ty2' ty2''
163 |       ret "SubArr" ctx2 [tree1, tree2]
164 |     (_, TAll bnd) -> do
165 |       -- it is always better to use SubAllR first
166 |       (a, ty2') <- unbind bnd
167 |       (ctx', tree) <- sub (TVarBnd a : ctx) ty1 ty2'
168 |       let (_, _, ctx2) = break3 (\case TVarBnd a' -> a == a'; _ -> False) ctx'
169 |       ret "SubAllR" ctx2 [tree]
170 |     (TAll bnd, _) | not (isAll ty2) -> do
171 |       -- of course ty2 is not forall
172 |       (a, ty1') <- unbind bnd
173 |       let ty1'' = subst a (ETVar a) ty1'
174 |       (ctx', tree) <- sub (ETVarBnd a : Mark a : ctx) ty1'' ty2
175 |       let (_, _, ctx2) = break3 (\case Mark a' -> a == a'; _ -> False) ctx'
176 |       ret "SubAllL" ctx2 [tree]
177 |     (ETVar a, _) | a `notElem` toListOf fv ty2 -> do
178 |       (ctx', tree) <- instL ctx a ty2
179 |       ret "SubInstL" ctx' [tree]
180 |     (_, ETVar a) | a `notElem` toListOf fv ty1 -> do
181 |       (ctx', tree) <- instR ctx ty1 a
182 |       ret "SubInstR" ctx' [tree]
183 |     _ -> throwError $ "No rule matching: " ++ showSubIn
184 |   where
185 |     showSubIn = show ctx ++ " |- " ++ show ty1 ++ " <: " ++ show ty2
186 |     showSub ctx' = showSubIn ++ " -| " ++ show ctx'
187 | 
188 |     ret :: String -> Ctx -> [Tree String] -> InferMonad (Ctx, Tree String)
189 |     ret rule ctx' tree = do
190 |       lift $ tell ["Subtype[" ++ rule ++ "]: " ++ showSub ctx']
191 |       return (ctx', Node (rule ++ ": " ++ showSub ctx') tree)
192 | 
193 | check :: Ctx -> Trm -> Typ -> InferMonad (Ctx, Tree String)
194 | check ctx tm ty = do
195 |   lift $ tell ["Checking: " ++ showCheckIn]
196 |   case (tm, ty) of
197 |     (LitInt _, TInt) -> ret "ChkLitInt" ctx []
198 |     (LitBool _, TBool) -> ret "ChkLitBool" ctx []
199 |     (Lam bnd, TArr ty1 ty2) -> do
200 |       (x, tm') <- unbind bnd
201 |       (ctx', tree) <- check (VarBnd x ty1 : ctx) tm' ty2
202 |       let (_, _, ctx2) = break3 (\case VarBnd x' _ -> x == x'; _ -> False) ctx'
203 |       ret "ChkLam" ctx2 [tree]
204 |     (tm', TAll bnd) -> do
205 |       (a, ty') <- unbind bnd
206 |       (ctx', tree) <- check (TVarBnd a : ctx) tm' ty'
207 |       let (_, _, ctx2) = break3 (\case TVarBnd a' -> a == a'; _ -> False) ctx'
208 |       ret "ChkAll" ctx2 [tree]
209 |     _ -> do
210 |       (ty1, ctx', tree1) <- infer ctx tm
211 |       ty1' <- appCtxTyp ctx' ty1
212 |       ty' <- appCtxTyp ctx' ty
213 |       (ctx'', tree2) <- sub ctx' ty1' ty'
214 |       ret "ChkSub" ctx'' [tree1, tree2]
215 |   where
216 |     showCheckIn = show ctx ++ " |- " ++ show tm ++ " <== " ++ show ty
217 |     showCheck ctx' = showCheckIn ++ " -| " ++ show ctx'
218 | 
219 |     ret :: String -> Ctx -> [Tree String] -> InferMonad (Ctx, Tree String)
220 |     ret rule ctx' tree = do
221 |       lift $ tell ["Checked[" ++ rule ++ "]: " ++ showCheck ctx']
222 |       return (ctx', Node (rule ++ ": " ++ showCheck ctx') tree)
223 | 
224 | infer :: Ctx -> Trm -> InferMonad (Typ, Ctx, Tree String)
225 | infer ctx tm = do
226 |   lift $ tell ["Inferring: " ++ showInferIn]
227 |   case tm of
228 |     Var x -> case find (\case VarBnd x' _ -> x == x'; _ -> False) ctx of
229 |       Just (VarBnd _ ty) -> ret "InfVar" ty ctx []
230 |       _ -> throwError $ "Variable" ++ show x ++ " not found in context: " ++ show ctx
231 |     Ann tm' ty -> do
232 |       (ctx', tree) <- check ctx tm' ty
233 |       ret "InfAnn" ty ctx' [tree]
234 |     LitInt _ -> ret "InfLitInt" TInt ctx []
235 |     LitBool _ -> ret "InfLitBool" TBool ctx []
236 |     Lam bnd -> do
237 |       (x, tm') <- unbind bnd
238 |       a <- freshTVar
239 |       b <- freshTVar
240 |       let ctx' = VarBnd x (ETVar a) : ETVarBnd b : ETVarBnd a : ctx
241 |       (ctx'', tree) <- check ctx' tm' (ETVar b)
242 |       let (_, _, ctx2) = break3 (\case VarBnd x' _ -> x == x'; _ -> False) ctx''
243 |       ret "InfLam" (TArr (ETVar a) (ETVar b)) ctx2 [tree]
244 |     App tm1 tm2 -> do
245 |       (ty1, ctx', tree1) <- infer ctx tm1
246 |       ty1' <- appCtxTyp ctx' ty1
247 |       (ty2, ctx'', tree2) <- inferApp ctx' ty1' tm2
248 |       ret "InfApp" ty2 ctx'' [tree1, tree2]
249 |     _ -> throwError $ "No rule matching: " ++ showInferIn
250 |   where
251 |     showInferIn = show ctx ++ " |- " ++ show tm
252 |     showInfer ty' ctx' = showInferIn ++ " ==> " ++ show ty' ++ " -| " ++ show ctx'
253 | 
254 |     ret :: String -> Typ -> Ctx -> [Tree String] -> InferMonad (Typ, Ctx, Tree String)
255 |     ret rule ty ctx' tree = do
256 |       lift $ tell ["Inferred[" ++ rule ++ "]: " ++ showInfer ty ctx']
257 |       return (ty, ctx', Node (rule ++ ": " ++ showInfer ty ctx') tree)
258 | 
259 | inferApp :: Ctx -> Typ -> Trm -> InferMonad (Typ, Ctx, Tree String)
260 | inferApp ctx ty tm = do
261 |   lift $ tell ["InferApp: " ++ showInferAppIn]
262 |   case ty of
263 |     TArr ty1 ty2 -> do
264 |       (ctx', tree) <- check ctx tm ty1
265 |       ret "InfAppArr" ty2 ctx' [tree]
266 |     ETVar a -> do
267 |       a1 <- freshTVar
268 |       a2 <- freshTVar
269 |       let (ctx1, _, ctx2) = break3 (\case ETVarBnd a' -> a == a'; _ -> False) ctx
270 |           ctx' = ctx1 ++ SETVarBnd a (TArr (ETVar a1) (ETVar a2)) : ETVarBnd a1 : ETVarBnd a2 : ctx2
271 |       (ctx'', tree) <- check ctx' tm (ETVar a1)
272 |       ret "InfAppETVar" (ETVar a2) ctx'' [tree]
273 |     TAll bnd -> do
274 |       (a, ty') <- unbind bnd
275 |       (ctx', tree) <- check ctx tm (subst a (ETVar a) ty')
276 |       ret "InfAppAll" (subst a (ETVar a) ty') ctx' [tree]
277 |     _ -> throwError $ "No rule matching: " ++ showInferAppIn
278 |   where
279 |     showInferAppIn = show ctx ++ " |- " ++ show tm ++ " * " ++ show ty
280 |     showInferApp ty' ctx' = showInferAppIn ++ " ==>> " ++ show ty' ++ " -| " ++ show ctx'
281 | 
282 |     ret :: String -> Typ -> Ctx -> [Tree String] -> InferMonad (Typ, Ctx, Tree String)
283 |     ret rule ty' ctx' trees = do
284 |       lift $ tell ["InferredApp[" ++ rule ++ "]: " ++ showInferApp ty' ctx']
285 |       return (ty', ctx', Node (rule ++ ": " ++ showInferApp ty' ctx') trees)
286 | 
287 | runDK :: Trm -> Either String (Tree String)
288 | runDK tm = case runInferMonad $ infer [] tm of
289 |   Left errs -> Left (intercalate "\n" errs)
290 |   Right ((_, _, tree), _) -> Right tree
291 | 


--------------------------------------------------------------------------------
/src/Alg/DK/Worklist.hs:
--------------------------------------------------------------------------------
 1 | module Alg.DK.Worklist
 2 |   ( module Alg.DK.Worklist.DK,
 3 |     module Alg.DK.Worklist.Elementary,
 4 |     module Alg.DK.Worklist.Bounded,
 5 |     module Alg.DK.Worklist.IU,
 6 |   )
 7 | where
 8 | 
 9 | import Alg.DK.Worklist.Bounded
10 | import Alg.DK.Worklist.DK
11 | import Alg.DK.Worklist.Elementary
12 | import Alg.DK.Worklist.IU
13 | 


--------------------------------------------------------------------------------
/src/Alg/DK/Worklist/Bounded.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances #-}
  2 | {-# LANGUAGE LambdaCase #-}
  3 | {-# LANGUAGE MultiParamTypeClasses #-}
  4 | 
  5 | module Alg.DK.Worklist.Bounded (runBounded) where
  6 | 
  7 | import Alg.DK.Common (isAllB, isLam)
  8 | import Alg.DK.Worklist.Common (Entry (..), Judgment (..), TBind (..), Worklist, initWL, runInfer, substWLOrd)
  9 | import Control.Monad.Except (MonadError (throwError))
 10 | import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell))
 11 | import Data.Foldable (find)
 12 | import Lib (InferMonad, freshTVar)
 13 | import Syntax (Trm (..), Typ (..))
 14 | import Unbound.Generics.LocallyNameless
 15 |   ( Fresh (fresh),
 16 |     Subst (subst),
 17 |     aeq,
 18 |     bind,
 19 |     fv,
 20 |     substBind,
 21 |     unbind,
 22 |   )
 23 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf)
 24 | 
 25 | mono :: Worklist -> Typ -> Bool
 26 | -- TODO: we should be careful about the wildcard when extending more types
 27 | mono _ TInt = True
 28 | mono _ TBool = True
 29 | mono ws (TArr ty1 ty2) = mono ws ty1 && mono ws ty2
 30 | mono _ (ETVar _) = True
 31 | mono ws (TVar a) = case find (\case WTVar a' (TVarBBind TTop) -> a == a'; _ -> False) ws of
 32 |   Just _ -> True
 33 |   Nothing -> False
 34 | mono _ _ = False
 35 | 
 36 | infer :: String -> Worklist -> InferMonad ()
 37 | infer rule ws = do
 38 |   lift $ tell [rule ++ ": " ++ show ws]
 39 |   case ws of
 40 |     [] -> return ()
 41 |     WTVar _ _ : ws' -> infer "GCTVar" ws'
 42 |     WVar _ _ : ws' -> infer "GCVar" ws'
 43 |     WJug (Sub TInt TInt) : ws' -> infer "SubReflInt" ws'
 44 |     WJug (Sub TBool TBool) : ws' -> infer "SubReflBool" ws'
 45 |     WJug (Sub (TVar a) (TVar b)) : ws' | a == b -> infer "SubReflTVar" ws'
 46 |     WJug (Sub (ETVar a) (ETVar b)) : ws' | a == b -> infer "SubReflETVar" ws'
 47 |     WJug (Sub (STVar a) (STVar b)) : ws' | a == b -> infer "SubReflSTVar" ws'
 48 |     WJug (Sub _ TTop) : ws' -> infer "SubTop" ws'
 49 |     WJug (Sub TBot _) : ws' -> infer "SubBot" ws'
 50 |     WJug (Sub ty1@(TVar a) ty2) : ws'
 51 |       | Just (WTVar _ (TVarBBind b)) <-
 52 |           find (\case WTVar a' _ -> a == a'; _ -> False) ws',
 53 |         not (aeq ty1 ty2),
 54 |         not (aeq b TTop) ->
 55 |           infer "SubTVarTrans" $ WJug (Sub b ty2) : ws'
 56 |     WJug (Sub ty1@(STVar a) ty2) : ws'
 57 |       | Just (WTVar _ (STVarBBind b)) <-
 58 |           find (\case WTVar a' _ -> a == a'; _ -> False) ws',
 59 |         not (aeq ty1 ty2),
 60 |         not (aeq b TTop) ->
 61 |           infer "SubSTVarTrans" $ WJug (Sub b ty2) : ws'
 62 |     WJug (Sub (TArr ty1 ty2) (TArr ty1' ty2')) : ws' ->
 63 |       infer "SubArr" $ WJug (Sub ty1' ty1) : WJug (Sub ty2 ty2') : ws'
 64 |     WJug (Sub (TAllB bnd b) ty2) : ws' | not (isAllB ty2) -> do
 65 |       -- ty2 is not Top as well
 66 |       (a, ty1) <- unbind bnd
 67 |       let ty1' = subst a (ETVar a) ty1
 68 |       infer "SubAllL" $
 69 |         WJug (Sub ty1' ty2)
 70 |           : WJug (Sub (ETVar a) b)
 71 |           : WTVar a ETVarBind
 72 |           : ws'
 73 |     WJug (Sub (TAllB bnd1 b1) (TAllB bnd2 b2)) : ws' -> do
 74 |       a <- freshTVar
 75 |       let ty1 = substBind bnd1 (ETVar a)
 76 |           ty2 = substBind bnd2 (ETVar a)
 77 |       infer "SubAll" $
 78 |         WJug (Sub ty1 ty2)
 79 |           : WJug (Sub b1 b2)
 80 |           : WJug (Sub b2 b1)
 81 |           : WTVar a (STVarBBind b1)
 82 |           : ws'
 83 |     WJug (Sub (ETVar a) ty) : ws'
 84 |       | a `notElem` toListOf fv ty,
 85 |         mono ws ty -> do
 86 |           ws'' <- substWLOrd a ty ws'
 87 |           infer "SubInstETVar" ws''
 88 |     WJug (Sub ty (ETVar a)) : ws'
 89 |       | a `notElem` toListOf fv ty,
 90 |         mono ws ty -> do
 91 |           ws'' <- substWLOrd a ty ws'
 92 |           infer "SubInstETVar" ws''
 93 |     WJug (Sub (ETVar a) ty@(TArr ty1 ty2)) : ws'
 94 |       | a `notElem` toListOf fv ty -> do
 95 |           a1 <- fresh a
 96 |           a2 <- fresh a
 97 |           ws'' <-
 98 |             substWLOrd a (TArr (ETVar a1) (ETVar a2)) $
 99 |               WTVar a1 ETVarBind : WTVar a2 ETVarBind : ws'
100 |           infer "SubSplitL" $ WJug (Sub (TArr (ETVar a1) (ETVar a2)) (TArr ty1 ty2)) : ws''
101 |     WJug (Sub ty@(TArr ty1 ty2) (ETVar a)) : ws'
102 |       | a `notElem` toListOf fv ty -> do
103 |           a1 <- fresh a
104 |           a2 <- fresh a
105 |           ws'' <-
106 |             substWLOrd a (TArr (ETVar a1) (ETVar a2)) $
107 |               WTVar a1 ETVarBind : WTVar a2 ETVarBind : ws'
108 |           infer "SubSplitR" $ WJug (Sub (TArr ty1 ty2) (TArr (ETVar a1) (ETVar a2))) : ws''
109 |     WJug End : ws' -> infer "End" ws'
110 |     WJug (Chk (Lam bnd) TTop) : ws' -> do
111 |       (x, e) <- unbind bnd
112 |       infer "ChkLamTop" $ WJug (Chk e TTop) : WVar x TBot : ws'
113 |     WJug (Chk (Lam bnd) (TArr ty1 ty2)) : ws' -> do
114 |       (x, e) <- unbind bnd
115 |       infer "ChkLam" $ WJug (Chk e ty2) : WVar x ty1 : ws'
116 |     entry@(WJug (Chk (Lam bnd) (ETVar a))) : ws' -> do
117 |       (x, e) <- unbind bnd
118 |       a1 <- fresh a
119 |       a2 <- fresh a
120 |       ws'' <-
121 |         substWLOrd a (TArr (ETVar a1) (ETVar a2)) $
122 |           entry : WJug (Chk e (ETVar a2)) : WVar x (ETVar a1) : ws'
123 |       infer "ChkLamSplit" ws''
124 |     WJug (Chk tm ty) : ws' | not $ isLam tm -> do
125 |       a <- freshTVar
126 |       infer "ChkSub" $ WJug (Inf tm (bind a (Sub (TVar a) ty))) : ws'
127 |     WJug (Inf (Var x) j) : ws' -> do
128 |       case find (\case WVar x' _ -> x == x'; _ -> False) ws' of
129 |         Just (WVar _ ty) -> infer "InfVar" $ WJug (substBind j ty) : ws'
130 |         _ -> throwError $ show x ++ " is not found"
131 |     WJug (Inf (Ann tm ty) j) : ws' ->
132 |       infer "InfAnn" $ WJug (Chk tm ty) : WJug (substBind j ty) : ws'
133 |     WJug (Inf (TLamB bnd b) j) : ws' -> do
134 |       (a, tm) <- unbind bnd
135 |       case tm of -- to make my life easier
136 |         Ann tm' ty ->
137 |           infer "InfTLam" $
138 |             WJug (Chk tm' ty)
139 |               : WTVar a (TVarBBind b)
140 |               : WJug (substBind j (TAllB (bind a ty) b))
141 |               : ws'
142 |         _ -> throwError $ show tm ++ " is not an annotated term"
143 |     WJug (Inf (LitInt _) j) : ws' ->
144 |       infer "InfLitInt" $ WJug (substBind j TInt) : ws'
145 |     WJug (Inf (LitBool _) j) : ws' ->
146 |       infer "InfLitBool" $ WJug (substBind j TBool) : ws'
147 |     WJug (Inf (App tm1 tm2) j) : ws' -> do
148 |       a <- freshTVar
149 |       b <- freshTVar
150 |       let j' = Inf tm1 $ bind a $ Match (TVar a) $ bind b $ InfApp (TVar b) tm2 j
151 |       infer "InfApp" $ WJug j' : ws'
152 |     WJug (Inf (TApp tm ty) j) : ws' -> do
153 |       a <- freshTVar
154 |       infer "InfTApp" $ WJug (Inf tm (bind a (InfTApp (TVar a) ty j))) : ws'
155 |     WJug (Inf (Lam bnd) j) : ws' -> do
156 |       a <- freshTVar
157 |       b <- freshTVar
158 |       (x, e) <- unbind bnd
159 |       infer "InfLam" $
160 |         WJug (Chk e (ETVar b))
161 |           : WVar x (ETVar a)
162 |           : WJug (substBind j (TArr (ETVar a) (ETVar b)))
163 |           : WTVar a ETVarBind
164 |           : WTVar b ETVarBind
165 |           : ws'
166 |     WJug (Match ty@(TArr _ _) j) : ws' ->
167 |       infer "MatchArr" $ WJug (substBind j ty) : ws'
168 |     WJug (Match TBot j) : ws' ->
169 |       infer "MatchBot" $ WJug (substBind j (TArr TBot TBot)) : ws'
170 |     WJug (Match (TAllB bnd b) j) : ws' -> do
171 |       (a, ty) <- unbind bnd
172 |       let j' = Match (subst a (ETVar a) ty) j
173 |       infer "MatchAll" $ WJug j' : WJug (Sub (ETVar a) b) : WTVar a ETVarBind : ws'
174 |     WJug (Match (TVar a) j) : ws'
175 |       | Just (WTVar _ (TVarBBind b)) <-
176 |           find (\case WTVar a' _ -> a == a'; _ -> False) ws' ->
177 |           infer "MatchTVar" $ WJug (Match b j) : ws'
178 |     entry@(WJug (Match (ETVar a) _)) : ws' -> do
179 |       a1 <- fresh a
180 |       a2 <- fresh a
181 |       ws'' <-
182 |         substWLOrd a (TArr (ETVar a1) (ETVar a2)) $
183 |           entry : WTVar a1 ETVarBind : WTVar a2 ETVarBind : ws'
184 |       infer "MatchETVar" ws''
185 |     WJug (InfApp (TArr ty1 ty2) tm j) : ws' ->
186 |       infer "InfApp" $ WJug (Chk tm ty1) : WJug (substBind j ty2) : ws'
187 |     WJug (InfTApp (TAllB bnd b) ty2 j) : ws' -> do
188 |       (a, ty1) <- unbind bnd
189 |       let j1 = substBind j (subst a ty2 ty1)
190 |           j2 = Sub ty2 b
191 |       infer "InfTAppAll" $ WJug j1 : WJug j2 : ws'
192 |     WJug (InfTApp TBot _ j) : ws' ->
193 |       infer "InfTAppBot" $ WJug (substBind j TBot) : ws'
194 |     WJug (InfTApp (TVar a) ty2 j) : ws'
195 |       | Just (WTVar _ (TVarBBind ty1)) <-
196 |           find (\case WTVar a' _ -> a == a'; _ -> False) ws' ->
197 |           infer "InfTAppTVar" $ WJug (InfTApp ty1 ty2 j) : ws'
198 |     _ -> throwError $ "No matching rule for " ++ show ws
199 | 
200 | runBounded :: Trm -> Either [String] [String]
201 | runBounded = runInfer infer . initWL
202 | 


--------------------------------------------------------------------------------
/src/Alg/DK/Worklist/Common.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveGeneric #-}
  2 | {-# LANGUAGE FlexibleInstances #-}
  3 | {-# LANGUAGE LambdaCase #-}
  4 | {-# LANGUAGE MultiParamTypeClasses #-}
  5 | 
  6 | module Alg.DK.Worklist.Common where
  7 | 
  8 | import Control.Monad.Error.Class (MonadError (throwError))
  9 | import Data.Data (Typeable)
 10 | import GHC.Generics (Generic)
 11 | import Lib (InferMonad, runInferMonad)
 12 | import Syntax (TmVar, Trm, TyVar, Typ)
 13 | import Unbound.Generics.LocallyNameless (Alpha, Bind, Subst, bind, fv, s2n, subst, unbind)
 14 | import Unbound.Generics.LocallyNameless.Fresh (FreshM, runFreshM)
 15 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf)
 16 | 
 17 | data Judgment
 18 |   = Sub Typ Typ
 19 |   | Chk Trm Typ
 20 |   | Inf Trm (Bind TyVar Judgment)
 21 |   | InfApp Typ Trm (Bind TyVar Judgment)
 22 |   | InfTApp Typ Typ (Bind TyVar Judgment)
 23 |   | Match Typ (Bind TyVar Judgment)
 24 |   | MatchUnion Typ Typ (Bind TyVar Judgment)
 25 |   | End
 26 |   deriving (Generic, Typeable)
 27 | 
 28 | data TBind
 29 |   = TVarBind
 30 |   | ETVarBind
 31 |   | STVarBind
 32 |   | TVarBBind Typ
 33 |   | STVarBBind Typ
 34 |   deriving (Generic, Typeable, Show)
 35 | 
 36 | data Entry
 37 |   = WTVar TyVar TBind
 38 |   | WVar TmVar Typ
 39 |   | WJug Judgment
 40 |   deriving (Generic, Typeable, Show)
 41 | 
 42 | type Worklist = [Entry]
 43 | 
 44 | instance Alpha Judgment
 45 | 
 46 | instance Alpha TBind
 47 | 
 48 | instance Alpha Entry
 49 | 
 50 | instance Subst Typ Judgment
 51 | 
 52 | instance Subst Typ TBind
 53 | 
 54 | instance Subst Typ Entry
 55 | 
 56 | substWL :: TyVar -> Typ -> [Entry] -> Worklist -> InferMonad Worklist
 57 | substWL a ty entries ws = case ws of
 58 |   [] -> throwError $ show a ++ "is not found"
 59 |   WTVar a' _ : ws' | a == a' -> return $ entries ++ ws'
 60 |   WTVar a' b : ws' -> do
 61 |     ws'' <- substWL a ty entries ws'
 62 |     return $ WTVar a' (subst a ty b) : ws''
 63 |   WVar x t : ws' -> do
 64 |     ws'' <- substWL a ty entries ws'
 65 |     return $ WVar x (subst a ty t) : ws''
 66 |   WJug c : ws' -> do
 67 |     ws'' <- substWL a ty entries ws'
 68 |     return $ WJug (subst a ty c) : ws''
 69 | 
 70 | before :: Worklist -> TyVar -> TyVar -> Bool
 71 | before ws a b =
 72 |   let (ws1, _) = break (\case WTVar a' _ -> a == a'; _ -> False) ws
 73 |       (ws1', _) = break (\case WTVar b' _ -> b == b'; _ -> False) ws
 74 |    in length ws1 > length ws1'
 75 | 
 76 | substWLOrdQuick :: [Entry] -> TyVar -> Typ -> Worklist -> InferMonad Worklist
 77 | substWLOrdQuick move a ty ws = case ws of
 78 |   [] -> throwError $ show a ++ "is not found"
 79 |   entry@(WTVar b ETVarBind) : ws'
 80 |     | a == b -> return $ move ++ ws'
 81 |     | b `notElem` toListOf fv ty -> do
 82 |         ws'' <- substWLOrdQuick move a ty ws'
 83 |         return $ entry : ws''
 84 |     | otherwise -> substWLOrdQuick (entry : move) a ty ws'
 85 |   WTVar b bnd : ws'
 86 |     | b `notElem` toListOf fv ty -> do
 87 |         ws'' <- substWLOrdQuick move a ty ws'
 88 |         return $ WTVar b (subst a ty bnd) : ws''
 89 |     | otherwise -> throwError $ show b ++ " occurs in " ++ show ty
 90 |   WVar x t : ws' -> do
 91 |     ws'' <- substWLOrdQuick move a ty ws'
 92 |     return $ WVar x (subst a ty t) : ws''
 93 |   WJug c : ws' -> do
 94 |     ws'' <- substWLOrdQuick move a ty ws'
 95 |     return $ WJug (subst a ty c) : ws''
 96 | 
 97 | substWLOrd :: TyVar -> Typ -> Worklist -> InferMonad Worklist
 98 | substWLOrd = substWLOrdQuick []
 99 | 
100 | runInfer :: (String -> Worklist -> InferMonad a) -> Worklist -> Either [String] [String]
101 | runInfer infer ws = case runInferMonad $ infer "Init" ws of
102 |   Left errs -> Left errs
103 |   Right (_, msgs) -> Right msgs
104 | 
105 | initWL :: Trm -> [Entry]
106 | initWL tm = [WJug (Inf tm (bind (s2n "_") End))]
107 | 
108 | instance {-# OVERLAPPING #-} Show [Entry] where
109 |   show [] = "⋅"
110 |   show (WTVar a b : ws) =
111 |     show ws
112 |       ++ ", "
113 |       ++ case b of
114 |         TVarBind -> show a
115 |         ETVarBind -> "^" ++ show a
116 |         STVarBind -> "~" ++ show a
117 |         TVarBBind t -> show a ++ " <: " ++ show t
118 |         STVarBBind t -> "~" ++ show a ++ " <: " ++ show t
119 |   show (WVar x t : ws) = show ws ++ ", " ++ show x ++ ": " ++ show t
120 |   show (WJug c : ws) = show ws ++ " ||- " ++ show c
121 | 
122 | instance Show Judgment where
123 |   showsPrec prec jug = runFreshM $ showsPrecFresh prec jug
124 |     where
125 |       showsPrecFresh :: Int -> Judgment -> FreshM ShowS
126 |       showsPrecFresh _ (Sub t1 t2) = return $ shows t1 . showString " <: " . shows t2
127 |       showsPrecFresh _ (Chk e t) = return $ shows e . showString " <== " . shows t
128 |       showsPrecFresh _ (Inf e bnd) = do
129 |         (x, j) <- unbind bnd
130 |         j' <- showsPrecFresh 0 j
131 |         return $ shows e . showString " ==>" . shows x . showString " " . j'
132 |       showsPrecFresh _ (InfApp t e bnd) = do
133 |         (x, j) <- unbind bnd
134 |         j' <- showsPrecFresh 0 j
135 |         return $ shows t . showString " * " . shows e . showString " ==>>" . shows x . showString " " . j'
136 |       showsPrecFresh _ (InfTApp t1 t2 bnd) = do
137 |         (x, j) <- unbind bnd
138 |         j' <- showsPrecFresh 0 j
139 |         return $ shows t1 . showString " o " . shows t2 . showString " ==>>" . shows x . showString " " . j'
140 |       showsPrecFresh _ (Match t bnd) = do
141 |         (x, j) <- unbind bnd
142 |         j' <- showsPrecFresh 0 j
143 |         return $ shows t . showString " |>" . shows x . showString " " . j'
144 |       showsPrecFresh _ (MatchUnion t1 t2 bnd) = do
145 |         (x, j) <- unbind bnd
146 |         j' <- showsPrecFresh 0 j
147 |         return $ shows t1 . showString " \\/ " . shows t2 . showString " |>" . shows x . showString " " . j'
148 |       showsPrecFresh _ End = return $ showString "End"
149 | 


--------------------------------------------------------------------------------
/src/Alg/DK/Worklist/DK.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances #-}
  2 | {-# LANGUAGE LambdaCase #-}
  3 | {-# LANGUAGE MultiParamTypeClasses #-}
  4 | {-# LANGUAGE PatternSynonyms #-}
  5 | 
  6 | module Alg.DK.Worklist.DK where
  7 | 
  8 | import Alg.DK.Common (isAll)
  9 | import Alg.DK.Worklist.Common (Entry (..), Judgment (..), TBind (..), Worklist, before, initWL, runInfer, substWL)
 10 | import Control.Monad.Except (MonadError (throwError))
 11 | import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell))
 12 | import Data.Foldable (find)
 13 | import Lib (InferMonad, freshTVar)
 14 | import Syntax (Trm (..), Typ (..), pattern TAll)
 15 | import Unbound.Generics.LocallyNameless
 16 |   ( Fresh (fresh),
 17 |     Subst (subst),
 18 |     bind,
 19 |     fv,
 20 |     substBind,
 21 |     unbind,
 22 |   )
 23 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf)
 24 | 
 25 | infer :: String -> Worklist -> InferMonad ()
 26 | infer rule ws = do
 27 |   lift $ tell [rule ++ ": " ++ show ws]
 28 |   case ws of
 29 |     [] -> return ()
 30 |     WTVar _ _ : ws' -> infer "GCTVar" ws'
 31 |     WVar _ _ : ws' -> infer "GCVar" ws'
 32 |     WJug (Sub TInt TInt) : ws' -> infer "SubReflInt" ws'
 33 |     WJug (Sub TBool TBool) : ws' -> infer "SubReflBool" ws'
 34 |     WJug (Sub (TVar a) (TVar b)) : ws' | a == b -> infer "SubReflTVar" ws'
 35 |     WJug (Sub (ETVar a) (ETVar b)) : ws' | a == b -> infer "SubReflETVar" ws'
 36 |     WJug (Sub (TArr ty1 ty2) (TArr ty1' ty2')) : ws' ->
 37 |       infer "SubArr" $ WJug (Sub ty1' ty1) : WJug (Sub ty2 ty2') : ws'
 38 |     WJug (Sub (TAll bnd) ty2) : ws' | not (isAll ty2) -> do
 39 |       (a, ty1) <- unbind bnd
 40 |       let ty1' = subst a (ETVar a) ty1
 41 |       infer "SubAllL" $ WJug (Sub ty1' ty2) : WTVar a ETVarBind : ws'
 42 |     WJug (Sub ty1 (TAll bnd)) : ws' -> do
 43 |       (a, ty2) <- unbind bnd
 44 |       infer "SubAllR" $ WJug (Sub ty1 ty2) : WTVar a TVarBind : ws'
 45 |     WJug (Sub (ETVar a) ty@(TArr ty1 ty2)) : ws'
 46 |       | a `notElem` toListOf fv ty -> do
 47 |           a1 <- fresh a
 48 |           a2 <- fresh a
 49 |           ws'' <- substWL a (TArr (ETVar a1) (ETVar a2)) [WTVar a1 ETVarBind, WTVar a2 ETVarBind] ws'
 50 |           infer "SubSplitL" $ WJug (Sub (TArr (ETVar a1) (ETVar a2)) (TArr ty1 ty2)) : ws''
 51 |     WJug (Sub ty@(TArr ty1 ty2) (ETVar a)) : ws'
 52 |       | a `notElem` toListOf fv ty -> do
 53 |           a1 <- fresh a
 54 |           a2 <- fresh a
 55 |           ws'' <- substWL a (TArr (ETVar a1) (ETVar a2)) [WTVar a1 ETVarBind, WTVar a2 ETVarBind] ws'
 56 |           infer "SubSplitR" $ WJug (Sub (TArr ty1 ty2) (TArr (ETVar a1) (ETVar a2))) : ws''
 57 |     WJug (Sub (ETVar a) (ETVar b)) : ws' | before ws' a b -> do
 58 |       ws'' <- substWL b (ETVar a) [] ws'
 59 |       infer "SubInstETVar1" ws''
 60 |     WJug (Sub (ETVar b) (ETVar a)) : ws' | before ws' a b -> do
 61 |       ws'' <- substWL b (ETVar a) [] ws'
 62 |       infer "SubInstETVar2" ws''
 63 |     WJug (Sub (TVar a) (ETVar b)) : ws' | before ws' a b -> do
 64 |       ws'' <- substWL b (TVar a) [] ws'
 65 |       infer "SubInstETVar3" ws''
 66 |     WJug (Sub (ETVar b) (TVar a)) : ws' | before ws' a b -> do
 67 |       ws'' <- substWL b (ETVar a) [] ws'
 68 |       infer "SubInstETVar4" ws''
 69 |     WJug (Sub TInt (ETVar b)) : ws' -> do
 70 |       ws'' <- substWL b TInt [] ws'
 71 |       infer "SubInstETVar5" ws''
 72 |     WJug (Sub (ETVar b) TInt) : ws' -> do
 73 |       ws'' <- substWL b TInt [] ws'
 74 |       infer "SubInstETVar6" ws''
 75 |     WJug (Sub TBool (ETVar b)) : ws' -> do
 76 |       ws'' <- substWL b TBool [] ws'
 77 |       infer "SubInstETVar7" ws''
 78 |     WJug (Sub (ETVar b) TBool) : ws' -> do
 79 |       ws'' <- substWL b TBool [] ws'
 80 |       infer "SubInstETVar8" ws''
 81 |     WJug End : ws' -> infer "End" ws'
 82 |     WJug (Chk tm (TAll bnd)) : ws' -> do
 83 |       (a, ty) <- unbind bnd
 84 |       infer "ChkAll" $ WJug (Chk tm ty) : WTVar a TVarBind : ws'
 85 |     WJug (Chk (Lam bnd) (TArr ty1 ty2)) : ws' -> do
 86 |       (x, e) <- unbind bnd
 87 |       infer "ChkLam" $ WJug (Chk e ty2) : WVar x ty1 : ws'
 88 |     WJug (Chk (Lam bnd) (ETVar a)) : ws' -> do
 89 |       (x, e) <- unbind bnd
 90 |       a1 <- fresh a
 91 |       a2 <- fresh a
 92 |       ws'' <-
 93 |         substWL a (TArr (ETVar a1) (ETVar a2)) [WTVar a1 ETVarBind, WTVar a2 ETVarBind] $
 94 |           WJug (Chk e (ETVar a2)) : WVar x (ETVar a1) : ws'
 95 |       infer "ChkLamSplit" ws''
 96 |     WJug (Chk tm ty) : ws' -> do
 97 |       a <- freshTVar
 98 |       infer "ChkSub" $ WJug (Inf tm (bind a (Sub (TVar a) ty))) : ws'
 99 |     WJug (Inf (Var x) j) : ws' -> do
100 |       case find (\case WVar x' _ -> x == x'; _ -> False) ws' of
101 |         Just (WVar _ ty) -> infer "InfVar" $ WJug (substBind j ty) : ws'
102 |         _ -> throwError $ show x ++ " is not found"
103 |     WJug (Inf (Ann tm ty) j) : ws' ->
104 |       infer "InfAnn" $ WJug (Chk tm ty) : WJug (substBind j ty) : ws'
105 |     WJug (Inf (LitInt _) j) : ws' ->
106 |       infer "InfLitInt" $ WJug (substBind j TInt) : ws'
107 |     WJug (Inf (LitBool _) j) : ws' ->
108 |       infer "InfLitBool" $ WJug (substBind j TBool) : ws'
109 |     WJug (Inf (Lam bnd) j) : ws' -> do
110 |       a <- freshTVar
111 |       b <- freshTVar
112 |       (x, e) <- unbind bnd
113 |       infer "InfLam" $
114 |         WJug (Chk e (ETVar b))
115 |           : WVar x (ETVar a)
116 |           : WJug (substBind j (TArr (ETVar a) (ETVar b)))
117 |           : WTVar a ETVarBind
118 |           : WTVar b ETVarBind
119 |           : ws'
120 |     WJug (Inf (App tm1 tm2) j) : ws' -> do
121 |       a <- freshTVar
122 |       infer "InfApp" $ WJug (Inf tm1 (bind a (InfApp (TVar a) tm2 j))) : ws'
123 |     WJug (InfApp (TAll bnd) tm j) : ws' -> do
124 |       (a, ty) <- unbind bnd
125 |       infer "InfAppAll" $ WJug (InfApp (subst a (ETVar a) ty) tm j) : WTVar a ETVarBind : ws'
126 |     WJug (InfApp (TArr ty1 ty2) tm j) : ws' ->
127 |       infer "InfAppArr" $ WJug (Chk tm ty1) : WJug (substBind j ty2) : ws'
128 |     WJug (InfApp (ETVar a) tm j) : ws' -> do
129 |       a1 <- fresh a
130 |       a2 <- fresh a
131 |       ws'' <-
132 |         substWL a (TArr (ETVar a1) (ETVar a2)) [WTVar a1 ETVarBind, WTVar a2 ETVarBind] $
133 |           WJug (InfApp (TArr (ETVar a1) (ETVar a2)) tm j) : ws'
134 |       infer "InfAppETVar" ws''
135 |     _ -> throwError $ "No matching rule for " ++ show ws
136 | 
137 | runWorklist :: Trm -> Either [String] [String]
138 | runWorklist = runInfer infer . initWL
139 | 


--------------------------------------------------------------------------------
/src/Alg/DK/Worklist/Elementary.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances #-}
  2 | {-# LANGUAGE LambdaCase #-}
  3 | {-# LANGUAGE MultiParamTypeClasses #-}
  4 | {-# LANGUAGE PatternSynonyms #-}
  5 | 
  6 | module Alg.DK.Worklist.Elementary (runElementary) where
  7 | 
  8 | import Alg.DK.Common (isAll)
  9 | import Alg.DK.Worklist.Common (Entry (..), Judgment (..), TBind (..), Worklist, before, initWL, runInfer, substWL)
 10 | import Control.Monad.Except (MonadError (throwError))
 11 | import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell))
 12 | import Data.Foldable (find)
 13 | import Lib (InferMonad, freshTVar)
 14 | import Syntax (Trm (..), Typ (..), pattern TAll, pattern TLam)
 15 | import Unbound.Generics.LocallyNameless
 16 |   ( Fresh (fresh),
 17 |     Subst (subst),
 18 |     bind,
 19 |     fv,
 20 |     substBind,
 21 |     unbind,
 22 |   )
 23 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf)
 24 | 
 25 | infer :: String -> Worklist -> InferMonad ()
 26 | infer rule ws = do
 27 |   lift $ tell [rule ++ ": " ++ show ws]
 28 |   case ws of
 29 |     [] -> return ()
 30 |     WTVar _ _ : ws' -> infer "GCTVar" ws'
 31 |     WVar _ _ : ws' -> infer "GCVar" ws'
 32 |     WJug (Sub TInt TInt) : ws' -> infer "SubReflInt" ws'
 33 |     WJug (Sub TBool TBool) : ws' -> infer "SubReflBool" ws'
 34 |     WJug (Sub (TVar a) (TVar b)) : ws' | a == b -> infer "SubReflTVar" ws'
 35 |     WJug (Sub (ETVar a) (ETVar b)) : ws' | a == b -> infer "SubReflETVar" ws'
 36 |     WJug (Sub (STVar a) (STVar b)) : ws' | a == b -> infer "SubReflSTVar" ws'
 37 |     WJug (Sub _ TTop) : ws' -> infer "SubTop" ws'
 38 |     WJug (Sub TBot _) : ws' -> infer "SubBot" ws'
 39 |     WJug (Sub (TArr ty1 ty2) (TArr ty1' ty2')) : ws' ->
 40 |       infer "SubArr" $ WJug (Sub ty1' ty1) : WJug (Sub ty2 ty2') : ws'
 41 |     WJug (Sub (TAll bnd) ty2) : ws' | not (isAll ty2) -> do
 42 |       -- ty2 is not Top as well
 43 |       (a, ty1) <- unbind bnd
 44 |       let ty1' = subst a (ETVar a) ty1
 45 |       infer "SubAllL" $ WJug (Sub ty1' ty2) : WTVar a ETVarBind : ws'
 46 |     WJug (Sub (TAll bnd1) (TAll bnd2)) : ws' -> do
 47 |       a <- freshTVar
 48 |       let ty1 = substBind bnd1 (ETVar a)
 49 |           ty2 = substBind bnd2 (ETVar a)
 50 |       infer "SubAll" $ WJug (Sub ty1 ty2) : WTVar a STVarBind : ws'
 51 |     WJug (Sub (ETVar a) ty@(TArr ty1 ty2)) : ws'
 52 |       | a `notElem` toListOf fv ty -> do
 53 |           a1 <- fresh a
 54 |           a2 <- fresh a
 55 |           ws'' <- substWL a (TArr (ETVar a1) (ETVar a2)) [WTVar a1 ETVarBind, WTVar a2 ETVarBind] ws'
 56 |           infer "SubSplitL" $ WJug (Sub (TArr (ETVar a1) (ETVar a2)) (TArr ty1 ty2)) : ws''
 57 |     WJug (Sub ty@(TArr ty1 ty2) (ETVar a)) : ws'
 58 |       | a `notElem` toListOf fv ty -> do
 59 |           a1 <- fresh a
 60 |           a2 <- fresh a
 61 |           ws'' <- substWL a (TArr (ETVar a1) (ETVar a2)) [WTVar a1 ETVarBind, WTVar a2 ETVarBind] ws'
 62 |           infer "SubSplitR" $ WJug (Sub (TArr ty1 ty2) (TArr (ETVar a1) (ETVar a2))) : ws''
 63 |     WJug (Sub (ETVar a) (ETVar b)) : ws' | before ws' a b -> do
 64 |       ws'' <- substWL b (ETVar a) [] ws'
 65 |       infer "SubInstETVar1" ws''
 66 |     WJug (Sub (ETVar b) (ETVar a)) : ws' | before ws' a b -> do
 67 |       ws'' <- substWL b (ETVar a) [] ws'
 68 |       infer "SubInstETVar2" ws''
 69 |     WJug (Sub (TVar a) (ETVar b)) : ws' | before ws' a b -> do
 70 |       ws'' <- substWL b (TVar a) [] ws'
 71 |       infer "SubInstETVar3" ws''
 72 |     WJug (Sub (ETVar b) (TVar a)) : ws' | before ws' a b -> do
 73 |       ws'' <- substWL b (ETVar a) [] ws'
 74 |       infer "SubInstETVar4" ws''
 75 |     WJug (Sub TInt (ETVar b)) : ws' -> do
 76 |       ws'' <- substWL b TInt [] ws'
 77 |       infer "SubInstETVar5" ws''
 78 |     WJug (Sub (ETVar b) TInt) : ws' -> do
 79 |       ws'' <- substWL b TInt [] ws'
 80 |       infer "SubInstETVar6" ws''
 81 |     WJug (Sub TBool (ETVar b)) : ws' -> do
 82 |       ws'' <- substWL b TBool [] ws'
 83 |       infer "SubInstETVar7" ws''
 84 |     WJug (Sub (ETVar b) TBool) : ws' -> do
 85 |       ws'' <- substWL b TBool [] ws'
 86 |       infer "SubInstETVar8" ws''
 87 |     WJug End : ws' -> infer "End" ws'
 88 |     WJug (Chk _ TTop) : ws' -> infer "ChkTop" ws'
 89 |     WJug (Chk tm (TAll bnd)) : ws' -> do
 90 |       (a, ty) <- unbind bnd
 91 |       infer "ChkAll" $ WJug (Chk tm ty) : WTVar a TVarBind : ws'
 92 |     WJug (Chk (Lam bnd) (TArr ty1 ty2)) : ws' -> do
 93 |       (x, e) <- unbind bnd
 94 |       infer "ChkLam" $ WJug (Chk e ty2) : WVar x ty1 : ws'
 95 |     WJug (Chk (Lam bnd) (ETVar a)) : ws' -> do
 96 |       (x, e) <- unbind bnd
 97 |       a1 <- fresh a
 98 |       a2 <- fresh a
 99 |       ws'' <-
100 |         substWL a (TArr (ETVar a1) (ETVar a2)) [WTVar a1 ETVarBind, WTVar a2 ETVarBind] $
101 |           WJug (Chk e (ETVar a2)) : WVar x (ETVar a1) : ws'
102 |       infer "ChkLamSplit" ws''
103 |     WJug (Chk tm ty) : ws' -> do
104 |       a <- freshTVar
105 |       infer "ChkSub" $ WJug (Inf tm (bind a (Sub (TVar a) ty))) : ws'
106 |     WJug (Inf (Var x) j) : ws' -> do
107 |       case find (\case WVar x' _ -> x == x'; _ -> False) ws' of
108 |         Just (WVar _ ty) -> infer "InfVar" $ WJug (substBind j ty) : ws'
109 |         _ -> throwError $ show x ++ " is not found"
110 |     WJug (Inf (Ann tm ty) j) : ws' ->
111 |       infer "InfAnn" $ WJug (Chk tm ty) : WJug (substBind j ty) : ws'
112 |     WJug (Inf (TLam bnd) j) : ws' -> do
113 |       (a, tm) <- unbind bnd
114 |       case tm of -- to make my life easier
115 |         Ann tm' ty ->
116 |           infer "InfTLam" $
117 |             WJug (Chk tm' ty)
118 |               : WTVar a TVarBind
119 |               : WJug (substBind j (TAll (bind a ty)))
120 |               : ws'
121 |         _ -> throwError $ show tm ++ " is not an annotated term"
122 |     WJug (Inf (LitInt _) j) : ws' ->
123 |       infer "InfLitInt" $ WJug (substBind j TInt) : ws'
124 |     WJug (Inf (LitBool _) j) : ws' ->
125 |       infer "InfLitBool" $ WJug (substBind j TBool) : ws'
126 |     WJug (Inf (Lam bnd) j) : ws' -> do
127 |       a <- freshTVar
128 |       b <- freshTVar
129 |       (x, e) <- unbind bnd
130 |       infer "InfLam" $
131 |         WJug (Chk e (ETVar b))
132 |           : WVar x (ETVar a)
133 |           : WJug (substBind j (TArr (ETVar a) (ETVar b)))
134 |           : WTVar a ETVarBind
135 |           : WTVar b ETVarBind
136 |           : ws'
137 |     WJug (Inf (App tm1 tm2) j) : ws' -> do
138 |       a <- freshTVar
139 |       infer "InfApp" $ WJug (Inf tm1 (bind a (InfApp (TVar a) tm2 j))) : ws'
140 |     WJug (Inf (TApp tm ty) j) : ws' -> do
141 |       a <- freshTVar
142 |       infer "InfTApp" $ WJug (Inf tm (bind a (InfTApp (TVar a) ty j))) : ws'
143 |     WJug (InfTApp (TAll bnd) ty2 j) : ws' -> do
144 |       (a, ty1) <- unbind bnd
145 |       infer "InfTAppAll" $ WJug (substBind j (subst a ty2 ty1)) : ws'
146 |     WJug (InfTApp TBot _ j) : ws' ->
147 |       infer "InfTAppBot" $ WJug (substBind j TBot) : ws'
148 |     WJug (InfApp (TAll bnd) tm j) : ws' -> do
149 |       (a, ty) <- unbind bnd
150 |       infer "InfAppAll" $ WJug (InfApp (subst a (ETVar a) ty) tm j) : WTVar a ETVarBind : ws'
151 |     WJug (InfApp (TArr ty1 ty2) tm j) : ws' ->
152 |       infer "InfAppArr" $ WJug (Chk tm ty1) : WJug (substBind j ty2) : ws'
153 |     WJug (InfApp TBot _ j) : ws' ->
154 |       infer "InfAppBot" $ WJug (substBind j TBot) : ws'
155 |     WJug (InfApp (ETVar a) tm j) : ws' -> do
156 |       a1 <- fresh a
157 |       a2 <- fresh a
158 |       ws'' <-
159 |         substWL a (TArr (ETVar a1) (ETVar a2)) [WTVar a1 ETVarBind, WTVar a2 ETVarBind] $
160 |           WJug (InfApp (TArr (ETVar a1) (ETVar a2)) tm j) : ws'
161 |       infer "InfAppETVar" ws''
162 |     _ -> throwError $ "No matching rule for " ++ show ws
163 | 
164 | runElementary :: Trm -> Either [String] [String]
165 | runElementary = runInfer infer . initWL
166 | 


--------------------------------------------------------------------------------
/src/Alg/DK/Worklist/IU.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances #-}
  2 | {-# LANGUAGE LambdaCase #-}
  3 | {-# LANGUAGE MultiParamTypeClasses #-}
  4 | {-# LANGUAGE PatternSynonyms #-}
  5 | 
  6 | -- TODO: need more test
  7 | 
  8 | module Alg.DK.Worklist.IU (runIU) where
  9 | 
 10 | import Alg.DK.Worklist.Common (Entry (..), Judgment (..), TBind (..), Worklist, initWL, substWLOrd)
 11 | import Control.Monad (msum, mzero)
 12 | import Control.Monad.Except (MonadError (throwError))
 13 | import Control.Monad.Logic (LogicT, observeT)
 14 | import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell))
 15 | import Data.Foldable (find)
 16 | import Lib (InferMonad, freshTVar, runInferMonad)
 17 | import Syntax (Trm (..), Typ (..), pattern TAll, pattern TLam)
 18 | import Unbound.Generics.LocallyNameless
 19 |   ( Fresh (fresh),
 20 |     Subst (subst),
 21 |     bind,
 22 |     fv,
 23 |     substBind,
 24 |     unbind,
 25 |   )
 26 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf)
 27 | 
 28 | notAll :: Typ -> Bool
 29 | -- TODO: we should be careful about the wildcard when extending more types
 30 | notAll TInt = True
 31 | notAll TBool = True
 32 | notAll TTop = True
 33 | notAll TBot = False
 34 | notAll (TArr _ _) = True
 35 | notAll (TVar _) = True
 36 | notAll (ETVar _) = True
 37 | notAll (STVar _) = False
 38 | notAll (TAll _) = False
 39 | notAll (TIntersection ty1 ty2) = notAll ty1 && notAll ty2
 40 | notAll (TUnion ty1 ty2) = notAll ty1 || notAll ty2
 41 | notAll _ = False
 42 | 
 43 | mono :: Typ -> Bool
 44 | mono TInt = True
 45 | mono TBool = True
 46 | mono TTop = False
 47 | mono TBot = False
 48 | mono (TArr ty1 ty2) = mono ty1 && mono ty2
 49 | mono (TVar _) = True
 50 | mono (ETVar _) = True
 51 | mono (STVar _) = False
 52 | mono (TAll _) = False
 53 | mono (TIntersection _ _) = False
 54 | mono (TUnion _ _) = False
 55 | mono _ = False
 56 | 
 57 | infer :: Worklist -> LogicT InferMonad [(String, Worklist)]
 58 | infer ws = do
 59 |   lift $ tell [show ws]
 60 |   case ws of
 61 |     [] -> ret "empty" []
 62 |     WTVar _ _ : ws' -> retInf "GCTVar" ws'
 63 |     WVar _ _ : ws' -> retInf "GCVar" ws'
 64 |     WJug (Sub TInt TInt) : ws' -> retInf "SubReflInt" ws'
 65 |     WJug (Sub TBool TBool) : ws' -> retInf "SubReflBool" ws'
 66 |     WJug (Sub (TVar a) (TVar b)) : ws' | a == b -> retInf "SubReflTVar" ws'
 67 |     WJug (Sub (ETVar a) (ETVar b)) : ws' | a == b -> retInf "SubReflETVar" ws'
 68 |     WJug (Sub (STVar a) (STVar b)) : ws' | a == b -> retInf "SubReflSTVar" ws'
 69 |     WJug (Sub _ TTop) : ws' -> retInf "SubTop" ws'
 70 |     WJug (Sub TBot _) : ws' -> retInf "SubBot" ws'
 71 |     WJug (Sub (TArr ty1 ty2) (TArr ty1' ty2')) : ws' ->
 72 |       retInf "SubArr" $ WJug (Sub ty1' ty1) : WJug (Sub ty2 ty2') : ws'
 73 |     WJug (Sub (TAll bnd1) (TAll bnd2)) : ws' -> do
 74 |       a <- lift freshTVar
 75 |       let ty1 = substBind bnd1 (ETVar a)
 76 |           ty2 = substBind bnd2 (ETVar a)
 77 |       retInf "SubAll" $ WJug (Sub ty1 ty2) : WTVar a STVarBind : ws'
 78 |     WJug (Sub (ETVar a) ty) : ws'
 79 |       | a `notElem` toListOf fv ty,
 80 |         mono ty -> do
 81 |           ws'' <- lift $ substWLOrd a ty ws'
 82 |           retInf "SubInstETVar" ws''
 83 |     WJug (Sub ty (ETVar a)) : ws'
 84 |       | a `notElem` toListOf fv ty,
 85 |         mono ty -> do
 86 |           ws'' <- lift $ substWLOrd a ty ws'
 87 |           retInf "SubInstETVar" ws''
 88 |     WJug (Sub (ETVar a) ty@(TArr ty1 ty2)) : ws'
 89 |       | a `notElem` toListOf fv ty,
 90 |         not $ mono ty -> do
 91 |           a1 <- lift $ fresh a
 92 |           a2 <- lift $ fresh a
 93 |           ws'' <-
 94 |             lift $
 95 |               substWLOrd a (TArr (ETVar a1) (ETVar a2)) $
 96 |                 WTVar a1 ETVarBind : WTVar a2 ETVarBind : ws'
 97 |           retInf "SubSplitL" $ WJug (Sub (TArr (ETVar a1) (ETVar a2)) (TArr ty1 ty2)) : ws''
 98 |     WJug (Sub ty@(TArr ty1 ty2) (ETVar a)) : ws'
 99 |       | a `notElem` toListOf fv ty,
100 |         not $ mono ty -> do
101 |           a1 <- lift $ fresh a
102 |           a2 <- lift $ fresh a
103 |           ws'' <-
104 |             lift $
105 |               substWLOrd a (TArr (ETVar a1) (ETVar a2)) $
106 |                 WTVar a1 ETVarBind : WTVar a2 ETVarBind : ws'
107 |           retInf "SubSplitR" $ WJug (Sub (TArr ty1 ty2) (TArr (ETVar a1) (ETVar a2))) : ws''
108 |     WJug (Sub _ _) : _ ->
109 |       -- possibly overlapped rules; may need back-tracking
110 |       msum
111 |         [ ruleSubAllL,
112 |           ruleSubIntersectionL,
113 |           ruleSubIntersectionR,
114 |           ruleSubIntersection,
115 |           ruleSubUnionL,
116 |           ruleSubUnionR,
117 |           ruleSubUnion
118 |         ]
119 |     WJug End : ws' -> retInf "End" ws'
120 |     WJug (Chk (Lam bnd) TTop) : ws' -> do
121 |       (x, e) <- lift $ unbind bnd
122 |       retInf "ChkLamTop" $ WJug (Chk e TTop) : WVar x TBot : ws'
123 |     WJug (Chk (Lam bnd) (TArr ty1 ty2)) : ws' -> do
124 |       (x, e) <- lift $ unbind bnd
125 |       retInf "ChkLam" $ WJug (Chk e ty2) : WVar x ty1 : ws'
126 |     entry@(WJug (Chk (Lam bnd) (ETVar a))) : ws' -> do
127 |       (x, e) <- lift $ unbind bnd
128 |       a1 <- lift $ fresh a
129 |       a2 <- lift $ fresh a
130 |       ws'' <-
131 |         lift $
132 |           substWLOrd a (TArr (ETVar a1) (ETVar a2)) $
133 |             entry : WJug (Chk e (ETVar a2)) : WVar x (ETVar a1) : ws'
134 |       retInf "ChkLamSplit" ws''
135 |     WJug (Chk _ _) : _ ->
136 |       -- possibly overlapped rules; may need back-tracking
137 |       msum
138 |         [ ruleChkIntersection,
139 |           ruleChkUnionL,
140 |           ruleChkUnionR,
141 |           ruleChkSub
142 |         ]
143 |     WJug (Inf (Var x) j) : ws' -> do
144 |       case find (\case WVar x' _ -> x == x'; _ -> False) ws' of
145 |         Just (WVar _ ty) -> retInf "InfVar" $ WJug (substBind j ty) : ws'
146 |         _ -> throwError $ show x ++ " is not found"
147 |     WJug (Inf (Ann tm ty) j) : ws' ->
148 |       retInf "InfAnn" $ WJug (Chk tm ty) : WJug (substBind j ty) : ws'
149 |     WJug (Inf (TLam bnd) j) : ws' -> do
150 |       (a, tm) <- lift $ unbind bnd
151 |       case tm of -- to make my life easier
152 |         Ann tm' ty ->
153 |           retInf "InfTLam" $
154 |             WJug (Chk tm' ty)
155 |               : WTVar a TVarBind
156 |               : WJug (substBind j (TAll (bind a ty)))
157 |               : ws'
158 |         _ -> throwError $ show tm ++ " is not an annotated term"
159 |     WJug (Inf (LitInt _) j) : ws' ->
160 |       retInf "InfLitInt" $ WJug (substBind j TInt) : ws'
161 |     WJug (Inf (LitBool _) j) : ws' ->
162 |       retInf "InfLitBool" $ WJug (substBind j TBool) : ws'
163 |     WJug (Inf (App tm1 tm2) j) : ws' -> do
164 |       a <- lift freshTVar
165 |       b <- lift freshTVar
166 |       let j' = Inf tm1 $ bind a $ Match (TVar a) $ bind b $ InfApp (TVar b) tm2 j
167 |       retInf "InfApp" $ WJug j' : ws'
168 |     WJug (Inf (TApp tm ty) j) : ws' -> do
169 |       a <- lift freshTVar
170 |       retInf "InfTApp" $ WJug (Inf tm (bind a (InfTApp (TVar a) ty j))) : ws'
171 |     WJug (Inf (Lam bnd) j) : ws' -> do
172 |       a <- lift freshTVar
173 |       b <- lift freshTVar
174 |       (x, e) <- lift $ unbind bnd
175 |       retInf "InfLam" $
176 |         WJug (Chk e (ETVar b))
177 |           : WVar x (ETVar a)
178 |           : WJug (substBind j (TArr (ETVar a) (ETVar b)))
179 |           : WTVar a ETVarBind
180 |           : WTVar b ETVarBind
181 |           : ws'
182 |     WJug (Match ty@(TArr _ _) j) : ws' ->
183 |       retInf "MatchArr" $ WJug (substBind j ty) : ws'
184 |     WJug (Match TBot j) : ws' ->
185 |       retInf "MatchBot" $ WJug (substBind j (TArr TBot TBot)) : ws'
186 |     WJug (Match (TAll bnd) j) : ws' -> do
187 |       (a, ty) <- lift $ unbind bnd
188 |       let j' = Match (subst a (ETVar a) ty) j
189 |       retInf "MatchAll" $ WJug j' : WTVar a ETVarBind : ws'
190 |     entry@(WJug (Match (ETVar a) _)) : ws' -> do
191 |       a1 <- lift $ fresh a
192 |       a2 <- lift $ fresh a
193 |       ws'' <-
194 |         lift $
195 |           substWLOrd a (TArr (ETVar a1) (ETVar a2)) $
196 |             entry : WTVar a1 ETVarBind : WTVar a2 ETVarBind : ws'
197 |       retInf "MatchETVar" ws''
198 |     WJug (Match (TUnion ty1 ty2) j) : ws' -> do
199 |       a <- lift freshTVar
200 |       b <- lift freshTVar
201 |       let j' = Match ty1 $ bind a $ Match ty2 $ bind b $ MatchUnion (TVar a) (TVar b) j
202 |       retInf "MatchUnion" $ WJug j' : ws'
203 |     WJug (Match (TIntersection _ _) _) : _ ->
204 |       msum
205 |         [ ruleMatchIntersectionL,
206 |           ruleMatchIntersectionR
207 |         ]
208 |     WJug (MatchUnion (TArr ty1 ty1') (TArr ty2 ty2') j) : ws' ->
209 |       retInf "MatchUnionArr" $
210 |         WJug (substBind j (TArr (TIntersection ty1 ty2) (TUnion ty1' ty2'))) : ws'
211 |     WJug (InfApp (TArr ty1 ty2) tm j) : ws' ->
212 |       retInf "InfApp" $ WJug (Chk tm ty1) : WJug (substBind j ty2) : ws'
213 |     WJug (InfTApp (TAll bnd) ty2 j) : ws' ->
214 |       retInf "InfTAppAll" $ WJug (substBind j (substBind bnd ty2)) : ws'
215 |     WJug (InfTApp TBot _ j) : ws' ->
216 |       retInf "InfTAppBot" $ WJug (substBind j TBot) : ws'
217 |     WJug (InfTApp (TUnion ty1 ty2) ty j) : ws' -> do
218 |       a <- lift freshTVar
219 |       b <- lift freshTVar
220 |       let j' = InfTApp ty1 ty $ bind a $ InfTApp ty2 ty $ bind b $ substBind j (TUnion (TVar a) (TVar b))
221 |       retInf "InfTAppUnion" $ WJug j' : ws'
222 |     WJug (InfTApp (TIntersection _ _) _ _) : _ ->
223 |       msum
224 |         [ ruleInfTAppIntersectionL,
225 |           ruleInfTAppIntersectionR
226 |         ]
227 |     _ -> return mzero
228 |   where
229 |     ret :: String -> [(String, Worklist)] -> LogicT InferMonad [(String, Worklist)]
230 |     ret rule logs = return $ (rule, ws) : logs
231 | 
232 |     retInf :: String -> Worklist -> LogicT InferMonad [(String, Worklist)]
233 |     retInf rule ws' = infer ws' >>= ret rule
234 | 
235 |     ruleSubAllL = case ws of
236 |       WJug (Sub (TAll bnd) ty2) : ws' | notAll ty2 -> do
237 |         (a, ty1) <- lift $ unbind bnd
238 |         let ty1' = subst a (ETVar a) ty1
239 |         retInf "SubAllL" $ WJug (Sub ty1' ty2) : WTVar a ETVarBind : ws'
240 |       _ -> mzero
241 | 
242 |     ruleSubIntersectionL = case ws of
243 |       WJug (Sub (TIntersection ty1 _) ty) : ws' ->
244 |         retInf "SubIntersectionL" $ WJug (Sub ty1 ty) : ws'
245 |       _ -> mzero
246 | 
247 |     ruleSubIntersectionR = case ws of
248 |       WJug (Sub ty (TIntersection _ ty2)) : ws' ->
249 |         retInf "SubIntersectionR" $ WJug (Sub ty ty2) : ws'
250 |       _ -> mzero
251 | 
252 |     ruleSubIntersection = case ws of
253 |       WJug (Sub ty (TIntersection ty1 ty2)) : ws' ->
254 |         retInf "SubIntersection" $ WJug (Sub ty ty1) : WJug (Sub ty ty2) : ws'
255 |       _ -> mzero
256 | 
257 |     ruleSubUnionL = case ws of
258 |       WJug (Sub ty (TUnion ty1 _)) : ws' ->
259 |         retInf "SubUnionL" $ WJug (Sub ty ty1) : ws'
260 |       _ -> mzero
261 | 
262 |     ruleSubUnionR = case ws of
263 |       WJug (Sub ty (TUnion _ ty2)) : ws' ->
264 |         retInf "SubUnionR" $ WJug (Sub ty ty2) : ws'
265 |       _ -> mzero
266 | 
267 |     ruleSubUnion = case ws of
268 |       WJug (Sub (TUnion ty1 ty2) ty) : ws' ->
269 |         retInf "SubUnion" $ WJug (Sub ty1 ty) : WJug (Sub ty2 ty) : ws'
270 |       _ -> mzero
271 | 
272 |     ruleChkIntersection = case ws of
273 |       WJug (Chk tm (TIntersection ty1 ty2)) : ws' ->
274 |         retInf "ChkIntersection" $ WJug (Chk tm ty1) : WJug (Chk tm ty2) : ws'
275 |       _ -> mzero
276 | 
277 |     ruleChkUnionL = case ws of
278 |       WJug (Chk tm (TUnion ty1 _)) : ws' ->
279 |         retInf "ChkUnionL" $ WJug (Chk tm ty1) : ws'
280 |       _ -> mzero
281 | 
282 |     ruleChkUnionR = case ws of
283 |       WJug (Chk tm (TUnion _ ty2)) : ws' ->
284 |         retInf "ChkUnionR" $ WJug (Chk tm ty2) : ws'
285 |       _ -> mzero
286 | 
287 |     ruleChkSub = case ws of
288 |       WJug (Chk tm ty) : ws' -> do
289 |         a <- lift freshTVar
290 |         retInf "ChkSub" $ WJug (Inf tm (bind a (Sub (TVar a) ty))) : ws'
291 |       _ -> mzero
292 | 
293 |     ruleMatchIntersectionL = case ws of
294 |       WJug (Match (TIntersection ty1 _) j) : ws' ->
295 |         retInf "MatchIntersectionL" $ WJug (Match ty1 j) : ws'
296 |       _ -> mzero
297 | 
298 |     ruleMatchIntersectionR = case ws of
299 |       WJug (Match (TIntersection _ ty2) j) : ws' ->
300 |         retInf "MatchIntersectionR" $ WJug (Match ty2 j) : ws'
301 |       _ -> mzero
302 | 
303 |     ruleInfTAppIntersectionL = case ws of
304 |       WJug (InfTApp (TIntersection ty1 _) ty j) : ws' ->
305 |         retInf "InfTAppIntersectionL" $ WJug (InfTApp ty1 ty j) : ws'
306 |       _ -> mzero
307 | 
308 |     ruleInfTAppIntersectionR = case ws of
309 |       WJug (InfTApp (TIntersection _ ty2) ty j) : ws' ->
310 |         retInf "InfTAppIntersectionR" $ WJug (InfTApp ty2 ty j) : ws'
311 |       _ -> mzero
312 | 
313 | runInfer :: Worklist -> Either [String] [String]
314 | runInfer ws = case runInferMonad $ observeT $ infer ws of
315 |   Left errs -> Left errs
316 |   Right (logs, _) -> Right $ map (\(rule, wl) -> rule ++ ": " ++ show wl) logs
317 | 
318 | runIU :: Trm -> Either [String] [String]
319 | runIU = runInfer . initWL
320 | 


--------------------------------------------------------------------------------
/src/Alg/HDM.hs:
--------------------------------------------------------------------------------
1 | module Alg.HDM
2 |   ( module Alg.HDM.AlgR,
3 |     module Alg.HDM.AlgW,
4 |   )
5 | where
6 | 
7 | import Alg.HDM.AlgR
8 | import Alg.HDM.AlgW
9 | 


--------------------------------------------------------------------------------
/src/Alg/HDM/AlgR.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances #-}
  2 | {-# LANGUAGE LambdaCase #-}
  3 | {-# LANGUAGE PatternSynonyms #-}
  4 | 
  5 | module Alg.HDM.AlgR (runAlgR) where
  6 | 
  7 | import Control.Monad.Except (MonadError (throwError))
  8 | import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell))
  9 | import Data.Bifunctor (bimap)
 10 | import Data.Foldable (find)
 11 | import Data.List (intercalate)
 12 | import Data.Tree (Tree (Node))
 13 | import Lib (InferMonad, freshTVar, runInferMonad)
 14 | import Syntax (TmVar, Trm (..), TyVar, Typ (..), pattern TAll)
 15 | import Unbound.Generics.LocallyNameless
 16 | 
 17 | type ExCtx = [TyVar]
 18 | 
 19 | data TyCtxEntry = TVarBnd TyVar | ExCtx ExCtx | VarBnd TmVar Typ | Invis ExCtx Typ
 20 | 
 21 | type TyCtx = [TyCtxEntry]
 22 | 
 23 | type TyEqs = [(Typ, Typ)]
 24 | 
 25 | showExCtx :: ExCtx -> String
 26 | showExCtx = intercalate ", " . map (\a -> "^" ++ show a) . reverse
 27 | 
 28 | showExCtxTyp :: ExCtx -> Typ -> String
 29 | showExCtxTyp exCtx ty = "[" ++ showExCtx exCtx ++ "]" ++ show ty
 30 | 
 31 | showTyEqs :: TyEqs -> String
 32 | showTyEqs = intercalate ", " . map (\(ty1, ty2) -> show ty1 ++ " ~ " ++ show ty2)
 33 | 
 34 | instance Show TyCtxEntry where
 35 |   show (TVarBnd a) = show a
 36 |   show (ExCtx exCtx) = "(" ++ showExCtx exCtx ++ ")"
 37 |   show (VarBnd x ty) = show x ++ " : " ++ show ty
 38 |   show (Invis exCtx ty) = "{" ++ showExCtxTyp exCtx ty ++ "}"
 39 | 
 40 | instance {-# OVERLAPPING #-} Show TyCtx where
 41 |   show = intercalate "; " . map show . reverse
 42 | 
 43 | mono :: Typ -> Bool
 44 | mono (TVar _) = True
 45 | mono (ETVar _) = True
 46 | mono TInt = True
 47 | mono TBool = True
 48 | mono (TArr ty1 ty2) = mono ty1 && mono ty2
 49 | mono ty = error $ "mono: not implemented for " ++ show ty
 50 | 
 51 | inst :: TyCtx -> Typ -> InferMonad (ExCtx, Typ, Tree String)
 52 | inst tyCtx ty = do
 53 |   lift $ tell ["Instantiating: " ++ showInput]
 54 |   case ty of
 55 |     (TAll bnd) -> do
 56 |       (a, ty') <- unbind bnd
 57 |       (exCtx, ty'', tree) <- inst (ExCtx [a] : tyCtx) (subst a (ETVar a) ty')
 58 |       ret "InstPoly" (a : exCtx) ty'' [tree]
 59 |     _ | mono ty -> ret "InstMono" [] ty []
 60 |     _ -> throwError $ "No rule matching: " ++ showInput
 61 |   where
 62 |     showInput = show tyCtx ++ " |- " ++ show ty
 63 |     showOutput exCtx' ty' = showInput ++ " >= " ++ showExCtxTyp exCtx' ty'
 64 | 
 65 |     ret :: String -> ExCtx -> Typ -> [Tree String] -> InferMonad (ExCtx, Typ, Tree String)
 66 |     ret rule exCtx' ty' trees = do
 67 |       lift $ tell ["Instantiated[" ++ rule ++ "]: " ++ showOutput exCtx' ty']
 68 |       return (exCtx', ty', Node (rule ++ ": " ++ showOutput exCtx' ty') trees)
 69 | 
 70 | gen :: TyCtx -> Trm -> InferMonad (Typ, TyCtx, Tree String)
 71 | gen tyCtx tm = do
 72 |   lift $ tell ["Generalizing: " ++ showInput]
 73 |   (exCtx, ty, tyCtx', tree) <- infer tyCtx tm
 74 |   let ty' = foldl (\ty'' a -> TAll $ bind a (subst a (TVar a) ty'')) ty exCtx
 75 |   lift $ tell ["Generalized: " ++ showOutput ty' tyCtx']
 76 |   return (ty', tyCtx', Node ("Gen: " ++ showOutput ty' tyCtx') [tree])
 77 |   where
 78 |     showInput = show tyCtx ++ " |- " ++ show tm
 79 |     showOutput ty' tyCtx' = showInput ++ " : " ++ show ty' ++ " -| " ++ show tyCtx'
 80 | 
 81 | infer :: TyCtx -> Trm -> InferMonad (ExCtx, Typ, TyCtx, Tree String)
 82 | -- Note here the return Typ is actually mono
 83 | infer tyCtx tm = do
 84 |   lift $ tell ["Inferring: " ++ showInput]
 85 |   case tm of
 86 |     Var x | Just (VarBnd _ ty) <- find (\case VarBnd x' _ -> x == x'; _ -> False) tyCtx -> do
 87 |       (exCtx, ty', tree) <- inst tyCtx ty
 88 |       ret "Var" exCtx ty' tyCtx [tree]
 89 |     LitInt _ -> ret "Int" [] TInt tyCtx []
 90 |     LitBool _ -> ret "Bool" [] TBool tyCtx []
 91 |     Lam bnd -> do
 92 |       (x, e) <- unbind bnd
 93 |       a <- freshTVar
 94 |       (exCtx2, ty2, tyCtx', tree) <- infer (VarBnd x (ETVar a) : ExCtx [a] : tyCtx) e
 95 |       case tyCtx' of
 96 |         VarBnd x' ty1 : ExCtx exCtx1 : tyCtx''
 97 |           | x == x' ->
 98 |               ret "Abs" (exCtx2 ++ exCtx1) (TArr ty1 ty2) tyCtx'' [tree]
 99 |         _ -> throwError $ show tyCtx' ++ " is not of the right form"
100 |     App tm1 tm2 -> do
101 |       (exCtx1, ty, tyCtx1, tree1) <- infer tyCtx tm1
102 |       (exCtx2, ty1, tyCtx2, tree2) <- infer (Invis exCtx1 ty : tyCtx1) tm2
103 |       case tyCtx2 of
104 |         Invis exCtx1' ty' : tyCtx2' -> do
105 |           a <- freshTVar
106 |           (tyCtx', tree3) <-
107 |             unify
108 |               (Invis [] (ETVar a) : ExCtx (a : exCtx2 ++ exCtx1') : tyCtx2')
109 |               [(ty', TArr ty1 (ETVar a))]
110 |           case tyCtx' of
111 |             Invis [] ty'' : ExCtx exCtx : tyCtx'' ->
112 |               ret "App" exCtx ty'' tyCtx'' [tree1, tree2, tree3]
113 |             _ -> throwError $ show tyCtx' ++ " is not of the right form"
114 |         _ -> throwError $ show tyCtx2 ++ " is not of the right form"
115 |     Let tm1 bnd -> do
116 |       (x, tm2) <- unbind bnd
117 |       (ty, tyCtx', tree1) <- gen tyCtx tm1
118 |       (exCtx, ty', tyCtx'', tree2) <- infer (VarBnd x ty : tyCtx') tm2
119 |       case tyCtx'' of
120 |         VarBnd x' _ : tyCtx''' | x == x' -> do
121 |           ret "Let" exCtx ty' tyCtx''' [tree1, tree2]
122 |         _ -> throwError $ show tyCtx'' ++ " is not of the right form"
123 |     _ -> throwError $ "No rule matching: " ++ showInput
124 |   where
125 |     showInput = show tyCtx ++ " |- " ++ show tm
126 |     showOutput exCtx ty tyCtx' = showInput ++ " : " ++ showExCtxTyp exCtx ty ++ " -| " ++ show tyCtx'
127 | 
128 |     ret :: String -> ExCtx -> Typ -> TyCtx -> [Tree String] -> InferMonad (ExCtx, Typ, TyCtx, Tree String)
129 |     ret rule exCtx ty tyCtx' trees = do
130 |       lift $ tell ["Inferred[" ++ rule ++ "]: " ++ showOutput exCtx ty tyCtx']
131 |       return (exCtx, ty, tyCtx', Node (rule ++ ": " ++ showOutput exCtx ty tyCtx') trees)
132 | 
133 | unify :: TyCtx -> TyEqs -> InferMonad (TyCtx, Tree String)
134 | unify tyCtx tyEqs = do
135 |   lift $ tell ["Unifying: " ++ showInput]
136 |   case tyEqs of
137 |     [] -> ret "SolNil" tyCtx []
138 |     _ -> do
139 |       (tyCtx', tyEqs'') <- unifySingleStep tyCtx tyEqs
140 |       (tyCtx'', tree) <- unify tyCtx' tyEqs''
141 |       ret "SolCons" tyCtx'' [tree]
142 |   where
143 |     showInput = show tyCtx ++ " |- " ++ showTyEqs tyEqs
144 |     showOutput tyCtx' = showInput ++ " -| " ++ show tyCtx'
145 | 
146 |     ret :: String -> TyCtx -> [Tree String] -> InferMonad (TyCtx, Tree String)
147 |     ret rule tyCtx' trees = do
148 |       lift $ tell ["Unified[" ++ rule ++ "]: " ++ showOutput tyCtx']
149 |       return (tyCtx', Node (rule ++ ": " ++ showOutput tyCtx') trees)
150 | 
151 | substExCtx :: TyVar -> [TyVar] -> ExCtx -> Maybe ExCtx
152 | substExCtx _ _ [] = Nothing
153 | substExCtx a exVars (a' : exCtx)
154 |   | a == a' = Just $ exVars ++ exCtx
155 |   | otherwise = do
156 |       exCtx' <- substExCtx a exVars exCtx
157 |       return $ a' : exCtx'
158 | 
159 | substTyCtx :: TyVar -> Typ -> [TyVar] -> TyCtx -> InferMonad TyCtx
160 | substTyCtx a ty exVars tyCtx = case tyCtx of
161 |   [] -> throwError $ show a ++ " is not found"
162 |   TVarBnd a' : tyCtx' -> do
163 |     tyCtx'' <- substTyCtx a ty exVars tyCtx'
164 |     return $ TVarBnd a' : tyCtx''
165 |   ExCtx exCtx : tyCtx' ->
166 |     case substExCtx a exVars exCtx of
167 |       Just exCtx' ->
168 |         return $ ExCtx exCtx' : tyCtx'
169 |       Nothing -> do
170 |         tyCtx'' <- substTyCtx a ty exVars tyCtx'
171 |         return $ ExCtx exCtx : tyCtx''
172 |   VarBnd x ty' : tyCtx' -> do
173 |     tyCtx'' <- substTyCtx a ty exVars tyCtx'
174 |     return $ VarBnd x (subst a ty ty') : tyCtx''
175 |   Invis exCtx ty' : tyCtx' -> do
176 |     case substExCtx a exVars exCtx of
177 |       Just exCtx' ->
178 |         return $ Invis exCtx' (subst a ty ty') : tyCtx'
179 |       Nothing -> do
180 |         tyCtx'' <- substTyCtx a ty exVars tyCtx'
181 |         return $ Invis exCtx (subst a ty ty') : tyCtx''
182 | 
183 | substTyEqs :: TyVar -> Typ -> TyEqs -> TyEqs
184 | substTyEqs a ty = map (bimap (subst a ty) (subst a ty))
185 | 
186 | before :: TyCtx -> TyVar -> TyVar -> Bool
187 | before tyCtx a b =
188 |   let (tyCtx1, _) = break (\case TVarBnd a' -> a == a'; _ -> False) tyCtx
189 |       (tyCtx1', _) = break (\case TVarBnd b' -> b == b'; _ -> False) tyCtx
190 |    in length tyCtx1 > length tyCtx1'
191 | 
192 | unifySingleStep :: TyCtx -> TyEqs -> InferMonad (TyCtx, TyEqs)
193 | unifySingleStep tyCtx tyEqs = case tyEqs of
194 |   (ty1, ty2) : tyEqs' -> do
195 |     lift $ tell ["UnifyingSingleStep: " ++ showInput]
196 |     case (ty1, ty2) of
197 |       (TInt, TInt) -> return (tyCtx, tyEqs')
198 |       (TBool, TBool) -> return (tyCtx, tyEqs')
199 |       (ETVar a, ETVar b) | a == b -> return (tyCtx, tyEqs')
200 |       (TArr ty1' ty2', TArr ty1'' ty2'') -> return (tyCtx, (ty1', ty1'') : (ty2', ty2'') : tyEqs')
201 |       (ETVar a, TArr _ _) -> do
202 |         a1 <- freshTVar
203 |         a2 <- freshTVar
204 |         tyCtx' <- substTyCtx a (TArr (ETVar a1) (ETVar a2)) [a1, a2] tyCtx
205 |         return (tyCtx', substTyEqs a (TArr (ETVar a1) (ETVar a2)) tyEqs')
206 |       (TArr _ _, ETVar a) -> do
207 |         a1 <- freshTVar
208 |         a2 <- freshTVar
209 |         tyCtx' <- substTyCtx a (TArr (ETVar a1) (ETVar a2)) [a1, a2] tyCtx
210 |         return (tyCtx', substTyEqs a (TArr (ETVar a1) (ETVar a2)) tyEqs')
211 |       (ETVar a, ETVar b) | before tyCtx a b -> do
212 |         tyCtx' <- substTyCtx b (ETVar a) [] tyCtx
213 |         return (tyCtx', substTyEqs b (ETVar a) tyEqs')
214 |       (ETVar b, ETVar a) | before tyCtx a b -> do
215 |         tyCtx' <- substTyCtx b (ETVar a) [] tyCtx
216 |         return (tyCtx', substTyEqs b (ETVar a) tyEqs')
217 |       (ETVar a, TInt) -> do
218 |         tyCtx' <- substTyCtx a TInt [] tyCtx
219 |         return (tyCtx', substTyEqs a TInt tyEqs')
220 |       (TInt, ETVar a) -> do
221 |         tyCtx' <- substTyCtx a TInt [] tyCtx
222 |         return (tyCtx', substTyEqs a TInt tyEqs')
223 |       (ETVar a, TBool) -> do
224 |         tyCtx' <- substTyCtx a TBool [] tyCtx
225 |         return (tyCtx', substTyEqs a TBool tyEqs')
226 |       (TBool, ETVar a) -> do
227 |         tyCtx' <- substTyCtx a TBool [] tyCtx
228 |         return (tyCtx', substTyEqs a TBool tyEqs')
229 |       _ -> throwError $ "No rule matching: " ++ showInput
230 |   [] -> throwError "Impossible"
231 |   where
232 |     showInput = show tyCtx ++ " |- " ++ showTyEqs tyEqs
233 | 
234 | runAlgR :: Trm -> Either String (Tree String)
235 | runAlgR tm = case runInferMonad $ infer [] tm of
236 |   Left err -> Left $ intercalate "\n" err
237 |   Right ((_, _, _, tree), _) -> Right tree
238 | 


--------------------------------------------------------------------------------
/src/Alg/HDM/AlgW.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE PatternSynonyms #-}
  2 | 
  3 | module Alg.HDM.AlgW (runAlgW) where
  4 | 
  5 | import Control.Monad (foldM)
  6 | import Control.Monad.Except ( MonadError(throwError) )
  7 | import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell))
  8 | import Data.List (intercalate)
  9 | import qualified Data.Map as Map
 10 | import qualified Data.Set as Set
 11 | import Data.Tree (Tree (Node))
 12 | import Lib (InferMonad, freshTVar, runInferMonad)
 13 | import Syntax (TmVar, Trm (..), TyVar, Typ (..), pattern TAll)
 14 | import Unbound.Generics.LocallyNameless hiding (Subst)
 15 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf)
 16 | 
 17 | type Env = Map.Map TmVar Typ
 18 | 
 19 | type Subst = Map.Map TyVar Typ
 20 | 
 21 | -- remove :: Env -> TmVar -> Env
 22 | -- remove env x = Map.delete x env
 23 | 
 24 | apply :: Subst -> Typ -> Typ
 25 | apply = substs . Map.toList
 26 | 
 27 | nullSubst :: Subst
 28 | nullSubst = Map.empty
 29 | 
 30 | compSubst :: Subst -> Subst -> Subst
 31 | compSubst s1 s2 = Map.map (apply s1) s2 `Map.union` s1
 32 | 
 33 | inst :: Typ -> InferMonad Typ
 34 | inst (TAll bnd) = unbind bnd >>= inst . snd
 35 | inst ty = return ty
 36 | 
 37 | gen :: Env -> Typ -> Typ
 38 | gen env ty = foldl (\ty' x -> TAll $ bind x ty') ty ftv
 39 |   where
 40 |     tFtv = Set.fromList $ toListOf fv ty
 41 |     envFtv = Set.fromList $ concatMap (toListOf fv) $ Map.elems env
 42 |     ftv = Set.toList $ tFtv `Set.difference` envFtv
 43 | 
 44 | mgu :: Typ -> Typ -> InferMonad (Subst, Tree String)
 45 | mgu ty1 ty2 = do
 46 |   lift $ tell ["Unifying: " ++ show ty1 ++ " ~ " ++ show ty2]
 47 |   case (ty1, ty2) of
 48 |     (TArr ty1' ty1'', TArr ty2' ty2'') -> do
 49 |       (s1, tree1) <- mgu ty1' ty2'
 50 |       (s2, tree2) <- mgu (apply s1 ty1'') (apply s1 ty2'')
 51 |       ret (s1 `compSubst` s2) [tree1, tree2]
 52 |     (TVar a, ty) -> varBind a ty >>= \s -> ret s []
 53 |     (ty, TVar a) -> varBind a ty >>= \s -> ret s []
 54 |     (TInt, TInt) -> ret nullSubst []
 55 |     (TBool, TBool) -> ret nullSubst []
 56 |     (TTuple tys, TTuple tys')
 57 |       | length tys == length tys' ->
 58 |           foldM
 59 |             ( \(s, trees) (ty, ty') -> do
 60 |                 (s', tree) <- mgu (apply s ty) (apply s ty')
 61 |                 return (s' `compSubst` s, trees ++ [tree])
 62 |             )
 63 |             (nullSubst, [])
 64 |             (zip tys tys')
 65 |             >>= uncurry ret
 66 |     _ -> throwError $ "cannot unify " ++ show ty1 ++ " with " ++ show ty2
 67 |   where
 68 |     showInput :: String
 69 |     showInput = show ty1 ++ " ~ " ++ show ty2
 70 | 
 71 |     showOutput :: Subst -> String
 72 |     showOutput s = showInput ++ " ~> " ++ showSubst s
 73 | 
 74 |     ret :: Subst -> [Tree String] -> InferMonad (Subst, Tree String)
 75 |     ret s trees = do
 76 |       lift $ tell ["Unified: " ++ showOutput s]
 77 |       return (s, Node ("Unify: " ++ showOutput s) trees)
 78 | 
 79 | varBind :: TyVar -> Typ -> InferMonad Subst
 80 | varBind a ty
 81 |   | aeq ty (TVar a) = return nullSubst
 82 |   | a `elem` toListOf fv ty = throwError $ show a ++ " occurs in " ++ show ty
 83 |   | otherwise = return $ Map.singleton a ty
 84 | 
 85 | algW :: Env -> Trm -> InferMonad (Subst, Typ, Tree String)
 86 | algW env tm = do
 87 |   lift $ tell ["Infering: " ++ showInput]
 88 |   case tm of
 89 |     LitInt _ -> ret "LitInt" nullSubst TInt []
 90 |     LitBool _ -> ret "LitBool" nullSubst TBool []
 91 |     Var x -> case Map.lookup x env of
 92 |       Nothing -> throwError $ "unbound variable " ++ show x
 93 |       Just poly -> do
 94 |         mono <- inst poly
 95 |         ret "Var" nullSubst mono []
 96 |     Lam bnd -> do
 97 |       (x, tm') <- unbind bnd
 98 |       a <- freshTVar
 99 |       let env' = env `Map.union` Map.singleton x (TVar a)
100 |       (s1, ty1, tree) <- algW env' tm'
101 |       ret "Lam" s1 (TArr (apply s1 (TVar a)) ty1) [tree]
102 |     App tm1 tm2 -> do
103 |       a <- freshTVar
104 |       (s1, ty1, tree1) <- algW env tm1
105 |       (s2, ty2, tree2) <- algW (Map.map (apply s1) env) tm2
106 |       (s3, tree3) <- mgu (apply s2 ty1) (TArr ty2 (TVar a))
107 |       ret "App" (s3 `compSubst` s2 `compSubst` s1) (apply s3 (TVar a)) [tree1, tree2, tree3]
108 |     Let tm1 bnd -> do
109 |       (x, tm2) <- unbind bnd
110 |       (s1, ty1, tree1) <- algW env tm1
111 |       let ty' = gen (Map.map (apply s1) env) ty1
112 |           env' = Map.insert x ty' env
113 |       (s2, ty2, tree2) <- algW (Map.map (apply s1) env') tm2
114 |       ret "Let" (s2 `compSubst` s1) ty2 [tree1, tree2]
115 |     Tuple tms -> do
116 |       (s, tys, trees) <-
117 |         foldM
118 |           ( \(s', tys', trees') tm' -> do
119 |               (s'', ty', tree') <- algW (Map.map (apply s') env) tm'
120 |               return (s'' `compSubst` s', tys' ++ [ty'], trees' ++ [tree'])
121 |           )
122 |           (nullSubst, [], [])
123 |           tms
124 |       ret "Tuple" s (TTuple tys) trees
125 |     _ -> throwError "not implemented"
126 |   where
127 |     showInput :: String
128 |     showInput = showEnv env ++ " |- " ++ show tm
129 | 
130 |     showOutput :: Subst -> Typ -> String
131 |     showOutput s ty = showInput ++ " : " ++ show ty ++ " with " ++ showSubst s
132 |     ret :: String -> Subst -> Typ -> [Tree String] -> InferMonad (Subst, Typ, Tree String)
133 |     ret rule s ty trees = do
134 |       lift $ tell ["Infered[" ++ rule ++ "]: " ++ showOutput s ty]
135 |       return (s, ty, Node (rule ++ ": " ++ showOutput s ty) trees)
136 | 
137 | runAlgW :: Trm -> Either String (Tree String)
138 | runAlgW tm = case runInferMonad $ algW Map.empty tm of
139 |   Left errs -> Left (intercalate "\n" errs)
140 |   Right ((_, _, tree), _) -> Right tree
141 | 
142 | showEnv :: Env -> String
143 | showEnv env = intercalate ", " $ map (\(x, ty) -> show x ++ ": " ++ show ty) (Map.toList env)
144 | 
145 | showSubst :: Subst -> String
146 | showSubst s = "{" ++ intercalate ", " (map (\(a, ty) -> show ty ++ " / " ++ show a) (Map.toList s)) ++ "}"
147 | 


--------------------------------------------------------------------------------
/src/Alg/Local.hs:
--------------------------------------------------------------------------------
1 | module Alg.Local
2 |   ( module Alg.Local.Contextual,
3 |     module Alg.Local.Local,
4 |   )
5 | where
6 | 
7 | import Alg.Local.Contextual
8 | import Alg.Local.Local
9 | 


--------------------------------------------------------------------------------
/src/Alg/Local/Contextual.hs:
--------------------------------------------------------------------------------
1 | module Alg.Local.Contextual
2 |   ( module Alg.Local.Contextual.Contextual,
3 |   )
4 | where
5 | 
6 | import Alg.Local.Contextual.Contextual
7 | 


--------------------------------------------------------------------------------
/src/Alg/Local/Contextual/Contextual.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveGeneric #-}
  2 | {-# LANGUAGE FlexibleInstances #-}
  3 | {-# LANGUAGE InstanceSigs #-}
  4 | {-# LANGUAGE LambdaCase #-}
  5 | 
  6 | module Alg.Local.Contextual.Contextual (runContextual) where
  7 | 
  8 | import Control.Monad.Except (throwError)
  9 | import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell))
 10 | import Data.Data (Typeable)
 11 | import Data.Foldable (find)
 12 | import Data.List (intercalate)
 13 | import Data.Tree (Tree (Node))
 14 | import GHC.Generics (Generic)
 15 | import Lib (InferMonad, runInferMonad)
 16 | import Syntax (TmVar, Trm (..), Typ (..))
 17 | import Unbound.Generics.LocallyNameless (Alpha, aeq, unbind)
 18 | 
 19 | data EnvEntry
 20 |   = VarBnd TmVar Typ
 21 | 
 22 | type Env = [EnvEntry]
 23 | 
 24 | data Ctx = CEmpty | CTyp Typ | CConsTrm Trm Ctx
 25 |   deriving (Generic, Typeable)
 26 | 
 27 | instance Alpha Ctx
 28 | 
 29 | instance Show EnvEntry where
 30 |   show :: EnvEntry -> String
 31 |   show (VarBnd x ty) = show x ++ ": " ++ show ty
 32 | 
 33 | instance {-# OVERLAPPING #-} Show [EnvEntry] where
 34 |   show :: [EnvEntry] -> String
 35 |   show = intercalate ", " . map show . reverse
 36 | 
 37 | instance Show Ctx where
 38 |   show :: Ctx -> String
 39 |   show CEmpty = "[]"
 40 |   show (CTyp ty) = show ty
 41 |   show (CConsTrm tm ctx) = "[" ++ show tm ++ "] |-> " ++ show ctx
 42 | 
 43 | genericConsumer :: Trm -> Bool
 44 | genericConsumer (LitInt _) = True
 45 | genericConsumer (LitBool _) = True
 46 | genericConsumer (Var _) = True
 47 | genericConsumer (Ann _ _) = True
 48 | genericConsumer _ = False
 49 | 
 50 | match :: Env -> Typ -> Ctx -> InferMonad (Tree String)
 51 | match env ty ctx = do
 52 |   lift $ tell ["Matching: " ++ showMatch]
 53 |   case (ty, ctx) of
 54 |     (_, CEmpty) -> ret "SubEmpty" []
 55 |     (_, CTyp ty') | aeq ty ty' -> ret "SubType" []
 56 |     (TArr ty1 ty2, CConsTrm tm ctx') -> do
 57 |       (_, tree1) <- infer env (CTyp ty1) tm
 58 |       tree2 <- match env ty2 ctx'
 59 |       ret "SubTerm" [tree1, tree2]
 60 |     (_, _) -> throwError $ "No rule matching: " ++ showMatch
 61 |   where
 62 |     showMatch = show env ++ " |- " ++ show ty ++ " ~ " ++ show ctx
 63 | 
 64 |     ret :: String -> [Tree String] -> InferMonad (Tree String)
 65 |     ret rule trees = do
 66 |       lift $ tell ["Matched[" ++ rule ++ "]: " ++ showMatch]
 67 |       return $ Node (rule ++ ": " ++ showMatch) trees
 68 | 
 69 | infer :: Env -> Ctx -> Trm -> InferMonad (Typ, Tree String)
 70 | infer env ctx tm = do
 71 |   lift $ tell ["Infering: " ++ showInferIn]
 72 |   case (ctx, tm) of
 73 |     (CEmpty, LitInt _) -> ret "ALitInt" TInt []
 74 |     (CEmpty, LitBool _) -> ret "ALitBool" TBool []
 75 |     (CEmpty, Var x)
 76 |       | Just (VarBnd _ ty) <- find (\case VarBnd x' _ -> x == x') env ->
 77 |           ret "AVar" ty []
 78 |     (CEmpty, Ann tm1 ty) -> do
 79 |       (_, tree) <- infer env (CTyp ty) tm1
 80 |       ret "AAnn" ty [tree]
 81 |     (_, App tm1 tm2) -> do
 82 |       (arrTy, tree) <- infer env (CConsTrm tm2 ctx) tm1
 83 |       case arrTy of
 84 |         TArr _ ty2 -> ret "AApp" ty2 [tree]
 85 |         _ -> throwError $ "Non-function type: " ++ show arrTy
 86 |     (CTyp (TArr ty1 ty2), Lam bnd) -> do
 87 |       (x, tm1) <- unbind bnd
 88 |       (ty3, tree) <- infer (VarBnd x ty1 : env) (CTyp ty2) tm1
 89 |       ret "ALam1" (TArr ty1 ty3) [tree]
 90 |     (CConsTrm tm2 ctx', Lam bnd) -> do
 91 |       (x, tm1) <- unbind bnd
 92 |       (ty1, tree1) <- infer env CEmpty tm2
 93 |       (ty2, tree2) <- infer (VarBnd x ty1 : env) ctx' tm1
 94 |       ret "ALam2" (TArr ty1 ty2) [tree1, tree2]
 95 |     (_, _) | not (aeq ctx CEmpty) && genericConsumer tm -> do
 96 |       (ty, tree1) <- infer env CEmpty tm
 97 |       tree2 <- match env ty ctx
 98 |       ret "ASub" ty [tree1, tree2]
 99 |     (_, _) -> throwError $ "No rule matching: " ++ showInferIn
100 |   where
101 |     showInferIn = show env ++ " |- " ++ show ctx ++ " => " ++ show tm
102 | 
103 |     showInfer :: Typ -> String
104 |     showInfer ty = showInferIn ++ " => " ++ show ty
105 | 
106 |     ret :: String -> Typ -> [Tree String] -> InferMonad (Typ, Tree String)
107 |     ret rule ty trees = do
108 |       lift $ tell ["Infered[" ++ rule ++ "]: " ++ showInfer ty]
109 |       return (ty, Node (rule ++ ": " ++ showInfer ty) trees)
110 | 
111 | runInfer :: Env -> Ctx -> Trm -> Either [String] ((Typ, Tree String), [String])
112 | runInfer env ctx tm = runInferMonad $ infer env ctx tm
113 | 
114 | runContextual :: Trm -> Either String (Tree String)
115 | runContextual tm = case runInfer [] CEmpty tm of
116 |   Left errs -> Left (unlines errs)
117 |   Right ((_, tree), _) -> Right tree
118 | 


--------------------------------------------------------------------------------
/src/Alg/Local/Local.hs:
--------------------------------------------------------------------------------
1 | module Alg.Local.Local where
2 | 


--------------------------------------------------------------------------------
/src/Lib.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 2 | 
 3 | module Lib (InferMonad, runInferMonad, freshTVar, break3) where
 4 | 
 5 | import Control.Monad.RWS (MonadTrans (lift), RWST, get, put, runRWST)
 6 | import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 7 | import Syntax (TyVar)
 8 | import Unbound.Generics.LocallyNameless (FreshMT, runFreshMT)
 9 | import Unbound.Generics.LocallyNameless.Fresh (Fresh (..))
10 | import Unbound.Generics.LocallyNameless.Name (s2n)
11 | 
12 | type InferMonad = ExceptT String (RWST () [String] Int (FreshMT Maybe))
13 | 
14 | instance (Monoid w, Fresh m) => Fresh (RWST r w s m) where
15 |   fresh = lift . fresh
16 | 
17 | runInferMonad :: InferMonad a -> Either [String] (a, [String])
18 | runInferMonad m = case runFreshMT $ runRWST (runExceptT m) () 0 of
19 |   Nothing -> Left ["Computation failed"]
20 |   Just (Left s, _, msgs) -> Left (s : msgs)
21 |   Just (Right res, _, msgs) -> Right (res, msgs)
22 | 
23 | freshTVar :: InferMonad TyVar
24 | freshTVar = do
25 |   let letters = ["a", "b", "c", "d"]
26 |   varId <- get
27 |   put (varId + 1)
28 |   fresh . s2n $ letters !! (varId `mod` length letters)
29 | 
30 | break3 :: (a -> Bool) -> [a] -> ([a], Maybe a, [a])
31 | break3 p xs = case break p xs of
32 |   (ys, []) -> (ys, Nothing, [])
33 |   (ys, z : zs) -> (ys, Just z, zs)
34 | 


--------------------------------------------------------------------------------
/src/Opt.hs:
--------------------------------------------------------------------------------
 1 | module Opt (Option (..), options) where
 2 | 
 3 | import System.Console.GetOpt
 4 | 
 5 | data Option = Alg String | Html
 6 |   deriving (Eq, Show)
 7 | 
 8 | options :: [OptDescr Option]
 9 | options =
10 |   [ Option [] ["alg"] (ReqArg Alg "ALG_NAME") "ALG_NAME",
11 |     Option [] ["html"] (NoArg Html) "Output HTML"
12 |   ]
13 | 


--------------------------------------------------------------------------------
/src/Parser.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE ImportQualifiedPost #-}
  2 | 
  3 | module Parser (parseTrm) where
  4 | 
  5 | import Control.Monad (void)
  6 | import Control.Monad.Combinators.Expr
  7 | import Data.Void (Void)
  8 | import Syntax
  9 | import Text.Megaparsec
 10 | import Text.Megaparsec.Char
 11 | import Text.Megaparsec.Char.Lexer qualified as L
 12 | import Unbound.Generics.LocallyNameless (Bind, bind, s2n)
 13 | 
 14 | type Parser = Parsec Void String
 15 | 
 16 | parseTrm :: String -> Either String Trm
 17 | parseTrm s =
 18 |   case runParser (whole trm) "" s of
 19 |     Left err -> Left $ errorBundlePretty err
 20 |     Right e -> Right e
 21 | 
 22 | -- | Top-level parsers (should consume all input)
 23 | whole :: Parser a -> Parser a
 24 | whole p = sc *> p <* eof
 25 | 
 26 | ------------------------------------------------------------------------
 27 | -- Expressions
 28 | ------------------------------------------------------------------------
 29 | 
 30 | trm :: Parser Trm
 31 | trm = makeExprParser appTrm trmOps
 32 | 
 33 | trmOps :: [[Operator Parser Trm]]
 34 | trmOps =
 35 |   [ [ InfixL (BinOp OpAdd <$ symbol "+"),
 36 |       InfixL (BinOp OpSub <$ symbol "-")
 37 |     ],
 38 |     [ InfixL (BinOp OpMul <$ symbol "*"),
 39 |       InfixL (BinOp OpDiv <$ symbol "/")
 40 |     ]
 41 |   ]
 42 | 
 43 | appTrm :: Parser Trm
 44 | appTrm = postfixChain factor (try tapp <|> app)
 45 | 
 46 | app :: Parser (Trm -> Trm)
 47 | app = do
 48 |   e <- factor
 49 |   return (`App` e)
 50 | 
 51 | tapp :: Parser (Trm -> Trm)
 52 | tapp = do
 53 |   symbol "@"
 54 |   t <- typ
 55 |   return (`TApp` t)
 56 | 
 57 | factor :: Parser Trm
 58 | factor = postfixChain atom annOp
 59 | 
 60 | annOp :: Parser (Trm -> Trm)
 61 | annOp = do
 62 |   symbol ":"
 63 |   t <- typ
 64 |   return (`Ann` t)
 65 | 
 66 | atom :: Parser Trm
 67 | atom =
 68 |   choice
 69 |     [ trmBind Lam $ symbol "\\",
 70 |       tLamB,
 71 |       letRec,
 72 |       letExp,
 73 |       ifExp,
 74 |       try tuple,
 75 |       Var . s2n <$> identifier,
 76 |       LitBool True <$ rword "True",
 77 |       LitBool False <$ rword "False",
 78 |       LitInt <$> int,
 79 |       parens trm
 80 |     ]
 81 | 
 82 | trmBind :: (Bind TmVar Trm -> Trm) -> Parser () -> Parser Trm
 83 | trmBind c p = do
 84 |   p
 85 |   x <- identifier
 86 |   symbol "."
 87 |   c . bind (s2n x) <$> trm
 88 | 
 89 | tLamB :: Parser Trm
 90 | tLamB = do
 91 |   symbol "/\\"
 92 |   (x, b) <- idBound
 93 |   symbol "."
 94 |   e <- trm
 95 |   return $ TLamB (bind (s2n x) e) b
 96 | 
 97 | letExp :: Parser Trm
 98 | letExp = do
 99 |   rword "let"
100 |   x <- identifier
101 |   symbol "="
102 |   e1 <- trm
103 |   rword "in"
104 |   Let e1 . bind (s2n x) <$> trm
105 | 
106 | letRec :: Parser Trm
107 | letRec = do
108 |   rword "letrec"
109 |   x <- identifier
110 |   symbol "="
111 |   e1 <- trm
112 |   rword "in"
113 |   LetRec . bind (s2n x) . (,) e1 <$> trm
114 | 
115 | ifExp :: Parser Trm
116 | ifExp = do
117 |   rword "if"
118 |   e1 <- trm
119 |   rword "then"
120 |   e2 <- trm
121 |   rword "else"
122 |   If e1 e2 <$> trm
123 | 
124 | tuple :: Parser Trm
125 | tuple = do
126 |   symbol "("
127 |   first <- trm
128 |   symbol ","
129 |   rest <- trm `sepBy` symbol ","
130 |   symbol ")"
131 |   return $ Tuple (first : rest)
132 | 
133 | ------------------------------------------------------------------------
134 | -- Types
135 | ------------------------------------------------------------------------
136 | 
137 | typ :: Parser Typ
138 | typ = makeExprParser aTyp typOps
139 | 
140 | typOps :: [[Operator Parser Typ]]
141 | typOps =
142 |   [ [InfixR (TArr <$ symbol "->")],
143 |     [InfixL (TUnion <$ symbol "|")],
144 |     [InfixL (TIntersection <$ symbol "&")]
145 |   ]
146 | 
147 | aTyp :: Parser Typ
148 | aTyp =
149 |   choice
150 |     [ tAllB,
151 |       TVar . s2n <$> identifier,
152 |       tConst,
153 |       parens typ
154 |     ]
155 | 
156 | tAllB :: Parser Typ
157 | tAllB = do
158 |   rword "forall"
159 |   (x, b) <- idBound
160 |   symbol "."
161 |   ty <- typ
162 |   return $ TAllB (bind (s2n x) ty) b
163 | 
164 | tConst :: Parser Typ
165 | tConst =
166 |   choice
167 |     [ TInt <$ rword "Int",
168 |       TBool <$ rword "Bool",
169 |       TTop <$ rword "Top",
170 |       TBot <$ rword "Bot"
171 |     ]
172 | 
173 | ------------------------------------------------------------------------
174 | -- Misc
175 | ------------------------------------------------------------------------
176 | 
177 | sc :: Parser ()
178 | sc = L.space space1 lineCmnt blockCmnt
179 |   where
180 |     lineCmnt = L.skipLineComment "--"
181 |     blockCmnt = L.skipBlockComment "{-" "-}"
182 | 
183 | lexeme :: Parser a -> Parser a
184 | lexeme = L.lexeme sc
185 | 
186 | symbol :: String -> Parser ()
187 | symbol = void . L.symbol sc
188 | 
189 | parens :: Parser a -> Parser a
190 | parens = between (symbol "(") (symbol ")")
191 | 
192 | int :: Parser Integer
193 | int = lexeme L.decimal
194 | 
195 | rword :: String -> Parser ()
196 | rword w = string w *> notFollowedBy alphaNumChar *> sc
197 | 
198 | postfixChain :: Parser a -> Parser (a -> a) -> Parser a
199 | postfixChain p op = do
200 |   x <- p
201 |   rest x
202 |   where
203 |     rest x =
204 |       ( do
205 |           f <- op
206 |           rest $ f x
207 |       )
208 |         <|> return x
209 | 
210 | rws :: [String]
211 | rws = ["Int", "Bool", "let", "letrec", "in", "fix", "True", "False", "if", "then", "else"]
212 | 
213 | identifier :: Parser String
214 | identifier = (lexeme . try) (p >>= check)
215 |   where
216 |     p = (:) <$> lowerChar <*> many identChar
217 |     check x =
218 |       if x `elem` rws
219 |         then fail $ "keyword " ++ show x ++ " cannot be an identifier"
220 |         else return x
221 | 
222 | identChar :: Parser Char
223 | identChar = alphaNumChar <|> oneOf "_'"
224 | 
225 | idBound :: Parser (String, Typ)
226 | idBound = try explicit <|> implicit
227 |   where
228 |     implicit = do
229 |       x <- identifier
230 |       return (x, TTop)
231 |     explicit = do
232 |       symbol "("
233 |       x <- identifier
234 |       symbol "<:"
235 |       t <- aTyp
236 |       symbol ")"
237 |       return (x, t)
238 | 


--------------------------------------------------------------------------------
/src/Print.hs:
--------------------------------------------------------------------------------
  1 | module Print (showTreeHtml, toNodeInfoTree) where
  2 | 
  3 | -- This code is from the Haskell package `tree-view`
  4 | 
  5 | -- Copyright (c) 2014, Emil Axelsson
  6 | 
  7 | -- All rights reserved.
  8 | 
  9 | -- Redistribution and use in source and binary forms, with or without
 10 | -- modification, are permitted provided that the following conditions are met:
 11 | 
 12 | --     * Redistributions of source code must retain the above copyright
 13 | --       notice, this list of conditions and the following disclaimer.
 14 | 
 15 | --     * Redistributions in binary form must reproduce the above
 16 | --       copyright notice, this list of conditions and the following
 17 | --       disclaimer in the documentation and/or other materials provided
 18 | --       with the distribution.
 19 | 
 20 | --     * Neither the name of Emil Axelsson nor the names of other
 21 | --       contributors may be used to endorse or promote products derived
 22 | --       from this software without specific prior written permission.
 23 | 
 24 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 25 | -- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 26 | -- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 27 | -- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 28 | -- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 29 | -- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 30 | -- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 31 | -- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 32 | -- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 33 | -- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 34 | -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 35 | 
 36 | import Control.Monad.State
 37 |   ( MonadState (get, put),
 38 |     State,
 39 |     evalState,
 40 |   )
 41 | import Data.Tree (Tree (Node))
 42 | import Data.Tree.View (Behavior (..), NodeInfo (..))
 43 | 
 44 | escapeBrackets :: String -> String
 45 | escapeBrackets = concatMap fixBrack
 46 |   where
 47 |     fixBrack '<' = "&lt;"
 48 |     fixBrack '>' = "&gt;"
 49 |     fixBrack c = [c]
 50 | 
 51 | htmlNode :: (NodeInfo, Int) -> String
 52 | htmlNode (n, i) =
 53 |   concat
 54 |     [ "<span id=\"node",
 55 |       show i,
 56 |       "\" class=\"node ",
 57 |       mode,
 58 |       "\"",
 59 |       onclick,
 60 |       "title=\"",
 61 |       nodeInfo n,
 62 |       "\"",
 63 |       ">",
 64 |       escapeBrackets $ nodeName n,
 65 |       "</span>"
 66 |     ]
 67 |   where
 68 |     mode = case nodeBehavior n of
 69 |       Fixed -> "fixed"
 70 |       InitiallyCollapsed -> "interactive collapsed"
 71 |       InitiallyExpanded -> "interactive expanded"
 72 |     onclick = case nodeBehavior n of
 73 |       Fixed -> " "
 74 |       _ -> " onclick=\"toggle(event)\" "
 75 | 
 76 | appLast :: [String] -> String -> [String]
 77 | appLast ss s = init ss ++ [last ss ++ s]
 78 | 
 79 | indentInit :: [String] -> [String]
 80 | indentInit [] = []
 81 | indentInit (s : ss) = (" ├╴" ++ s) : map (" │ " ++) ss
 82 | 
 83 | indentLast :: [String] -> [String]
 84 | indentLast [] = []
 85 | indentLast (s : ss) = (" └╴" ++ s) : map ("   " ++) ss
 86 | 
 87 | indentChildren :: [[String]] -> [[String]]
 88 | indentChildren [] = []
 89 | indentChildren ns = map indentInit (init ns) ++ [indentLast (last ns)]
 90 | 
 91 | enumTree :: Tree a -> Tree (a, Int)
 92 | enumTree = flip evalState 0 . traverse count
 93 |   where
 94 |     count :: a -> State Int (a, Int)
 95 |     count a = do
 96 |       i <- get
 97 |       put (i + 1)
 98 |       return (a, i)
 99 | 
100 | showTreeHtml' :: Tree (NodeInfo, Int) -> [String]
101 | showTreeHtml' (Node (n, i) []) = [htmlNode (n {nodeBehavior = Fixed}, i)]
102 | showTreeHtml' (Node n ns) =
103 |   ( htmlNode n
104 |       ++ "<span id=\"children_node"
105 |       ++ show (snd n)
106 |       ++ "\" class="
107 |       ++ display
108 |       ++ ">"
109 |   )
110 |     : appLast (concat (indentChildren (map showTreeHtml' ns))) "</span>"
111 |   where
112 |     display = case nodeBehavior $ fst n of
113 |       InitiallyCollapsed -> show "hidden"
114 |       _ -> show "shown"
115 | 
116 | showTreeHtml :: Tree NodeInfo -> String
117 | showTreeHtml = unlines . showTreeHtml' . enumTree
118 | 
119 | 
120 | toNodeInfoTree :: Tree String -> Tree NodeInfo
121 | toNodeInfoTree (Node s tree) = Node (NodeInfo InitiallyExpanded s "") $ map toNodeInfoTree tree
122 | 


--------------------------------------------------------------------------------
/src/Syntax.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveGeneric #-}
  2 | {-# LANGUAGE MultiParamTypeClasses #-}
  3 | {-# LANGUAGE PatternSynonyms #-}
  4 | 
  5 | module Syntax (TyVar, TmVar, Typ (..), PrimOp (..), opTyp, Trm (..), pattern TAll, pattern TLam) where
  6 | 
  7 | import Data.Data (Typeable)
  8 | import GHC.Generics (Generic)
  9 | import Unbound.Generics.LocallyNameless
 10 | 
 11 | type TyVar = Name Typ
 12 | 
 13 | type TmVar = Name Trm
 14 | 
 15 | data Typ
 16 |   = TInt
 17 |   | TBool
 18 |   | TTop
 19 |   | TBot
 20 |   | TVar TyVar
 21 |   | ETVar TyVar
 22 |   | STVar TyVar
 23 |   | TArr Typ Typ
 24 |   | TAllB (Bind TyVar Typ) Typ
 25 |   | TIntersection Typ Typ
 26 |   | TUnion Typ Typ
 27 |   | TTuple [Typ]
 28 |   deriving (Generic, Typeable)
 29 | 
 30 | pattern TAll :: Bind TyVar Typ -> Typ
 31 | pattern TAll bnd <- TAllB bnd TTop
 32 |   where
 33 |     TAll bnd = TAllB bnd TTop
 34 | 
 35 | data PrimOp
 36 |   = OpAdd
 37 |   | OpSub
 38 |   | OpMul
 39 |   | OpDiv
 40 |   deriving (Eq, Generic)
 41 | 
 42 | opTyp :: PrimOp -> Typ
 43 | opTyp OpAdd = TArr TInt (TArr TInt TInt)
 44 | opTyp OpSub = TArr TInt (TArr TInt TInt)
 45 | opTyp OpMul = TArr TInt (TArr TInt TInt)
 46 | opTyp OpDiv = TArr TInt (TArr TInt TInt)
 47 | 
 48 | data Trm
 49 |   = LitInt Integer
 50 |   | LitBool Bool
 51 |   | Var TmVar
 52 |   | Lam (Bind TmVar Trm)
 53 |   | App Trm Trm
 54 |   | Ann Trm Typ
 55 |   | TLamB (Bind TyVar Trm) Typ
 56 |   | TApp Trm Typ
 57 |   | Let Trm (Bind TmVar Trm)
 58 |   | LetRec (Bind TmVar (Trm, Trm))
 59 |   | Op PrimOp
 60 |   | BinOp PrimOp Trm Trm
 61 |   | If Trm Trm Trm
 62 |   | Tuple [Trm]
 63 |   deriving (Generic, Typeable)
 64 | 
 65 | pattern TLam :: Bind TyVar Trm -> Trm
 66 | pattern TLam bnd <- TLamB bnd TTop
 67 |   where
 68 |     TLam bnd = TLamB bnd TTop
 69 | 
 70 | instance Alpha Typ
 71 | 
 72 | instance Alpha Trm
 73 | 
 74 | instance Alpha PrimOp
 75 | 
 76 | instance Subst Trm Typ
 77 | 
 78 | instance Subst Typ Trm
 79 | 
 80 | instance Subst Typ PrimOp
 81 | 
 82 | instance Subst Trm PrimOp
 83 | 
 84 | instance Subst Typ Typ where
 85 |   isvar (TVar v) = Just (SubstName v)
 86 |   isvar (ETVar v) = Just (SubstName v)
 87 |   isvar (STVar v) = Just (SubstName v)
 88 |   isvar _ = Nothing
 89 | 
 90 | instance Subst Trm Trm where
 91 |   isvar (Var v) = Just (SubstName v)
 92 |   isvar _ = Nothing
 93 | 
 94 | showsPrecTyp :: Int -> Typ -> FreshM ShowS
 95 | showsPrecTyp _ TInt = return $ showString "Int"
 96 | showsPrecTyp _ TBool = return $ showString "Bool"
 97 | showsPrecTyp _ TTop = return $ showString "⊤"
 98 | showsPrecTyp _ TBot = return $ showString "⊥"
 99 | showsPrecTyp _ (TVar x) = return $ shows x
100 | showsPrecTyp _ (ETVar x) = return $ showString "^" . shows x
101 | showsPrecTyp _ (STVar x) = return $ showString "~" . shows x
102 | showsPrecTyp p (TArr a b) = do
103 |   a' <- showsPrecTyp 1 a
104 |   b' <- showsPrecTyp 0 b
105 |   return $ showParen (p > 0) $ a' . showString " -> " . b'
106 | showsPrecTyp p (TAll bnd) = do
107 |   (x, t) <- unbind bnd
108 |   t' <- showsPrecTyp 0 t
109 |   return $ showParen (p > 0) $ showString "∀" . shows x . showString ". " . t'
110 | showsPrecTyp p (TAllB bnd b) = do
111 |   (x, t) <- unbind bnd
112 |   t' <- showsPrecTyp 0 t
113 |   b' <- showsPrecTyp 0 b
114 |   return $ showParen (p > 0) $ showString "∀(" . shows x . showString " <: " . b' . showString "). " . t'
115 | showsPrecTyp p (TIntersection a b) = do
116 |   -- TODO: I am unsure about the number
117 |   a' <- showsPrecTyp 1 a
118 |   b' <- showsPrecTyp 1 b
119 |   return $ showParen (p > 0) $ a' . showString " & " . b'
120 | showsPrecTyp p (TUnion a b) = do
121 |   -- TODO: I am unsure about the number
122 |   a' <- showsPrecTyp 1 a
123 |   b' <- showsPrecTyp 1 b
124 |   return $ showParen (p > 0) $ a' . showString " | " . b'
125 | showsPrecTyp _ (TTuple ts) = do
126 |   ts' <- mapM (showsPrecTyp 0) ts
127 |   return $ showString "(" . foldr1 (\a b -> a . showString ", " . b) ts' . showString ")"
128 | 
129 | instance Show Typ where
130 |   showsPrec prec ty = runFreshM $ showsPrecTyp prec ty
131 | 
132 | showOp :: PrimOp -> ShowS
133 | showOp OpAdd = showString "+"
134 | showOp OpSub = showString "-"
135 | showOp OpMul = showString "*"
136 | showOp OpDiv = showString "/"
137 | 
138 | instance Show PrimOp where
139 |   showsPrec _ = showParen True . showOp
140 | 
141 | showsPrecTrm :: Int -> Trm -> FreshM ShowS
142 | showsPrecTrm _ (LitInt i) = return $ shows i
143 | showsPrecTrm _ (LitBool b) = return $ shows b
144 | showsPrecTrm _ (Var x) = return $ shows x
145 | showsPrecTrm p (Lam bnd) = do
146 |   (x, e) <- unbind bnd
147 |   e' <- showsPrecTrm 0 e
148 |   return $ showParen (p > 0) $ showString "λ" . shows x . showString ". " . e'
149 | showsPrecTrm p (App e1 e2) = do
150 |   e1' <- showsPrecTrm 9 e1
151 |   e2' <- showsPrecTrm 10 e2
152 |   return $ showParen (p > 9) $ e1' . showString " " . e2'
153 | showsPrecTrm p (Ann e t) = do
154 |   e' <- showsPrecTrm 1 e
155 |   return $ showParen (p > 1) $ e' . showString " : " . shows t
156 | showsPrecTrm p (TLam bnd) = do
157 |   (a, e) <- unbind bnd
158 |   e' <- showsPrecTrm 0 e
159 |   return $ showParen (p > 0) $ showString "Λ" . shows a . showString ". " . e'
160 | showsPrecTrm p (TLamB bnd b) = do
161 |   (a, e) <- unbind bnd
162 |   e' <- showsPrecTrm 0 e
163 |   b' <- showsPrecTyp 0 b
164 |   return $ showParen (p > 0) $ showString "Λ(" . shows a . showString " <: " . b' . showString "). " . e'
165 | showsPrecTrm p (TApp e t) = do
166 |   e' <- showsPrecTrm 9 e
167 |   t' <- showsPrecTyp 10 t
168 |   return $ showParen (p > 9) $ e' . showString " @" . t'
169 | showsPrecTrm p (Let e1 bnd) = do
170 |   (x, e2) <- unbind bnd
171 |   e1' <- showsPrecTrm 0 e1
172 |   e2' <- showsPrecTrm 0 e2
173 |   return $ showParen (p > 0) $ showString "let " . shows x . showString " = " . e1' . showString " in " . e2'
174 | showsPrecTrm p (LetRec bnd) = do
175 |   (x, (e1, e2)) <- unbind bnd
176 |   e1' <- showsPrecTrm 0 e1
177 |   e2' <- showsPrecTrm 0 e2
178 |   return $ showParen (p > 0) $ showString "letrec " . shows x . showString " = " . e1' . showString " in " . e2'
179 | showsPrecTrm _ (Op op) = return $ shows op
180 | showsPrecTrm p (BinOp op e1 e2) | op `elem` [OpAdd, OpSub] = do
181 |   e1' <- showsPrecTrm 6 e1
182 |   e2' <- showsPrecTrm 7 e2
183 |   return $ showParen (p > 6) $ e1' . showString " " . showOp op . showString " " . e2'
184 | showsPrecTrm p (BinOp op e1 e2) = do
185 |   e1' <- showsPrecTrm 7 e1
186 |   e2' <- showsPrecTrm 8 e2
187 |   return $ showParen (p > 7) $ e1' . showString " " . showOp op . showString " " . e2'
188 | showsPrecTrm p (If e1 e2 e3) = do
189 |   e1' <- showsPrecTrm 0 e1
190 |   e2' <- showsPrecTrm 0 e2
191 |   e3' <- showsPrecTrm 0 e3
192 |   return $ showParen (p > 0) $ showString "if " . e1' . showString " then " . e2' . showString " else " . e3'
193 | showsPrecTrm _ (Tuple es) = do
194 |   es' <- mapM (showsPrecTrm 0) es
195 |   return $ showString "(" . foldr1 (\a b -> a . showString ", " . b) es' . showString ")"
196 | 
197 | instance Show Trm where
198 |   showsPrec prec tm = runFreshM $ showsPrecTrm prec tm
199 | 


--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
 1 | # This file was automatically generated by 'stack init'
 2 | #
 3 | # Some commonly used options have been documented as comments in this file.
 4 | # For advanced use and comprehensive documentation of the format, please see:
 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/
 6 | 
 7 | # A 'specific' Stackage snapshot or a compiler version.
 8 | # A snapshot resolver dictates the compiler version and the set of packages
 9 | # to be used for project dependencies. For example:
10 | #
11 | # snapshot: lts-22.28
12 | # snapshot: nightly-2024-07-05
13 | # snapshot: ghc-9.6.6
14 | #
15 | # The location of a snapshot can be provided as a file or url. Stack assumes
16 | # a snapshot provided as a file might change, whereas a url resource does not.
17 | #
18 | # snapshot: ./custom-snapshot.yaml
19 | # snapshot: https://example.com/snapshots/2024-01-01.yaml
20 | snapshot:
21 |   url: http://mirrors.ustc.edu.cn/stackage/stackage-snapshots/lts/22/43.yaml
22 | 
23 | # User packages to be built.
24 | # Various formats can be used as shown in the example below.
25 | #
26 | # packages:
27 | # - some-directory
28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
29 | #   subdirs:
30 | #   - auto-update
31 | #   - wai
32 | packages:
33 | - .
34 | # Dependency packages to be pulled from upstream that are not in the snapshot.
35 | # These entries can reference officially published versions as well as
36 | # forks / in-progress versions pinned to a git hash. For example:
37 | #
38 | # extra-deps:
39 | # - acme-missiles-0.3
40 | # - git: https://github.com/commercialhaskell/stack.git
41 | #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
42 | #
43 | # extra-deps: []
44 | 
45 | # unbound-generics-0.4.4 currently only appears in the nightly snapshot 
46 | extra-deps:
47 |   - unbound-generics-0.4.4@sha256:f7fc93641d5043db8938a5e77f463afa7c473edca3ef26097d4b6f98d45e255c,5521
48 | 
49 | # Override default flag values for project packages and extra-deps
50 | # flags: {}
51 | 
52 | # Extra package databases containing global packages
53 | # extra-package-dbs: []
54 | 
55 | # Control whether we use the GHC we find on the path
56 | # system-ghc: true
57 | #
58 | # Require a specific version of Stack, using version ranges
59 | # require-stack-version: -any # Default
60 | # require-stack-version: ">=3.1"
61 | #
62 | # Override the architecture used by Stack, especially useful on Windows
63 | # arch: i386
64 | # arch: x86_64
65 | #
66 | # Extra directories used by Stack for building
67 | # extra-include-dirs: [/path/to/dir]
68 | # extra-lib-dirs: [/path/to/dir]
69 | #
70 | # Allow a newer minor version of GHC than the snapshot specifies
71 | # compiler-check: newer-minor
72 | 


--------------------------------------------------------------------------------
/stack.yaml.lock:
--------------------------------------------------------------------------------
 1 | # This file was autogenerated by Stack.
 2 | # You should not edit this file by hand.
 3 | # For more information, please see the documentation at:
 4 | #   https://docs.haskellstack.org/en/stable/lock_files
 5 | 
 6 | packages:
 7 | - completed:
 8 |     hackage: unbound-generics-0.4.4@sha256:f7fc93641d5043db8938a5e77f463afa7c473edca3ef26097d4b6f98d45e255c,5521
 9 |     pantry-tree:
10 |       sha256: 0f4e625ef42ebec6078ed94b7c539269bfe51ef148c91fa8803afff884ca24d7
11 |       size: 3267
12 |   original:
13 |     hackage: unbound-generics-0.4.4@sha256:f7fc93641d5043db8938a5e77f463afa7c473edca3ef26097d4b6f98d45e255c,5521
14 | snapshots:
15 | - completed:
16 |     sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146
17 |     size: 720271
18 |     url: http://mirrors.ustc.edu.cn/stackage/stackage-snapshots/lts/22/43.yaml
19 |   original:
20 |     url: http://mirrors.ustc.edu.cn/stackage/stackage-snapshots/lts/22/43.yaml
21 | 


--------------------------------------------------------------------------------
/test/Spec.hs:
--------------------------------------------------------------------------------
1 | main :: IO ()
2 | main = putStrLn "Test suite not yet implemented"
3 | 


--------------------------------------------------------------------------------
/type-inference-zoo.cabal:
--------------------------------------------------------------------------------
  1 | cabal-version: 1.12
  2 | 
  3 | -- This file has been generated from package.yaml by hpack version 0.37.0.
  4 | --
  5 | -- see: https://github.com/sol/hpack
  6 | 
  7 | name:           type-inference-zoo
  8 | version:        0.1.0.0
  9 | description:    Please see the README on GitHub at <https://github.com/cu1ch3n/type-inference-zoo#readme>
 10 | homepage:       https://github.com/cu1ch3n/type-inference-zoo#readme
 11 | bug-reports:    https://github.com/cu1ch3n/type-inference-zoo/issues
 12 | author:         Chen Cui
 13 | maintainer:     i@cuichen.cc
 14 | copyright:      2025 Chen Cui
 15 | license:        MIT
 16 | license-file:   LICENSE
 17 | build-type:     Simple
 18 | extra-source-files:
 19 |     README.md
 20 |     CHANGELOG.md
 21 | 
 22 | source-repository head
 23 |   type: git
 24 |   location: https://github.com/cu1ch3n/type-inference-zoo
 25 | 
 26 | library
 27 |   exposed-modules:
 28 |       Alg
 29 |       Alg.DK
 30 |       Alg.DK.Common
 31 |       Alg.DK.DK
 32 |       Alg.DK.Worklist
 33 |       Alg.DK.Worklist.Bounded
 34 |       Alg.DK.Worklist.Common
 35 |       Alg.DK.Worklist.DK
 36 |       Alg.DK.Worklist.Elementary
 37 |       Alg.DK.Worklist.IU
 38 |       Alg.HDM
 39 |       Alg.HDM.AlgR
 40 |       Alg.HDM.AlgW
 41 |       Alg.Local
 42 |       Alg.Local.Contextual
 43 |       Alg.Local.Contextual.Contextual
 44 |       Alg.Local.Local
 45 |       Lib
 46 |       Opt
 47 |       Parser
 48 |       Print
 49 |       Syntax
 50 |   other-modules:
 51 |       Paths_type_inference_zoo
 52 |   hs-source-dirs:
 53 |       src
 54 |   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
 55 |   build-depends:
 56 |       base >=4.7 && <5
 57 |     , containers
 58 |     , hspec
 59 |     , logict
 60 |     , megaparsec
 61 |     , mtl
 62 |     , parser-combinators
 63 |     , transformers
 64 |     , tree-view
 65 |     , unbound-generics
 66 |   default-language: Haskell2010
 67 | 
 68 | executable type-inference-zoo-exe
 69 |   main-is: Main.hs
 70 |   other-modules:
 71 |       Paths_type_inference_zoo
 72 |   hs-source-dirs:
 73 |       app
 74 |   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
 75 |   build-depends:
 76 |       base >=4.7 && <5
 77 |     , containers
 78 |     , hspec
 79 |     , logict
 80 |     , megaparsec
 81 |     , mtl
 82 |     , parser-combinators
 83 |     , transformers
 84 |     , tree-view
 85 |     , type-inference-zoo
 86 |     , unbound-generics
 87 |   default-language: Haskell2010
 88 | 
 89 | test-suite type-inference-zoo-test
 90 |   type: exitcode-stdio-1.0
 91 |   main-is: Spec.hs
 92 |   other-modules:
 93 |       Paths_type_inference_zoo
 94 |   hs-source-dirs:
 95 |       test
 96 |   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
 97 |   build-depends:
 98 |       base >=4.7 && <5
 99 |     , containers
100 |     , hspec
101 |     , logict
102 |     , megaparsec
103 |     , mtl
104 |     , parser-combinators
105 |     , transformers
106 |     , tree-view
107 |     , type-inference-zoo
108 |     , unbound-generics
109 |   default-language: Haskell2010
110 | 


--------------------------------------------------------------------------------