├── .gitattributes ├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── Expt ├── Agen │ ├── Basics.agda │ ├── Bind.agda │ ├── Cop.agda │ ├── Examples.agda │ ├── MangleActors.agda │ ├── Mangler.agda │ ├── Pair.agda │ ├── Pat.agda │ ├── Pub.agda │ ├── Solve.agda │ ├── Term.agda │ ├── Thin.agda │ └── cdb.agda-lib └── CdBsb.agda ├── Makefile ├── README.md ├── Src ├── ANSI.hs ├── Actor.hs ├── Actor │ └── Display.hs ├── Alarm.hs ├── Bwd.hs ├── Command.hs ├── Concrete │ ├── Base.hs │ ├── Parse.hs │ └── Pretty.hs ├── Display.hs ├── Doc │ └── Annotations.hs ├── Elaboration.hs ├── Elaboration │ ├── Monad.hs │ └── Pretty.hs ├── Forget.hs ├── Format.hs ├── Hide.hs ├── Info.hs ├── LaTeX.hs ├── Location.hs ├── Machine.hs ├── Machine │ ├── Base.hs │ ├── Display.hs │ ├── Exec.hs │ ├── Matching.hs │ ├── Steps.hs │ └── Trace.hs ├── Main.hs ├── Operator.hs ├── Operator │ └── Eval.hs ├── Options.hs ├── Parse.hs ├── Pattern.hs ├── Pattern │ └── Coverage.hs ├── Pretty.hs ├── Scope.hs ├── Semantics.hs ├── Syntax.hs ├── Syntax │ └── Debug.hs ├── Term.hs ├── Term │ ├── Base.hs │ ├── Display.hs │ ├── Mangler.hs │ └── Substitution.hs ├── Thin.hs ├── Unelaboration.hs ├── Unelaboration │ └── Monad.hs ├── Utils.hs └── Vector.hs ├── TODO.md ├── build ├── notations.tex ├── trace.gif └── trace.svg ├── cabal.project.local ├── emacs ├── emacs └── typos.el ├── examples ├── elaboration.act ├── golden │ ├── README.gold │ ├── Roadmap.gold │ ├── elaboration.gold │ ├── krivine.gold │ ├── krivine2.gold │ ├── mltt.gold │ ├── mltt2.gold │ ├── mlttEta.gold │ ├── mlttList.gold │ ├── stlc.gold │ ├── stlc2.gold │ ├── stlc3.gold │ ├── stlc4.gold │ ├── stlctpp.gold │ ├── stlctpp2.gold │ └── untyped.gold ├── krivine.act ├── krivine2.act ├── mltt.act ├── mltt2.act ├── mlttEta.act ├── mlttList.act ├── stlc.act ├── stlc2.act ├── stlc3.act ├── stlc4.act ├── stlctpp.act ├── stlctpp2.act ├── stlctpp2.flags └── untyped.act ├── failing └── mltt_krivine.act ├── papers ├── 2022-SPLS │ ├── Roadmap.md │ └── stuck.act └── 2022-TYPES │ ├── Makefile │ ├── easychair.cls │ ├── golden │ ├── krivine2.gold │ ├── mlttEta.gold │ ├── mlttList.gold │ ├── stlc-in-abstract.gold │ ├── stlc.gold │ └── untyped.gold │ ├── stlc-in-abstract.act │ ├── talk │ ├── examples │ │ ├── build │ │ │ ├── notations.tex │ │ │ └── notations2.tex │ │ ├── krivine2.act │ │ ├── mlttEta.act │ │ ├── mlttList.act │ │ ├── stlc.act │ │ └── untyped.act │ ├── pictures │ │ ├── actors │ │ │ ├── conor.jpg │ │ │ ├── craig-cropped.jpg │ │ │ ├── craig.jpg │ │ │ ├── gallais.jpg │ │ │ ├── georgi.jpg │ │ │ └── malin.eps │ │ ├── globe.jpg │ │ └── graslin.jpg │ ├── stlc-animated.tex │ └── typOS_TYPES2022.tex │ ├── types.tex │ └── typos.bib ├── stack.yaml ├── test ├── Test │ └── Main.hs ├── app-operator-fail.act ├── app-operator.act ├── as-patterns.act ├── barred-atom-pattern.act ├── barred-atom.act ├── binders.act ├── case-pair-failing.act ├── case-pair.act ├── case-proposal.act ├── case-tuples-failing.act ├── case-tuples.act ├── channelvar-fail.act ├── citizens.act ├── citizens.flags ├── communicating-pairs.act ├── communication-fail.act ├── coverage.act ├── coverage.flags ├── covered.act ├── covered.flags ├── define-operator.act ├── define-operator.flags ├── elab-channel-failing.act ├── elab-push-failing.act ├── elab-send-failing.act ├── golden │ ├── app-operator-fail.gold │ ├── app-operator.gold │ ├── as-patterns.gold │ ├── barred-atom-pattern.gold │ ├── barred-atom.gold │ ├── binders.gold │ ├── case-pair-failing.gold │ ├── case-pair.gold │ ├── case-proposal.gold │ ├── case-tuples-failing.gold │ ├── case-tuples.gold │ ├── channelvar-fail.gold │ ├── citizens.gold │ ├── communicating-pairs.gold │ ├── communication-fail.gold │ ├── coverage.gold │ ├── covered.gold │ ├── define-operator.gold │ ├── elab-channel-failing.gold │ ├── elab-push-failing.gold │ ├── elab-send-failing.gold │ ├── let-binders.gold │ ├── losing-finishes.gold │ ├── multi-fail.gold │ ├── multibind.gold │ ├── no-space.gold │ ├── not-actorvar-fail.gold │ ├── operator-elab-fail-2.gold │ ├── operator-elab-fail-3.gold │ ├── operator-elab-fail-4.gold │ ├── operator-elab-fail.gold │ ├── operator-fail.gold │ ├── parse-fail-2.gold │ ├── parse-fail-3.gold │ ├── parse-fail.gold │ ├── plumbing.gold │ ├── printing-open.gold │ ├── printing-open2.gold │ ├── printing.gold │ ├── reduce-neutrals-2.gold │ ├── reduce-neutrals.gold │ ├── reserved-keyword.gold │ ├── restarting.gold │ ├── scope-fail.gold │ ├── semanticPi.gold │ ├── shadowed-pattern.gold │ ├── shadowing-fail.gold │ ├── spop-fail.gold │ ├── spop-top-fail.gold │ ├── stlcDidNotWin.gold │ ├── stuckguard.gold │ ├── subject-as-pattern-fail.gold │ ├── subject-scrutinising-fail.gold │ ├── syntax-fail.gold │ ├── syntaxcat-fail.gold │ ├── toonice.gold │ ├── two-fail.gold │ ├── type-projection.gold │ ├── typecheck.gold │ ├── unfinished.gold │ └── unsolved-meta.gold ├── let-binders.act ├── losing-finishes.act ├── multi-fail.act ├── multibind.act ├── no-space.act ├── not-actorvar-fail.act ├── operator-elab-fail-2.act ├── operator-elab-fail-3.act ├── operator-elab-fail-4.act ├── operator-elab-fail.act ├── operator-fail.act ├── parse-fail-2.act ├── parse-fail-3.act ├── parse-fail.act ├── plumbing.act ├── printing-open.act ├── printing-open2.act ├── printing.act ├── printing.flags ├── reduce-neutrals-2.act ├── reduce-neutrals-2.flags ├── reduce-neutrals.act ├── reduce-neutrals.flags ├── reserved-keyword.act ├── restarting.act ├── scope-fail.act ├── semanticPi.act ├── shadowed-pattern.act ├── shadowing-fail.act ├── spop-fail.act ├── spop-top-fail.act ├── stlcDidNotWin.act ├── stlcDidNotWin.flags ├── stuckguard.act ├── subject-as-pattern-fail.act ├── subject-scrutinising-fail.act ├── syntax-fail.act ├── syntaxcat-fail.act ├── toonice.act ├── two-fail.act ├── two-fail.flags ├── type-projection.act ├── typecheck.act ├── unfinished.act ├── unfinished.flags └── unsolved-meta.act └── typos.cabal /.gitattributes: -------------------------------------------------------------------------------- 1 | *.gold -text 2 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push] 4 | 5 | jobs: 6 | cabal: 7 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 8 | runs-on: ${{ matrix.os }} 9 | strategy: 10 | matrix: 11 | os: [ubuntu-latest, macOS-latest, windows-latest] 12 | cabal: [latest] 13 | ghc: 14 | - "8.10" 15 | - "9.0" 16 | - latest 17 | exclude: 18 | - os: macOS-latest 19 | ghc: 9.0 20 | - os: macOS-latest 21 | ghc: 8.10 22 | 23 | - os: windows-latest 24 | ghc: 9.0 25 | - os: windows-latest 26 | ghc: 8.10 27 | 28 | steps: 29 | - uses: actions/checkout@v2 30 | 31 | - uses: haskell/actions/setup@v1.2 32 | id: setup-haskell-cabal 33 | name: Setup Haskell 34 | with: 35 | ghc-version: ${{ matrix.ghc }} 36 | cabal-version: ${{ matrix.cabal }} 37 | 38 | - name: Configure 39 | run: | 40 | cabal configure --enable-tests --test-show-details=direct --write-ghc-environment-files=always 41 | 42 | - name: Freeze 43 | run: | 44 | cabal freeze 45 | 46 | - uses: actions/cache@v2 47 | name: Cache ~/.cabal/store 48 | with: 49 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 50 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ secrets.CACHE_CABAL_VERSION }}-${{ hashFiles('cabal.project.freeze') }} 51 | 52 | - name: Install dependencies 53 | run: | 54 | cabal build all --only-dependencies 55 | 56 | - name: Build 57 | run: | 58 | cabal build all 59 | 60 | - name: Test 61 | # if: runner.os != 'Windows' 62 | env: 63 | TERM: dumb 64 | run: | 65 | cabal test all 66 | 67 | stack: 68 | name: stack / ghc ${{ matrix.ghc }} 69 | runs-on: ubuntu-latest 70 | strategy: 71 | matrix: 72 | stack: [latest] 73 | ghc: ["8.10.7"] 74 | 75 | steps: 76 | - uses: actions/checkout@v2 77 | 78 | - uses: haskell/actions/setup@v1.2 79 | name: Setup Haskell Stack 80 | with: 81 | ghc-version: ${{ matrix.ghc }} 82 | stack-version: ${{ matrix.stack }} 83 | 84 | - uses: actions/cache@v2 85 | name: Cache ~/.stack 86 | with: 87 | path: ~/.stack 88 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ secrets.CACHE_STACK_VERSION }}-stack 89 | 90 | - name: Install dependencies 91 | run: | 92 | stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies 93 | 94 | - name: Build 95 | run: | 96 | stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks 97 | 98 | - name: Test 99 | # if: runner.os != 'Windows' 100 | env: 101 | TERM: dumb 102 | run: | 103 | stack test --system-ghc 104 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.hie 8 | *.chi 9 | *.chs.h 10 | *.dyn_o 11 | *.dyn_hi 12 | .hpc 13 | .hsenv 14 | .cabal-sandbox/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | *.eventlog 20 | .stack-work/ 21 | cabal.project.local 22 | cabal.project.local~ 23 | .HTF/ 24 | .ghc.environment.* 25 | *.agdai 26 | *# 27 | *~ 28 | *.log 29 | *.out 30 | *.pdf 31 | *.nav 32 | *.snm 33 | *.toc 34 | *.vrb 35 | *.fls 36 | *.fdb_latexmk 37 | -------------------------------------------------------------------------------- /Expt/Agen/Basics.agda: -------------------------------------------------------------------------------- 1 | module Basics where 2 | 3 | open import Agda.Builtin.FromNat public 4 | import Agda.Builtin.Nat as N 5 | 6 | data _~_ {X : Set}(x : X) : X -> Set where 7 | r~ : x ~ x 8 | {-# BUILTIN EQUALITY _~_ #-} 9 | 10 | refl : {X : Set}(x : X) -> x ~ x 11 | refl x = r~ 12 | 13 | _~$~_ : forall {S T} 14 | {f g : S -> T} -> f ~ g -> 15 | {x y : S} -> x ~ y -> 16 | f x ~ g y 17 | r~ ~$~ r~ = r~ 18 | infixl 2 _~$~_ 19 | 20 | id : forall {l}{X : Set l} -> X -> X 21 | id x = x 22 | 23 | _-_ : forall {i j k}{A : Set i}{B : A -> Set j}{C : (a : A) -> B a -> Set k} 24 | (f : (a : A) -> B a) 25 | (g : {a : A}(b : B a) -> C a b) 26 | (a : A) -> C a (f a) 27 | (f - g) a = g (f a) 28 | 29 | ko : forall {i j}{A : Set i}{B : A -> Set j} 30 | (a : A)(b : B a) -> A 31 | ko a _ = a 32 | 33 | data `0 : Set where 34 | record `1 : Set where instance constructor <> 35 | data `2 : Set where ff tt : `2 36 | 37 | data Bwd (X : Set) : Set where 38 | [] : Bwd X 39 | _-,_ : Bwd X -> X -> Bwd X 40 | infixl 30 _-,_ _<<<_ 41 | 42 | Nat : Set 43 | Nat = Bwd `1 44 | 45 | pattern zero = [] 46 | pattern suc x = x -, _ 47 | 48 | instance 49 | numberNat : Number Nat 50 | Number.Constraint numberNat _ = `1 51 | Number.fromNat numberNat N.zero = zero 52 | Number.fromNat numberNat (N.suc n) = suc (Number.fromNat numberNat n) 53 | 54 | _<<<_ : forall {X} -> Bwd X -> Bwd X -> Bwd X 55 | xz <<< [] = xz 56 | xz <<< (yz -, y) = xz <<< yz -, y 57 | 58 | []<<<_ : forall {X} -> (yz : Bwd X) -> [] <<< yz ~ yz 59 | []<<< [] = r~ 60 | []<<< (yz -, x) rewrite []<<< yz = r~ 61 | 62 | record _><_ (S : Set)(T : S -> Set) : Set where 63 | constructor _,_ 64 | field 65 | fst : S 66 | snd : T fst 67 | open _><_ public 68 | pattern !_ t = _ , t 69 | _*_ : Set -> Set -> Set 70 | S * T = S >< \ _ -> T 71 | pattern _&_ a b = ! a , b 72 | infixr 10 _><_ !_ _,_ _*_ 73 | infixr 11 _&_ 74 | _+_ : Set -> Set -> Set 75 | S + T = `2 >< \ { ff -> S ; tt -> T } 76 | Maybe = `1 +_ 77 | pattern aye x = tt , x 78 | pattern naw = ff , <> 79 | 80 | _>><<_ : forall {S0 S1 T0 T1} -> (f : S0 -> S1)(g : forall {s0} -> T0 s0 -> T1 (f s0)) -> 81 | S0 >< T0 -> S1 >< T1 82 | (f >><< g) (s , t) = f s , g t 83 | 84 | maybe : forall {S T} -> (S -> T) -> Maybe S -> Maybe T 85 | maybe f naw = naw 86 | maybe f (aye s) = aye (f s) 87 | 88 | _>M=_ : forall {S T} -> Maybe S -> (S -> Maybe T) -> Maybe T 89 | aye s >M= k = k s 90 | naw >M= k = naw 91 | 92 | _>>=_ = _>M=_ 93 | 94 | module _ {X : Set} where 95 | 96 | <_> [_] : (X -> Set) -> Set 97 | < T > = X >< T 98 | [ T ] = {x : X} -> T x 99 | infixr 10 <_> [_] 100 | 101 | _*:_ _-:>_ : (X -> Set) -> (X -> Set) -> (X -> Set) 102 | (S *: T) x = S x * T x 103 | (S -:> T) x = S x -> T x 104 | infixr 10 _*:_ 105 | infixr 9 _-:>_ 106 | 107 | record Applicative (f : Set -> Set) : Set₁ where 108 | field 109 | pure : {X : Set} -> X -> f X 110 | _<*>_ : {X Y : Set} -> f (X -> Y) -> f X -> f Y 111 | 112 | _<$>_ : {X Y : Set} -> (X -> Y) -> f X -> f Y 113 | f <$> x = (| f x |) 114 | 115 | infixr 11 _<$>_ 116 | infixl 10 _<*>_ 117 | 118 | open Applicative {{...}} public 119 | 120 | IdApp : Applicative id 121 | Applicative.pure IdApp = id 122 | Applicative._<*>_ IdApp = id 123 | 124 | instance 125 | MaybeApp : Applicative Maybe 126 | MaybeApp = record { pure = aye 127 | ; _<*>_ = \f s -> f >M= \ f -> s >M= \ s -> aye (f s) 128 | } 129 | 130 | -------------------------------------------------------------------------------- /Expt/Agen/Bind.agda: -------------------------------------------------------------------------------- 1 | module Bind where 2 | 3 | open import Basics 4 | open import Thin 5 | 6 | module BIND {X : Set} where 7 | open THIN {X} 8 | 9 | data _|-_ (x : X)(P : Bwd X -> Set)(ga : Bwd X) : Set where 10 | kk : P ga -> (x |- P) ga 11 | ll : P (ga -, x) -> (x |- P) ga 12 | 13 | _\\_ : {P : Bwd X -> Set}(x : X) -> 14 | [ ((_-, x) - (P ^:_)) -:> (x |- P) ^:_ ] 15 | x \\ (p & th -^ .x) = kk p & th 16 | x \\ (p & th -, .x) = ll p & th 17 | 18 | under : forall {x ga}{P : Bwd X -> Set} 19 | -> (x |- P) ^: ga -> P ^: ga -, x 20 | under (kk p & th) = p & th -^ _ 21 | under (ll p & th) = p & th -, _ 22 | 23 | data Only (x : X) : Bwd X -> Set where 24 | only : Only x ([] -, x) 25 | -------------------------------------------------------------------------------- /Expt/Agen/Examples.agda: -------------------------------------------------------------------------------- 1 | module Examples where 2 | 3 | open import Agda.Builtin.String 4 | 5 | open import Basics 6 | open import Thin 7 | open import Cop 8 | open import Pair 9 | open import Bind 10 | open import Term 11 | open import Mangler 12 | open import Pub 13 | open import Pat 14 | 15 | open THIN {`1} 16 | open COP {`1} 17 | open PAIR {`1} 18 | open BIND {`1} 19 | open PUB {`1} 20 | 21 | record AA : Set where 22 | constructor atom 23 | field 24 | code : Nat 25 | open AA 26 | 27 | eqNat : (a b : Nat) → Maybe (a ~ b) 28 | eqNat zero zero = aye r~ 29 | eqNat (suc a) (suc b) = (| (refl suc ~$~_) (eqNat a b) |) 30 | eqNat x y = naw 31 | 32 | eqAA : (a b : AA) → Maybe (a ~ b) 33 | eqAA (atom a) (atom b) = (| (refl atom ~$~_) (eqNat a b) |) 34 | 35 | open PAT AA eqAA 36 | 37 | 38 | pattern App = atom zero 39 | pattern Lam = atom (suc zero) 40 | 41 | betaLHS : Pat [] 42 | betaLHS = pp (aa App) (pp (pp (aa Lam) (bb (io ??))) (io ??)) 43 | 44 | open OMATCH (_) ??))) hh)) os) -/^ _) 51 | 52 | beta : forall {ga} -> Term ga -> Maybe (Term ga) 53 | beta {ga} t = do 54 | pi <- match? ga betaLHS t 55 | aye (stan'^ betaLHS betaRHS pi) 56 | 57 | redex : Term (suc zero) 58 | redex = a^ App ,^ ((a^ Lam ,^ b^ (v^ (no -, _))) ,^ v^ (no -, _)) 59 | 60 | test = beta redex 61 | -------------------------------------------------------------------------------- /Expt/Agen/MangleActors.agda: -------------------------------------------------------------------------------- 1 | open import Basics 2 | 3 | module MangleActors 4 | (ActorVar Unknown : Nat -> Set) 5 | (ATOM : Set) 6 | where 7 | 8 | open import Thin 9 | open import Cop 10 | open import Pair 11 | open import Bind 12 | open import Pub 13 | 14 | open THIN {`1} 15 | open COP {`1} 16 | open PAIR {`1} 17 | open BIND {`1} 18 | open PUB {`1} 19 | open import Term 20 | 21 | module _ where 22 | 23 | open TERM ActorVar ATOM 24 | 25 | Src : Nat -- scope from the pattern that bound it 26 | -> Set 27 | Src = Tm 28 | _S>_ = _%>_ 29 | _S>^_ = _%>^_ 30 | 31 | module _ where 32 | 33 | open TERM Unknown ATOM 34 | 35 | Trg : Nat -- what's actually in scope? 36 | -> Set 37 | Trg = Tm 38 | _T>_ = _%>_ 39 | _T>^_ = _%>^_ 40 | 41 | Env : Nat -> Set 42 | Env ga = forall {xi} 43 | -> ActorVar xi 44 | -> Trg ^: (ga <<< xi) 45 | 46 | thEnv : forall {ga de} -> Env ga -> ga <= de -> Env de 47 | thEnv rho th av = rho av |^ (th +^+ io) 48 | 49 | module T {M} = TERM M ATOM 50 | open T 51 | 52 | {- 53 | ma : forall 54 | {ga0 -- support of source term 55 | ga {- how many vars are really in scope -} 56 | } 57 | -> Env ga 58 | -> Src ga0 59 | -> ga0 <= ga 60 | -> Trg ^: ga 61 | 62 | ma rh (vv only) th = v^ th 63 | ma rh (aa (atom a)) th = a^ a 64 | ma rh (pp (s t)) th = 65 | ma rh s (luth u -& th) ,^ ma rh t (ruth u -& th) 66 | ma rh (bb (kk x)) th = b^ (ma (thEnv rh (io -^ <>)) x (th -^ <>)) 67 | ma rh (bb (ll x)) th = b^ (ma (thEnv rh (io -^ <>)) x (th -, <>)) 68 | ma rh (mm (x & sg)) th = rh x //^ masu rh sg th where 69 | 70 | masu : forall 71 | {xi -- scope of the actor var 72 | ga0 -- support of source term 73 | ga {- how many vars are really in scope -} 74 | } 75 | -> Env ga 76 | -> xi S> ga0 77 | -> ga0 <= ga 78 | -> (ga <<< xi) T>^ ga 79 | 80 | masu rh [] th = eta^ is 81 | masu rh (sg -, x) th = 82 | (masu rh sg (io -^ x -& th) /,\ v^ ((no -, x) -& th)) 83 | -/^ x 84 | masu rh ((sg t) -/ x) th = 85 | (masu rh sg (luth u -& th) /,\ ma rh t (ruth u -& th)) 86 | -/^ x 87 | -} 88 | 89 | module _ 90 | {ga {- how many vars are really in scope -}} 91 | (rh : Env ga) where 92 | 93 | ma : forall 94 | {de0 -- support of source term 95 | de -- how many binders in source term we're under 96 | } 97 | -> Src de0 98 | -> de0 <= de 99 | -> Trg ^: (ga <<< de) 100 | 101 | masu : forall 102 | {xi -- scope of actor var 103 | de0 -- support of source term 104 | de -- how many binders in source term we're under 105 | } 106 | -> xi S> de0 107 | -> de0 <= de 108 | -> (ga <<< xi) T>^ (ga <<< de) 109 | 110 | ma (vv only) th = v^ (no +^+ th) 111 | ma (aa (atom a)) th = a^ a 112 | ma (pp (s t)) th = 113 | ma s (luth u -& th) ,^ ma t (ruth u -& th) 114 | ma (bb (kk t)) th = b^ (ma t (th -^ <>)) 115 | ma (bb (ll t)) th = b^ (ma t (th -, <>)) 116 | ma (mm (x & sg)) th = rh x //^ masu sg th 117 | 118 | masu [] th = is {- ga -} & io{-ga-} +^+ th {- 0<=de -} 119 | masu ((sg t) -/ x) th = 120 | (masu sg (luth u -& th) /,\ ma t (ruth u -& th)) 121 | -/^ x 122 | masu (sg -, x) (th -^ y) 123 | with ta & ph <- masu (sg -, x) th 124 | = ta & ph -^ y 125 | masu (sg -, x) (th -, .x) 126 | with ta & ph <- masu sg th 127 | = ta -, x & ph -, x 128 | -------------------------------------------------------------------------------- /Expt/Agen/Mangler.agda: -------------------------------------------------------------------------------- 1 | module Mangler where 2 | 3 | open import Basics 4 | open import Thin 5 | open import Cop 6 | open import Pair 7 | open import Bind 8 | open import Term 9 | 10 | open THIN {`1} 11 | open COP {`1} 12 | open PAIR {`1} 13 | open BIND {`1} 14 | 15 | module MANGLE (M M' : Nat -> Set)(A : Set) where 16 | 17 | module T = TERM M A 18 | module T' = TERM M' A 19 | 20 | -- xi: global scope 21 | -- ga: local scope 22 | record Mangler (f : Set -> Set) (xi ga : Nat) 23 | : Set where 24 | coinductive 25 | field 26 | -- mangTh : Maybe (ga <= xi) 27 | mangV : forall {x} -> Only x ga 28 | -> f (T'.Term (xi <<< ga)) 29 | mangB : forall {x} -> Mangler f xi (ga -, x) 30 | mangM : forall {de} -> M de -> f ((xi <<< de) T'.%>^ (xi <<< ga)) 31 | -> f (T'.Term (xi <<< ga)) 32 | mangSelFrom : forall {ga0} -> ga0 <= ga -> Mangler f xi ga0 33 | 34 | open Mangler 35 | 36 | module _ {f : Set -> Set}{{App : Applicative f}} where 37 | 38 | open T 39 | 40 | mangle : forall {ga xi} -> Mangler f xi ga -> 41 | T.Tm ga -> f (T'.Term (xi <<< ga)) 42 | mangleCdB : forall {ga0 xi ga} -> Mangler f xi ga -> 43 | T.Tm ga0 -> ga0 <= ga -> f (T'.Term (xi <<< ga)) 44 | mangleS : forall xi {up ga} -> Mangler f xi ga -> 45 | up T.%> ga -> f ((xi <<< up) T'.%>^ (xi <<< ga)) 46 | mangleCdBS : forall xi {ga0 up ga} -> Mangler f xi ga -> 47 | up T.%> ga0 -> ga0 <= ga -> 48 | f ((xi <<< up) T'.%>^ (xi <<< ga)) 49 | 50 | mangle mu (vv x) = mangV mu x 51 | mangle mu (aa a) with a , _ <- mota a = pure (T'.a^ a) 52 | mangle mu (pp (a b)) 53 | = (| mangleCdB mu a (luth u) T'.,^ mangleCdB mu b (ruth u) |) 54 | mangle mu (bb (kk tm)) = ((kk - T'.bb) $^_) <$> mangle mu tm 55 | mangle mu (bb (ll tm)) = (| T'.b^ (mangle (mangB mu) tm) |) 56 | mangle mu (mm (m & sg)) = mangM mu m (mangleS _ mu sg) 57 | 58 | mangleCdB mu tm th = (_|^ (io +^+ th)) <$> mangle (mangSelFrom mu th) tm 59 | 60 | mangleS xi mu [] = pure (T'.is & io) 61 | mangleS xi mu (sg -, x) = adjust <$> mangleS xi (mangSelFrom mu (io -^ x)) sg where 62 | adjust : forall {ga de x} -> ga T'.%>^ de -> (ga -, x) T'.%>^ (de -, x) 63 | adjust (sg & th) = sg T'.-, x & th -, x 64 | mangleS xi mu ((sg tm) -/ x) 65 | = (| (| mangleCdBS xi mu sg (luth u) /,\ mangleCdB mu tm (ruth u)|) T'.-/^ pure x |) 66 | 67 | mangleCdBS xi mu sg th = (_|^ (io +^+ th)) <$> mangleS xi (mangSelFrom mu th) sg 68 | -------------------------------------------------------------------------------- /Expt/Agen/Pair.agda: -------------------------------------------------------------------------------- 1 | module Pair where 2 | 3 | open import Basics 4 | open import Thin 5 | open import Cop 6 | 7 | module PAIR {X : Set} where 8 | open THIN {X} 9 | open COP {X} 10 | 11 | 12 | infixr 13 __ __ 13 | record __ (P Q : Bwd X -> Set) (de : Bwd X) : Set where 14 | constructor __ 15 | field 16 | {losu rosu} : Bwd X 17 | {loth} : losu <= de 18 | {roth} : rosu <= de 19 | lout : P losu 20 | pcop : loth /u\ roth 21 | rout : Q rosu 22 | open __ 23 | 24 | module _ {P Q : Bwd X -> Set} where 25 | 26 | infixr 10 _/,\_ 27 | _/,\_ : [ P ^:_ -:> Q ^:_ -:> P Q ^:_ ] 28 | p & th /,\ q & ph with (! ! ps & _) , u <- cop th ph = p q & ps 29 | 30 | outl : [ P Q ^:_ -:> P ^:_ ] 31 | outl (p q & ps) = p & luth u -& ps 32 | 33 | outr : [ P Q ^:_ -:> Q ^:_ ] 34 | outr (p q & ps) = q & ruth u -& ps 35 | 36 | splay : forall {de}{M : P Q ^: de -> Set} -> 37 | ((p : P ^: de)(q : Q ^: de) -> M (p /,\ q)) -> 38 | (x : P Q ^: de) -> M x 39 | splay {de}{M} m 40 | (p q & ps) 41 | with z <- m (p & luth u -& ps) (q & ruth u -& ps) 42 | rewrite copQ u ps 43 | = z 44 | 45 | data Atom (A : Set) : Bwd X -> Set where 46 | atom : A -> Atom A [] 47 | 48 | `_ : forall {A} -> A -> [ Atom A ^:_ ] 49 | ` a = atom a & no 50 | 51 | mota : forall {A ga} -> Atom A ga -> A * ga ~ [] 52 | mota (atom a) = (a , r~) 53 | -------------------------------------------------------------------------------- /Expt/Agen/Pub.agda: -------------------------------------------------------------------------------- 1 | module Pub where 2 | 3 | open import Basics 4 | open import Thin 5 | 6 | module PUB {X : Set} where 7 | open THIN {X} 8 | 9 | Squ : forall {wz zz}((th' & th) (ph' & ph) : < wz <=_ *: _<= zz >) -> Set 10 | Squ (! th' , th) (! ph' , ph) = < [ th' -& th ]~_ *: [ ph' -& ph ]~_ > 11 | {- 12 | wz wz-----th'---->o wz-----th'---->o 13 | | | |`-, | 14 | Squ ph' th = ph' `-, th 15 | | | | `-, | 16 | v v v --->v 17 | o-----ph'---->zz zz o-----ph'---->zz 18 | -} 19 | data Pub : forall {wz zz}(ths phs : < wz <=_ *: _<= zz >) -> Set where 20 | _-^_ : forall {wz zz}{(th' & th) (ph' & ph) : < wz <=_ *: _<= zz >} 21 | -> Pub (th' & th) (ph' & ph) -> forall z 22 | -> Pub (th' & th -^ z) (ph' & ph -^ z) 23 | _-^,_ : forall {wz zz}{(th' & th) (ph' & ph) : < wz <=_ *: _<= zz >} 24 | -> Pub (th' & th) (ph' & ph) -> forall y 25 | -> Pub (th' & th -^ y) (ph' -^ y & ph -, y) 26 | _-,^_ : forall {wz zz}{(th' & th) (ph' & ph) : < wz <=_ *: _<= zz >} 27 | -> Pub (th' & th) (ph' & ph) -> forall x 28 | -> Pub (th' -^ x & th -, x) (ph' & ph -^ x) 29 | _-,_ : forall {wz zz}{(th' & th) (ph' & ph) : < wz <=_ *: _<= zz >} 30 | -> Pub (th' & th) (ph' & ph) -> forall z 31 | -> Pub (th' -, z & th -, z) (ph' -, z & ph -, z) 32 | [] : Pub ([] & []) ([] & []) 33 | 34 | pub : forall {xz yz zz}(th : xz <= zz)(ph : yz <= zz) -> 35 | < _<= xz *: _<= yz > >< \ (th' & ph') -> 36 | Squ (th' & th) (ph' & ph) * Pub (th' & th) (ph' & ph) 37 | pub (th -^ z) (ph -^ .z) 38 | with ! v & w , p <- pub th ph 39 | = ! v -^ z & w -^ z , p -^ z 40 | pub (th -^ y) (ph -, .y) 41 | with ! v & w , p <- pub th ph 42 | = ! v -^ y & w -^, y , p -^, y 43 | pub (th -, x) (ph -^ .x) 44 | with ! v & w , p <- pub th ph 45 | = ! v -^, x & w -^ x , p -,^ x 46 | pub (th -, z) (ph -, .z) 47 | with ! v & w , p <- pub th ph 48 | = ! v -, z & w -, z , p -, z 49 | pub [] [] = ! [] & [] , [] 50 | 51 | pubU : forall {xz yz zz}{th : xz <= zz}{ph : yz <= zz} 52 | -> ((th0 & ph0 , _) (th1 & ph1 , _) : < _<= xz *: _<= yz > >< \ (th' & ph') 53 | -> Squ (th' & th) (ph' & ph)) 54 | -> Pub (th0 & th) (ph0 & ph) 55 | -> < [_-& th0 ]~ th1 *: [_-& ph0 ]~ ph1 > 56 | pubU (! v0 -^ .z & w0 -^ .z) (! v1 -^ .z & w1 -^ .z) (p -^ z) = 57 | pubU (! v0 & w0) (! v1 & w1) p 58 | pubU (! v0 -^ .y & w0 -^, .y) (! v1 -^ .y & w1 -^, .y) (p -^, y) 59 | with v & w <- pubU (! v0 & w0) (! v1 & w1) p = v & w -^ y 60 | pubU (! v0 -^, .x & w0 -^ .x) (! v1 -^, .x & w1 -^ .x) (p -,^ x) 61 | with v & w <- pubU (! v0 & w0) (! v1 & w1) p = v -^ x & w 62 | pubU (_ & ((v0 -^, .x) , w0 -^ .x)) (_ & ((v1 -, .x) , ())) (p -,^ x) 63 | pubU (! v0 -, .z & w0 -, .z) (! v1 -^, .z & w1 -^, .z) (p -, z) 64 | with v & w <- pubU (! v0 & w0) (! v1 & w1) p = v -^, z & w -^, z 65 | pubU (! v0 -, .z & w0 -, .z) (! v1 -, .z & w1 -, .z) (p -, z) 66 | with v & w <- pubU (! v0 & w0) (! v1 & w1) p = v -, z & w -, z 67 | pubU (! [] & []) (! [] & []) [] = [] & [] 68 | 69 | widen : forall {wz zz}(ths : < wz <=_ *: _<= zz >) -> 70 | < Squ ths *: Pub ths > 71 | widen (th' & th -^ y) 72 | with (v & w) & p <- widen (th' & th) 73 | = (v -^ y & w -^, y) & p -^, y 74 | widen (th' -^ .x & th -, x) 75 | with (v & w) & p <- widen (th' & th) 76 | = (v -^, x & w -^ x) & p -,^ x 77 | widen (th' -, .x & th -, x) 78 | with (v & w) & p <- widen (th' & th) 79 | = (v -, x & w -, x) & p -, x 80 | widen ([] & []) = ([] & []) & [] 81 | 82 | widenU : forall {wz zz}(ths : < wz <=_ *: _<= zz >) -> 83 | let (ps , v , w) & p = widen ths in 84 | {phs@(ph0 & ph1) : < wz <=_ *: _<= zz >} -> 85 | Pub ths phs -> 86 | (w' : [ ph0 -& ph1 ]~ ps) -> 87 | w' =12> w 88 | widenU (th0 & th1 -^ z) (p -^ z) (w' -^ .z) 89 | with a & b <- widenU (th0 & th1) p w' = a -^ z & b -^, z 90 | widenU (th0 & th1 -^ y) (p -^, y) (w' -^, .y) 91 | with a & b <- widenU (th0 & th1) p w' = a -^, y & b -, y 92 | widenU (th0 -^ x & th1 -, x) (p -,^ x) (w' -^ .x) 93 | with a & b <- widenU (th0 & th1) p w' = a & b -^ x 94 | widenU (th0 -, z & th1 -, .z) (p -, z) (w' -, .z) 95 | with a & b <- widenU (th0 & th1) p w' = a -, z & b -, z 96 | widenU ([] & []) [] [] = [] & [] 97 | 98 | thicken? : forall {xz yz zz}(ph : yz <= zz)(ps : xz <= zz) -> 99 | Maybe < [_-& ph ]~ ps > 100 | thicken? ph ps with pub ph ps 101 | ... | ph' & ps' , v & w , p with all? ps' 102 | ... | ff , <> = ff , <> 103 | ... | tt , r~ , r~ 104 | with r~ <- lio w 105 | = tt , ! v 106 | 107 | -------------------------------------------------------------------------------- /Expt/Agen/Solve.agda: -------------------------------------------------------------------------------- 1 | module Solve where 2 | 3 | open import Agda.Builtin.String 4 | 5 | open import Basics 6 | open import Thin 7 | open import Cop 8 | open import Pair 9 | open import Bind 10 | open import Term 11 | 12 | open THIN 13 | open module T (zm : Bwd Nat) = TERM (_<- zm) String 14 | open COP {`1} 15 | open PAIR {`1} 16 | open BIND {`1} 17 | 18 | data Constraint (n : Nat) (zm : Bwd Nat) : Set where 19 | all : Constraint (suc n) zm -> Constraint n zm 20 | eq : ∀ {m p} -> p <= m -> m <- zm -> _%>^_ zm p n -> Term zm n -> Constraint n zm 21 | 22 | data Meta (m : Nat) -- How many global things we can depend on 23 | (zm : Bwd Nat) -- All the metas in scope 24 | : Nat -- How many things we can depend on (morally m + x) 25 | -> Set where 26 | lambda : ∀ {p} -> Meta (suc m) zm p -> Meta m zm p 27 | hole : Meta m zm m 28 | defn : Term zm m -> Meta m zm m 29 | 30 | data Ctx : Nat -- number of object variables in scope 31 | -> Bwd Nat -- metavariable context 32 | -> Set where 33 | [] : Ctx [] [] 34 | _-,_ : ∀ {n zm} -> Ctx n zm -> ∀ x -> Ctx (n -, x) zm 35 | _-?_ : ∀ {n zm m p} -> Ctx n zm -> m <= n -> Meta m zm p -> Ctx n (zm -, p) 36 | 37 | solve : ∀ {n zm m p} -> Ctx n zm -> p <= m -> m <- zm -> _%>^_ zm p n -> Term zm n 38 | -> Maybe < zm <=_ *: Ctx n > 39 | solve (ctx -, x) et i (sg & ph -^ .x) (tm & th -^ .x) = do 40 | ps & ctx' <- solve ctx et i (sg & ph) (tm & th) 41 | aye (ps & ctx' -, x) 42 | solve (ctx -, x) et i (sg & ph -^ .x) (tm & (th -, .x)) = naw 43 | solve {zm = zm} (ctx -, x) et i (sg & (ph -, .x)) (tm & th -^ .x) = do 44 | let (de & ta) = prune zm (io -^ x) sg 45 | (ps & ctx') <- solve ctx (de -& et) i (ta |^ ph) (tm & th) 46 | aye (ps & ctx' -, x) 47 | solve (ctx -, x) et i (sg & (ph -, .x)) (tm & (th -, .x)) = {!!} 48 | solve (_-?_ ctx x m) et i sg tm = {!!} 49 | -------------------------------------------------------------------------------- /Expt/Agen/cdb.agda-lib: -------------------------------------------------------------------------------- 1 | name: cdb 2 | include: . 3 | flags: --guardedness --safe 4 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all build install clean install-hasktags TAGS test gif bash-completion 2 | 3 | CABAL_OPTIONS= #--ghc-options=-O0 4 | CABAL=cabal $(CABAL_OPTIONS) 5 | 6 | build: 7 | $(CABAL) build 8 | 9 | all: install test 10 | 11 | install: 12 | $(CABAL) install --overwrite-policy=always 13 | 14 | clean: 15 | rm -rf dist dist-newstyle TAGS 16 | 17 | install-hasktags: 18 | cabal update 19 | cabal install hasktags 20 | 21 | TAGS: 22 | hasktags --etags . 23 | 24 | test: 25 | TERM=dumb cabal run typos-tests -- -i 26 | 27 | build/%.gif: examples/%.act 28 | typos examples/$(*F).act --latex-animated build/$(*F).tex 29 | sed -i "s|%\\\\input|\\\\input|" build/$(*F).tex 30 | cd build && \ 31 | latexmk -pdf $(*F).tex && \ 32 | convert -verbose -density 300 -coalesce $(*F).pdf $(*F)-%03d.gif && \ 33 | fdupes -dN . && \ 34 | convert -verbose -delay 25 -loop 0 $(*F)-*.gif $(*F)-tmp.gif && \ 35 | convert -verbose -dispose previous -background "rgb(100%,100%,100%)" \ 36 | $(*F)-tmp.gif -trim -layers TrimBounds -coalesce \ 37 | -bordercolor "rgb(100%,100%,100%)" -border 40 -layers optimize $(*F).gif && \ 38 | rm $(*F)-* 39 | 40 | gif: build/stlc.gif 41 | 42 | bash-completion: 43 | # Use as follows: source <(make bash-completion) 44 | typos --bash-completion-script `which typos` 45 | 46 | trace: build/stlc.gif 47 | cp build/stlc.gif build/trace.gif 48 | rm build/stlc.tex 49 | typos examples/stlc.act --latex build/stlc.tex 50 | sed -i "s|%\\\\input|\\\\input|" build/stlc.tex 51 | cd build && \ 52 | latexmk -pdf stlc.tex && \ 53 | pdf2svg stlc.pdf trace.svg 54 | -------------------------------------------------------------------------------- /Src/ANSI.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description: For decorating the output with colour, font weight, etc 3 | 4 | Support a variety of annotations (colour, font weight and underlining) that 5 | can apply to different layers. 6 | 7 | Note that the rest of the code (currently) uses explicit colour names to get 8 | its work done. 9 | -} 10 | module ANSI where 11 | 12 | import Data.List (intercalate) 13 | 14 | -- | The colours we know about 15 | data Colour 16 | = Black | Red | Green | Yellow | Blue 17 | | Magenta | Cyan | White 18 | deriving (Eq, Show, Enum) 19 | 20 | -- | Two layers, 'Foreground' and 'Background' 21 | data Layer 22 | = Foreground | Background 23 | 24 | -- | Three 'Weight's, 'Bold', 'Faint' or 'Normal' 25 | data Weight 26 | = Bold | Faint | Normal 27 | deriving (Eq, Show) 28 | 29 | -- | 'Underlining', Single or Double 30 | data Underlining 31 | = Single | Double 32 | deriving (Eq, Show) 33 | 34 | -- | 'Annotation', in this case colour, weight and/or underlining 35 | data Annotation 36 | = SetColour Layer Colour 37 | | SetWeight Weight 38 | | SetUnderlining Underlining 39 | 40 | -- | The "magic" of how to get a terminal to output annotated text is 41 | -- only known inside this function. Similarly for the details of the 42 | -- meaning of 'Weight' and 'Layer' 43 | -- 44 | -- TODO: Unfortuntely these don't nest well because at the end of an 45 | -- annotation span we use a code that resets the whole stack of annotations. 46 | -- The pretty printer does some extra work to merge nested annotations into 47 | -- contiguous spans which can then be highlighted using raw ANSI codes. 48 | -- So this "secret" is not at all respected and this should be deal with 49 | -- better. 50 | withANSI :: [Annotation] -> String -> String 51 | withANSI [] str = str 52 | withANSI anns str = concat 53 | [ "\x1b[", intercalate ";" (show . encode <$> anns) , "m" 54 | , str 55 | , "\x1b[0m" ] 56 | 57 | where 58 | 59 | encode (SetColour l c) = layer l + colour c 60 | encode (SetWeight w) = weight w 61 | encode (SetUnderlining u) = underlining u 62 | 63 | layer Foreground = 30 64 | layer Background = 40 65 | 66 | colour = fromEnum 67 | 68 | weight Bold = 1 69 | weight Faint = 2 70 | weight Normal = 22 71 | 72 | underlining Single = 4 73 | underlining Double = 21 74 | -------------------------------------------------------------------------------- /Src/Actor/Display.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Actor.Display where 4 | 5 | import Control.Monad.Except 6 | 7 | import qualified Data.Map as Map 8 | 9 | import Actor 10 | import Concrete.Pretty () 11 | import Display 12 | import Pretty 13 | import Term.Display () 14 | import Thin 15 | import Unelaboration.Monad (nameOn) 16 | import Unelaboration (DAEnv) 17 | 18 | instance Display Env where 19 | type DisplayEnv Env = () 20 | display rho@Env{..} = 21 | let na = (globalScope, ones (length globalScope), globalScope) in 22 | fmap collapse $ forM (Map.toList actorVars) $ \ (av, (xs, t)) -> do 23 | av <- display av 24 | t <- withEnv (foldl nameOn na xs) $ display t 25 | pure $ hsep (av : map pretty xs ++ [equals, t]) 26 | 27 | instance Display ActorMeta where 28 | type DisplayEnv ActorMeta = () 29 | display = viaPretty 30 | 31 | instance Display Channel where 32 | type DisplayEnv Channel = () 33 | display = viaPretty 34 | 35 | instance Display AActor where 36 | type DisplayEnv AActor = DAEnv 37 | display = viaPretty 38 | 39 | instance Display (Pat, AActor) where 40 | type DisplayEnv (Pat, AActor) = DAEnv 41 | display = viaPretty 42 | -------------------------------------------------------------------------------- /Src/Alarm.hs: -------------------------------------------------------------------------------- 1 | module Alarm where 2 | 3 | import Control.Monad (guard) 4 | import Data.Functor (($>)) 5 | import System.IO.Unsafe (unsafePerformIO) 6 | 7 | import ANSI 8 | import Options 9 | import Utils 10 | 11 | alarm :: Options -> String -> a -> a 12 | alarm opts str x = unsafePerformIO $ do 13 | putStrLn $ 14 | withANSI (guard (colours opts) $> SetColour Background Red) $ 15 | "Alarm:" ++ ' ' : str 16 | -- Check if terminal can give us input before asking for it 17 | unlessM isTermDumb (() <$ getLine) 18 | pure x 19 | -------------------------------------------------------------------------------- /Src/Bwd.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description: snoc lists 3 | -} 4 | module Bwd where 5 | 6 | import Data.Map (Map) 7 | import qualified Data.Map as Map 8 | import Data.Maybe (fromMaybe) 9 | import Control.Monad.State 10 | 11 | data Bwd x = B0 | Bwd x :< x 12 | deriving (Show, Eq, Ord, Functor, Foldable, Traversable) 13 | infixl 4 :< 14 | 15 | instance Semigroup (Bwd x) where 16 | xz <> B0 = xz 17 | xz <> (yz :< y) = xz <> yz :< y 18 | 19 | instance Monoid (Bwd x) where 20 | mempty = B0 21 | 22 | -- | lookup with a more convenient name 23 | ( Int -> x 24 | (_ :< x) < 28 | 29 | -- | append a list onto a snoc list, giving a snoc list, 30 | -- reversing the list as it goes 31 | (<><) :: Bwd x -> [x] -> Bwd x 32 | xz <>< [] = xz 33 | xz <>< (x : xs) = (xz :< x) <>< xs 34 | 35 | -- | put a snoc list onto the head of a list, giving a list 36 | (<>>) :: Bwd x -> [x] -> [x] 37 | B0 <>> xs = xs 38 | (xz :< x) <>> xs = xz <>> (x:xs) 39 | 40 | -- | mapzss f b l is equivalent to (fmap f b) <>> l 41 | -- but hand-coded to do it in a single pass and does not 42 | -- traverse the list. 43 | mapzss :: (a -> b) -> Bwd a -> [b] -> [b] 44 | mapzss f B0 xs = xs 45 | mapzss f (xz :< x) xs = mapzss f xz (f x : xs) 46 | 47 | -- | Equivalent to (fmap f xz) <>> [], but in one pass 48 | mapzs :: (a -> b) -> Bwd a -> [b] 49 | mapzs f xz = mapzss f xz [] 50 | 51 | -- | Treat a snoc list as a stack and returns the top. 52 | -- Warning: incomplete pattern match. 53 | top :: Bwd x -> x 54 | top (_ :< x) = x 55 | 56 | -- | 'takez' is 'take' but renamed so 'take' can still be used 57 | takez :: Bwd x -> Int -> Bwd x 58 | takez _ 0 = B0 59 | takez (xz :< x) w = takez xz (w-1) :< x 60 | 61 | -- | 'dropz' is 'drop' but renamed so 'drop' can still be used 62 | dropz :: Bwd x -> Int -> Bwd x 63 | dropz xz 0 = xz 64 | dropz (xz :< x) w = dropz xz (w-1) 65 | 66 | -- | singleton snoc list 67 | singleton :: x -> Bwd x 68 | singleton x = B0 :< x 69 | 70 | -- | matches 'only' singleton, and will fail in not-nice ways otherwise 71 | only :: Bwd x -> x 72 | only (B0 :< x) = x 73 | 74 | -- | 'focusBy' takes a predicate p and a snoc list, and returns 75 | -- a pointed cursor into that snoc for the first item that satisfies p 76 | -- (or Nothing otherwise). 77 | focusBy :: (x -> Maybe y) -> Bwd x -> Maybe (Bwd x, y, [x]) 78 | focusBy p xz = go xz [] where 79 | 80 | go B0 xs = Nothing 81 | go (xz :< x) xs 82 | | Just y <- p x = pure (xz, y, xs) 83 | | otherwise = go xz (x : xs) 84 | 85 | -- | 'focus' specializes 'focusBy' to equality with the given element 86 | focus :: Eq x => x -> Bwd x -> Maybe (Bwd x, x, [x]) 87 | focus x = focusBy (\ y -> y <$ guard (x == y)) 88 | 89 | -- | "curl up" n items from the snoc part onto the list part 90 | curl :: Int -> (Bwd x, [x]) -> (Bwd x, [x]) 91 | curl 0 xzs = xzs 92 | curl n (xz :< x, xs) = curl (n-1) (xz, x : xs) 93 | 94 | -- | A 'Cursor' is a location in a list (or a snoc list) 95 | -- Note that it can point to the head or tail, it does not 96 | -- points to an element location. 97 | data Cursor x 98 | = Bwd x :<+>: [x] 99 | deriving (Eq, Foldable, Functor, Show, Traversable) 100 | infixl 3 :<+>: 101 | 102 | -- | Each value of type `x` induces its own space of 103 | -- de Bruijn indices. This function tags each value 104 | -- with the corresponding index. 105 | -- 106 | -- deBruijnify (B0 :< "x" :< "y" :< "x") 107 | -- == B0 :< ("x",1) :< ("y",0) :< ("x",0) 108 | deBruijnify :: forall x. Ord x => Bwd x -> Bwd (x, Int) 109 | deBruijnify xz = go xz `evalState` Map.empty where 110 | 111 | new :: x -> State (Map x Int) Int 112 | new x = do 113 | st <- get 114 | let n = fromMaybe 0 (Map.lookup x st) 115 | put (Map.insert x (n + 1) st) 116 | pure n 117 | 118 | go :: Bwd x -> State (Map x Int) (Bwd (x, Int)) 119 | go B0 = pure B0 120 | go (xz :< x) = do 121 | n <- new x 122 | xnz <- go xz 123 | pure (xnz :< (x, n)) 124 | 125 | -- | 'groupBy' for snoc lists 126 | groupBy :: (a -> a -> Bool) -> Bwd a -> Bwd (Bwd a) 127 | groupBy eq B0 = B0 128 | groupBy eq (xz :< x) = go [x] x xz where 129 | 130 | go acc x (yz :< y) | eq x y = go (y : acc) x yz 131 | go acc _ yz = groupBy eq yz :< (B0 <>< acc) 132 | 133 | -- | 'nub' for snoc lists 134 | nub :: Eq a => Bwd a -> Bwd a 135 | nub = go [] where 136 | go acc B0 = B0 137 | go acc (xs :< x) 138 | | x `elem` acc = go acc xs 139 | | otherwise = go (x : acc) xs :< x 140 | 141 | -- | 'unzipWith' for snoc lists 142 | unzipWith :: (a -> (b, c)) -> Bwd a -> (Bwd b, Bwd c) 143 | unzipWith f B0 = (B0, B0) 144 | unzipWith f (az :< a) = 145 | let (bz, cz) = unzipWith f az in 146 | let (b, c) = f a in 147 | (bz :< b, cz :< c) 148 | -------------------------------------------------------------------------------- /Src/Display.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds, UndecidableInstances #-} 2 | 3 | module Display where 4 | 5 | import Data.Void 6 | 7 | import Control.Monad.Except 8 | import Control.Monad.Reader 9 | 10 | import Actor 11 | import Concrete.Pretty () 12 | import Forget 13 | import Format 14 | import Options 15 | import Pretty (Doc, Annotations, Pretty(..), renderWith) 16 | import Thin 17 | 18 | import Unelaboration.Monad (Unelab(..), evalUnelab, Naming) 19 | import qualified Unelaboration.Monad as Unelaboration 20 | import Unelaboration () 21 | 22 | import GHC.Stack 23 | 24 | -- uglyprinting 25 | 26 | data DisplayComplaint 27 | = UnexpectedEmptyThinning Naming 28 | | VarOutOfScope Naming 29 | | InvalidNaming Naming 30 | | UnknownChannel String 31 | | UnelabError Unelaboration.Complaint 32 | deriving (Show) 33 | 34 | newtype DisplayM e a = Display 35 | { runDisplay :: (ReaderT e 36 | (Either DisplayComplaint)) 37 | a } 38 | deriving ( Functor, Applicative, Monad 39 | , MonadError DisplayComplaint 40 | , MonadReader e) 41 | 42 | withEnv :: e' -> DisplayM e' a -> DisplayM e a 43 | withEnv rh (Display md) = Display (withReaderT (const rh) md) 44 | 45 | withForget :: Forget e e' => DisplayM e' a -> DisplayM e a 46 | withForget (Display md) = Display (withReaderT forget md) 47 | 48 | evalDisplay :: e -> DisplayM e a -> Either DisplayComplaint a 49 | evalDisplay e = (`runReaderT` e) 50 | . runDisplay 51 | 52 | unsafeEvalDisplay :: e -> DisplayM e a -> a 53 | unsafeEvalDisplay e = either (error . show) id . evalDisplay e 54 | 55 | type Display0 m = (Display m, DisplayEnv m ~ ()) 56 | class Show t => Display t where 57 | type DisplayEnv t 58 | display :: HasCallStack => t -> DisplayM (DisplayEnv t) (Doc Annotations) 59 | displayPrec :: HasCallStack => Int -> t -> DisplayM (DisplayEnv t) (Doc Annotations) 60 | 61 | display = displayPrec 0 62 | displayPrec _ = display 63 | 64 | pdisplay :: Display t => t -> DisplayM (DisplayEnv t) (Doc Annotations) 65 | pdisplay = displayPrec 1 66 | 67 | subdisplay :: (Display t, Forget e (DisplayEnv t)) => t -> DisplayM e (Doc Annotations) 68 | subdisplay = withForget . display 69 | 70 | subpdisplay :: (Display t, Forget e (DisplayEnv t)) => t -> DisplayM e (Doc Annotations) 71 | subpdisplay = withForget . pdisplay 72 | 73 | viaPretty :: (Pretty (Unelabed t), Unelab t, UnelabEnv t ~ e) => 74 | t -> DisplayM e (Doc Annotations) 75 | viaPretty t = do 76 | env <- ask 77 | case evalUnelab env (unelab t) of 78 | Left err -> throwError (UnelabError err) 79 | Right t -> pure $ pretty t 80 | 81 | instance Display () where 82 | type DisplayEnv () = () 83 | display = viaPretty 84 | 85 | instance Display Void where 86 | type DisplayEnv Void = () 87 | display = viaPretty 88 | 89 | instance Display DB where 90 | type DisplayEnv DB = Naming 91 | display = viaPretty 92 | {- 93 | instance (Show t, Unelab t, Pretty (Unelabed t)) => 94 | Display [Format () (Doc Annotations) t] where 95 | type DisplayEnv [Format () (Doc Annotations) t] = UnelabEnv t 96 | display = viaPretty 97 | -} 98 | instance (Show t, Unelab t, Pretty (Unelabed t)) => 99 | Display [Format Directive Debug t] where 100 | type DisplayEnv [Format Directive Debug t] = UnelabEnv t 101 | display = viaPretty 102 | 103 | instance Display Pat where 104 | type DisplayEnv Pat = Naming 105 | display = viaPretty 106 | 107 | unsafeDocDisplay :: (DisplayEnv a ~ Naming, Display a) => Options -> Naming -> a -> Doc Annotations 108 | unsafeDocDisplay opts naming t 109 | = unsafeEvalDisplay naming 110 | $ display t 111 | 112 | unsafeDocDisplayClosed :: (DisplayEnv a ~ Naming, Display a) => Options -> a -> Doc Annotations 113 | unsafeDocDisplayClosed opts t 114 | = unsafeEvalDisplay Unelaboration.initNaming 115 | $ display t 116 | 117 | unsafeDisplay :: (DisplayEnv a ~ Naming, Display a) => Options -> Naming -> a -> String 118 | unsafeDisplay opts naming t 119 | = renderWith (renderOptions opts) 120 | $ unsafeDocDisplay opts naming t 121 | 122 | unsafeDisplayClosed :: (DisplayEnv a ~ Naming, Display a) => Options -> a -> String 123 | unsafeDisplayClosed opts t 124 | = renderWith (renderOptions opts) 125 | $ unsafeDocDisplayClosed opts t 126 | -------------------------------------------------------------------------------- /Src/Doc/Annotations.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description: Annotations that can be put on text to be printed 3 | -} 4 | module Doc.Annotations where 5 | 6 | import Control.Applicative ((<|>)) 7 | 8 | import ANSI (Annotation(..),Colour,Weight,Underlining,Layer(..)) 9 | import Text.PrettyPrint.Compact (Doc, annotate) 10 | import Data.Maybe (catMaybes) 11 | 12 | -- | The 'Annotations' that we can choose to put on text. 13 | data Annotations = Annotations 14 | { foregroundColour :: Maybe Colour 15 | , backgroundColour :: Maybe Colour 16 | , fontWeight :: Maybe Weight 17 | , fontUnderlining :: Maybe Underlining 18 | } deriving (Eq, Show) 19 | 20 | -- | Inherit the 'Semigroup' instance pointwise 21 | instance Semigroup Annotations where 22 | Annotations fg1 bg1 fw1 fu1 <> Annotations fg2 bg2 fw2 fu2 23 | = Annotations (fg2 <|> fg1) (bg2 <|> bg1) (fw2 <|> fw1) (fu2 <|> fu1) 24 | 25 | -- | Inherit the 'Monoid' instance pointwise 26 | instance Monoid Annotations where 27 | mempty = Annotations Nothing Nothing Nothing Nothing 28 | 29 | -- | Break up an Annotations as a record into a list of its constituent commands 30 | toANSIs :: Annotations -> [Annotation] 31 | toANSIs (Annotations fg bg fw fu) 32 | = catMaybes 33 | [ SetColour Foreground <$> fg 34 | , SetColour Background <$> bg 35 | , SetWeight <$> fw 36 | , SetUnderlining <$> fu 37 | ] 38 | 39 | -- | Create a single annotation record from a list of annotations 40 | fromANSIs :: [Annotation] -> Annotations 41 | fromANSIs = foldl (\ acc ann -> acc <> fromANSI ann) mempty where 42 | fromANSI :: Annotation -> Annotations 43 | fromANSI (SetColour Foreground c) = mempty { foregroundColour = Just c } 44 | fromANSI (SetColour Background c) = mempty { backgroundColour = Just c } 45 | fromANSI (SetWeight w) = mempty { fontWeight = Just w } 46 | fromANSI (SetUnderlining u) = mempty { fontUnderlining = Just u } 47 | 48 | -- | Add some annotations to some 'Doc' 49 | withANSI :: [Annotation] -> Doc Annotations -> Doc Annotations 50 | withANSI = annotate . fromANSIs 51 | -------------------------------------------------------------------------------- /Src/Forget.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description: for forgetting information about a structure. Basically a generalized projection. 3 | -} 4 | module Forget where 5 | 6 | -- | Class Forget says that one can 'project out' something of type b from something of type a. 7 | class Forget a b where 8 | forget :: a -> b 9 | 10 | -- | We can always forget everything 11 | instance Forget a () where 12 | forget _ = () 13 | -------------------------------------------------------------------------------- /Src/Format.hs: -------------------------------------------------------------------------------- 1 | module Format where 2 | {- Description: various utilities for nicely "format strings" that 3 | - can direct how to print terms, debugging info and just plain text 4 | 5 | In particular: 6 | For terms 7 | - %r - Raw 8 | - %i - Instantiate 9 | - %n - Normalize 10 | - %s - Show 11 | For Debugging: 12 | - %E - show environment 13 | - %S - show stack 14 | - %M - show store 15 | -} 16 | 17 | import Bwd (Bwd(..), (<>>)) 18 | import Parse (Parser(Parser), Source(Source), parseError, ErrorLocation(Precise), here, notHere) 19 | import Location (Location, tick, ticks) 20 | 21 | -- | Format specifiction, where 22 | -- - dir is a directive controlling the printing of terms 23 | -- - dbg is the type of debugging info available 24 | -- - t is the actual term 25 | data Format dir dbg t 26 | = TermPart dir t -- for formatting terms 27 | | DebugPart dbg -- for debugging 28 | | StringPart String -- for random stuff? 29 | deriving (Show, Eq, Functor, Foldable, Traversable) 30 | 31 | -- | When printing terms, what to do with them when doing so 32 | data Directive = Normalise | Instantiate | Raw | ShowT 33 | deriving (Show, Eq) 34 | 35 | -- | When printing debug information, what to dump 36 | data Debug = ShowStack | ShowStore | ShowEnv 37 | deriving (Show, Eq) 38 | 39 | -- | Parse format specification, for but terms and debug 40 | pformat :: Parser [Format Directive Debug ()] 41 | pformat = Parser $ \ (Source str loc) -> case str of 42 | '"':str -> here (go str (tick loc '"') B0) 43 | _ -> notHere loc 44 | 45 | where 46 | 47 | snoc :: String -> Bwd (Format Directive Debug ()) -> Bwd (Format Directive Debug ()) 48 | snoc "" acc = acc 49 | -- hopefully there aren't too many of these 50 | snoc str (acc :< StringPart strl) = acc :< StringPart (strl ++ str) 51 | snoc str acc = acc :< StringPart str 52 | 53 | go :: String -> Location -> Bwd (Format Directive Debug ()) -> ([Format Directive Debug ()], Source) 54 | go str loc acc = 55 | let (pref, rest) = span (`notElem` "%\"\\") str in 56 | let loc' = ticks loc pref in 57 | case rest of 58 | -- formatting expressions 59 | '%':'r':end -> go end (ticks loc' "%r") (snoc pref acc :< TermPart Raw ()) 60 | '%':'i':end -> go end (ticks loc' "%i") (snoc pref acc :< TermPart Instantiate ()) 61 | '%':'n':end -> go end (ticks loc' "%n") (snoc pref acc :< TermPart Normalise ()) 62 | '%':'s':end -> go end (ticks loc' "%s") (snoc pref acc :< TermPart ShowT ()) 63 | '%':'E':end -> go end (ticks loc' "%E") (snoc pref acc :< DebugPart ShowEnv) 64 | '%':'S':end -> go end (ticks loc' "%S") (snoc pref acc :< DebugPart ShowStack) 65 | '%':'M':end -> go end (ticks loc' "%M") (snoc pref acc :< DebugPart ShowStore) 66 | '%':end -> go end (tick loc' '%') (snoc (pref ++ "%") acc) 67 | -- special characters 68 | '\\':'n':end -> go end (ticks loc' "\\n") (snoc (pref ++ "\n") acc) 69 | '\\':'t':end -> go end (ticks loc' "\\t") (snoc (pref ++ "\t") acc) 70 | -- escaped characters 71 | '\\':c:end -> go end (tick loc' '\\') (snoc (pref ++ [c]) acc) 72 | -- closing double quote 73 | '"':end -> (snoc pref acc <>> [], Source end (tick loc' '"')) 74 | -- error 75 | _ -> parseError Precise loc "Unclosed format string" 76 | -------------------------------------------------------------------------------- /Src/Hide.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | 3 | {-| 4 | Description: Hiding a value by making it behave like a singleton 5 | -} 6 | 7 | module Hide where 8 | 9 | -- | Hide adds a layer above a value that lets us make it look 10 | -- like a singleton, but not forget the actual value. 11 | newtype Hide x = Hide {unhide :: x} 12 | deriving (Functor) 13 | instance Show (Hide x) where show _ = "" 14 | instance Eq (Hide x) where _ == _ = True 15 | instance Ord (Hide x) where compare _ _ = EQ 16 | 17 | -- | Something is a 'Named' value of type 'a' if it is a pair of a 18 | -- hidden String and a value of type 'a'. The value part is completely 19 | -- transparent, i.e. treats the (hidden) string as an annotation. 20 | data Named a = Hide String := a 21 | deriving (Show, Eq, Ord, Functor, Foldable, Traversable) 22 | -------------------------------------------------------------------------------- /Src/Info.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Info where 3 | import Control.Monad 4 | import Pretty 5 | 6 | -- Partial info 7 | 8 | data Info a = Unknown | Known a | Inconsistent 9 | deriving (Show, Eq, Functor) 10 | 11 | 12 | instance Applicative Info where 13 | pure = Known 14 | (<*>) = ap 15 | 16 | instance Monad Info where 17 | Unknown >>= f = Unknown 18 | Known a >>= f = f a 19 | Inconsistent >>= f = Inconsistent 20 | 21 | instance Eq a => Semigroup (Info a) where 22 | Unknown <> y = y 23 | x <> Unknown = x 24 | Known x <> Known y | x == y = Known x 25 | _ <> _ = Inconsistent 26 | 27 | instance Eq a => Monoid (Info a) where 28 | mempty = Unknown 29 | 30 | instance Pretty a => Pretty (Info a) where 31 | prettyPrec d = \case 32 | Unknown -> "Unknown" 33 | Known a -> parenthesise (d > 0) (hsep ["Known", prettyPrec 1 a]) 34 | Inconsistent -> "Inconsistent" 35 | 36 | -------------------------------------------------------------------------------- /Src/Machine.hs: -------------------------------------------------------------------------------- 1 | module Machine (module Machine, module Machine.Base, module Machine.Display, module Machine.Exec) where 2 | 3 | import Machine.Base 4 | import Machine.Display 5 | import Machine.Exec 6 | -------------------------------------------------------------------------------- /Src/Machine/Matching.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Machine.Matching where 4 | 5 | import Data.Bifunctor 6 | 7 | import Bwd 8 | import Vector 9 | import Actor 10 | import Concrete.Base 11 | import Thin 12 | import Term.Base 13 | import Term.Display() 14 | import Hide 15 | import Pattern (Pat'(..)) 16 | import Pretty 17 | 18 | {- 19 | import Display (unsafeDisplayClosed) 20 | import Debug.Trace 21 | import Options (unsafeOptions) 22 | -} 23 | 24 | data Failure 25 | = DontKnow --Meta 26 | | Mismatch 27 | deriving (Show) 28 | 29 | instance Pretty Failure where 30 | pretty DontKnow = "Don't Know" -- <+> pretty meta 31 | pretty Mismatch = "Mismatch" 32 | 33 | data Problem m = Problem 34 | { localBinders :: Bwd String -- binders we have gone under 35 | , problemPat :: Pat -- pattern to match 36 | , problemTerm :: Term' m -- candidate term 37 | } 38 | 39 | -- Only use this to debug clauses 40 | mismatch :: Pat -> Term' m -> Failure 41 | mismatch _ _ = Mismatch 42 | --mismatch p t = trace (unsafeDisplayClosed unsafeOptions p ++ " ∌ " ++ unsafeDisplayClosed unsafeOptions t) Mismatch 43 | 44 | stuck :: Xn m -> Bool 45 | stuck (_ :$: _) = True 46 | stuck (_ :-: _) = True 47 | stuck (GX _ _) = True 48 | stuck _ = False 49 | 50 | type Matching' m = ([(ActorMeta, EnvImg' m)], [(String, Hide String)]) 51 | type Matching = Matching' Meta 52 | 53 | matchingToEnv :: Matching' m -> Env' m -> Env' m 54 | matchingToEnv (actors, alphas) env = 55 | foldr (uncurry newActorVar) (foldr declareAlpha env alphas) actors 56 | 57 | matchingCase :: Matching -> (Root, Env) -> (Root, Env) 58 | matchingCase (actors, alphas) (r, env) = foldr f (r, foldr declareAlpha env alphas) actors 59 | where 60 | f :: (ActorMeta, ([String], Term)) -> (Root, Env) -> (Root, Env) 61 | f (a@(ActorMeta pass avar), defn) (r, env) = newActorVar a defn <$> case pass of 62 | ACitizen -> (r, env) 63 | ASubject -> case splitRoot r avar of 64 | (g, r) -> (r, guardSubject avar defn g env) 65 | 66 | initMatching :: Matching' m 67 | initMatching = mempty 68 | 69 | 70 | match :: (Term' m -> Term' m) -- head normal former 71 | -> Matching' m 72 | -> Problem m 73 | -> ( Term' m -- reduced version of the terms in the input problems 74 | , Either Failure (Matching' m)) 75 | match hnf mat p = first hd $ matchN hnf mat (p :* V0) 76 | 77 | matchN :: (Term' m -> Term' m) -- head normal former 78 | -> Matching' m 79 | -> Vector n (Problem m) 80 | -> ( Vector n (Term' m) -- reduced version of the terms in the input problems 81 | , Either Failure (Matching' m)) 82 | matchN hnf mat V0 = (V0, pure mat) 83 | matchN hnf mat (Problem zx (AT x p) tm :* xs) 84 | = let mat' = first ((x, (zx <>> [], tm)) :) mat in 85 | matchN hnf mat' (Problem zx p tm :* xs) 86 | matchN hnf mat (Problem zx (MP x ph) tm@(CdB _ th) :* xs) 87 | | is1s ph -- common easy special case, essentially x@_ 88 | = let mat' = first ((x, (zx <>> [], tm)) :) mat in 89 | first (tm:*) $ matchN hnf mat' xs 90 | | otherwise 91 | = let g = bigEnd th - bigEnd ph in 92 | -- we can do better: 93 | -- t may not depend on disallowed things until definitions are expanded 94 | case instThicken hnf (ones g <> ph) tm of 95 | (tm, Right thickened) -> 96 | let mat' = first ((x, ((ph ?< zx) <>> [], thickened)) :) mat in 97 | first (tm:*) $ matchN hnf mat' xs 98 | (tm, Left err) -> (tm :* fmap problemTerm xs, Left err) 99 | matchN hnf mat (Problem zx pat tm :* xs) = let tmnf = hnf tm in case (pat, expand tmnf) of 100 | (HP, _) -> first (tmnf:*) $ matchN hnf mat xs 101 | (GP, _) -> (tmnf :* fmap problemTerm xs, Left (mismatch pat tmnf)) 102 | (_, t) | stuck t -> case matchN hnf mat xs of 103 | (tms, err@(Left Mismatch)) -> (tmnf :* tms, err) 104 | (tms, _) -> (tmnf:*tms, Left DontKnow) 105 | (VP i, VX j _) | i == j -> first (tmnf:*) $ matchN hnf mat xs 106 | (AP a, AX b _) | a == b -> first (tmnf:*) $ matchN hnf mat xs 107 | (PP p q, s :%: t) -> case matchN hnf mat (Problem zx p s :* Problem zx q t :* xs) of 108 | (s :* t :* tms, res) -> ((s % t) :* tms, res) 109 | (BP (Hide x) p, y :.: t) -> 110 | let mat' = second ((x, Hide y) :) mat in 111 | case matchN hnf mat' (Problem (zx :< x) p t :* xs) of 112 | (b :* tms, res) -> ((y \\ b) :* tms, res) 113 | _ -> (tmnf :* fmap problemTerm xs, Left (mismatch pat tmnf)) 114 | 115 | 116 | instThicken :: (Term' m -> Term' m) -> Th -> Term' m 117 | -> (Term' m, Either Failure (Term' m)) 118 | instThicken hnf ph t = let tmnf = hnf t in case tmnf of 119 | v@(CdB V _) -> case thickenCdB ph v of 120 | Just v -> (tmnf, pure v) 121 | Nothing -> (tmnf, Left Mismatch) 122 | m@(CdB (meta :$ _) _) -> case thickenCdB ph m of 123 | Just m -> (tmnf, pure m) 124 | Nothing -> (tmnf, Left DontKnow) 125 | x -> case expand x of 126 | AX a ga -> (tmnf, pure (atom a (weeEnd ph))) 127 | s :%: t -> case instThicken hnf ph s of 128 | (s, Left Mismatch) -> (s % t, Left Mismatch) 129 | (s, ress) -> case instThicken hnf ph t of 130 | (t, Left Mismatch) -> (s % t, Left Mismatch) 131 | (t, rest) -> (s % t, (%) <$> ress <*> rest) 132 | (x :.: t) -> case instThicken hnf (ph -? True) t of 133 | (b, resb) -> (x \\ b, (x \\) <$> resb) 134 | -------------------------------------------------------------------------------- /Src/Machine/Steps.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {- | Description: 3 | 4 | -} 5 | module Machine.Steps ( 6 | MachineStep(..) 7 | , readSteps , tracingHelp 8 | ) where 9 | 10 | import Options.Applicative (ReadM, readerError) 11 | import Data.Tuple (swap) 12 | 13 | import Pretty (Pretty(pretty), text, render, vcat, Doc, Annotations, hsep) 14 | 15 | -- | Define the steps that the machine can take 16 | data MachineStep 17 | = MachineRecv 18 | | MachineSend 19 | | MachineExec 20 | | MachineMove 21 | | MachineUnify 22 | | MachineBreak 23 | | MachineClause 24 | deriving (Eq, Show, Enum, Bounded) 25 | 26 | -- | Pair up 'MachineStep' with its 'String' 27 | stepName :: MachineStep -> String 28 | stepName = \case 29 | MachineRecv -> "recv" 30 | MachineSend -> "send" 31 | MachineExec -> "exec" 32 | MachineMove -> "move" 33 | MachineUnify -> "unify" 34 | MachineBreak -> "break" 35 | MachineClause -> "clause" 36 | 37 | -- | Pair up 'MachineStep' with its 'String' 38 | namesOfSteps :: [(MachineStep, String)] 39 | namesOfSteps = map (\ x -> (x, stepName x)) [minBound..maxBound] 40 | 41 | -- | Output 'MachineStep' in a way that's nicer for humans 42 | instance Pretty MachineStep where 43 | pretty = text . stepName 44 | 45 | -- | What are the steps that the machine can take? 46 | theSteps :: [Doc Annotations] 47 | theSteps = map (text.snd) namesOfSteps 48 | 49 | -- | Read a single step 50 | aStep :: String -> ReadM MachineStep 51 | aStep s = case lookup s (map swap namesOfSteps) of 52 | Just x -> pure x 53 | Nothing -> readerError $ "Unknown tracing level '" ++ s ++ "'. " ++ allowedLevels 54 | where 55 | allowedLevels = "Accepted levels:\n" ++ (render . vcat $ theSteps) 56 | 57 | -- | Read all the steps to trace 58 | readSteps :: [String] -> ReadM [MachineStep] 59 | readSteps = mapM aStep 60 | 61 | -- | String to print out to let users know what tracing levels there are 62 | tracingHelp :: String 63 | tracingHelp = "Override tracing level (combinations of {" ++ levels ++ "} in quotes, separated by spaces, e.g. " ++ exampleLevels ++ ")" 64 | where 65 | levels = render $ vcat theSteps 66 | exampleLevels = "\"" ++ render (hsep $ map (pretty.fst) namesOfSteps ) ++ "\"" 67 | -------------------------------------------------------------------------------- /Src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad 6 | 7 | import Data.Foldable (fold) 8 | 9 | import System.Exit 10 | import System.FilePath (takeExtension) 11 | 12 | import ANSI hiding (withANSI) 13 | import qualified ANSI 14 | import Bwd 15 | import Concrete.Base 16 | import Parse 17 | import Actor 18 | import Elaboration.Pretty() 19 | import Machine 20 | import Pretty 21 | import Term.Base 22 | import Options 23 | import Command 24 | import Operator.Eval 25 | import Machine.Trace (diagnostic, ldiagnostic, adiagnostic) 26 | import Utils 27 | import Location 28 | import qualified Data.Map as Map 29 | import Data.Maybe (isNothing) 30 | import Data.List (intercalate) 31 | 32 | main :: IO () 33 | main = do 34 | opts <- getOptions 35 | txt <- readFile (filename opts) 36 | let parser = case takeExtension (filename opts) of 37 | ".md" -> pmarkdown 38 | _ -> pfile 39 | let ccs = parse parser (Source txt $ initLocation (filename opts)) 40 | case elaborate opts ccs of 41 | Left err -> do 42 | ctxt <- if noContext opts then pure "" else fileContext (getRange err) 43 | putStrLn $ renderWith (renderOptions opts) $ fold 44 | [ flush (withANSI [ SetColour Background Red ] "Error") <> ctxt 45 | , pretty err 46 | ] 47 | exitFailure 48 | Right (ws, acs, table) -> do 49 | -- putStrLn $ unsafeEvalDisplay initNaming $ collapse <$> traverse display acs 50 | 51 | -- Elaboration warnings 52 | unless ((quiet opts && not (wAll opts)) || null ws) $ do 53 | putStrLn $ renderWith (renderOptions opts) $ vcat $ map pretty ws 54 | 55 | let p = Process opts B0 initRoot (initEnv B0) initStore (Win unknown) [] initRoot 56 | let res@(Process _ fs _ env sto a _ geas) = run opts p acs 57 | 58 | let whatIs m = Map.lookup m (solutions sto) >>= snd 59 | 60 | -- TODO: eventually need to be more careful about the operators due to local extensions 61 | let dat = HeadUpData (mkOpTable (B0 <>< fs)) sto (opts {quiet = True}) env whatIs 62 | 63 | -- run diagnostics 64 | let (win, trace) = diagnostic opts dat fs 65 | 66 | -- Failed run error 67 | unless win $ do 68 | putStrLn $ anerror opts $ " Did not win" 69 | -- putStrLn $ let (_, _, _, a) = unsafeEvalDisplay initDEnv $ displayProcess' res in 70 | -- renderWith (renderOptions $ options p) a 71 | 72 | -- Unsolved metas warning 73 | let unsolved = Map.mapMaybe (\ (_, msol) -> () <$ guard (isNothing msol)) $ solutions sto 74 | case Map.keys unsolved of 75 | [] -> pure () 76 | ms -> putStrLn $ warning opts 77 | $ " Unsolved meta" ++ (if length ms > 1 then "s" else "") 78 | ++ " (" ++ intercalate ", " (show <$> ms) ++ ")" 79 | 80 | -- Resulting derivation 81 | unless (quiet opts) $ do 82 | putStrLn trace 83 | 84 | -- LaTeX & beamer backends 85 | whenJust (latex opts) $ \ file -> do 86 | writeFile file $ ldiagnostic table dat fs 87 | putStrLn $ success opts $ " wrote latex derivation to " ++ file 88 | whenJust (latexAnimated opts) $ \ file -> do 89 | writeFile file $ adiagnostic table dat fs (logs res) 90 | putStrLn $ success opts $ " wrote animated latex derivation to " ++ file 91 | dmesg "" res `seq` pure () 92 | 93 | unless win $ exitFailure 94 | 95 | label :: Colour -> String -> Options -> String -> String 96 | label col lbl opts str = 97 | ANSI.withANSI (SetColour Background Yellow <$ guard (colours opts)) (lbl ++ ":") 98 | ++ str 99 | 100 | warning = label Yellow "Warning" 101 | success = label Green "Success" 102 | anerror = label Red "Error" 103 | -------------------------------------------------------------------------------- /Src/Operator/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | module Operator.Eval where 3 | 4 | import Data.Map (Map) 5 | import qualified Data.Map as Map 6 | import Data.Set (Set) 7 | import qualified Data.Set as Set 8 | 9 | import Thin 10 | import Term.Base 11 | import Term.Substitution ((//^)) 12 | import Concrete.Base 13 | import Operator 14 | import Options 15 | import Actor 16 | import Unelaboration.Monad (UnelabMeta) 17 | 18 | dependencySet :: StoreF i d -> Guard -> Set Guard 19 | dependencySet st@Store{..} g = case Map.lookup g guards of 20 | Nothing -> Set.singleton g 21 | Just gs -> foldMap (dependencySet st) gs 22 | 23 | -- | i stores extra information, typically a naming; d is a date type 24 | data StoreF i d = Store 25 | { solutions :: Map Meta (i, Maybe Term) 26 | , guards :: Map Guard (Set Guard) -- key is conjunction of values; acyclic! 27 | , today :: d 28 | } deriving (Show, Functor) 29 | 30 | data HeadUpData' m = forall i d. HeadUpData 31 | { opTable :: Operator -> Clause 32 | , metaStore :: StoreF i d 33 | , huOptions :: Options 34 | , huEnv :: Env' m 35 | , whatIs :: m -> Maybe (Term' m) 36 | } 37 | 38 | instance Show (HeadUpData' m) where 39 | show _ = "HUD" 40 | 41 | instance Dischargeable (HeadUpData' m) where 42 | _ \\ dat = dat 43 | 44 | type HeadUpData = HeadUpData' Meta 45 | 46 | -- Expanding the term using the information currently available: 47 | -- + meta solutions 48 | -- + operator clauses 49 | headUp :: forall m . (Show m, UnelabMeta m) => HeadUpData' m -> Term' m -> Term' m 50 | headUp dat@HeadUpData{..} term = case expand term of 51 | m :$: sg | Just t <- whatIs m 52 | -> headUp dat (t //^ sg) 53 | tty :-: o -> case (expand tty, expand o) of 54 | (t ::: ty, AX op i) -> operate (Operator op) ((t,ty), []) 55 | (t ::: ty, o@(CdB (A op) th :%: wargs)) -> 56 | case asList (\ ps -> pure $ operate (Operator op) ((t, ty), ps)) wargs of 57 | Nothing -> contract (tty :-: contract o) 58 | Just t -> t 59 | (t, o) -> contract (tty :-: contract o) 60 | GX g t | Set.null (dependencySet metaStore g) -> headUp dat t 61 | _ -> term 62 | 63 | where 64 | 65 | operate :: Operator -> ((Term' m, Term' m), [Term' m]) -> Term' m 66 | operate op tps = case runClause (opTable op) huOptions (headUp dat) huEnv tps of 67 | Left ((t, ty), ps) -> rad t ty -% (getOperator op, ps) 68 | Right t -> headUp dat t 69 | -------------------------------------------------------------------------------- /Src/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {- | Description: The various options that can be given on the command line 3 | 4 | Also stores whether the terminal is dumb, which is an "environment option" 5 | -} 6 | module Options where 7 | 8 | -- from the optparse-applicative package 9 | import Options.Applicative -- needs lots from here 10 | 11 | import System.Console.Terminal.Size (size, width) 12 | import System.Environment (getEnv) 13 | 14 | import qualified ANSI 15 | import Machine.Steps (MachineStep(..), readSteps, tracingHelp) 16 | import Pretty (Annotations,toANSIs) 17 | import qualified Text.PrettyPrint.Compact as Compact 18 | 19 | -- | The Options that can be specified 20 | data Options = Options 21 | { filename :: String -- Actor file 22 | , wAll :: Bool -- turn on (All) warnings 23 | , quiet :: Bool -- be quiet when working 24 | , colours :: Bool -- colour output? 25 | , tracingOption :: Maybe [MachineStep] -- which machine steps to trace? 26 | , latex :: Maybe FilePath -- where to put the latex output 27 | , latexAnimated :: Maybe FilePath -- where to put the animated latex output 28 | , termWidth :: Int -- width of terminal to assume 29 | , noContext :: Bool -- Do not print file context of errors 30 | } deriving (Show) 31 | 32 | -- | A partially-filled 'Options' that is not actually safe to use 'raw'. 33 | -- In theory, shouldn't be exported from here, but it is used... 34 | unsafeOptions :: Options 35 | unsafeOptions = Options 36 | { filename = "" 37 | , wAll = True 38 | , quiet = False 39 | , colours = True 40 | , tracingOption = Nothing 41 | , latex = Nothing 42 | , latexAnimated = Nothing 43 | , termWidth = 80 44 | , noContext = False 45 | } 46 | 47 | -- | Parse our options. 48 | poptions :: Parser Options 49 | poptions = Options 50 | <$> argument str (metavar "FILE" <> completer (bashCompleter "file") <> help "Actor file") 51 | <*> flag False True (long "wAll" <> help "Print all warnings") 52 | <*> flag False True (short 'q' <> long "quiet" <> help "Silence tracing") 53 | <*> flag True False (long "no-colour" <> help "Do not use colours in the output") 54 | <*> (optional $ option (str >>= (readSteps . words)) 55 | (long "tracing" <> metavar "LEVELS" <> help tracingHelp)) 56 | <*> optional (option str (metavar "FILE" <> long "latex" <> completer (bashCompleter "file") <> help "Output LaTeX derivation to FILE")) 57 | <*> optional (option str (metavar "FILE" <> long "latex-animated" <> completer (bashCompleter "file") <> help "Output animated LaTeX derivation to FILE")) 58 | <*> pure 80 -- dummy value 59 | <*> flag False True (long "no-context" <> help "Do not print file context of errors") 60 | 61 | -- | Actually get the options 62 | getOptions :: IO Options 63 | getOptions = do 64 | opts <- execParser (info (poptions <**> helper) 65 | (fullDesc <> progDesc "Execute actors in FILE" 66 | <> header "typOS - an operating system for typechecking processes")) 67 | termSize <- size 68 | let w = maybe 80 width termSize 69 | pure $ opts { termWidth = w } 70 | 71 | -- | Is the terminal in which we're currently running "dumb" ? 72 | isTermDumb :: IO Bool 73 | isTermDumb = ("dumb"==) <$> getEnv "TERM" 74 | 75 | -- | for creating the first argument to 'renderWith' 76 | renderOptions :: Options -> Compact.Options Annotations String 77 | renderOptions opts = Compact.Options 78 | { optsPageWidth = termWidth opts 79 | , optsAnnotate = \ ann str -> 80 | if colours opts then ANSI.withANSI (toANSIs ann) str else str 81 | } 82 | -------------------------------------------------------------------------------- /Src/Pattern.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | module Pattern where 3 | 4 | import qualified Data.Map as Map 5 | 6 | import Control.Applicative 7 | 8 | import Thin 9 | import Hide 10 | 11 | import Concrete.Base (Root) 12 | import Term.Base 13 | 14 | -- patterns are de Bruijn 15 | -- | Abstract Patterns, generic over the notion of 16 | -- | binding site 17 | data Pat' s 18 | = AT s (Pat' s) -- v@p 19 | | VP DB 20 | | AP String 21 | | PP (Pat' s) (Pat' s) 22 | | BP (Hide String) (Pat' s) 23 | | MP s Th 24 | | GP -- grumpy pattern 25 | | HP -- happy pattern 26 | deriving (Show, Eq, Functor) 27 | 28 | isCatchall :: Pat' s -> Bool 29 | isCatchall (MP x th) = is1s th 30 | isCatchall HP = True 31 | isCatchall _ = False 32 | 33 | instance Thable (Pat' s) where 34 | AT v p *^ th = AT v (p *^ th) 35 | VP v *^ th = VP (v *^ th) 36 | AP a *^ th = AP a 37 | PP p q *^ th = PP (p *^ th) (q *^ th) 38 | BP x b *^ th = BP x (b *^ (th -? True)) 39 | MP m ph *^ th = MP m (ph *^ th) 40 | GP *^ th = GP 41 | HP *^ th = HP 42 | 43 | instance Selable (Pat' s) where 44 | th ^? AT v p = AT v (th ^? p) 45 | th ^? VP v = maybe GP VP (thickx th v) 46 | th ^? AP a = AP a 47 | th ^? PP p q = PP (th ^? p) (th ^? q) 48 | th ^? BP x b = BP x ((th -? True) ^? b) 49 | th ^? MP m ph = MP m (let (tph, _, _) = pullback th ph in tph) 50 | th ^? GP = GP 51 | th ^? HP = HP 52 | 53 | instance Dischargeable (Pat' m) where 54 | x \\ p = BP (Hide x) p 55 | 56 | (#?) :: String -> [Pat' s] -> Pat' s 57 | a #? ts = foldr PP (AP "") (AP a : ts) 58 | 59 | -- match assumes that p's vars are the local end of t's 60 | match :: Root 61 | -> Pat' String 62 | -> Term 63 | -> Maybe (Root, (Map.Map String Meta, Map.Map Meta Term)) 64 | match r (AT x p) t = do 65 | let (m, r') = meta r x 66 | (r, (ms, mts)) <- match r' p t 67 | pure (r, (Map.insert x m ms, Map.insert m t mts)) 68 | match r (MP x ph) (CdB t th) = do 69 | let g = bigEnd th - bigEnd ph -- how many globals? 70 | ps <- thicken (ones g <> ph) th 71 | let (m, r') = meta r x 72 | return (r', (Map.singleton x m, Map.singleton m (CdB t ps))) 73 | match r p t = case (p, expand t) of 74 | (VP i, VX j _) | i == j -> return (r, (Map.empty, Map.empty)) 75 | (AP a, AX b _) | a == b -> return (r, (Map.empty, Map.empty)) 76 | (HP, _) -> return (r, (Map.empty, Map.empty)) 77 | (PP p q, s :%: t) -> do 78 | (r, m) <- match r p s 79 | (r, n) <- match r q t 80 | return (r, m <> n) 81 | (BP _ p, _ :.: t) -> match r p t 82 | _ -> empty 83 | -------------------------------------------------------------------------------- /Src/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description: The internals of pretty-printing. 3 | -} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Pretty 6 | ( module Text.PrettyPrint.Compact 7 | , module Doc.Annotations 8 | , Pretty(..) 9 | , Collapse(..) 10 | , BracesList(..) 11 | , asBlock 12 | , indent 13 | , keyword 14 | , escape 15 | , parenthesise 16 | , pipe 17 | ) where 18 | 19 | import Data.Void (Void, absurd) 20 | 21 | import ANSI hiding (withANSI) 22 | import Bwd (Bwd(..),Cursor(..),(<>>)) 23 | import Doc.Annotations (Annotations,withANSI,toANSIs) -- will be re-exported? 24 | import Text.PrettyPrint.Compact hiding (Options) -- will be re-exported from here 25 | 26 | -- | Class Pretty lets us declare what things are (nicely) printable. 27 | class Pretty a where 28 | pretty :: a -> Doc Annotations 29 | pretty = prettyPrec 0 30 | 31 | prettyPrec :: Int -> a -> Doc Annotations 32 | prettyPrec _ = pretty 33 | 34 | -- | Indent by 'n' spaces 35 | indent :: Int -> Doc Annotations -> Doc Annotations 36 | indent n d = string (replicate n ' ') <> d 37 | 38 | -- | asBlock n header lines 39 | -- | @ n the indentation for the block's line 40 | -- | @ header the title line of the block 41 | -- | @ lines the block's lines 42 | asBlock :: Int -> Doc Annotations -> [Doc Annotations] -> Doc Annotations 43 | asBlock n header [] = header 44 | asBlock n header lines = header $$ vcat (map (indent n) lines) 45 | 46 | -- | maybe 'parenthesize' a document 47 | parenthesise :: Bool -> Doc Annotations -> Doc Annotations 48 | parenthesise True = parens 49 | parenthesise False = id 50 | 51 | -- | keywords are underlined 52 | keyword :: Doc Annotations -> Doc Annotations 53 | keyword = withANSI [ SetUnderlining Single ] 54 | 55 | -- | 'pipe' symbol 56 | pipe :: Doc Annotations 57 | pipe = "|" 58 | 59 | -- | 'escape' goes through a 'String' and escape carriage return and tab 60 | escape :: String -> String 61 | escape = concatMap go where 62 | 63 | go :: Char -> String 64 | go '\n' = "\\n" 65 | go '\t' = "\\t" 66 | go c = [c] 67 | 68 | -- Instances for some common types 69 | 70 | instance Pretty String where 71 | pretty s = text s 72 | 73 | instance Pretty () where 74 | pretty _ = text "()" 75 | 76 | instance Pretty Void where 77 | pretty = absurd 78 | 79 | ------------------------------------------------------------------ 80 | -- | a 't's worth of |Doc| can be 'Collapse'd if it can be flattened to a 'Doc' 81 | class Collapse t where 82 | collapse :: t (Doc Annotations) -> Doc Annotations 83 | 84 | -- | print snoc lists as "[< a , b , c ]", and the empty one as "[<]" 85 | instance Collapse Bwd where 86 | collapse ds = encloseSep "[<" "]" ", " (ds <>> []) 87 | 88 | -- | print lists as usual 89 | instance Collapse [] where 90 | collapse ds = encloseSep lbracket rbracket ", " ds 91 | 92 | -- | print 'Cursor' with a Bold Red ":<+>:" in the middle 93 | instance Collapse Cursor where 94 | collapse (lstrs :<+>: rstrs) = 95 | sep [ collapse lstrs 96 | , withANSI [SetColour Foreground Red, SetWeight Bold] ":<+>:" 97 | , collapse rstrs 98 | ] 99 | 100 | -- | 'BracesList' is a marker for printing something in braces 101 | newtype BracesList t = BracesList { unBracesList :: [t] } 102 | 103 | -- | print 'BracesList' as lists with braces... 104 | instance Collapse BracesList where 105 | collapse (BracesList ds) = encloseSep "{" "}" "; " ds 106 | -------------------------------------------------------------------------------- /Src/Scope.hs: -------------------------------------------------------------------------------- 1 | module Scope where 2 | {- Description: Defining 'Scope'. A scope is a pair of a hidden value (a bound name) in a "term" 3 | -} 4 | 5 | import Hide (Hide(unhide)) 6 | import Thin (Thable(..), (-?)) 7 | 8 | -- TODO: refactor Tm using Scope? 9 | -- | Definition of Scope 10 | data Scope x t = Scope (Hide x) t 11 | deriving (Eq, Show) 12 | 13 | -- | extract the bound name from a 'Scope' 14 | boundName :: Scope x t -> x 15 | boundName (Scope x _) = unhide x 16 | 17 | -- | Scopes are thinable (by adding a bit at the end) 18 | instance Thable t => Thable (Scope x t) where 19 | Scope x t *^ th = Scope x (t *^ (th -? True)) 20 | -------------------------------------------------------------------------------- /Src/Syntax/Debug.hs: -------------------------------------------------------------------------------- 1 | module Syntax.Debug where 2 | 3 | import Syntax 4 | import Data.Maybe (fromJust) 5 | import qualified Data.Map as Map 6 | import Display (display, unsafeEvalDisplay) 7 | import Machine.Display() 8 | import Unelaboration.Monad (initNaming) 9 | import Text.PrettyPrint.Compact (render) 10 | 11 | printIt = putStrLn $ unlines 12 | [ show validateIt 13 | , "===" 14 | , render (unsafeEvalDisplay initNaming $ display (syntaxDesc ["Syntax"])) 15 | , "===" 16 | , render (unsafeEvalDisplay initNaming $ display $ Syntax.contract (fromJust (Syntax.expand (Map.singleton "Syntax" (syntaxDesc ["Syntax"])) (syntaxDesc ["Syntax"]))))] 17 | 18 | {- 19 | ['EnumOrTag 20 | ['Nil 'Atom 'Wildcard 'Syntax] 21 | [['AtomBar ['Fix \at. ['NilOrCons 'Atom at]]] 22 | ['Cons 'Syntax 'Syntax] 23 | ['NilOrCons 'Syntax 'Syntax] 24 | ['Bind ['EnumOrTag ['Syntax] []] 'Syntax] 25 | ['EnumOrTag ['Fix \at. ['NilOrCons 'Atom at]] 26 | ['Fix \cell. ['NilOrCons ['Cons 'Atom ['Fix \rec. ['NilOrCons 'Syntax rec]]] cell]]] 27 | ['Enum ['Fix \at. ['NilOrCons 'Atom at]]] 28 | ['Tag ['Fix \cell. ['NilOrCons ['Cons 'Atom ['Fix \rec. ['NilOrCons 'Syntax rec]]] cell]]] 29 | ['Fix ['Bind 'Syntax 'Syntax]]]] 30 | -} 31 | -------------------------------------------------------------------------------- /Src/Term.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | module Term (module Term, module Term.Base, module Term.Substitution{-, Term.Mangler-}) where 3 | 4 | import Term.Base 5 | import Term.Substitution hiding (expand) 6 | -- import Term.Mangler 7 | -------------------------------------------------------------------------------- /Src/Term/Display.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | 3 | module Term.Display where 4 | 5 | import Display 6 | import Term 7 | import Thin 8 | import Unelaboration.Monad 9 | 10 | instance (Show m, UnelabMeta m) => Display (Tm m) where 11 | type DisplayEnv (Tm m) = Naming 12 | display = viaPretty 13 | 14 | instance Display Meta where 15 | type DisplayEnv Meta = () 16 | display= viaPretty 17 | 18 | instance (Show m, UnelabMeta m) => Display (CdB (Tm m)) where 19 | type DisplayEnv (CdB (Tm m)) = Naming 20 | display = viaPretty 21 | 22 | instance (Show m, UnelabMeta m) => Display (Sbst m) where 23 | type DisplayEnv (Sbst m) = Naming 24 | display = viaPretty 25 | -------------------------------------------------------------------------------- /Src/Term/Mangler.hs: -------------------------------------------------------------------------------- 1 | module Term.Mangler where 2 | 3 | import Control.Monad.Writer 4 | import Control.Applicative 5 | import qualified Data.Map as Map 6 | 7 | import Thin 8 | import Hide 9 | import Term.Base 10 | import Term.Substitution 11 | 12 | data Mangler f {-xi-} {-ga-} = Mangler 13 | { mangGlo :: Int -- size of xi 14 | , mangLoc :: Int -- size of ga 15 | , mangV :: f (Term {-xi <<< ga -}) -- ga is singleton 16 | , mangB :: Mangler f {-xi-} {-ga , x-} -- how to mangle under a relevant binder 17 | , mangM :: Meta {-de-} -> f (Subst {-xi <<< de --> xi <<< ga -}) -> f (Term {-xi <<< ga -}) 18 | , mangSelFrom :: Th {-ga0 <= ga -} 19 | -> Mangler f {-xi-} {-ga0-} 20 | } 21 | 22 | mangTgt :: Mangler f -> Int 23 | mangTgt mu = mangGlo mu + mangLoc mu 24 | 25 | mangW :: Mangler f {-xi-} {-ga0 <<< ga1-} -> 26 | Int -> -- size of ga1 27 | Mangler f {-xi-} {-ga0-} 28 | mangW mu w = mangSelFrom mu (ones (mangLoc mu - w) <> none w) 29 | 30 | stanMangler :: Int -- number of global vars xi 31 | -> Int -- number of local vars ga 32 | -> Map.Map Meta (Term {-xi <<< de-}) -- de are vars in pattern you are allowed to depend on 33 | -> Mangler (Writer Any) {-xi-} {-ga-} 34 | stanMangler xi ga tbl = Mangler 35 | { mangGlo = xi 36 | , mangLoc = ga 37 | , mangV = pure (CdB V (none xi -? True)) 38 | , mangB = stanMangler xi (ga + 1) tbl 39 | , mangM = \ m sg -> 40 | case Map.lookup m tbl of 41 | Nothing -> (m $:) <$> sg 42 | Just t -> (t //^) <$> sg <* tell (Any True) 43 | , mangSelFrom = \ ph -> stanMangler xi (weeEnd ph) tbl 44 | } 45 | 46 | depMangler :: Foldable t => t Meta -- do we depend on any of these metas? 47 | -> Mangler (Const Any) 48 | depMangler ms = Mangler 49 | { mangGlo = 0 -- hack 50 | , mangLoc = 0 -- hack 51 | , mangV = Const mempty 52 | , mangB = depMangler ms 53 | , mangM = \ m sg -> sg *> (Const $ Any $ m `elem` ms) 54 | , mangSelFrom = \ ph -> depMangler ms 55 | } 56 | 57 | 58 | class Manglable t where 59 | mangle :: Applicative f => Mangler f {-xi-} {-ga-} -> t {-ga-} -> f (CdB t {- xi <<< ga-}) 60 | -- -- mangle' is worker for mangle 61 | -- mangle' :: Applicative f => Mangler m m' f -> t m -> f (CdB (t m')) 62 | mangleCdB :: Applicative f => Mangler f {-xi-} {-ga-} -> CdB (t {-ga-}) -> f (CdB (t {- xi <<< ga-})) 63 | 64 | {- 65 | mangle mu t = case mangTh mu of 66 | Just th -> pure (t, th) 67 | Nothing -> mangle' mu t 68 | -} 69 | 70 | mangleCdB mu (CdB t th) = mangle mu' t where 71 | -- we recheck for mangI after doing a selection computing m' 72 | mu' = mangSelFrom mu th 73 | 74 | instance Manglable a => Manglable (Named a) where 75 | mangle mu (x := a) = ((x :=) $^) <$> mangle mu a 76 | 77 | instance Manglable (Tm Meta) where 78 | mangle mu V = mangV mu 79 | mangle mu (A a) = pure (atom a (mangTgt mu)) 80 | mangle mu (P k p) = (P k $^) <$> mangle mu p 81 | mangle mu ((Hide x := False) :. t) = (x \\) <$> (weak <$> mangle mu t) 82 | mangle mu ((Hide x := True) :. t) = (x \\) <$> mangle (mangB mu) t 83 | mangle mu (m :$ sg) = mangM mu m (mangle mu sg) 84 | 85 | instance (Manglable a, Manglable b) => Manglable (RP a b) where 86 | mangle mu (a :<>: b) = (<&>) <$> mangleCdB mu a <*> mangleCdB mu b 87 | 88 | instance Manglable (Sbst Meta) where 89 | mangle mu (sg :^^ w) = sbstW <$> sg' <*> pure (ones w) where 90 | mu' = mangW mu w 91 | sg' = case sg of 92 | S0 -> pure (sbstI (mangGlo mu)) 93 | ST (sg :<>: t) -> sbstT <$> mangleCdB mu' sg <*> mangleCdB mu' t 94 | -------------------------------------------------------------------------------- /Src/Term/Substitution.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 2 | {-# HLINT ignore "Redundant bracket" #-} 3 | module Term.Substitution where 4 | 5 | import Bwd 6 | import Hide 7 | import Thin 8 | import Term.Base hiding (expand) 9 | 10 | -- import Debug.Trace 11 | track = const id 12 | -- track = trace 13 | 14 | data OrdWit 15 | = LtBy Int -- positive 16 | | GeBy Int -- non-negative 17 | deriving Show 18 | 19 | euclid :: Int -> Int -> OrdWit 20 | euclid x y = let d = x - y in case d < 0 of 21 | True -> LtBy (negate d) 22 | False -> GeBy d 23 | 24 | (//^) :: CdB (Tm m) -> CdB (Sbst m) -> CdB (Tm m) 25 | tth@(CdB t th) //^ sgph@(CdB sg ph) = 26 | -- track "\n" $ 27 | -- track ("Term: " ++ show tth) $ 28 | -- track ("Subst: " ++ show sgph) $ 29 | case sbstSel th sg of 30 | CdB sg ps -> 31 | let res = CdB (t // sg) (ps <^> ph) in 32 | -- track ("Result: " ++ show res) $ 33 | -- track "\n" $ 34 | res 35 | 36 | (//) :: Tm m -> Sbst m -> Tm m 37 | t // (S0 :^^ _) = t 38 | V // (ST (_ :<>: CdB (_ := t) _) :^^ 0) = t 39 | P p (CdB tl thl :<>: CdB tr thr) // sg = 40 | P p (CdB (tl // sgl) phl :<>: CdB (tr // sgr) phr) where 41 | CdB sgl phl = sbstSel thl sg 42 | CdB sgr phr = sbstSel thr sg 43 | ((x := b) :. t) // (sg :^^ w) = (x := b) :. (t // (sg :^^ if b then w+1 else w)) 44 | (m :$ rh) // sg = m :$ (rh /// sg) 45 | (G g t) // sg = G g (t // sg) 46 | 47 | (///) :: Sbst m -> Sbst m -> Sbst m 48 | (S0 :^^ _) /// sg = sg 49 | rh /// (S0 :^^ _) = rh 50 | (rh :^^ v) /// (sg :^^ w) = 51 | case euclid w v of 52 | LtBy d -> case sg of 53 | ST (CdB sg phl :<>: t) -> 54 | (ST (CdB ((rh :^^ (d-1)) /// sg) phl :<>: t) :^^ w) 55 | {- 56 | ------- ; ------- 57 | w w 58 | ------- ------- 59 | ------- ----> t 60 | d > 0 sg 61 | ------- 62 | rh 63 | -} 64 | GeBy d -> case rh of 65 | ST (CdB rh thl :<>: CdB (x := s) thr) -> let 66 | CdB sgl phl = sbstSel thl (sg :^^ d) 67 | CdB sgr phr = sbstSel thr (sg :^^ d) 68 | in (ST (CdB (rh /// sgl) phl :<>: CdB (x := (s // sgr)) phr) :^^ v) 69 | {- 70 | ------- ; ------- 71 | v v 72 | ------- ------- 73 | ----> s ------- 74 | rh d 75 | ------- 76 | sg 77 | -} 78 | 79 | expand :: Sbst m -- ga ---> de0 80 | -> Th -- de0 <= de 81 | -> Bwd (CdB (Tm m)) -- [Term de] 82 | expand (S0 :^^ 0) th = B0 83 | expand (ST (CdB sg th' :<>: (CdB (hi := tm) ph)) :^^ 0) th = expand sg (th' *^ th) :< (CdB tm ph) *^ th 84 | expand (sg :^^ n) th = expand (sg :^^ (n - 1)) (th -? False) :< var (DB 0) (weeEnd th) *^ th 85 | -------------------------------------------------------------------------------- /Src/Unelaboration/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | 3 | module Unelaboration.Monad where 4 | 5 | import Control.Monad.Except 6 | import Control.Monad.Reader 7 | 8 | import GHC.Stack 9 | 10 | import Bwd 11 | import Forget 12 | 13 | import Actor (ActorMeta'(..), ActorMeta, Passport(..)) 14 | import Concrete.Base (Variable(..)) 15 | import Location (unknown) 16 | import Term.Base (Meta, compressedMeta) 17 | import Thin 18 | 19 | ------------------------------------------------------------------------ 20 | -- Naming 21 | 22 | type Naming = 23 | ( Bwd String -- what's in the support 24 | , Th -- and how that was chosen from 25 | , Bwd String -- what's in scope 26 | ) 27 | 28 | initNaming :: Naming 29 | initNaming = (B0, ones 0, B0) 30 | 31 | nameOn :: Naming -> String -> Naming 32 | nameOn (xz, th, yz) x = (xz :< x, th -? True, yz :< x) 33 | 34 | nameSel :: Th -> Naming -> Naming 35 | nameSel th (xz, ph, yz) = (th ?< xz, th <^> ph, yz) 36 | 37 | freshen :: String -> Naming -> String 38 | freshen x (xz, _, _) = head [y | y <- ys, all (y /=) xz] where 39 | ys = x : [x ++ show (i :: Integer) | i <- [0..]] 40 | 41 | ------------------------------------------------------------------------ 42 | -- Monad 43 | 44 | data Complaint = UnexpectedEmptyThinning Naming 45 | | VarOutOfScope Naming 46 | | InvalidNaming Naming 47 | | UnknownChannel String 48 | deriving (Show) 49 | 50 | newtype UnelabM e a = Unelab 51 | { runUnelab :: (ReaderT e 52 | (Either Complaint)) 53 | a } 54 | deriving ( Functor, Applicative, Monad 55 | , MonadError Complaint 56 | , MonadReader e) 57 | 58 | withEnv :: e' -> UnelabM e' a -> UnelabM e a 59 | withEnv rh (Unelab md) = Unelab (withReaderT (const rh) md) 60 | 61 | evalUnelab :: e -> UnelabM e a -> Either Complaint a 62 | evalUnelab e (Unelab m) = runReaderT m e 63 | 64 | unsafeEvalUnelab :: e -> UnelabM e a -> a 65 | unsafeEvalUnelab e m = either (error . show) id $ evalUnelab e m 66 | 67 | withForget :: Forget e e' => UnelabM e' a -> UnelabM e a 68 | withForget (Unelab md) = Unelab (withReaderT forget md) 69 | 70 | ------------------------------------------------------------------------ 71 | -- Class 72 | 73 | class Unelab t where 74 | type UnelabEnv t 75 | type Unelabed t 76 | 77 | unelab :: HasCallStack => t -> UnelabM (UnelabEnv t) (Unelabed t) 78 | 79 | subunelab :: (Unelab t, Forget e (UnelabEnv t)) => t -> UnelabM e (Unelabed t) 80 | subunelab = withForget . unelab 81 | 82 | ------------------------------------------------------------------------ 83 | -- Unelaboration of meta variables 84 | 85 | type UnelabMeta m = (Unelab m, UnelabEnv m ~ (), Unelabed m ~ Variable) 86 | 87 | instance Unelab Meta where 88 | type UnelabEnv Meta = () 89 | type Unelabed Meta = Variable 90 | unelab m = pure $ Variable unknown $ compressedMeta m 91 | 92 | instance Unelab ActorMeta where 93 | type UnelabEnv ActorMeta = () 94 | type Unelabed ActorMeta = Variable 95 | -- TODO: fixme 96 | unelab (ActorMeta ASubject str) = pure (Variable unknown $ "$" ++ str) 97 | unelab (ActorMeta _ str) = pure (Variable unknown str) 98 | -------------------------------------------------------------------------------- /Src/Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils where 2 | 3 | import Data.Set (Set) 4 | import qualified Data.Set as Set 5 | import Data.These (These(..)) 6 | 7 | import Control.Monad.State 8 | 9 | isAllJustBy :: [a] -> (a -> Maybe b) -> Either a [b] 10 | isAllJustBy [] f = pure [] 11 | isAllJustBy (a:as) f = do 12 | b <- maybe (Left a) Right (f a) 13 | bs <- isAllJustBy as f 14 | pure (b:bs) 15 | 16 | isAll :: (a -> Bool) -> [a] -> Either a () 17 | isAll p [] = pure () 18 | isAll p (x:xs) = do 19 | if p x then pure () else Left x 20 | isAll p xs 21 | 22 | whenCons :: Applicative m => [a] -> (a -> [a] -> m ()) -> m () 23 | whenCons [] k = pure () 24 | whenCons (a:as) k = k a as 25 | 26 | whenLeft :: Applicative m => Either a b -> (a -> m ()) -> m () 27 | whenLeft (Left a) k = k a 28 | whenLeft (Right _) k = pure () 29 | 30 | whenNothing :: Applicative m => Maybe a -> m () -> m () 31 | whenNothing Nothing k = k 32 | whenNothing (Just _) k = pure () 33 | 34 | whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () 35 | whenJust Nothing k = pure () 36 | whenJust (Just a) k = k a 37 | 38 | whenM :: Monad m => m Bool -> m () -> m () 39 | whenM cond m = cond >>= flip when m 40 | 41 | unlessM :: Monad m => m Bool -> m () -> m () 42 | unlessM cond m = cond >>= flip unless m 43 | 44 | instance Semigroup m => Semigroup (State s m) where 45 | (<>) = liftM2 (<>) 46 | 47 | instance Monoid m => Monoid (State s m) where 48 | mempty = pure mempty 49 | 50 | class HalfZip f where 51 | halfZip :: f x -> f y -> Maybe (f (x, y)) 52 | 53 | instance HalfZip [] where 54 | halfZip [] [] = Just [] 55 | halfZip (x:xs) (y:ys) = ((x,y):) <$> halfZip xs ys 56 | halfZip _ _ = Nothing 57 | 58 | allUnique :: (Ord a, Foldable f) => f a -> Either a (Set a) 59 | allUnique = flip foldr (pure Set.empty) $ \ a acc -> do 60 | s <- acc 61 | if a `Set.member` s then Left a else Right (Set.insert a s) 62 | 63 | alignWith :: (These a b -> c) -> [a] -> [b] -> [c] 64 | alignWith f [] bs = map (f . That) bs 65 | alignWith f as [] = map (f . This) as 66 | alignWith f (a:as) (b:bs) = f (These a b) : alignWith f as bs 67 | -------------------------------------------------------------------------------- /Src/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | module Vector where 3 | 4 | import Data.Kind 5 | 6 | data Nat = Z | S Nat 7 | 8 | infixr 5 :* 9 | data Vector (n :: Nat) (a :: Type) where 10 | V0 :: Vector Z a 11 | (:*) :: a -> Vector n a -> Vector (S n) a 12 | 13 | hd :: Vector (S n) a -> a 14 | hd (t :* _) = t 15 | 16 | instance Functor (Vector n) where 17 | fmap f V0 = V0 18 | fmap f (x :* xs) = f x :* fmap f xs 19 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | ### Documentation 2 | 3 | * [ ] Document `!.` and `^`, `/` extract modes 4 | * [ ] More structured documentation à la readthedocs? 5 | 6 | ### Syntax 7 | 8 | * [x] Insist keywords are followed by a space (`casew{}` vs. `case w {}`) 9 | * [x] Annotating max locations (cf. () in Parse) 10 | * [ ] User-friendly syntaxes 11 | * [ ] Industrial-strength parsing 12 | * [x] Source location information 13 | * [x] Let binders 14 | * [x] as-patterns 15 | * [x] irrefutable patterns in binders 16 | * [x] literate markdown 17 | * [ ] literate LaTeX 18 | * [ ] protect against "redefining" syntax keywords such as 'Atom etc 19 | 20 | ### Features 21 | 22 | * [ ] Module system 23 | * [ ] Concurrent runtime 24 | * [ ] Construct error messages from unfinished runs 25 | * [ ] Deadlock detection 26 | * [x] Coverage checker for `case` 27 | * [x] Standalone stacks (attached to strings, not judgements) 28 | * [ ] Unification modulo computation 29 | * [ ] Guarding execution until validation 30 | + [ ] Unique names for subactors 31 | + [ ] block terms on names 32 | + [ ] Blocking wrapper evaporates when named thing is `Done` 33 | * [x] PRINTF argument for model-based normalisation 34 | * [ ] PRINTF argument for type of 35 | 36 | 37 | ### VM 38 | 39 | * [ ] VM performance 40 | + [ ] Profiling 41 | + [ ] Bookkeep parts of the tree that are not stuck on new metas 42 | + [ ] Record more precise "Date" information (e.g. sets of blocking meta) 43 | + [x] 'Done' status for winning branches 44 | + [x] 'Fail' status for dead branches 45 | * [ ] Add "stuckon" tracing option for pattern-matching machinery 46 | * [ ] Add "match" tracing option 47 | * [ ] Compile matches to case trees 48 | * [ ] Record metas that got us stuck 49 | 50 | ### Judgement Contracts 51 | 52 | * [ ] Syntax have an associated Semantics (what's canonical) 53 | * [ ] Judgement take inputs / subjects / outputs 54 | + [ ] Subject should be syntatic 55 | + [ ] Inputs / outputs should be in the semantics of the given syntax 56 | + [ ] child subjects are structural components of parent subjects 57 | + [x] if a subject pattern variable is transmitted, it is the subject of some child 58 | + [ ] Each syntax has a designated judgement with that syntax as subject (the justifier / gatekeeper / guarantor) 59 | * [ ] Distinction between subjects and citizens (interpreted values of subjects) 60 | + [ ] make separate environments for subjects and citizens 61 | + [ ] guarding subjects-as-citizens 62 | + [ ] meaning of guarded subjects is given by citizens (silently) 63 | * [ ] Contracts (constraints on inputs, guarantees on outputs) 64 | + [ ] each ? and ! must have a contract how it was/will be a $ 65 | + [ ] define a standard model that we match against in ? and synthesise in ! 66 | + [ ] there are other explicit models (e.g. a Kripke one for NBE) 67 | 68 | ### CLI 69 | 70 | * [ ] Hide extract mode under a CLI option 71 | 72 | ### LaTeX 73 | 74 | * [x] Colours for input and output 75 | * [ ] Allow Latex injection in the source file 76 | * [ ] Proper escaping of things latex don't like 77 | 78 | ### Examples 79 | 80 | * [x] STLC with clever lists 81 | * [ ] Tests for extract mode 82 | * [x] List induction 83 | 84 | ### Refactoring 85 | 86 | * [x] Add range information to Variable 87 | * [ ] More structured type of names 88 | * [ ] Make sure LaTeX output is valid LaTeX 89 | * [x] `data Actor (ph :: Phase)`? 90 | * [ ] Define `ElaborationMonad m =>` & cleanup sclause 91 | * [ ] Drop run-length encoding subst in favour of relevant subst 92 | * [ ] Match monad for Matching (Env in a state) 93 | * [ ] `keyword` pretty printing should use the data type of keywords 94 | * [ ] `class Declarable a where { declare :: a -> Context -> Context }` 95 | instead of declareObjVar, declareChannel, declareXXX 96 | * [x] Add `throwComplaint :: Range -> Complaint -> Elab ()` and 97 | refactor `Complaint` to be range-free with the range carried 98 | by a `WithRange` wrapper. 99 | 100 | ### Pretty 101 | 102 | * [ ] Try alternative libraries 103 | 104 | ### Cleanup 105 | 106 | * [ ] Fix all the incomplete patterns errors 107 | -------------------------------------------------------------------------------- /build/notations.tex: -------------------------------------------------------------------------------- 1 | \usepackage{amssymb} 2 | \usepackage{proof} 3 | 4 | \renewcommand{\typosBinding}[1]{} 5 | \renewcommand{\typosPushing}[3]{#2 : #3 \vdash} 6 | 7 | \renewcommand{\typosAxiom}[1]{\infer{#1}{}} 8 | \renewcommand{\typosDerivation}[2]{\infer{#1}{#2}} 9 | \renewcommand{\typosBeginPrems}{} 10 | \renewcommand{\typosBetweenPrems}{&} 11 | \renewcommand{\typosEndPrems}{} 12 | 13 | \renewcommand{\typosScope}[2]{\lambda #1. #2} 14 | 15 | \renewcommand{\tagLamForOne}[1]{#1} 16 | \renewcommand{\tagEmbForOne}[1]{\underline{#1}} 17 | \renewcommand{\tagAnnForTwo}[2]{(#1 : #2)} 18 | \renewcommand{\tagAppForTwo}[2]{#1 #2} 19 | \renewcommand{\enumNat}[0]{\mathbb{N}} 20 | \renewcommand{\tagArrForTwo}[2]{#1 \to #2} 21 | \renewcommand{\callingtype}[1]{\textsc{type}~ #1} 22 | \renewcommand{\callingcheck}[2]{#1 \ni #2} 23 | \renewcommand{\callingsynth}[2]{#1 \in #2} 24 | -------------------------------------------------------------------------------- /build/trace.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msp-strath/TypOS/34acf92b034c540e624413119ead88b326ea33d0/build/trace.gif -------------------------------------------------------------------------------- /cabal.project.local: -------------------------------------------------------------------------------- 1 | ignore-project: False 2 | library-vanilla: False 3 | executable-dynamic: True 4 | 5 | package * 6 | ghc-options: -j +RTS -A128m -RTS 7 | 8 | program-options 9 | ghc-options: -j +RTS -A128m -RTS 10 | -------------------------------------------------------------------------------- /emacs/emacs: -------------------------------------------------------------------------------- 1 | ;; this should be inserted in your .emacs 2 | ;; be careful to replace PATH/TO/ with the path... 3 | 4 | ;; typos 5 | (autoload 'typos-mode "PATH/TO/typos/emacs/typos.el" nil t) 6 | (add-to-list 'auto-mode-alist '("\\.act\\'" . typos-mode)) 7 | ;; additionally if you want rainbow delimiters on parens, braces & brackets 8 | (add-hook 'typos-mode-hook 'rainbow-delimiters-mode) -------------------------------------------------------------------------------- /emacs/typos.el: -------------------------------------------------------------------------------- 1 | (require 'compile) 2 | 3 | ;; based on: http://ergoemacs.org/emacs/elisp_syntax_coloring.html 4 | 5 | ;; define several class of keywords 6 | (setq typos-keywords '("syntax" "operator" "exec" "trace" "rule" "judgementform" "typecheck" 7 | "break" "unify" "send" "recv" "move" 8 | "case" "let" 9 | "Atom" "AtomBar" "Wildcard" "EnumOrTag" "Enum" "Tag" "Cons" "Nil" "NilOrCons" "Fix" "Bind" 10 | "BREAK" "PRINT" "PRINTF")) 11 | (setq typos-operators '("@" "!" "$" "?" "~" "#")) 12 | (setq typos-symbols '("|-" "|" "<->" "->" "~>" ";" "=>" "=" "{" "}")) 13 | 14 | ;; create the regex string for each class of keywords 15 | (setq typos-keywords-regexp (regexp-opt typos-keywords 'words)) 16 | (setq typos-operators-regexp (regexp-opt typos-operators)) 17 | (setq typos-symbols-regexp (regexp-opt typos-symbols)) 18 | 19 | ;; clear memory 20 | (setq typos-keywords nil) 21 | (setq typos-operators nil) 22 | (setq typos-symbols nil) 23 | 24 | ;; create the list for font-lock. 25 | ;; each class of keyword is given a particular face 26 | (setq typos-font-lock-keywords 27 | `( 28 | (,typos-keywords-regexp . font-lock-keyword-face) 29 | (,typos-symbols-regexp . font-lock-builtin-face) 30 | (,typos-operators-regexp . font-lock-builtin-face) 31 | )) 32 | 33 | ;; syntax table 34 | (defvar typos-syntax-table nil "Syntax table for `typos-mode'.") 35 | (setq typos-syntax-table 36 | (let ((synTable (make-syntax-table))) 37 | 38 | ;; comments 39 | (modify-syntax-entry ?\{ "(}1nb" synTable) 40 | (modify-syntax-entry ?\} "){4nb" synTable) 41 | (modify-syntax-entry ?- "_ 123" synTable) 42 | (modify-syntax-entry ?\n ">" synTable) 43 | 44 | synTable)) 45 | 46 | ;; define the mode 47 | (define-derived-mode typos-mode fundamental-mode 48 | "TypOS mode" 49 | ;; handling comments 50 | :syntax-table typos-syntax-table 51 | ;; code for syntax highlighting 52 | (setq font-lock-defaults '((typos-font-lock-keywords))) 53 | (setq mode-name "typos") 54 | ;; clear memory 55 | (setq typos-keywords-regexp nil) 56 | (setq typos-operators-regexp nil) 57 | ) 58 | 59 | ;; Customisation options 60 | 61 | (defgroup typos nil 62 | "An operating system for typechecking processes." 63 | :group 'languages) 64 | 65 | (defcustom typos-command "typos" 66 | "The path to the typOS command to run." 67 | :type 'string 68 | :group 'typos) 69 | 70 | (defcustom typos-options nil 71 | "Command line options to pass to typOS." 72 | :type 'string 73 | :group 'typos) 74 | 75 | ;; Compilation mode for running typOS 76 | ;; (based on https://spin.atomicobject.com/2016/05/27/write-emacs-package/ ) 77 | 78 | (defun typos-compilation-filter () 79 | "Filter function for compilation output." 80 | (ansi-color-apply-on-region compilation-filter-start (point-max))) 81 | 82 | (define-compilation-mode typos-compilation-mode "TypOS" 83 | "TypOS compilation mode." 84 | (progn 85 | (set (make-local-variable 'compilation-error-regexp-alist) 86 | '(("\\(^[^[:space:]]*\\):\\([0-9]+\\):\\([0-9]+\\)-\\(\\([0-9]+\\):\\)?\\([0-9]+\\)$" 87 | 1 (2 . 5) (3 . 6) 2) 88 | ("^Parse error \\(at\\|near\\) location: \\([^[:space:]]*\\):\\([0-9]+\\):\\([0-9]+\\)" 89 | 2 3 (4 . 5) 2) 90 | ("^Warning: \\([^[:space:]]*\\):\\([0-9]+\\):\\([0-9]+\\)-\\(\\([0-9]+\\):\\)?\\([0-9]+\\)$" 91 | 1 (2 . 5) (3 . 6) 1) 92 | )) 93 | (add-hook 'compilation-filter-hook 'typos-compilation-filter nil t))) 94 | 95 | (defface typos-highlight-error-face 96 | '((t (:underline (:color "red" :style wave)))) 97 | "The face used for errors.") 98 | 99 | (defun typos-run-on-file (typos-file options) 100 | "Run typOS in a compilation buffer on TYPOS-FILE." 101 | (setq compilation-auto-jump-to-first-error t) 102 | (setq next-error-highlight-timer t) 103 | (setq next-error-highlight t) 104 | (setq typos-error-highlight (make-overlay (point-min) (point-min))) 105 | (overlay-put typos-error-highlight 'face 'typos-highlight-error-face) 106 | (setq compilation-highlight-overlay typos-error-highlight) 107 | (save-some-buffers compilation-ask-about-save 108 | (when (boundp 'compilation-save-buffers-predicate) 109 | compilation-save-buffers-predicate)) 110 | 111 | (when (get-buffer "*typos output*") 112 | (kill-buffer "*typos output*")) 113 | (let ((typos-command-to-run (concat typos-command " " options " " typos-file))) 114 | (with-current-buffer (get-buffer-create "*typos output*") 115 | (compilation-start typos-command-to-run 'typos-compilation-mode (lambda (m) (buffer-name))) 116 | (overlay-put (make-overlay (point-min) (point-max) (current-buffer) nil t) 117 | 'face 118 | `(:background "black",:foreground "white",:extend t))))) 119 | 120 | ;;;###autoload 121 | (defun typos-run (override-options) 122 | "Run typOS on the current file." 123 | (interactive "P") 124 | (let ((opts (if override-options (read-string "Options: ") typos-options))) 125 | (typos-run-on-file (shell-quote-argument (buffer-file-name)) opts))) 126 | 127 | (define-key typos-mode-map (kbd "C-c C-l") 'typos-run) 128 | 129 | (provide 'typos-mode) 130 | -------------------------------------------------------------------------------- /examples/elaboration.act: -------------------------------------------------------------------------------- 1 | syntax { 'Source = ['Tag [['Data 'Atom ['Fix \cs. ['NilOrCons ['Cons 'Atom 'Tele] cs]]]]] 2 | ; 'Tele = ['Tag [['Ret 'Atom] 3 | ['Arr 'Wildcard 'Tele]]] 4 | } 5 | 6 | syntax { 'Type = ['EnumOrTag ['Unit 'Bool 'Rec] [['Pair 'Type 'Type]]] 7 | ; 'Desc = ['Fix \s. ['NilOrCons 'Prod s]] -- sums 8 | ; 'Prod = ['Fix \p. ['NilOrCons 'Type p]] -- of products 9 | } 10 | 11 | elabTele : ?'Atom. ?'Tele. !'Prod. 12 | type : ?'Atom. ?'Wildcard. !'Type. 13 | 14 | elabTele@p = p?dat. p?tm. case tm 15 | { ['Ret ty] -> (ty ~ dat | p![].) 16 | ; ['Arr ty tel] -> 17 | type@q. q!dat. q!ty. q?ty'. 18 | elabTele@r. r!dat. r!tel. r?ps. 19 | p![ty'|ps]. 20 | } 21 | 22 | type@p = p?dat. p?tm. case tm 23 | { 'Bool -> p!'Bool. 24 | ; 'Unit -> p!'Unit. 25 | ; ['Pair ty1 ty2] -> 26 | 'Type?T1 T2. 27 | ( type@q. q!dat. q!ty1. q?res. res ~ T1 28 | | type@q. q!dat. q!ty2. q?res. res ~ T2 29 | | p!['Pair T1 T2]. 30 | ) 31 | ; _ -> case compare tm dat 32 | { 'EQ -> p!'Rec. 33 | ; _ -> # "Invalid type: %i" tm 34 | } 35 | } 36 | 37 | elabDat : ?'Atom. ?['Fix \cs. ['NilOrCons ['Cons 'Atom 'Tele] cs]]. !'Desc. 38 | elabDat@p = p?dat. p?cs. case cs 39 | { [] -> p![]. 40 | ; [[_ | c] | cs'] -> 41 | elabTele@q. q!dat. q!c. q?desc. 42 | elabDat@r. r!dat. r!cs'. r?descs. 43 | p![desc | descs]. 44 | } 45 | 46 | elab : ?'Source. !['Cons 'Atom 'Desc]. 47 | elab@p = p?['Data nm cs]. elabDat@q. q!nm. q!cs. q?desc. p![nm | desc]. 48 | 49 | exec elab@p. 50 | p!['Data 'Bits [ ['Nil | ['Ret 'Bits]] 51 | ['Cons | ['Arr 'Bool ['Arr 'Bits ['Ret 'Bits]]]]] 52 | ]. 53 | p?[nm | desc]. 54 | PRINTF "Data %i elaborated to:\n%i" nm desc. 55 | 56 | exec elab@p. 57 | p!['Data 'Tree [ ['Leaf | ['Arr 'Bool ['Ret 'Tree]]] 58 | ['Node | ['Arr ['Pair 'Tree ['Pair 'Bool 'Tree]] ['Ret 'Tree]]]] 59 | ]. 60 | p?[nm | desc]. 61 | PRINTF "Data %i elaborated to:\n%i" nm desc. -------------------------------------------------------------------------------- /examples/golden/README.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | err > 3 | err > 4 | -------------------------------------------------------------------------------- /examples/golden/Roadmap.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | err > 3 | err > 4 | -------------------------------------------------------------------------------- /examples/golden/elaboration.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Data 'Tree elaborated to: 3 | out > [['Bool] [['Pair 'Rec ['Pair 'Bool 'Rec]]]] 4 | out > Data 'Bits elaborated to: 5 | out > [[] ['Bool 'Rec]] 6 | out > 7 | err > 8 | err > 9 | -------------------------------------------------------------------------------- /examples/golden/krivine.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > ['Lam \x. ['Lam \y. ['App x ['App x ['App x ['App x y]]]]]] 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /examples/golden/krivine2.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > ['Lam \x. ['Lam \y. ['App x ['App x ['App x ['App x y]]]]]] 3 | out > ['Lam \x. x] 4 | out > ['Lam \g. g] 5 | out > 6 | err > 7 | err > 8 | -------------------------------------------------------------------------------- /examples/golden/mltt.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: mltt.act:47:35-51 3 | out > Sent subject {v=['Rad ns S]} T is not a subject variable 4 | out > when elaborating a case branch handling the pattern ['Pi S \v. T] 5 | out > when elaborating a case branch handling the pattern ['App f s] 6 | out > when elaborating a case branch handling the pattern 'Nothing 7 | out > when elaborating the judgement definition for synth 8 | out > Warning: mltt.act:49:46-65 9 | out > Sent subject {x=['Rad ns S]} body is not a subject variable 10 | out > when elaborating a case branch handling the pattern ['Lam \x. body] 11 | out > when elaborating a case branch handling the pattern ['Pi S \v. T] 12 | out > when elaborating a case branch handling the pattern ['App f s] 13 | out > when elaborating a case branch handling the pattern 'Nothing 14 | out > when elaborating the judgement definition for synth 15 | out > ['Pi ['Pi 'Ty \x. ['Emb x]] \_. ['Pi 'Ty \x. ['Emb x]]] 16 | out > ['Lam \a. ['Emb a]] 17 | out > 18 | err > 19 | err > 20 | -------------------------------------------------------------------------------- /examples/golden/mltt2.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: mltt2.act:107:87-109:7 3 | out > Incomplete pattern matching. The following patterns are missing: 4 | out > 'Ty 5 | out > ['Lam \_. a] 6 | out > ['Emb a] 7 | out > when elaborating a case branch handling the pattern [['App f1 s1] 'App f2 s2] 8 | out > when elaborating a case branch handling the pattern 'Nothing 9 | out > when elaborating the judgement definition for equalSynthWorker 10 | out > Warning: mltt2.act:110:6-11 11 | out > Unreachable clause [x | y] 12 | out > when elaborating a case branch handling the pattern 'Nothing 13 | out > when elaborating the judgement definition for equalSynthWorker 14 | out > Other 'Ty 15 | out > Other 'Ty 16 | out > Other 'Ty 17 | out > Other 'Ty 18 | out > Other ['Pi 'Ty \_. 'Ty] 19 | out > Other 'Ty 20 | out > Other 'Ty 21 | out > Other 'Ty 22 | out > Other 'Ty 23 | out > Other 'Ty 24 | out > Other 'Ty 25 | out > Ty 26 | out > Other 'Ty 27 | out > Other 'Ty 28 | out > Other 'Ty 29 | out > Other 'Ty 30 | out > Other 'Ty 31 | out > Ty 32 | out > Other ['Pi 'Ty \_. 'Ty] 33 | out > Other 'Ty 34 | out > Other 'Ty 35 | out > Other 'Ty 36 | out > Other 'Ty 37 | out > Other 'Ty 38 | out > Other 'Ty 39 | out > Other 'Ty 40 | out > Ty 41 | out > Other 'Ty 42 | out > Other 'Ty 43 | out > Other 'Ty 44 | out > Other 'Ty 45 | out > Ty 46 | out > Emb 47 | out > App 48 | out > Rad 49 | out > Other ['Lam \x. ['Pi ['Emb x] \_. ['Emb x]]] 50 | out > Other ['Pi 'Ty \_. 'Ty] 51 | out > Beta 52 | out > Other ['Pi ['Emb ['Rad ['Pi 'Ty \x. ['Emb x]] 'Ty]] 53 | out > \_. ['Emb ['Rad ['Pi 'Ty \x. ['Emb x]] 'Ty]]] 54 | out > Other 'Ty 55 | out > Ups 56 | out > Emb 57 | out > Rad 58 | out > Other ['Pi 'Ty \x. ['Emb x]] 59 | out > Other 'Ty 60 | out > Ups 61 | out > Emb 62 | out > Rad 63 | out > Other ['Pi 'Ty \x. ['Emb x]] 64 | out > Other 'Ty 65 | out > Ups 66 | out > Other 'Ty 67 | out > Other ['Pi 'Ty \x. ['Emb x]] 68 | out > Other ['Pi 'Ty \x. ['Emb x]] 69 | out > Pi 70 | out > Other 'Ty 71 | out > Other 'Ty 72 | out > Other 'Ty 73 | out > Ty 74 | out > Other 'Ty 75 | out > Emb 76 | out > Emb 77 | out > Emb 78 | out > Var 79 | out > Emb 80 | out > App 81 | out > Rad 82 | out > Other ['Lam \x. ['Pi ['Emb x] \_. ['Emb x]]] 83 | out > Other ['Pi 'Ty \_. 'Ty] 84 | out > Beta 85 | out > Other ['Pi ['Emb ['Rad ['Pi 'Ty \x. ['Emb x]] 'Ty]] 86 | out > \_. ['Emb ['Rad ['Pi 'Ty \x. ['Emb x]] 'Ty]]] 87 | out > Other 'Ty 88 | out > Ups 89 | out > Type: ['Pi ['Emb ['Rad ['Pi 'Ty \x. ['Emb x]] 'Ty]] 90 | out > \_. ['Emb ['Rad ['Pi 'Ty \x. ['Emb x]] 'Ty]]] 91 | out > Rad 92 | out > Other ['Lam \x. ['Emb x]] 93 | out > Emb 94 | out > App 95 | out > Rad 96 | out > Other ['Lam \x. ['Pi ['Emb x] \_. ['Emb x]]] 97 | out > Other ['Pi 'Ty \_. 'Ty] 98 | out > Beta 99 | out > Other ['Pi ['Emb ['Rad ['Pi 'Ty \x. ['Emb x]] 'Ty]] 100 | out > \_. ['Emb ['Rad ['Pi 'Ty \x. ['Emb x]] 'Ty]]] 101 | out > Other 'Ty 102 | out > Ups 103 | out > Eval: ['Rad ['Lam \x. ['Emb x]] ['Pi ['Emb ['Rad ['Pi 'Ty \x. ['Emb x]] 'Ty]] 104 | out > \_. ['Emb ['Rad ['Pi 'Ty \x. ['Emb x]] 105 | out > 'Ty]]]] 106 | out > 107 | err > 108 | err > 109 | -------------------------------------------------------------------------------- /examples/golden/mlttList.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: mlttList.act:202:36-37 3 | out > Sent subject e is not a subject variable 4 | out > when elaborating a case branch handling the pattern ['Emb e a] 5 | out > when elaborating a case branch handling the pattern ['ListRec 6 | out > \xs. T 7 | out > n 8 | out > \y ys ih. c] 9 | out > when elaborating a case branch handling the pattern ['Rad t ['List S]] 10 | out > when elaborating a case branch handling the pattern ['App f s] 11 | out > when elaborating the judgement definition for evalSynth 12 | out > two plus two is ['Plus ['Sing 'Tt] ['Plus ['Sing 'Tt] ['Plus ['Sing 'Tt] 13 | out > ['Sing 'Tt]]]]. 14 | out > 15 | err > 16 | err > 17 | -------------------------------------------------------------------------------- /examples/golden/stlc.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Victory! 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /examples/golden/stlc2.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: stlc2.act:29:5-16 3 | out > Pattern subject ty did not get scrutinised 4 | out > when elaborating a case branch handling the pattern ['Rad t ty] 5 | out > when elaborating a case branch handling the pattern 'Nothing 6 | out > when elaborating the judgement definition for synth 7 | out > 8 | err > 9 | err > 10 | -------------------------------------------------------------------------------- /examples/golden/stlc3.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | err > 3 | err > 4 | -------------------------------------------------------------------------------- /examples/golden/stlc4.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Store: 3 | out > 43: [?[("check",[1])("S",[1])] := 'Nat 4 | out > , ?[("check",[1])("T",[2])] := 'Nat 5 | out > , ?[("check",[1,4])("synth",[1])("",[4])("synth",[0])("",[2])("check",[0])("S",[1])] := ?[("check",[1,4])("synth",[1])("",[4])("synth",[0])("",[2])("check",[0])("T",[2])] 6 | out > , ?[("check",[1,4])("synth",[1])("",[4])("synth",[0])("",[2])("check",[0])("T",[2])] := 'Nat 7 | out > , ?[("check",[1,4])("synth",[1])("U",[2])] := 'Nat 8 | out > , ?[("check",[1,4])("synth",[1])("V",[3])] := 'Nat] 9 | out > Env: [] 10 | out > Stack: 11 | out > [ , check |-@p {} 13 | out > , synth |-@p {} 14 | out > , ([] Done ) | <> 15 | out > , ([([] Done ) | <> 16 | out > , \z_0. 17 | out > , ctxt |- z_0 -> ?[("check",[1])("S",[1])] . 18 | out > , ([([([([<> | ([([] Done ) | <>, ([([([] Done ) @ p | q [] @ <>] Done ) | <> 19 | out > , ([] Done ) @ p | q [] @ <>] 20 | out > Done 21 | out > ) 22 | out > @ p | q [] @ <>] 23 | out > Done 24 | out > ) 25 | out > , ([<> | ([\w_1. 26 | out > , ctxt |- w_1 -> ?[("check",[1,4])("synth",[1])("",[4])("synth",[0])("",[2])("check",[0])("S",[1])] . 27 | out > , ([([] Done ) @ p | q [] @ <>] Done ) @ p | q [w] @ <>] 28 | out > Done 29 | out > )] 30 | out > Done 31 | out > ) 32 | out > @ p | q [] @ <>] 33 | out > Done 34 | out > ) 35 | out > @ p | q [] @ <>] 36 | out > Done 37 | out > ) | <> 38 | out > , ([([([] Done ) @ p | q [] @ <>] Done ) @ p | r [] @ <>] Done ) | <>] 39 | out > Done 40 | out > ) 41 | out > @ p | q [] @ <>] 42 | out > Done 43 | out > ) 44 | out > @ p | q [z] @ <>] 45 | out > Done 46 | out > ) 47 | out > @ p | p [] @ <>] 48 | out > 49 | err > 50 | err > 51 | -------------------------------------------------------------------------------- /examples/golden/stlctpp.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | err > 3 | err > 4 | -------------------------------------------------------------------------------- /examples/golden/stlctpp2.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Result: 3 | out > [0,1] ++ [2] 4 | out > : ['List ['List 'One]] 5 | out > = ['Rad ['Cons 'Nil ['Cons ['Cons 'Nil 'Nil] 6 | out > ['Cons ['Cons 'Nil ['Cons 'Nil 'Nil]] 'Nil]]] 7 | out > ['List ['List 'One]]] 8 | out > 9 | err > 10 | err > 11 | -------------------------------------------------------------------------------- /examples/golden/untyped.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > ['Lam \x. ['Lam \y. ['App x ['App x ['App x ['App x y]]]]]] 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /examples/krivine.act: -------------------------------------------------------------------------------- 1 | -- trace { exec } 2 | 3 | syntax 4 | { 'Term = ['Tag [ 5 | ['Lam ['Bind 'Term 'Term]] 6 | ['App 'Term 'Term] 7 | ]] 8 | ; 'Stack = ['NilOrCons 'Term 'Stack] 9 | } 10 | 11 | env |- 'Term -> 'Term 12 | krivine : ?'Term. ?'Stack. !'Term. 13 | unwind : ?'Term. ?'Stack. !'Term. 14 | 15 | unwind@p = p?tm. p?stk. case stk 16 | { [] -> p!tm. 17 | ; [a | as] -> unwind@q. q!['App tm a]. q!as. q?res. p!res. 18 | } 19 | 20 | krivine@p = p?tm. p?stk. 21 | case (lookup env tm) 22 | { ['Just v] -> unwind@q. q!v. q!stk. q?res. p!res. 23 | ; 'Nothing -> case tm 24 | { ['App f t] -> 'Term?vt. 25 | ( krivine@q. q!t. q![]. q?res. res ~ vt 26 | | krivine@q. q!f. q![vt|stk]. q?res. p!res. 27 | ) 28 | ; ['Lam \x.b] -> case stk 29 | { [] -> \x. env |- x -> x. 30 | krivine@q. q!b. q![]. q?res. p!['Lam \x.res]. 31 | ; [a | as] -> krivine@q. q!{x=a}b. q!as. q?res. p!res. 32 | } 33 | } 34 | } 35 | 36 | exec krivine@p. 37 | p!['App ['Lam \f. ['Lam \x. ['App f ['App f x]]]] 38 | ['Lam \g. ['Lam \y. ['App g ['App g y]]]]]. 39 | p![]. p?v. PRINTF "%i" v . 40 | -------------------------------------------------------------------------------- /examples/krivine2.act: -------------------------------------------------------------------------------- 1 | -- trace { break } 2 | 3 | syntax 4 | { 'Term = ['Tag [ 5 | ['Lam ['Bind 'Term 'Term]] 6 | ['App 'Term 'Term] 7 | ]] 8 | ; 'Stack = ['NilOrCons 'Term 'Stack] 9 | ; 'Entry = ['Tag [ 10 | ['Argument 'Term] 11 | ['Variable 'Term] 12 | ]] 13 | } 14 | 15 | env |- 'Term -> 'Entry 16 | krivine : ?'Term. ?'Stack. !'Term. 17 | unwind : ?'Term. ?'Stack. !'Term. 18 | 19 | unwind@p = p?tm. p?stk. case stk 20 | { [] -> case tm 21 | { ['Lam \x.b] -> 22 | -- stack is empty: evaluate under a binder with a placeholder variable 23 | \x. env |- x -> ['Variable x]. 24 | krivine@q. q!b. q![]. q?res. p!['Lam \x.res]. 25 | ; _ -> p!tm. 26 | } 27 | ; [a | as] -> case tm 28 | { ['Lam \x.b] -> 29 | -- stack is not empty: add an environment entry for x 30 | \x. env |- x -> ['Argument a]. 31 | krivine@q. q!b. q!as. q?res. 32 | case res { {x*}rr -> p!rr. 33 | ; _ -> # "This should not happen! %r should not occur in %i" x res 34 | } 35 | ; _ -> unwind@q. q!['App tm a]. q!as. q?res. p!res. 36 | } 37 | } 38 | 39 | krivine@p = p?tm. p?stk. 40 | case (lookup env tm) 41 | { ['Just ['Argument val]] -> krivine@q. q!val. q!stk. q?res. p!res. -- compute (val stk) 42 | ; ['Just ['Variable var]] -> unwind@q. q!var. q!stk. q?res. p!res. -- return (var $$ stk) 43 | ; 'Nothing -> case tm 44 | { ['App f t] -> 'Term?vt. 45 | ( krivine@q. q!t. q![]. q?res. res ~ vt 46 | | krivine@q. q!f. q![vt|stk]. q?res. p!res. 47 | ) 48 | ; ['Lam \x.body] -> unwind@q. q!tm. q!stk. q?res. p!res. 49 | } 50 | } 51 | 52 | 53 | exec krivine@p. 54 | p!['App ['Lam \f. f] -- id 55 | ['Lam \g. g]]. -- id 56 | p![]. p?v. PRINTF "%i" v. 57 | 58 | exec krivine@p. 59 | p!['App ['Lam \f. ['Lam \x.['App f ['App f x]]]] -- id 60 | ['Lam \g. g]]. -- id 61 | p![]. p?v. PRINTF "%i" v. 62 | 63 | exec krivine@p. 64 | p!['App ['Lam \f. ['Lam \x. ['App f ['App f x]]]] -- 2 65 | ['Lam \g. ['Lam \y. ['App g ['App g y]]]]]. -- 2 66 | p![]. p?v. PRINTF "%i" v . 67 | -------------------------------------------------------------------------------- /examples/mltt.act: -------------------------------------------------------------------------------- 1 | syntax 2 | { 'Check = ['EnumOrTag ['Ty] 3 | [ ['Lam ['Bind 'Synth 'Check]] 4 | ['Pi 'Check ['Bind 'Synth 'Check]] 5 | ['Emb 'Synth] 6 | ] 7 | ] 8 | ; 'Synth = ['Tag [ ['Rad 'Check 'Check] 9 | ['App 'Synth 'Check] 10 | ]] 11 | } 12 | 13 | type : $'Check. !'Check. 14 | 15 | check : ?'Check. {- Type -} $'Check. {- Term -} !'Check. {-Normal form-} 16 | synth : $'Synth. !'Check. {-Type-} !'Check. {-Normal form-} 17 | ctxt |- 'Synth -> 'Check 18 | 19 | ------------------------------------------------------------------------------ 20 | -- Implementation 21 | 22 | type@p = check@q. q!'Ty. q <-> p 23 | 24 | check@p = p?ty. p?tm. case $tm 25 | { 'Ty -> (ty ~ 'Ty | p!'Ty.) 26 | ; ['Pi S \x. T] -> 27 | (ty ~ 'Ty 28 | |type@q. q!S. q?NS. \x. ctxt |- x -> NS. 29 | type@r. r!T. r?NT. p!['Pi NS \x. NT]. 30 | ) 31 | ; ['Emb e] -> synth@q. q!e. q?nty. (nty ~ ty | q <-> p) 32 | ; ['Lam \x. body] -> case ty 33 | { ['Pi S \x. T] -> \x. ctxt |- x -> S. 34 | check@q. q!T. q!body. q?vbody. 35 | p!['Lam \x. vbody]. 36 | ; _ -> #"Expected Pi; got %n" ty 37 | } 38 | } 39 | 40 | synth@p = p?tm . case (lookup ctxt tm) 41 | { ['Just S] -> p!S. p!['Emb tm]. 42 | ; 'Nothing -> case $tm 43 | { ['Rad t ty] -> type@q. q!ty. q?nty. p!nty. 44 | check@r. r!nty. r!t. r <-> p 45 | ; ['App f s] -> synth@q. q!f. q?ty. q?nf. case ty 46 | { ['Pi S \v. T] -> check@r. r!S. r!s. r?ns. 47 | type@u. u!{v=['Rad ns S]}T. u?NT. p!NT. 48 | case nf 49 | { ['Lam \x. body] -> check@w. w!NT. w!{x=['Rad ns S]}body. w <-> p 50 | ; ['Emb e] -> p!['Emb ['App e ns]]. 51 | ; _ -> #"Expected Lam or Emb; got %n" nf 52 | } 53 | ; _ -> #"Expected Pi; got %n" ty 54 | } 55 | } 56 | } 57 | 58 | exec synth@p. p!['Rad 59 | ['Lam \x. ['Emb x]] 60 | ['Emb 61 | ['App ['Rad 62 | ['Lam \x. ['Pi ['Emb x] \a. ['Emb x]]] 63 | ['Pi 'Ty \x. 'Ty]] 64 | ['Pi 'Ty \x. ['Emb x]]]]]. 65 | p?nty. p?ntm. 66 | PRINTF "%n" nty. 67 | PRINTF "%n" ntm. 68 | 69 | {- 70 | exec type@p. p!['Emb 71 | ['App ['Rad 72 | ['Lam \x. ['Pi ['Emb x] \a. ['Emb x]]] 73 | ['Pi 'Ty \x. 'Ty]] 74 | ['Pi 'Ty \x. ['Emb x]]]]. p?ty. 75 | PRINTF "%n" ty. 76 | -} 77 | -------------------------------------------------------------------------------- /examples/stlc.act: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- Datatypes 3 | 4 | syntax 5 | { 'Type = ['EnumOrTag ['Nat] 6 | [['Arr 'Type 'Type]] 7 | ] 8 | } 9 | 10 | syntax 11 | { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] 12 | ['Emb 'Synth] 13 | ]] 14 | ; 'Synth = ['Tag [ ['Ann 'Check 'Type] 15 | ['App 'Synth 'Check] 16 | ]] 17 | } 18 | 19 | ------------------------------------------------------------------------------ 20 | -- Interface 21 | 22 | /type : $'Type. 23 | check : ?'Type. $'Check. 24 | synth : $'Synth. !'Type. 25 | 26 | -- | myCtxt maps synthesisable variables to types 27 | myCtxt |- 'Synth -> 'Type 28 | 29 | ------------------------------------------------------------------------------ 30 | -- Contract 31 | 32 | {type T} check T t {} 33 | {} synth t T {type T} 34 | 35 | {} myCtxt |- x -> T {synth x T} 36 | 37 | ------------------------------------------------------------------------------ 38 | -- Implementation 39 | 40 | type@p = p?ty. case $ty 41 | { 'Nat -> 42 | ; ['Arr S T] -> 43 | ( type@q. q!S. 44 | | type@r. r!T. 45 | ) 46 | } 47 | 48 | check@p = p?ty. p?tm. case $tm 49 | { ['Lam \x. body] -> 50 | 'Type?S T. 51 | ( ty ~ ['Arr S T] 52 | | 'Synth\x. 53 | myCtxt |- x -> S. 54 | check@q. q!T. q!body.) 55 | ; ['Emb e] -> synth@q. q!e. q?S. S ~ ty 56 | } 57 | 58 | synth@p = p?tm . case (lookup myCtxt tm) 59 | { ['Just S] -> p!S. 60 | ; 'Nothing -> case $tm 61 | { ['Ann t ty] -> 62 | ( type@q. q!ty. 63 | | check@r. r!ty. r!t. 64 | | p!ty. 65 | ) 66 | ; ['App f s] -> 'Type?U V. p!V. 67 | ( synth@q. q!f. q?ty. ty ~ ['Arr U V] 68 | | check@r. r!U. r!s. 69 | ) 70 | } 71 | } 72 | 73 | 74 | ------------------------------------------------------------------------------ 75 | -- Examples 76 | {- 77 | exec check@p. p! ['Arr 'Nat ['Arr 'Nat 'Nat]]. 78 | p! ['Lam \z. ['Lam \_. ['Emb z]]]. 79 | -} 80 | {- 81 | exec check@p. p! ['Arr 'Nat 'Nat]. 82 | p! ['Lam \z. ['Emb z]]. 83 | 84 | -} 85 | 86 | exec check@p. 87 | p! ['Arr 'Nat 'Nat]. 88 | p! ['Lam \z. ['Emb 89 | ['App ['Ann ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] 90 | ['Emb z]]]]. 91 | PRINTF "Victory!". 92 | -------------------------------------------------------------------------------- /examples/stlc2.act: -------------------------------------------------------------------------------- 1 | -- trace { exec } 2 | 3 | syntax 4 | { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] 5 | ['Emb 'Synth] 6 | ]] 7 | ; 'Synth = ['Tag [ ['Rad 'Check 'Type] 8 | ['App 'Synth 'Check] 9 | ]] 10 | ; 'Type = ['EnumOrTag [ 'Base 'Nat 'Bool ] 11 | [ ['Arr 'Type 'Type] 12 | ]] 13 | } 14 | 15 | check : ?'Type. $'Check. 16 | synth : $'Synth. !'Type. 17 | ctxt |- 'Synth -> 'Type 18 | 19 | check@p = p?ty. p?tm. case $tm 20 | { ['Lam \x. body] -> 'Type?S. 'Type?T. 21 | (ty ~ ['Arr S T] 22 | | \y. ctxt |- y -> S. check@q. q!T. q!{x=y}body.) 23 | ; ['Emb e] -> synth@q. q!e. q?S. S ~ ty 24 | } 25 | 26 | synth@p = p?tm . case (lookup ctxt tm) 27 | { ['Just S] -> p!S. 28 | ; 'Nothing -> case $tm 29 | { ['Rad t ty] -> (check@q. q!ty. q!t. | p!ty.) 30 | ; ['App f s] -> 'Type?U. 'Type?V. 31 | ( synth@q. q!f. q?ty. ty ~ ['Arr U V] 32 | | check@r. r!U. r!s. 33 | | p!V.) 34 | } 35 | } 36 | 37 | exec check@p. 'Check?t. 38 | (p! ['Arr 'Nat 'Nat]. p! t. | t ~ ['Lam \z. ['Emb z]]) 39 | -------------------------------------------------------------------------------- /examples/stlc3.act: -------------------------------------------------------------------------------- 1 | -- trace { exec } 2 | 3 | syntax 4 | { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] 5 | ['Emb 'Synth] 6 | ]] 7 | ; 'Synth = ['Tag [ ['Rad 'Check 'Type] 8 | ['App 'Synth 'Check] 9 | ]] 10 | ; 'Type = ['EnumOrTag [ 'Base 'Nat 'Bool ] 11 | [['Arr 'Type 'Type]] 12 | ] 13 | } 14 | 15 | type : $'Type. 16 | type@p = p?ty. case $ty 17 | { 'Base -> 18 | ; 'Nat -> 19 | ; 'Bool -> 20 | ; ['Arr s t] -> (type@q. q!s. | type@r. r!t.) 21 | } 22 | 23 | check : ?'Type. $'Check. 24 | synth : $'Synth. !'Type. 25 | ctxt |- 'Synth -> 'Type 26 | 27 | check@p = p?ty. p?tm. case $tm 28 | { ['Lam \x. body] -> 'Type?S. 'Type?T. 29 | (ty ~ ['Arr S T] 30 | | \y. ctxt |- y -> S. check@q. q!T. q!{x=y}body.) 31 | ; ['Emb e] -> synth@q. q!e. q?S. S ~ ty 32 | } 33 | 34 | synth@p = p?tm . case (lookup ctxt tm) 35 | { ['Just S] -> p!S. 36 | ; 'Nothing -> case $tm 37 | { ['Rad t ty] -> (check@q. q!ty. q!t. | p!ty. | type@r. r!ty.) 38 | ; ['App f s] -> 'Type?U. 'Type?V. 39 | ( synth@q. q!f. q?ty. ty ~ ['Arr U V] 40 | | check@r. r!U. r!s. 41 | | p!V.) 42 | } 43 | } 44 | 45 | exec check@p. 46 | 'Type?X. 'Check?t. 47 | ((p! X. p! t. 48 | | X ~ ['Arr 'Nat 'Nat]) 49 | | t ~ ['Lam \z. ['Emb z]]) 50 | -------------------------------------------------------------------------------- /examples/stlc4.act: -------------------------------------------------------------------------------- 1 | -- trace { exec } 2 | 3 | syntax 4 | { 'Type = ['EnumOrTag [ 'Base 'Nat 'Bool] 5 | [['Arr 'Type 'Type] 6 | ]] 7 | } 8 | 9 | ^type : $'Type. 10 | type@p = p?ty. case $ty 11 | { 'Base -> 12 | ; 'Nat -> 13 | ; 'Bool -> 14 | ; ['Arr S T] -> (type@q.q!S. | type@q.q!T.) 15 | } 16 | 17 | syntax 18 | { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] 19 | ['Emb 'Synth] 20 | ]] 21 | ; 'Synth = ['Tag [ ['Rad 'Check 'Type] 22 | ['App 'Synth 'Check] 23 | ]] 24 | } 25 | check : ?'Type. $'Check. 26 | synth : $'Synth. !'Type. 27 | ctxt |- 'Synth -> 'Type 28 | 29 | check@p = p?ty. p?tm. case $tm 30 | { ['Lam \x. body] -> 'Type?S. 'Type?T. 31 | (ty ~ ['Arr S T] 32 | | \x. ctxt |- x -> S. check@q. q!T. q!body.) 33 | ; ['Emb e] -> synth@q. q!e. q?S. S ~ ty 34 | } 35 | synth@p = p?tm . case (lookup ctxt tm) 36 | { ['Just S] -> p!S. 37 | ; 'Nothing -> case $tm 38 | { ['Rad t ty] -> (check@q. q!ty. q!t. | p!ty. | type@q.q!ty.) 39 | ; ['App f s] -> 'Type?U. 'Type?V. 40 | ( synth@q. q!f. q?ty. ty ~ ['Arr U V] 41 | | check@r. r!U. r!s. 42 | | p!V.) 43 | } 44 | } 45 | 46 | exec check@p. p! ['Arr 'Nat 'Nat]. 47 | p! ['Lam \z. ['Emb ['App ['Rad ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] ['Emb z]]]]. 48 | PRINTF "Store:\n %M\nEnv: %E\nStack:\n %S". 49 | -------------------------------------------------------------------------------- /examples/stlctpp.act: -------------------------------------------------------------------------------- 1 | -- trace { exec } 2 | 3 | syntax 4 | { 'Check = ['EnumOrTag ['Nil] 5 | [ ['Lam ['Bind 'Synth 'Check]] 6 | ['Cons 'Check 'Check] 7 | ['Emb 'Synth] 8 | ]] 9 | ; 'Synth = ['Tag [ ['Rad 'Check 'Type] 10 | ['Fst 'Synth] 11 | ['Snd 'Synth] 12 | ['ListElim 'Type 'Synth 'Check 13 | ['Bind 'Synth ['Bind 'Synth ['Bind 'Synth 'Check]]]] 14 | ['App 'Synth 'Check] 15 | ]] 16 | ; 'Type = ['EnumOrTag ['One] 17 | [['Pair 'Type 'Type] 18 | ['List 'Type] 19 | ['Arr 'Type 'Type] 20 | ]] 21 | } 22 | 23 | isType |- 'Type -> 'Nil 24 | type : $'Type. 25 | check : ?'Type. $'Check. 26 | 27 | ctxt |- 'Synth -> 'Type 28 | synth : $'Synth. !'Type. 29 | 30 | type@p = p?ty. case (lookup isType ty) 31 | { ['Just S] -> 32 | ; 'Nothing -> case $ty 33 | { 'One -> -- winning is silent 34 | ; ['Pair S T] -> type@q. q!S. | type@r. r!T. 35 | ; ['List S] -> type@q. q!S. 36 | ; ['Arr S T] -> type@q. q!S. | type@r. r!T. 37 | -- ; otherwise -> #"not a valid type" 38 | } 39 | } 40 | 41 | check@p = p?ty. p?tm. case $tm 42 | { ['Lam \x. body] -> 43 | 'Type?S. 'Type?T. -- fresh metas for S(ource) and T(arget) of function type 44 | (ty ~ ['Arr S T] -- ensure ty is (S -> T) 45 | | \y. -- bind the fresh variable y 46 | ctxt |- y -> S. -- extend the context with fresh variable y : S 47 | check@q. q!T. q!{x=y}body.) -- check the body with x=y 48 | ; 'Nil -> case ty -- Nil is overloaded, type-directed disambiguation now 49 | { 'One -> 50 | ; ['List S] -> 51 | ; otherwise -> #"wrong type for Nil" 52 | } 53 | ; ['Cons s t] -> case ty -- Cons is also overloaded 54 | { ['Pair S T] -> check@q. q!S. q!s. | check@r. r!T. r!t. 55 | ; ['List S] -> check@q. q!S. q!s. | check@r. r!['List S]. r!t. 56 | ; otherwise -> #"wrong type for Cons" 57 | } 58 | ; ['Emb e] -> -- change of direction 59 | synth@q. q!e. -- infer the type 60 | q?S. S ~ ty -- receive the answer and check we agree 61 | } 62 | 63 | synth@p = p?tm . 64 | -- lookup: in case tm is a free variable and a type has been pushed for it 65 | case (lookup ctxt tm) 66 | { ['Just S] -> p!S. 67 | ; 'Nothing -> case $tm 68 | { ['Rad t ty] -> (type@r. r!ty. | check@q. q!ty. q!t. | p!ty.) 69 | ; ['Fst e] -> 'Type?S. 'Type?T. (synth@q. q!e. q?ty. ty ~ ['Pair S T] | p!S.) 70 | ; ['Snd e] -> 'Type?S. 'Type?T. (synth@q. q!e. q?ty. ty ~ ['Pair S T] | p!T.) 71 | ; ['ListElim ty e n (\x. \xs. \ih. c)] -> 72 | p!ty. | type@r. r!ty. | check@q. q!ty. q!n. | 73 | 'Type?X. (synth@u. u!e. u?V. V ~ ['List X] | 74 | \y. ctxt |- y -> X. 75 | \ys. ctxt |- ys -> ['List X]. 76 | \jh. ctxt |- jh -> ty. 77 | check@v. v!ty. v!{x=y,xs=ys,ih=jh}c. 78 | ) 79 | ; ['App f s] -> 'Type?U. 'Type?V. 80 | ( synth@q. q!f. q?ty. ty ~ ['Arr U V] 81 | | check@r. r!U. r!s. 82 | | p!V.) 83 | } 84 | } 85 | 86 | exec \A. isType |- A -> []. check@p. 87 | p!['Arr ['List A] ['Arr ['List A] ['List A]]]. 88 | p!['Lam \as. ['Lam \bs. 89 | ['Emb ['ListElim ['List A] as 90 | ['Emb bs] -- [] ++ ys = ys 91 | (\x. \xs. \ih. ['Cons ['Emb x] ['Emb ih]])]]]]. -- (x :: xs) ++ ys = x :: (xs ++ ys) 92 | -------------------------------------------------------------------------------- /examples/stlctpp2.flags: -------------------------------------------------------------------------------- 1 | --no-colour --quiet --wAll 2 | -------------------------------------------------------------------------------- /examples/untyped.act: -------------------------------------------------------------------------------- 1 | syntax 2 | { 'Term = ['Tag [ 3 | ['Lam ['Bind 'Term 'Term]] 4 | ['App 'Term 'Term] 5 | ]] 6 | } 7 | 8 | env |- 'Term -> 'Term 9 | eval : ?'Term. !'Term. 10 | 11 | eval@p = p?tm. case (lookup env tm) 12 | { ['Just v] -> p!v. 13 | ; 'Nothing -> case tm 14 | { ['Lam \x. t] -> \x. env |- x -> x. 15 | eval@q. q!t. q?v. p!['Lam \x. v]. 16 | ; ['App f s] -> 'Term?u. 17 | ( eval@q. q!s. q?v. u ~ v 18 | | eval@r. r!f. r?g. case g 19 | { ['Lam \y. t] -> eval@z. z!{y=u}t. z?w. p!w. 20 | ; _ -> p!['App g u]. 21 | } 22 | ) 23 | } 24 | } 25 | 26 | exec eval@p. p!['App ['Lam \f. ['Lam \x. ['App f ['App f x]]]] 27 | ['Lam \g. ['Lam \y. ['App g ['App g y]]]]]. 28 | p?v. PRINTF "%i" v . 29 | 30 | -- expected: \ x . (\ y . x (x (x (x y)))) 31 | -------------------------------------------------------------------------------- /failing/mltt_krivine.act: -------------------------------------------------------------------------------- 1 | trace { break } 2 | 3 | syntax 4 | { 'Check = ['EnumOrTag ['Ty] 5 | [ ['Lam ['Bind 'Synth 'Check]] 6 | ['Pi 'Check ['Bind 'Synth 'Check]] 7 | ['Emb 'Synth] 8 | ] 9 | ] 10 | ; 'Synth = ['Tag [ ['Rad 'Check 'Check] 11 | ['App 'Synth 'Check] 12 | ]] 13 | 14 | ; 'Stack = ['NilOrCons 'Check 'Stack] 15 | ; 'Entry = ['Tag [ ['Arg 'Synth] 16 | ['Var 'Check 'Synth] 17 | ]] 18 | } 19 | 20 | type : ?'Check. !'Check. 21 | 22 | check : ?'Check. ?'Check. ?'Stack. !'Check. 23 | synth : 'Synth -> 'Entry 24 | |- ?'Synth. ?'Stack. !'Check. !'Check. 25 | 26 | unwind : ?'Check. ?'Synth. ?'Stack. !'Check. !'Check. 27 | 28 | ------------------------------------------------------------------------------ 29 | -- Implementation 30 | 31 | type@p = p?ty. check@q. q!'Ty. q!ty. q![]. q?nf. p!nf. 32 | 33 | check@p = p?ty. p?tm. p?stk. case tm 34 | { 'Ty -> (ty ~ 'Ty | stk ~ [] | p!'Ty.) 35 | ; ['Pi S \x. T] -> 36 | (ty ~ 'Ty 37 | |type@q. q!S. q?NS. 38 | \x. synth{x -> ['Var NS x]}. 39 | type@r. r!T. r?NT. p!['Pi NS \x. NT]. 40 | ) 41 | ; ['Emb e] -> synth@q. q!e. q![]. q?nty. q?ne. 42 | (ty ~ nty 43 | |unwind@r. r!nty. r!['Rad ne nty]. r!stk. r?newTy. r?newTm. p!newTm.) 44 | 45 | ; ['Lam \x. body] -> case ty 46 | { ['Pi S \x. T] -> case stk 47 | { [] -> \x. synth{x -> ['Var S x]}. 48 | check@q. q!T. q!body. q!stk. q?vbody. 49 | p!['Lam \x. vbody]. 50 | ; [a|as] -> \x. synth{ x -> ['Arg ['Rad a S]]}. 51 | type@r. r!T. r?NT. 52 | check@q. q!NT. q!body. q!as. q?nbody. 53 | case nbody 54 | { {x*}nbody2 -> p!nbody2. 55 | ; _ -> #"%i should not occur in %s" x nbody 56 | } 57 | } 58 | ; _ -> #"Expected Pi; got %i" ty 59 | } 60 | } 61 | 62 | synth@p = p?tm. p?stk. lookup tm { rec -> case rec 63 | { ['Arg x] -> synth@q. q!x. q!stk. q?nty. q?nx. p!nty. p!nx. 64 | ; ['Var S v] -> unwind@q. q!S. q!v. q!stk. q?nty. q?nv. p!nty. p!nv. 65 | }} else case tm 66 | { ['Rad t ty] -> type@q. q!ty. q?nty. 67 | check@r. r!nty. r!t. r![]. r?nt. 68 | unwind@u. u!nty. u!['Rad nt nty]. u!stk. u?newTy. u?newTm. 69 | p!newTy. p!newTm. 70 | ; ['App f s] -> synth@q. q!f. q![s|stk]. q?nty. q?nf. 71 | p!nty. p!nf. 72 | } 73 | 74 | unwind@p = p?ty. p?tm. p?stk. case stk 75 | { [] -> case tm 76 | { ['Rad rtm rty] -> p!rty. p!rtm. 77 | ; _ -> p!ty. p!['Emb tm]. 78 | } 79 | ; [a | as] -> case ty 80 | { ['Pi S \x. T] -> \x. synth{x -> ['Arg ['Rad a S]]}. 81 | type@q. q!T. q?NT. 82 | unwind@r. r!NT. r!['App tm a]. r!as. 83 | r?nty. r?ntm. 84 | case [nty|ntm] 85 | { {x*}[nty2|ntm2] -> p!nty2. p!['Emb ntm2]. 86 | ; _ -> #"%i should not occur in %s or %s" x nty ntm 87 | } 88 | } 89 | } 90 | 91 | exec synth@p. p!['Rad 92 | ['Lam \x. ['Emb x]] 93 | ['Emb 94 | ['App ['Rad 95 | ['Lam \x. ['Pi ['Emb x] \a. ['Emb x]]] 96 | ['Pi 'Ty \x. 'Ty]] 97 | ['Pi 'Ty \x. ['Emb x]]]]]. p![]. 98 | p?nty. p?ntm. 99 | PRINTF "%S". 100 | PRINTF "%i" nty. 101 | PRINTF "%i" ntm. 102 | -------------------------------------------------------------------------------- /papers/2022-SPLS/Roadmap.md: -------------------------------------------------------------------------------- 1 | # Presentation Roadmap 2 | 3 | ## Big talking points 4 | 5 | 1. Judgements with modes (bidi stlc) 6 | 2. Rule systems as actors 7 | + Pattern/expression distinction 8 | + Schematic variables have 1 binding site with a clear scope 9 | 3. Why are we doing this? 10 | + LF-ness (syntax with binding, just works) 11 | + Resumptions are updated 12 | + Rule out design errors by construction 13 | 4. What are the prospects for verifying TypOS actors? 14 | + Modes ---> requirements vs. guarantees 15 | 16 | ### Rule systems as actors 17 | 18 | TypOS reifies the metaphor: 19 | 20 | > A rule is a server for its conclusion, 21 | > and a client for its premises 22 | 23 | ### Pat vs. exp examples 24 | 25 | f ∈ Πx:S.T S ∋ s ) Ok, T[s/x] is in exp position: 26 | ---------------------- } demand to compute T[s/x] is easily satisfied 27 | f s ∈ T[s/x] ) 28 | 29 | s ∈ S t ∈ T[s/x] ) Not ok, T[s/x] is in pattern position: 30 | ---------------------- } demand to invert substitution T[s/x] to recover T 31 | (s, t) ∈ Σx:S.T ) is magical thinking 32 | 33 | ### Example: Holey program 34 | 35 | Example with hole in program, extend to fill hole. 36 | Bonus marks if later parts of the program constrain type of the hole 37 | Good propaganda case for updatable resumptions 38 | -------------------------------------------------------------------------------- /papers/2022-SPLS/stuck.act: -------------------------------------------------------------------------------- 1 | trace { unify } -- exec, send, recv, move, unify } 2 | 3 | ------------------------------------------------------------------------------ 4 | -- Interface 5 | 6 | syntax 7 | { 'Type = ['EnumOrTag ['Nat] 8 | [['Arr 'Type 'Type]] 9 | ] 10 | } 11 | 12 | /type : ?'Type. 13 | 14 | syntax 15 | { 'Check = ['EnumOrTag [] [ ['Lam ['Bind 'Synth 'Check]] 16 | ['Emb 'Synth] 17 | ]] 18 | ; 'Synth = ['EnumOrTag [] [ ['Ann 'Check 'Type] 19 | ['App 'Synth 'Check] 20 | ]] 21 | } 22 | 23 | check : ?'Type. ?'Check. 24 | synth : ?'Synth. !'Type. 25 | ctxt |- 'Synth -> 'Type -- ctxt maps synthesisable variables to types 26 | 27 | ------------------------------------------------------------------------------ 28 | -- Implementation 29 | 30 | type@p = p?ty. case ty 31 | { 'Nat -> 32 | ; ['Arr S T] -> 33 | ( type@q. q!S. 34 | | type@r. r!T. 35 | ) 36 | } 37 | 38 | check@p = p?ty. p?tm. case tm 39 | { ['Lam \x. body] -> 40 | 'Type?S. 'Type?T. 41 | ( ty ~ ['Arr S T] 42 | | \x. 43 | ctxt |- x -> S . 44 | check@q. q!T. q!body.) 45 | ; ['Emb e] -> synth@q. q!e. q?S. S ~ ty 46 | } 47 | 48 | synth@p = p?tm . if tm in ctxt { S -> p!S. } else case tm 49 | { ['Ann t ty] -> 50 | ( type@q. q!ty. 51 | | check@r. r!ty. r!t. 52 | | p!ty. 53 | ) 54 | ; ['App f s] -> 'Type?U. 'Type?V. p!V. 55 | ( synth@q. q!f. q?ty. ty ~ ['Arr U V] 56 | | check@r. r!U. r!s. 57 | ) 58 | } 59 | 60 | ------------------------------------------------------------------------------ 61 | -- Examples 62 | 63 | exec 'Type?FRESH. 'Check?t. 64 | check@p. 65 | p! ['Arr 'Nat 'Nat]. 66 | p! ['Lam \z. ['Emb 67 | ['App ['Ann ['Lam \w. t] FRESH] 68 | ['Emb z]]]]. -------------------------------------------------------------------------------- /papers/2022-TYPES/Makefile: -------------------------------------------------------------------------------- 1 | TARGET:=types 2 | BIB:=typos.bib 3 | TEX:=$(TARGET).tex 4 | PDF:=$(TARGET).pdf 5 | DEPS:=easychair.cls 6 | 7 | all: $(TEX) $(DEPS) 8 | mkdir -p _build 9 | cp $(BIB) $(DEPS) $(TEX) _build 10 | cd _build && latexmk -bibtex -pdf $(TEX) 11 | ln -sf _build/$(PDF) $(PDF) 12 | 13 | clean: 14 | rm -rf _build $(PDF) 15 | -------------------------------------------------------------------------------- /papers/2022-TYPES/golden/krivine2.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > ['Lam \x. ['Lam \y. ['App x ['App x ['App x ['App x y]]]]]] 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /papers/2022-TYPES/golden/mlttList.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > two plus two is ['Plus ['Sing 'Tt] ['Plus ['Sing 'Tt] ['Plus ['Sing 'Tt] 3 | out > ['Sing 'Tt]]]]. 4 | out > 5 | err > 6 | err > 7 | -------------------------------------------------------------------------------- /papers/2022-TYPES/golden/stlc-in-abstract.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Victory! 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /papers/2022-TYPES/golden/stlc.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > U = ['Arr 'Nat 'Nat] 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /papers/2022-TYPES/golden/untyped.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > ['Lam \x. ['Lam \y. ['App x ['App x ['App x ['App x y]]]]]] 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /papers/2022-TYPES/stlc-in-abstract.act: -------------------------------------------------------------------------------- 1 | -- trace { exec, send, recv, move, unify } 2 | 3 | ------------------------------------------------------------------------------ 4 | -- Interface 5 | 6 | syntax 7 | { 'Type = ['EnumOrTag ['Nat] 8 | [['Arr 'Type 'Type]] 9 | ] 10 | } 11 | 12 | /type : ?'Type. 13 | 14 | syntax 15 | { 'Check = ['EnumOrTag [] [ ['Lam ['Bind 'Synth 'Check]] 16 | ['Emb 'Synth] 17 | ]] 18 | ; 'Synth = ['EnumOrTag [] [ ['Ann 'Check 'Type] 19 | ['App 'Synth 'Check] 20 | ]] 21 | } 22 | 23 | check : ?'Type. ?'Check. 24 | synth : ?'Synth. !'Type. 25 | 26 | ctxt |- 'Synth -> 'Type -- ctxt maps Synth variables to Types 27 | 28 | ------------------------------------------------------------------------------ 29 | -- Implementation 30 | 31 | type@p = p?ty. case ty 32 | { 'Nat -> 33 | ; ['Arr S T] -> 34 | ( type@q. q!S. 35 | | type@r. r!T. 36 | ) 37 | } 38 | 39 | 40 | check@p = p?ty. p?tm. case tm 41 | { ['Lam \x. body] -> 42 | 'Type?S. 'Type?T. 43 | ( ty ~ ['Arr S T] 44 | | \x. 45 | ctxt |- x -> S . 46 | check@q. q!T. q!body.) 47 | ; ['Emb e] -> synth@q. q!e. q?S. S ~ ty 48 | } 49 | 50 | synth@p = p?tm . case (lookup ctxt tm) 51 | { ['Just S] -> p!S. 52 | ; 'Nothing -> case tm 53 | { ['Ann t ty] -> 54 | ( type@q. q!ty. 55 | | check@r. r!ty. r!t. 56 | | p!ty. 57 | ) 58 | ; ['App f s] -> 'Type?S. 'Type?T. 59 | ( synth@q. q!f. q?ty. ty ~ ['Arr S T] 60 | | check@r. r!S. r!s. 61 | | p!T. 62 | ) 63 | } 64 | } 65 | 66 | ------------------------------------------------------------------------------ 67 | -- Examples 68 | exec check@p. p! ['Arr 'Nat ['Arr 'Nat 'Nat]]. 69 | p! ['Lam \z. ['Lam \_. ['Emb z]]]. 70 | 71 | {- 72 | exec check@p. p! ['Arr 'Nat 'Nat]. 73 | p! ['Lam \z. ['Emb z]]. 74 | 75 | -} 76 | 77 | exec check@p. 78 | p! ['Arr 'Nat 'Nat]. 79 | p! ['Lam \z. ['Emb 80 | ['App ['Ann ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] 81 | ['Emb z]]]]. 82 | PRINTF "Victory!". 83 | -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/examples/build/notations.tex: -------------------------------------------------------------------------------- 1 | \usepackage{amssymb} 2 | \usepackage{proof} 3 | 4 | \renewcommand{\typosBinding}[1]{} 5 | \renewcommand{\typosPushing}[3]{#2 : #3 \vdash} 6 | 7 | \renewcommand{\typosAxiom}[1]{\infer{#1}{}} 8 | \renewcommand{\typosDerivation}[2]{\infer{#1}{#2}} 9 | \renewcommand{\typosBeginPrems}{} 10 | \renewcommand{\typosBetweenPrems}{&} 11 | \renewcommand{\typosEndPrems}{} 12 | 13 | \renewcommand{\typosScope}[2]{\lambda #1. #2} 14 | 15 | \renewcommand{\tagLamForOne}[1]{#1} 16 | \renewcommand{\tagEmbForOne}[1]{\underline{#1}} 17 | \renewcommand{\tagAnnForTwo}[2]{(#1 : #2)} 18 | \renewcommand{\tagAppForTwo}[2]{#1 #2} 19 | \renewcommand{\enumNat}[0]{\mathbb{N}} 20 | \renewcommand{\tagArrForTwo}[2]{#1 \to #2} 21 | \renewcommand{\callingtype}[1]{\textsc{type}~ #1} 22 | \renewcommand{\callingcheck}[2]{#1 \ni #2} 23 | \renewcommand{\callingsynth}[2]{#1 \in #2} 24 | -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/examples/build/notations2.tex: -------------------------------------------------------------------------------- 1 | \usepackage{amssymb} 2 | \usepackage{proof} 3 | 4 | \renewcommand{\typosBinding}[1]{} 5 | \renewcommand{\typosPushing}[3]{#2 \mapsto #3 \vdash} 6 | 7 | \renewcommand{\typosAxiom}[1]{\infer{#1}{}} 8 | \renewcommand{\typosDerivation}[2]{\infer{#1}{#2}} 9 | \renewcommand{\typosBeginPrems}{} 10 | \renewcommand{\typosBetweenPrems}{&} 11 | \renewcommand{\typosEndPrems}{} 12 | 13 | \renewcommand{\typosScope}[2]{(\lambda #1. #2)} 14 | \renewcommand{\tagLamForOne}[1]{#1} 15 | \renewcommand{\tagAppForTwo}[2]{#1\,#2} 16 | 17 | \providecommand\callingeval{} 18 | \renewcommand{\callingeval}[2]{#1 \leadsto #2} 19 | -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/examples/krivine2.act: -------------------------------------------------------------------------------- 1 | syntax 2 | { -- untyped lambda terms 3 | 'Term = ['Tag [ ['Lam ['Bind 'Term 'Term]] 4 | ['App 'Term 'Term] ]] 5 | ; 'Stack = ['NilOrCons 'Term 'Stack] 6 | ; 'Entry = ['Tag [ 7 | ['Argument 'Term] 8 | ['Variable 'Term] 9 | ]] 10 | } 11 | 12 | env |- 'Term -> 'Entry 13 | 14 | krivine : ?'Term. ?'Stack. !'Term. 15 | unwind : ?'Term. ?'Stack. !'Term. 16 | 17 | unwind@p = p?tm. p?stk. case stk 18 | { [] -> case tm 19 | { ['Lam \x.b] -> 20 | -- stack is empty: evaluate under a binder with a placeholder variable 21 | \x. env |- x -> ['Variable x]. 22 | krivine@q. q!b. q![]. q?res. p!['Lam \x.res]. 23 | ; _ -> p!tm. 24 | } 25 | ; [a | as] -> case tm 26 | { ['Lam \x.b] -> 27 | -- stack is not empty: add an environment entry for x 28 | \x. env |- x -> ['Argument a]. 29 | krivine@q. q!b. q!as. q?res. 30 | case res { {x*}rr -> p!rr. 31 | ; _ -> # "This should not happen! %r should not occur in %i" x res 32 | } 33 | ; _ -> unwind@q. q!['App tm a]. q!as. q?res. p!res. 34 | } 35 | } 36 | 37 | krivine@p = p?tm. p?stk. 38 | if tm in env { rec -> case rec 39 | -- if the variable maps to an argument, we have some more 40 | -- evaluating to do. Otherwise we can just unwind the stack 41 | -- on top of the placeholder variable. 42 | { ['Argument val] -> krivine@q. q!val. q!stk. q?res. p!res. 43 | ; ['Variable var] -> unwind@q. q!var. q!stk. q?res. p!res. 44 | }} 45 | else case tm 46 | { ['App f t] -> 'Term?vt. 47 | ( krivine@q. q!t. q![]. q?res. res ~ vt 48 | | krivine@q. q!f. q![vt|stk]. q?res. p!res. 49 | ) 50 | ; _ -> unwind@q. q!tm. q!stk. q?res. p!res. 51 | } 52 | 53 | exec krivine@p. 54 | p!['App ['Lam \f. ['Lam \x. ['App f ['App f x]]]] 55 | ['Lam \g. ['Lam \y. ['App g ['App g y]]]]]. 56 | p![]. p?v. PRINTF "%i" v . 57 | -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/examples/stlc.act: -------------------------------------------------------------------------------- 1 | 2 | ------------------------------------------------------------------------------ 3 | -- Interface 4 | 5 | syntax 6 | { 'Type = ['EnumOrTag ['Nat] 7 | [['Arr 'Type 'Type]] 8 | ] 9 | ; 'Check = ['EnumOrTag ['Zero] [ ['Lam ['Bind 'Synth 'Check]] 10 | ['Emb 'Synth] 11 | ['Succ 'Check] 12 | ]] 13 | ; 'Synth = ['EnumOrTag [] [ ['Ann 'Check 'Type] 14 | ['App 'Synth 'Check] 15 | ]] 16 | } 17 | 18 | /type : ?'Type. 19 | check : ?'Type. ?'Check. 20 | synth : ?'Synth. !'Type. 21 | 22 | ctxt |- 'Synth -> 'Type -- ctxt maps synthesisable variables to types 23 | 24 | ------------------------------------------------------------------------------ 25 | -- Implementation 26 | 27 | type@p = p?ty. case ty 28 | { 'Nat -> 29 | ; ['Arr S T] -> 30 | ( type@q. q!S. 31 | | type@r. r!T. 32 | ) 33 | } 34 | 35 | 36 | check@p = p?ty. p?tm. case tm 37 | { ['Lam \x. body] -> 'Type?S. 'Type?T. 38 | ( ty ~ ['Arr S T] 39 | | \x. ctxt |- x -> S. check@q. q!T. q!body.) 40 | ; ['Emb e] -> synth@q. q!e. q?S. S ~ ty 41 | ; 'Zero -> ty ~ 'Nat 42 | ; ['Succ n] -> check@q. q!'Nat. q!n. | ty ~ 'Nat } 43 | 44 | synth@p = p?tm. if tm in ctxt 45 | { S -> p!S. } 46 | else case tm 47 | { ['Ann t T] -> ( type@q. q!T. 48 | | check@r. r!T. r!t. 49 | | p!T. ) 50 | ; ['App f s] -> 'Type?S. 'Type?T. p!T. 51 | ( synth@q. q!f. q?F. F ~ ['Arr S T] 52 | | check@r. r!S. r!s.) } 53 | 54 | ------------------------------------------------------------------------------ 55 | -- Typechecking an incomplete program 56 | 57 | exec 'Type?U. 'Check?u. 58 | (check@p. 59 | p! ['Arr 'Nat 'Nat]. 60 | p! ['Lam \z. ['Emb 61 | ['App ['Ann ['Lam \w. u] U] 62 | ['Emb z]]]]. 63 | | u ~ ['Succ 'Zero] 64 | | PRINTF "U = %i" U.) 65 | 66 | -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/examples/untyped.act: -------------------------------------------------------------------------------- 1 | syntax 2 | { -- untyped lambda terms 3 | 'Term = ['Tag [ ['Lam ['Bind 'Term 'Term]] 4 | ['App 'Term 'Term] ]] 5 | } 6 | 7 | eval : ?'Term. !'Term. 8 | 9 | env |- 'Term -> 'Term 10 | 11 | eval@p = p?tm. if tm in env { v -> p!v. } else case tm 12 | { ['Lam \x. t] -> \x. env |- x -> x. 13 | eval@q. q!t. q?v. p!['Lam \x. v]. 14 | ; ['App f s] -> 'Term?u. 15 | ( eval@q. q!s. q?v. u ~ v 16 | | eval@r. r!f. r?g. case g 17 | { ['Lam \y. t] -> eval@z. z!{y=u}t. z <-> p 18 | ; _ -> p!['App g u]. 19 | } 20 | ) 21 | } 22 | 23 | exec eval@p. p!['App ['Lam \f. ['Lam \x. ['App f ['App f x]]]] 24 | ['Lam \g. ['Lam \y. ['App g ['App g y]]]]]. 25 | p?v. PRINTF "%i" v . 26 | 27 | -- expected: \ x . (\ y . x (x (x (x y)))) 28 | -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/pictures/actors/conor.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msp-strath/TypOS/34acf92b034c540e624413119ead88b326ea33d0/papers/2022-TYPES/talk/pictures/actors/conor.jpg -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/pictures/actors/craig-cropped.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msp-strath/TypOS/34acf92b034c540e624413119ead88b326ea33d0/papers/2022-TYPES/talk/pictures/actors/craig-cropped.jpg -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/pictures/actors/craig.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msp-strath/TypOS/34acf92b034c540e624413119ead88b326ea33d0/papers/2022-TYPES/talk/pictures/actors/craig.jpg -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/pictures/actors/gallais.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msp-strath/TypOS/34acf92b034c540e624413119ead88b326ea33d0/papers/2022-TYPES/talk/pictures/actors/gallais.jpg -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/pictures/actors/georgi.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msp-strath/TypOS/34acf92b034c540e624413119ead88b326ea33d0/papers/2022-TYPES/talk/pictures/actors/georgi.jpg -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/pictures/globe.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msp-strath/TypOS/34acf92b034c540e624413119ead88b326ea33d0/papers/2022-TYPES/talk/pictures/globe.jpg -------------------------------------------------------------------------------- /papers/2022-TYPES/talk/pictures/graslin.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msp-strath/TypOS/34acf92b034c540e624413119ead88b326ea33d0/papers/2022-TYPES/talk/pictures/graslin.jpg -------------------------------------------------------------------------------- /papers/2022-TYPES/typos.bib: -------------------------------------------------------------------------------- 1 | 2 | 3 | @PhdThesis{kuper2015theses, 4 | author = {Kuper, Lindsey}, 5 | title = {Lattice-Based Data Structures For Deterministic Parallel And Distributed Programming}, 6 | school = {Indiana University}, 7 | year = {2015}, 8 | } 9 | 10 | @inproceedings{hewitt1973actors, 11 | author = {Hewitt, Carl and Bishop, Peter and Steiger, Richard}, 12 | title = {A Universal Modular ACTOR Formalism for Artificial Intelligence}, 13 | year = {1973}, 14 | publisher = {Morgan Kaufmann Publishers Inc.}, 15 | booktitle = {{IJCAI} '73}, 16 | pages = {235--245}, 17 | } 18 | 19 | @PhdThesis{fowler2019thesis, 20 | author = {Fowler, Simon}, 21 | title = {Typed Concurrent Functional Programming with Channels, Actors, and Sessions}, 22 | school = {University of Edinburgh}, 23 | year = {2019}, 24 | } 25 | 26 | @InProceedings{honda1993session, 27 | author = {Honda, Kohei}, 28 | editor = {Best, Eike}, 29 | title = {Types for dyadic interaction}, 30 | booktitle = {{CONCUR} '93}, 31 | year = {1993}, 32 | publisher = {Springer}, 33 | pages = {509--523}, 34 | } 35 | 36 | @inproceedings{codebruijn, 37 | author = {McBride, Conor}, 38 | editor = {Robert Atkey and Sam Lindley}, 39 | title = {Everybody's Got To Be Somewhere}, 40 | booktitle = {MSFP '18}, 41 | volume = {275}, 42 | pages = {53--69}, 43 | year = {2018}, 44 | } 45 | 46 | @article{turnstyleplus, 47 | author = {Stephen Chang and Michael Ballantyne and Milo Turner and William J. Bowman}, 48 | title = {Dependent type systems as macros}, 49 | journal = {Proc. {ACM} Program. Lang.}, 50 | volume = {4}, 51 | number = {{POPL}}, 52 | pages = {3:1--3:29}, 53 | year = {2020}, 54 | } 55 | 56 | @inproceedings{andromeda, 57 | author = {Andrej Bauer and Philipp G. Haselwarter and Anja Petkovic}, 58 | editor = {Anna Maria Bigatti and Jacques Carette and James H. Davenport and Michael Joswig and Timo de Wolff}, 59 | title = {Equality Checking for General Type Theories in Andromeda 2}, 60 | booktitle = {ICMS '20}, 61 | series = {Lecture Notes in Computer Science}, 62 | volume = {12097}, 63 | pages = {253--259}, 64 | publisher = {Springer}, 65 | year = {2020}, 66 | } 67 | 68 | @book{redex, 69 | author = {Felleisen, Matthias and Findler, Robert Bruce and Flatt, Matthew}, 70 | title = {Semantics Engineering with PLT Redex.}, 71 | publisher = {MIT Press}, 72 | year = {2009} 73 | } 74 | 75 | @article{delphin, 76 | author = {Adam Poswolsky and Carsten Sch{\"{u}}rmann}, 77 | title = {System Description: Delphin -- {A} Functional Programming Language for Deductive Systems}, 78 | journal = {Electron. Notes Theor. Comput. Sci.}, 79 | volume = {228}, 80 | pages = {113--120}, 81 | year = {2009}, 82 | doi = {10.1016/j.entcs.2008.12.120}, 83 | } 84 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.0 2 | packages: 3 | - . 4 | extra-deps: 5 | - pretty-compact-3.0 6 | - base-compat-0.10.5 7 | -------------------------------------------------------------------------------- /test/Test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | 5 | import Data.List ((\\), isPrefixOf) 6 | 7 | import System.Directory 8 | import System.FilePath 9 | 10 | import Test.Tasty (TestTree,testGroup) 11 | import Test.Tasty.Silver 12 | import Test.Tasty.Silver.Interactive 13 | 14 | data TestConfig = TestConfig 15 | { name :: String 16 | , extension :: String 17 | , goldenExt :: String 18 | , goldenDir :: String 19 | , folder :: FilePath 20 | , excluded :: [FilePath] 21 | , excludedDirs :: [FilePath] 22 | } 23 | 24 | main :: IO () 25 | main = defaultMain . testGroup "TypOS" =<< sequence 26 | [ typosExamples 27 | , typosTests 28 | , markdown 29 | -- , paperTYPES -- using an old version of the language 30 | ] 31 | 32 | paperTYPES :: IO TestTree 33 | paperTYPES = do 34 | let name = "TYPES paper" 35 | let extension = ".act" 36 | let goldenExt = ".gold" 37 | let folder = "papers/2022-TYPES" 38 | let goldenDir = folder "golden" 39 | let excluded = [] 40 | let excludedDirs = [] 41 | ioTests TestConfig{..} 42 | 43 | markdown :: IO TestTree 44 | markdown = do 45 | let name = "Markdown" 46 | let extension = ".md" 47 | let goldenExt = ".gold" 48 | let folder = "." 49 | let goldenDir = "examples" "golden" 50 | let excluded = ["TODO.md"] 51 | let excludedDirs = ["dist/", "dist-newstyle/", "build/"] 52 | ioTests TestConfig{..} 53 | 54 | 55 | typosExamples :: IO TestTree 56 | typosExamples = do 57 | let name = "Examples" 58 | let extension = ".act" 59 | let goldenExt = ".gold" 60 | let folder = "examples" 61 | let goldenDir = folder "golden" 62 | let excluded = [] 63 | let excludedDirs = [] 64 | ioTests TestConfig{..} 65 | 66 | 67 | typosTests :: IO TestTree 68 | typosTests = do 69 | let name = "Tests" 70 | let extension = ".act" 71 | let goldenExt = ".gold" 72 | let folder = "test" 73 | let goldenDir = folder "golden" 74 | let excluded = [] 75 | let excludedDirs = [] 76 | ioTests TestConfig{..} 77 | 78 | 79 | ioTests :: TestConfig -> IO TestTree 80 | ioTests TestConfig{..} = testGroup name <$> do 81 | files <- map normalise <$> findByExtension [extension] folder 82 | let excludedFiles = (normalise . (folder ) <$> excluded) 83 | forM (filter (\ f -> not (any (`isPrefixOf` f) excludedDirs)) $ files \\ excludedFiles) $ \ file -> do 84 | let dir = takeDirectory file 85 | let name = takeBaseName file 86 | let gold = goldenDir addExtension name goldenExt 87 | let flgs = dir addExtension name "flags" 88 | b <- doesFileExist flgs 89 | flags <- if b then words <$> readFile flgs else pure ["-q", "--no-colour", "--wAll"] 90 | pure $ goldenVsProg name gold "typos" (flags ++ [file]) "" 91 | -------------------------------------------------------------------------------- /test/app-operator-fail.act: -------------------------------------------------------------------------------- 1 | withOp : ?'Wildcard. ?'Wildcard. 2 | withOp@p = p?fun. p?res. 3 | fun - ['app 'arg1] - ['app 'arg2] 4 | ~ res 5 | -------------------------------------------------------------------------------- /test/app-operator.act: -------------------------------------------------------------------------------- 1 | withOp : ?['Pi 'Wildcard \_. ['Pi 'Wildcard \_.'Wildcard]]. 2 | ?'Wildcard. 3 | withOp@p = p?fun. p?res. 4 | fun - ['app 'arg1] - ['app 'arg2] 5 | ~ res 6 | 7 | exec 8 | ( withOp@p. p!\x y.y. p!'arg1. 9 | | withOp@p. p!\x y.y. p!'arg2. 10 | | withOp@p. p!\x y.x. p!'arg1. 11 | | withOp@p. p!\x y.x. p!'arg2. 12 | -- | withOp@p. p!'stuck. p!'arg1. 13 | -- | withOp@p. p!'stuck. p!'arg2. 14 | ) -------------------------------------------------------------------------------- /test/as-patterns.act: -------------------------------------------------------------------------------- 1 | 2 | example: ?'Wildcard. 3 | example@ch = ch?t. case t 4 | { p@q@(r@[a | b]) -> 5 | ( p ~ q 6 | | q ~ r 7 | | PRINTF "%i = %i = %i = [ %i | %i ]" p q r {x=a}x b. 8 | ) 9 | ; _ -> 10 | } 11 | 12 | exec example@ch. ch!['Hello | 'World]. -------------------------------------------------------------------------------- /test/barred-atom-pattern.act: -------------------------------------------------------------------------------- 1 | barred : ?['AtomBar ['Crash 'Oops 'Fail]]. 2 | barred@p = p?'Oops. -------------------------------------------------------------------------------- /test/barred-atom.act: -------------------------------------------------------------------------------- 1 | barred : !['Cons ['AtomBar ['Bye 'SeeYa]] ['AtomBar ['Crash 'Oops 'Fail]]]. 2 | barred@p = p!['Hi | 'Oops]. -------------------------------------------------------------------------------- /test/binders.act: -------------------------------------------------------------------------------- 1 | sink : ?'Wildcard. 2 | emit : !'Wildcard. 3 | 4 | stack |- 'Wildcard -> 'Nil 5 | push : 6 | pop : ?'Wildcard. 7 | 8 | play : 9 | 10 | sink@p = p?_. PRINTF "Sunk". 11 | emit@p = p!\_.[]. PRINTF "Emited". 12 | 13 | push@p = \x. stack |- x -> []. PRINTF "Pushd". pop@q. q!x. 14 | 15 | pop@p = p?x. case (lookup stack x) { ['Just _] -> PRINTF "Popd". ; _ -> } 16 | 17 | play@p = 18 | ( emit@q. sink@r. q <-> r 19 | | push@q. 20 | ) 21 | 22 | exec play@p. 23 | -------------------------------------------------------------------------------- /test/case-pair-failing.act: -------------------------------------------------------------------------------- 1 | syntax { 'Type = ['Enum ['Nat 'Bool]] } 2 | 3 | typeEq : ?'Type. ?'Type. 4 | typeEq@p = p?a. p?b. case [a|b] 5 | { ['Bool|'Bool] -> PRINTF "Happy Bools". 6 | ; ['Nat|'Nat] -> PRINTF "Happy Nats". 7 | ; 'Nat -> -- correctly rejected 8 | ; [l|r] -> PRINTF "%i is not equal to %i" l r. 9 | } 10 | 11 | exec typeEq@p. p!'Bool. p!'Bool. 12 | exec typeEq@p. p!'Nat. p!'Nat. 13 | exec typeEq@p. p!'Bool. p!'Nat. 14 | exec typeEq@p. p!'Nat. p!'Bool. -------------------------------------------------------------------------------- /test/case-pair.act: -------------------------------------------------------------------------------- 1 | syntax { 'Type = ['Enum ['Nat 'Bool]] } 2 | 3 | typeEq : ?'Type. ?'Type. 4 | typeEq@p = p?a. p?b. case [a|b] 5 | { ['Bool|'Bool] -> PRINTF "Happy Bools". 6 | ; ['Nat|'Nat] -> PRINTF "Happy Nats". 7 | ; [l|r] -> PRINTF "%i is not equal to %i" l r. 8 | } 9 | 10 | exec typeEq@p. p!'Bool. p!'Bool. 11 | exec typeEq@p. p!'Nat. p!'Nat. 12 | exec typeEq@p. p!'Bool. p!'Nat. 13 | exec typeEq@p. p!'Nat. p!'Bool. -------------------------------------------------------------------------------- /test/case-proposal.act: -------------------------------------------------------------------------------- 1 | syntax { 'Bool = ['Enum ['True 'False]] 2 | ; 'Ordering = ['Enum ['LT 'EQ 'GT]] 3 | } 4 | 5 | ctxt |- 'Wildcard -> 'Ordering 6 | 7 | example : ?'Wildcard. ?'Wildcard. !'Ordering. 8 | example@p = p?s. p?t. 9 | case [(lookup ctxt s) (lookup ctxt t) [s t]] 10 | { [['Just S] ['Just T] _] -> p!S. 11 | ; _ -> case (compare s t) { cmp -> p!cmp. } 12 | } 13 | 14 | exec 15 | example@p. p![]. p![[] []]. p?res. PRINTF "Result: %i" res. 16 | exec 17 | example@p. p!'a. p!'b. p?res. PRINTF "Result: %i" res. 18 | exec \x. 19 | example@p. p!\y.y. p!x. p?res. PRINTF "Result: %i" res. 20 | exec 21 | example@p. p!\y.y. p!\t.t. p?res. PRINTF "Result: %i" res. 22 | exec 23 | \x. ctxt |- x -> 'GT. \y. ctxt |- y -> 'EQ. 24 | example@p. p!x. p!y. p?res. PRINTF "Result: %i" res. 25 | -------------------------------------------------------------------------------- /test/case-tuples-failing.act: -------------------------------------------------------------------------------- 1 | syntax { 'Type = ['Enum ['Nat 'Bool]] } 2 | 3 | typeEq : ?'Type. ?'Type. 4 | typeEq@p = p?a. p?b. case [a b] 5 | { ['Bool 'Bool] -> PRINTF "Happy Bools". 6 | ; ['Nat 'Nat] -> PRINTF "Happy Nats". 7 | ; 'Nat -> -- correctly rejected 8 | ; [l r] -> PRINTF "%i is not equal to %i" l r. 9 | } 10 | 11 | exec typeEq@p. p!'Bool. p!'Bool. 12 | exec typeEq@p. p!'Nat. p!'Nat. 13 | exec typeEq@p. p!'Bool. p!'Nat. 14 | exec typeEq@p. p!'Nat. p!'Bool. -------------------------------------------------------------------------------- /test/case-tuples.act: -------------------------------------------------------------------------------- 1 | syntax { 'Type = ['Enum ['Nat 'Bool]] } 2 | 3 | typeEq : ?'Type. ?'Type. 4 | typeEq@p = p?a. p?b. case [a b] 5 | { ['Bool 'Bool] -> PRINTF "Happy Bools". 6 | ; ['Nat 'Nat] -> PRINTF "Happy Nats". 7 | ; [l r] -> PRINTF "%i is not equal to %i" l r. 8 | } 9 | 10 | exec typeEq@p. p!'Bool. p!'Bool. 11 | exec typeEq@p. p!'Nat. p!'Nat. 12 | exec typeEq@p. p!'Bool. p!'Nat. 13 | exec typeEq@p. p!'Nat. p!'Bool. -------------------------------------------------------------------------------- /test/channelvar-fail.act: -------------------------------------------------------------------------------- 1 | echo : ?'Wildcard. !'Wildcard. 2 | echo@p = p?t. echo!t. -------------------------------------------------------------------------------- /test/citizens.act: -------------------------------------------------------------------------------- 1 | syntax { 'Bool = ['Enum ['True 'False]] } 2 | 3 | 4 | discard : ?'Bool. 5 | bool : $'Bool. 6 | 7 | discard@p = p?x. case x 8 | { 'True -> PRINTF "T". 9 | ; 'False -> PRINTF "F". 10 | } 11 | 12 | 13 | bool@p = p?x. (case $x 14 | { 'True -> discard@q. q!x. 15 | ; 'False -> discard@q. q!x. 16 | } 17 | | discard@q. q!x.) 18 | 19 | exec bool@p. p!'False. 20 | -------------------------------------------------------------------------------- /test/citizens.flags: -------------------------------------------------------------------------------- 1 | --no-colour 2 | -------------------------------------------------------------------------------- /test/communicating-pairs.act: -------------------------------------------------------------------------------- 1 | syntax { 'Ping = ['Enum ['Ping]] 2 | ; 'Pong = ['Enum ['Pong]] 3 | } 4 | 5 | unpack : ?['Cons 'Ping 'Pong]. !'Ping. !'Pong. 6 | pack : ?'Ping. ?'Pong. !['Cons 'Ping 'Pong]. 7 | 8 | unpack@p = p?pp@[fst | snd]. p!fst. p!snd. 9 | pack@p = p?fst. p?snd. p![fst | snd]. 10 | 11 | exec pack@p. p!'Ping. p!'Pong. p?both. 12 | unpack@q. q!both. q?fst snd. 13 | case fst { 'Ping -> 14 | case snd { 'Pong -> 15 | PRINTF "Success". }} -------------------------------------------------------------------------------- /test/communication-fail.act: -------------------------------------------------------------------------------- 1 | doom : ?'Wildcard. 2 | doom@p = case [] 3 | { _ -> p?t. case t 4 | { [] -> # "Got nil" 5 | ; [_|_] -> # "Got cons" 6 | ; \_._ -> # "Got binder" 7 | ; _ -> # "Got atom" 8 | } 9 | } -------------------------------------------------------------------------------- /test/coverage.act: -------------------------------------------------------------------------------- 1 | syntax { 'Nat = ['EnumOrTag ['Zero] [['Succ 'Nat]]]} 2 | 3 | foo : ?'Nat.!'Nat. 4 | foo@p = p?n. case n 5 | { 'Zero -> p!'Zero. 6 | ; 'Zero -> p!'Zero. 7 | } 8 | 9 | foo' : ?'Nat.!'Nat. 10 | foo'@p = p?n. case n 11 | { ['Succ k] -> p!['Succ k]. 12 | ; ['Succ k] -> p!['Succ k]. 13 | } -------------------------------------------------------------------------------- /test/coverage.flags: -------------------------------------------------------------------------------- 1 | --no-colour -------------------------------------------------------------------------------- /test/covered.act: -------------------------------------------------------------------------------- 1 | coveredAtom : ?'Atom. 2 | coveredAtom@p = p?at. case at 3 | { 'Atom -> 4 | ; 'NotAtom -> 5 | ; 'Atom -> 6 | } 7 | 8 | syntax { 'Type = ['EnumOrTag ['Nat] [['Arr 'Type 'Type]]] } 9 | 10 | type : ?'Type. 11 | type@p = p?ty. case ty 12 | { 'Nat -> 13 | ; ['Arr 'Nat 'Nat] -> 14 | ; ['Arr a b] -> 15 | ; _ -> 16 | } 17 | 18 | syntax { 'Nat = ['EnumOrTag ['Zero] [['Succ 'Nat]]] } 19 | 20 | foo : ?'Nat.!'Nat. 21 | 22 | foo@p = p?n. case n 23 | { 'Zero -> p!'Zero. 24 | -- ; ['Succ k] -> foo@q. q!k . q?k'. p!['Succ k']. 25 | } 26 | 27 | syntax { 'Tree = ['Tag [['Leaf 'Nat] ['Node 'Tree 'Nat 'Tree]]] } 28 | 29 | toNat : ?'Tree. !'Nat. 30 | toNat@p = p?t. case t 31 | { ['Leaf 'Zero] -> p!'Zero. 32 | ; ['Node ['Node _ _ _] _ ['Node _ _ _]] -> p!['Succ 'Zero]. 33 | } 34 | 35 | separate : ?'Tree. 36 | separate@p = p?t. case t 37 | { ['Leaf ['Succ 'Zero]] -> 38 | ; ['Node ['Node _ _ _] _ ['Leaf _]] -> 39 | ; ['Node ['Leaf _] _ ['Node _ _ _]] -> 40 | ; ['Node _ 'Zero _] -> 41 | ; ['Node ['Node _ _ _] _ ['Leaf _]] -> 42 | ; ['Node ['Leaf _] _ ['Node _ _ _]] -> 43 | } -------------------------------------------------------------------------------- /test/covered.flags: -------------------------------------------------------------------------------- 1 | --no-colour -------------------------------------------------------------------------------- /test/define-operator.act: -------------------------------------------------------------------------------- 1 | syntax { 'Bool = ['Enum ['True 'False]] } 2 | syntax { 'Nat = ['EnumOrTag ['zero] [['succ 'Nat]]] } 3 | 4 | operator 5 | { (x : A) - 'id : A 6 | ; (f : 'Wildcard) - ['myApp (t : 'Wildcard)] : 'Wildcard 7 | ; (a : A) - ['when (b : 'Bool)] : A 8 | ; (b : 'Bool) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard 9 | ; (n : 'Nat) - ['plus (m : 'Nat)] : 'Nat 10 | ; (n : 'Nat) - ['mult (m : 'Nat)] : 'Nat 11 | -- TODO: 12 | -- ; (p : ['Sg a \x.b]) - 'fst : a 13 | -- ; (p : ['Sg a \x.b]) - 'snd : {x=p - 'fst} b 14 | } 15 | 16 | operator 17 | { t : B - 'id ~> t 18 | ; (\x. t) : 'Wildcard - ['myApp s] ~> {x=s}t 19 | 20 | ; x : A - ['when 'True] ~> x 21 | 22 | ; 'True : 'Bool - ['if l r] ~> l 23 | ; 'False : 'Bool - ['if l r] ~> r 24 | 25 | ; 'zero : 'Nat - ['plus n] ~> n 26 | ; ['succ m] : 'Nat - ['plus n] ~> ['succ (m - ['plus n])] 27 | ; m : 'Nat - ['plus 'zero] ~> m 28 | ; m : 'Nat - ['plus n] : 'Nat - ['plus x] ~> m - ['plus (n - ['plus x])] 29 | 30 | -- parsed as m [(plus, [n]), (plus, [x])] 31 | 32 | ; 'zero : 'Nat - ['mult n] ~> 'zero 33 | ; m : 'Nat - ['mult 'zero] ~> 'zero 34 | 35 | -- TODO: this should raise a complaint that these are non-confluent 36 | -- (unless we manage to get plus to be commutative) 37 | ; ['succ m] : 'Nat - ['mult n] ~> n - ['plus (m - ['mult n])] 38 | ; m : 'Nat - ['mult ['succ n]] ~> m - ['plus (m - ['mult n])] 39 | ; m : 'Nat - ['plus n] : 'Nat - ['mult p] ~> (m - ['mult p]) - ['plus (n - ['mult p])] 40 | } 41 | 42 | -- parsed as m [(plus, [n]), (mult, [p])] 43 | 44 | exec 45 | 'Bool?block. 46 | -- poor man's type annotations 47 | let t : 'Atom = 'test. 48 | let h : 'Wildcard = 'hello. 49 | ( PRINTF "%i" t - 'id. 50 | | t - 'id ~ t 51 | | h - ['when block] ~ h 52 | | block ~ 'True 53 | | PRINTF "%i" block. 54 | | 'Nat?m n p. m - ['plus n] - ['mult p] ~ (m - ['mult p]) - ['plus (n - ['mult p])] 55 | ) 56 | -------------------------------------------------------------------------------- /test/define-operator.flags: -------------------------------------------------------------------------------- 1 | --no-colour -------------------------------------------------------------------------------- /test/elab-channel-failing.act: -------------------------------------------------------------------------------- 1 | parent : ?'Wildcard. 2 | child : ?'Wildcard. 3 | 4 | parent@p = 5 | \x. 6 | 7 | 8 | \y. 9 | child@q. 10 | 11 | p <-> q -------------------------------------------------------------------------------- /test/elab-push-failing.act: -------------------------------------------------------------------------------- 1 | nopush : 2 | 3 | nopush@p = \x. nopush 4 | |- x -> [] 5 | . -------------------------------------------------------------------------------- /test/elab-send-failing.act: -------------------------------------------------------------------------------- 1 | silent : 2 | silent@p = p![]. -------------------------------------------------------------------------------- /test/golden/app-operator-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | withOp : ?'Wildcard. ?'Wildcard. 5 | out > 2 | withOp@p = p?fun. p?res. 6 | out > 3 | fun - ['app 'arg1] - ['app 'arg2] 7 | out > ^^^^^^^^^^^^^^^^^^ 8 | out > app-operator-fail.act:3:2-20 9 | out > Inferred object description 'Wildcard does not match pattern ['Pi S \x. T] 10 | out > when elaborating a constraint involving fun - ['app 'arg1] - ['app 'arg2] 11 | out > when elaborating the judgement definition for withOp 12 | out > 13 | -------------------------------------------------------------------------------- /test/golden/app-operator.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error: Did not win 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /test/golden/as-patterns.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > ['Hello | 'World] = ['Hello | 'World] = ['Hello | 'World] = [ 'Hello | 'World ] 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /test/golden/barred-atom-pattern.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | barred : ?['AtomBar ['Crash 'Oops 'Fail]]. 5 | out > 2 | barred@p = p?'Oops. 6 | out > ^^^^^ 7 | out > barred-atom-pattern.act:2:13-18 8 | out > 'Oops is one of the barred atoms [Crash, Oops, Fail] 9 | out > when elaborating a case branch handling the pattern 'Oops 10 | out > when elaborating the judgement definition for barred 11 | out > 12 | -------------------------------------------------------------------------------- /test/golden/barred-atom.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | barred : !['Cons ['AtomBar ['Bye 'SeeYa]] ['AtomBar ['Crash 'Oops 'Fail]]]. 5 | out > 2 | barred@p = p!['Hi | 'Oops]. 6 | out > ^^^^^^^^ 7 | out > barred-atom.act:2:18-26 8 | out > 'Oops is one of the barred atoms [Crash, Oops, Fail] 9 | out > when elaborating p!['Hi | 'Oops] 10 | out > when elaborating the judgement definition for barred 11 | out > 12 | -------------------------------------------------------------------------------- /test/golden/binders.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Emited 3 | out > Sunk 4 | out > Pushd 5 | out > Popd 6 | out > 7 | err > 8 | err > 9 | -------------------------------------------------------------------------------- /test/golden/case-pair-failing.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 5 | { ['Bool|'Bool] -> PRINTF "Happy Bools". 5 | out > 6 | ; ['Nat|'Nat] -> PRINTF "Happy Nats". 6 | out > 7 | ; 'Nat -> -- correctly rejected 7 | out > ^^^^ 8 | out > case-pair-failing.act:7:4-8 9 | out > Pattern 'Nat does not check against ['Cons 'Type 'Type] 10 | out > when elaborating a case branch handling the pattern 'Nat 11 | out > when elaborating the judgement definition for typeEq 12 | out > 13 | -------------------------------------------------------------------------------- /test/golden/case-pair.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > 'Nat is not equal to 'Bool 3 | out > 'Bool is not equal to 'Nat 4 | out > Happy Nats 5 | out > Happy Bools 6 | out > 7 | err > 8 | err > 9 | -------------------------------------------------------------------------------- /test/golden/case-proposal.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Result: 'GT 3 | out > Result: 'EQ 4 | out > Result: 'GT 5 | out > Result: 'LT 6 | out > Result: 'LT 7 | out > 8 | err > 9 | err > 10 | -------------------------------------------------------------------------------- /test/golden/case-tuples-failing.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 5 | { ['Bool 'Bool] -> PRINTF "Happy Bools". 5 | out > 6 | ; ['Nat 'Nat] -> PRINTF "Happy Nats". 6 | out > 7 | ; 'Nat -> -- correctly rejected 7 | out > ^^^^ 8 | out > case-tuples-failing.act:7:4-8 9 | out > Pattern 'Nat does not check against ['Cons 'Type ['Cons 'Type 'Nil]] 10 | out > when elaborating a case branch handling the pattern 'Nat 11 | out > when elaborating the judgement definition for typeEq 12 | out > 13 | -------------------------------------------------------------------------------- /test/golden/case-tuples.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > 'Nat is not equal to 'Bool 3 | out > 'Bool is not equal to 'Nat 4 | out > Happy Nats 5 | out > Happy Bools 6 | out > 7 | err > 8 | err > 9 | -------------------------------------------------------------------------------- /test/golden/channelvar-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | echo : ?'Wildcard. !'Wildcard. 5 | out > 2 | echo@p = p?t. echo!t. 6 | out > ^^^^ 7 | out > channelvar-fail.act:2:14-18 8 | out > Invalid channel variable echo refers to a judgement 9 | out > when elaborating the judgement definition for echo 10 | out > 11 | -------------------------------------------------------------------------------- /test/golden/citizens.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > F 3 | out > F 4 | out > bool 'False 5 | out > discard 'False 6 | out > discard 'False 7 | out > 8 | err > 9 | err > 10 | -------------------------------------------------------------------------------- /test/golden/communicating-pairs.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Success 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /test/golden/communication-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > communication-fail.act:3:9-8:5 4 | out > Doomed branch communicated p?t. case t { [] -> #"Got nil" 5 | out > ; [_ | _] -> #"Got cons" 6 | out > ; \_. _ -> #"Got binder" 7 | out > ; _ -> #"Got atom"} 8 | out > when elaborating a case branch handling the pattern _ 9 | out > when elaborating the judgement definition for doom 10 | out > 11 | -------------------------------------------------------------------------------- /test/golden/coverage.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: coverage.act:6:4-9 3 | out > Unreachable clause 'Zero 4 | out > when elaborating the judgement definition for foo 5 | out > Warning: coverage.act:4:13-7:3 6 | out > Incomplete pattern matching. The following pattern is missing: 7 | out > ['Succ a] 8 | out > when elaborating the judgement definition for foo 9 | out > Warning: coverage.act:12:4-13 10 | out > Unreachable clause ['Succ k] 11 | out > when elaborating the judgement definition for foo' 12 | out > Warning: coverage.act:10:14-13:3 13 | out > Incomplete pattern matching. The following pattern is missing: 14 | out > 'Zero 15 | out > when elaborating the judgement definition for foo' 16 | out > 17 | out > 18 | err > 19 | err > 20 | -------------------------------------------------------------------------------- /test/golden/covered.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: covered.act:5:4-9 3 | out > Unreachable clause 'Atom 4 | out > when elaborating the judgement definition for coveredAtom 5 | out > Warning: covered.act:2:22-6:3 6 | out > Incomplete pattern matching. The following pattern is missing: 7 | out > _ 8 | out > when elaborating the judgement definition for coveredAtom 9 | out > Warning: covered.act:22:13-25:3 10 | out > Incomplete pattern matching. The following pattern is missing: 11 | out > ['Succ a] 12 | out > when elaborating the judgement definition for foo 13 | out > Warning: covered.act:30:15-33:3 14 | out > Incomplete pattern matching. The following patterns are missing: 15 | out > ['Node ['Node a b c] d ['Leaf e]] 16 | out > ['Node ['Leaf a] b ['Node c d e]] 17 | out > ['Node ['Leaf a] b ['Leaf c]] 18 | out > ['Leaf ['Succ a]] 19 | out > when elaborating the judgement definition for toNat 20 | out > Warning: covered.act:41:4-37 21 | out > Unreachable clause ['Node ['Node _ _ _] _ ['Leaf _]] 22 | out > when elaborating the judgement definition for separate 23 | out > Warning: covered.act:42:4-37 24 | out > Unreachable clause ['Node ['Leaf _] _ ['Node _ _ _]] 25 | out > when elaborating the judgement definition for separate 26 | out > Warning: covered.act:36:18-43:3 27 | out > Incomplete pattern matching. The following patterns are missing: 28 | out > ['Node ['Node a b c] ['Succ d] ['Node e f g]] 29 | out > ['Node ['Leaf a] ['Succ b] ['Leaf c]] 30 | out > ['Leaf 'Zero] 31 | out > ['Leaf ['Succ ['Succ a]]] 32 | out > when elaborating the judgement definition for separate 33 | out > 34 | out > 35 | err > 36 | err > 37 | -------------------------------------------------------------------------------- /test/golden/define-operator.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > 'test : 'Atom - 'id 3 | out > 'True 4 | out > Warning: Unsolved metas (m:9, n:10, p:11) 5 | out > 6 | out > 7 | err > 8 | err > 9 | -------------------------------------------------------------------------------- /test/golden/elab-channel-failing.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 9 | child@q. 5 | out > 10 | 6 | out > 11 | p <-> q 7 | out > ^^^^^^^ 8 | out > elab-channel-failing.act:11:4-11 9 | out > Wrong direction LT between ? 'Wildcard and ! 'Wildcard 10 | out > when elaborating the connection p <-> q 11 | out > when elaborating the judgement definition for parent 12 | out > 13 | -------------------------------------------------------------------------------- /test/golden/elab-push-failing.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | nopush : 5 | out > 2 | 6 | out > 3 | nopush@p = \x. nopush 7 | out > ^^^^^^ 8 | out > elab-push-failing.act:3:15-21 9 | out > Invalid context stack variable nopush refers to a judgement 10 | out > when elaborating the judgement definition for nopush 11 | out > 12 | -------------------------------------------------------------------------------- /test/golden/elab-send-failing.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | silent : 5 | out > 2 | silent@p = p![]. 6 | out > ^^^^^ 7 | out > elab-send-failing.act:2:11-16 8 | out > Invalid send of [] on channel p 9 | out > when elaborating the judgement definition for silent 10 | out > 11 | -------------------------------------------------------------------------------- /test/golden/let-binders.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > ['Tick 'Tick 'Tick 'Tick 'Tick] 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /test/golden/losing-finishes.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | err > 3 | err > 4 | -------------------------------------------------------------------------------- /test/golden/multi-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Alarm: fail 3 | out > Error: Did not win 4 | out > 5 | err > 6 | err > 7 | -------------------------------------------------------------------------------- /test/golden/multibind.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Success 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /test/golden/no-space.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Parse error near location: no-space.act:19:21 3 | out > Expected '!', '?', '-', '~', '<->', ':', '@', or '|-'. 4 | out > 5 | -------------------------------------------------------------------------------- /test/golden/not-actorvar-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | test : 5 | out > 2 | test@p = \fst. case $fst { [fst snd trd] -> \snd. } 6 | out > ^^^^ 7 | out > not-actorvar-fail.act:2:20-24 8 | out > Invalid subject variable fst 9 | out > when elaborating the case scrutinee fst 10 | out > when elaborating the judgement definition for test 11 | out > 12 | -------------------------------------------------------------------------------- /test/golden/operator-elab-fail-2.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 4 | 5 | out > 5 | operator 6 | out > 6 | { 'True : 'Bool - ['if l] ~> l 7 | out > ^^^^^ 8 | out > operator-elab-fail-2.act:6:21-26 9 | out > Invalid arity: 1 missing operator parameters for if 10 | out > 11 | -------------------------------------------------------------------------------- /test/golden/operator-elab-fail-3.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 5 | operator 5 | out > 6 | { 'True : 'Bool - ['if l r] ~> l 6 | out > 7 | ; 'False : 'Bool - ['ifte l r] ~> r 7 | out > ^^^^^ 8 | out > operator-elab-fail-3.act:7:22-27 9 | out > Invalid operator name ifte 10 | out > 11 | -------------------------------------------------------------------------------- /test/golden/operator-elab-fail-4.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | syntax { 'Bool = ['Enum ['False 'True]] } 5 | out > 2 | 6 | out > 3 | operator { (b : 'Boo) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } 7 | out > ^^^^ 8 | out > operator-elab-fail-4.act:3:16-20 9 | out > Expected a semantics but got 'Boo 10 | out > 11 | -------------------------------------------------------------------------------- /test/golden/operator-elab-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 5 | operator 5 | out > 6 | { 'True : 'Bool - ['if l r] ~> l 6 | out > 7 | ; 'False : 'Bool - ['if l m r] ~> r 7 | out > ^^^^^^^^^ 8 | out > operator-elab-fail.act:7:22-31 9 | out > Invalid arity: 1 extra operator parameters for if 10 | out > 11 | -------------------------------------------------------------------------------- /test/golden/operator-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 3 | 5 | out > 4 | failure : ?['Pi 'Wildcard \_.'Wildcard]. ?'Wildcard. !'Wildcard. 6 | out > 5 | failure@p = p?f. p?t. p!f - 'app. 7 | out > ^^^^^^^^ 8 | out > operator-fail.act:5:24-32 9 | out > Invalid arity: 1 missing operator parameters for app 10 | out > when elaborating p!f - 'app 11 | out > when elaborating the judgement definition for failure 12 | out > 13 | -------------------------------------------------------------------------------- /test/golden/parse-fail-2.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Parse error near location: parse-fail-2.act:10:4 3 | out > Expected '-', '|', or ';'. 4 | out > 5 | -------------------------------------------------------------------------------- /test/golden/parse-fail-3.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Parse error near location: parse-fail-3.act:12:15 3 | out > Expected ')', '!', '?', '@', '-', '~', '<->', or '|-'. 4 | out > 5 | -------------------------------------------------------------------------------- /test/golden/parse-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Parse error near location: parse-fail.act:7:0 3 | out > Expected '-', or '.'. 4 | out > 5 | -------------------------------------------------------------------------------- /test/golden/plumbing.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Ping 'Manual 3 | out > Pong 'Manual 4 | out > Done 'Manual 5 | out > Ping 'Plumbed 6 | out > Pong 'Plumbed 7 | out > Done 'Plumbed 8 | out > Ping 'Plumbed 9 | out > Pong 'Plumbed 10 | out > Done 'Plumbed 11 | out > 12 | err > 13 | err > 14 | -------------------------------------------------------------------------------- /test/golden/printing-open.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 4 | operator 5 | out > 5 | { x : a - 'id ~> x 6 | out > 6 | ; x : a - 'id ~> 'hello 7 | out > ^^^^^^ 8 | out > printing-open.act:6:19-25 9 | out > 'hello does not match the semantics description a 10 | out > 11 | -------------------------------------------------------------------------------- /test/golden/printing-open2.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | typecheck \X x.x : ['Pi 'Semantics \A. ['Pi A \_.A]] 5 | out > 2 | 6 | out > 3 | typecheck \X x.X : ['Pi 'Semantics \A. ['Pi A \_.A]] 7 | out > ^ 8 | out > printing-open2.act:3:15-16 9 | out > Incompatible semantics descriptions, expected X but got 'Semantics 10 | out > when elaborating the term variable X 11 | out > 12 | -------------------------------------------------------------------------------- /test/golden/printing.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Raw: < ?[("b",[1])] > 3 | out > Instantiated: < 'True > 4 | out > Normalised: < ?[("b",[1])] > 5 | out > Raw: < ?[("c",[2])] : 'Bool - ['if ?[("b",[1])]] > 6 | out > Instantiated: < 'False : 'Bool - ['if 'True] > 7 | out > Normalised: < ?[("c",[2])] : 'Bool - ['if ?[("b",[1])]] > 8 | out > strict 'True 9 | out > strict 'False 10 | out > 11 | err > 12 | err > 13 | -------------------------------------------------------------------------------- /test/golden/reduce-neutrals-2.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: Unsolved metas (b1:1, b2:2) 3 | out > 4 | out > 5 | err > Matching 'at : 'Atom - ['fst ?[("b1",[1])]] - ['snd ?[("b2",[2])]] 6 | err > against x : X - ['fst b1] : _3 - ['snd b2] ~> x : X - ['fst 7 | err > b1 : ['EnumOrTag 8 | err > ['True] 9 | err > []] - ['snd b2]] 10 | err > Success! 11 | err > 12 | err > 13 | err > 14 | -------------------------------------------------------------------------------- /test/golden/reduce-neutrals.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: Unsolved metas (b1:1, b2:2) 3 | out > 4 | out > 5 | err > 'at not an operator application 6 | err > Matching 'at - ['if ?[("b1",[1])] : ['EnumOrTag 7 | err > ['True] []] - ['if ?[("b2",[2])]]] 8 | err > against x : X - ['if b1] : _3 - ['if b2] ~> x : X - ['if b1 : ['EnumOrTag 9 | err > ['True] 10 | err > []] - ['if b2]] 11 | err > Failure Mismatch 12 | err > 13 | err > 'at not an operator application 14 | err > Matching 'at - ['if ?[("b1",[1])]] 15 | err > against x : X - ['if b1] : _3 - ['if b2] ~> x : X - ['if b1 : ['EnumOrTag 16 | err > ['True] 17 | err > []] - ['if b2]] 18 | err > Failure Mismatch 19 | err > 20 | err > Matching 'at : 'Atom - ['if ?[("b1",[1])]] - ['if ?[("b2",[2])]] 21 | err > against x : X - ['if b1] : _3 - ['if b2] ~> x : X - ['if b1 : ['EnumOrTag 22 | err > ['True] 23 | err > []] - ['if b2]] 24 | err > Success! 25 | err > 26 | err > 'at not an operator application 27 | err > Matching 'at - ['if ?[("b1",[1])] : ['EnumOrTag 28 | err > ['True] []] - ['if ?[("b2",[2])]]] 29 | err > against x : X - ['if b1] : _3 - ['if b2] ~> x : X - ['if b1 : ['EnumOrTag 30 | err > ['True] 31 | err > []] - ['if b2]] 32 | err > Failure Mismatch 33 | err > 34 | err > 35 | err > 36 | -------------------------------------------------------------------------------- /test/golden/reserved-keyword.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Parse error near location: reserved-keyword.act:3:7 3 | out > 'let' is a reserved keyword 4 | out > 5 | -------------------------------------------------------------------------------- /test/golden/restarting.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Ping 3 | out > Pong 4 | out > Done 5 | out > 6 | err > 7 | err > 8 | -------------------------------------------------------------------------------- /test/golden/scope-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | test : 5 | out > 2 | test@p = \tl. 6 | out > 3 | case [hd tl] 7 | out > ^^ 8 | out > scope-fail.act:3:8-10 9 | out > Out of scope variable hd 10 | out > when elaborating the term variable hd 11 | out > when elaborating a term scrutinee [hd tl] 12 | out > when elaborating the case scrutinee [hd tl] 13 | out > when elaborating the judgement definition for test 14 | out > 15 | -------------------------------------------------------------------------------- /test/golden/semanticPi.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | 5 | out > 2 | exec ['Pi 'Wildcard \_. 'Wildcard]?t. case t 6 | out > 3 | { \ x. b -> PRINTF "%i" b. 7 | out > ^^^^^^ 8 | out > semanticPi.act:3:4-10 9 | out > Cannot match pattern \x. b at semantic Pi ['Pi 'Wildcard \_. 'Wildcard] 10 | out > when elaborating a case branch handling the pattern \x. b 11 | out > when elaborating an exec statement 12 | out > 13 | -------------------------------------------------------------------------------- /test/golden/shadowed-pattern.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 5 | -- been evicted from the scope. 5 | out > 6 | a : ?'Wildcard. 6 | out > 7 | a@p = p?x. case x { (\ z . {z*}z) -> PRINTF "the body is %r" z. } 7 | out > ^ 8 | out > shadowed-pattern.act:7:31-32 9 | out > Out of scope variable z 10 | out > when elaborating the pattern variable z 11 | out > when elaborating a case branch handling the pattern \z. {z*} z 12 | out > when elaborating the judgement definition for a 13 | out > 14 | -------------------------------------------------------------------------------- /test/golden/shadowing-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | test : 5 | out > 2 | test@p = 'Wildcard?fst. case fst { [_ snd trd] -> \snd. } 6 | out > ^^^ 7 | out > shadowing-fail.act:2:51-54 8 | out > snd is already defined 9 | out > when binding a local variable 10 | out > when elaborating a case branch handling the pattern [_ snd trd] 11 | out > when elaborating the judgement definition for test 12 | out > 13 | -------------------------------------------------------------------------------- /test/golden/spop-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 1 | source : !'Wildcard. 5 | out > 2 | source@p = p!{x*}[]. 6 | out > ^ 7 | out > spop-fail.act:2:14-15 8 | out > Out of scope variable x 9 | out > when elaborating p!{x*} [] 10 | out > when elaborating the judgement definition for source 11 | out > 12 | -------------------------------------------------------------------------------- /test/golden/spop-top-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 3 | = \x. \y. source@q. q?t. 5 | out > 4 | let v : 'Wildcard = {y x}t. 6 | out > 5 | p!v. 7 | out > ^ 8 | out > spop-top-fail.act:5:6-7 9 | out > Out of scope variable x 10 | out > when elaborating the term variable x 11 | out > when elaborating the term variable v 12 | out > when elaborating p!v 13 | out > when elaborating the judgement definition for source 14 | out > 15 | -------------------------------------------------------------------------------- /test/golden/stlcDidNotWin.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Done? 3 | out > Error: Did not win 4 | out > check ['Arr 'Nat ['Arr 'Nat 'Nat]] 5 | out > ['Lam \z. ['Emb ['App ['Ann ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] 6 | out > ['Emb z]]]] 7 | out > \z_0. myCtxt |- z_0 -> 'Nat. 8 | out > check ['Arr 'Nat 'Nat] 9 | out > ['Emb ['App ['Ann ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] ['Emb z_0]]] 10 | out > synth ['App ['Ann ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] ['Emb z_0]] 'Nat 11 | out > synth ['Ann ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] ['Arr 'Nat 'Nat] 12 | out > type ['Arr 'Nat 'Nat] 13 | out > type 'Nat 14 | out > type 'Nat 15 | out > check ['Arr 'Nat 'Nat] ['Lam \w. ['Emb w]] 16 | out > \w_1. myCtxt |- w_1 -> 'Nat. 17 | out > check 'Nat ['Emb w_1] 18 | out > synth w_1 'Nat 19 | out > check 'Nat ['Emb z_0] 20 | out > synth z_0 'Nat 21 | out > 'Nat /~ ['Arr 'Nat 'Nat] 22 | out > 23 | err > 24 | err > 25 | -------------------------------------------------------------------------------- /test/golden/stuckguard.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Warning: stuckguard.act:6:4-10 3 | out > Pattern subject m did not get scrutinised 4 | out > when elaborating a case branch handling the pattern ['S m] 5 | out > when elaborating the judgement definition for isNat 6 | out > < ['S ['S 'Z]] > 7 | out > < ['S ['S 'Z]] > 8 | out > < ['S ['S 'Z]] > 9 | out > Error: Did not win 10 | out > 11 | err > 12 | err > 13 | -------------------------------------------------------------------------------- /test/golden/subject-as-pattern-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 9 | fooFail : $'Bool. -- this should not work 5 | out > 10 | fooFail@p = p?x. case [ x $x] 6 | out > 11 | { [ 'True | y@z ] -> 7 | out > ^^^^^^^ 8 | out > subject-as-pattern-fail.act:11:12-19 9 | out > As pattern y@z duplicates a subject variable 10 | out > when elaborating a case branch handling the pattern ['True | y@z] 11 | out > when elaborating the judgement definition for fooFail 12 | out > 13 | -------------------------------------------------------------------------------- /test/golden/subject-scrutinising-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: subject-scrutinising-fail.act:4:8-7:3 3 | out > Received subject b on channel p and did not scrutinise it 4 | out > when elaborating the judgement definition for not 5 | out > Warning: subject-scrutinising-fail.act:10:15-16:3 6 | out > Inconsistent scrutinisation of subject in match 7 | out > when elaborating a match with case scrutinee compare 'True 'True 8 | out > when elaborating the judgement definition for silly 9 | out > Warning: subject-scrutinising-fail.act:21:34-35 10 | out > Subject pattern thrown away using an underscore 11 | out > when elaborating the judgement definition for rejectedFake 12 | out > Warning: subject-scrutinising-fail.act:22:19-24:0 13 | out > Received subject i on channel p and did not scrutinise it 14 | out > when elaborating the judgement definition for rerejectedFake 15 | out > Warning: subject-scrutinising-fail.act:29:20-35:3 16 | out > Inconsistent scrutinisation of subject in match 17 | out > when elaborating a match with case scrutinee compare 'True 'True 18 | out > when elaborating the judgement definition for impossible 19 | out > Warning: subject-scrutinising-fail.act:47:16-50:3 20 | out > Inconsistent scrutinisation of subject in match 21 | out > when elaborating a match with case scrutinee lookup stack tm 22 | out > when elaborating the judgement definition for isVar 23 | out > Warning: subject-scrutinising-fail.act:54:4-21 24 | out > Pattern subject x did not get scrutinised 25 | out > when elaborating a case branch handling the pattern [['Just b] | x] 26 | out > when elaborating the judgement definition for strictIsVarCombo 27 | out > Warning: subject-scrutinising-fail.act:67:47-61 28 | out > Sent subject {x=z, y=z} body is not a subject variable 29 | out > when elaborating a case branch handling the pattern \x y. body 30 | out > when elaborating the judgement definition for renamingSubjects 31 | out > 32 | err > 33 | err > 34 | -------------------------------------------------------------------------------- /test/golden/syntax-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 2 | ; 'Term = ['EnumOrTag ['Zro 'One] 5 | out > 3 | [['Suc 'Term]]] 6 | out > 4 | ; 'Type = ['Tag [['Pair 'Type 'Type]]] 7 | out > ^^^^^ 8 | out > syntax-fail.act:4:9-14 9 | out > The syntactic category Type is already defined 10 | out > 11 | -------------------------------------------------------------------------------- /test/golden/syntaxcat-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error 3 | out > 4 | out > 4 | 5 | out > 5 | test : 6 | out > 6 | test@p = 'Tic?a. 'Tac?b. [a b] ~ [b a] 7 | out > ^^^^^^^^^^^^^ 8 | out > syntaxcat-fail.act:6:25-38 9 | out > Incompatible semantics descriptions, expected ['Cons 10 | out > 'Tic ['Cons 11 | out > 'Tac 12 | out > 'Nil]] but got ['Cons 13 | out > 'Tac 14 | out > ['Cons 15 | out > 'Tic 16 | out > 'Nil]] 17 | out > when guessing syntactic categories for [a b] [b a] 18 | out > when elaborating the judgement definition for test 19 | out > 20 | -------------------------------------------------------------------------------- /test/golden/toonice.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: toonice.act:6:12-8:0 3 | out > Received subject i on channel p and did not scrutinise it 4 | out > when elaborating the judgement definition for toonice 5 | out > 6 | err > 7 | err > 8 | -------------------------------------------------------------------------------- /test/golden/two-fail.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Alarm: left 3 | out > Alarm: right 4 | out > Error: Did not win 5 | out > test 6 | out > left 7 | out > right 8 | out > 9 | err > 10 | err > 11 | -------------------------------------------------------------------------------- /test/golden/type-projection.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > The type of ?[("b",[1])] is 'Bool 3 | out > Warning: Unsolved meta (b:1) 4 | out > 5 | err > 6 | err > 7 | -------------------------------------------------------------------------------- /test/golden/typecheck.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Hurrah! 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /test/golden/unfinished.gold: -------------------------------------------------------------------------------- 1 | ret > ExitFailure 1 2 | out > Error: Did not win 3 | out > driver 'a 'b 4 | out > duplicate 'a ['a 'a] 5 | out > stuck ['a 'a] 'b 6 | out > duplicate 'b ['b 'b] 7 | out > 'a /~ 'b 8 | out > 'a /~ 'b 9 | out > 10 | err > 11 | err > 12 | -------------------------------------------------------------------------------- /test/golden/unsolved-meta.gold: -------------------------------------------------------------------------------- 1 | ret > ExitSuccess 2 | out > Warning: Unsolved metas (t:2, u:3) 3 | out > 4 | err > 5 | err > 6 | -------------------------------------------------------------------------------- /test/let-binders.act: -------------------------------------------------------------------------------- 1 | test : 2 | test@p = \a. let x : ['Enum ['Tick]] = 'Tick. 3 | PRINTF "%i" [x x x x x]. 4 | 5 | exec test@p. 6 | -------------------------------------------------------------------------------- /test/losing-finishes.act: -------------------------------------------------------------------------------- 1 | loser : !'Atom. 2 | loser@p = # "fail" -------------------------------------------------------------------------------- /test/multi-fail.act: -------------------------------------------------------------------------------- 1 | fail : ?'Atom. !'Atom. 2 | fail@p = p?at. 'Atom?at'. (# "fail" | at ~ at' | p!at'.) 3 | 4 | exec fail@p. p!'Hi. p?res. -------------------------------------------------------------------------------- /test/multibind.act: -------------------------------------------------------------------------------- 1 | syntax { 'Term = ['Bind 'Term ['Bind 'Term 'Nil]] } 2 | 3 | test : ?'Term. ?'Term. 4 | test@p = 'Term?S T U. -- multi binder in fresh meta 5 | ( S ~ \x y. [] -- multi binder in term 6 | | p?T' U'. -- multi binder in receive 7 | (T ~ T' | U ~ U') 8 | | case S 9 | { \x y. [] -- multi binder in pattern 10 | -> \ a b c. -- multi binder in under 11 | PRINTF "Success". 12 | } 13 | ) 14 | 15 | exec test@p. p!\ _ _.[]. p!\_ _.[]. -------------------------------------------------------------------------------- /test/no-space.act: -------------------------------------------------------------------------------- 1 | noSpace : ?'Wildcard. 2 | noSpace@p=p?w.case w{_->} 3 | 4 | syntax { 'Unit = ['Enum ['Top]] } 5 | 6 | works : $'Unit. 7 | works2 : $'Unit. 8 | works3 : ?'Unit. 9 | fails : ?'Unit. 10 | 11 | works@p = p?x. case$ x { 'Top -> } 12 | 13 | works2@p = p?x. case$ 14 | 15 | x { 'Top -> PRINTF "".} 16 | 17 | works3@p = p?x. case{--}x { 'Top -> } 18 | 19 | fails@p = p?x. casex { 'Top -> } 20 | 21 | -------------------------------------------------------------------------------- /test/not-actorvar-fail.act: -------------------------------------------------------------------------------- 1 | test : 2 | test@p = \fst. case $fst { [fst snd trd] -> \snd. } -------------------------------------------------------------------------------- /test/operator-elab-fail-2.act: -------------------------------------------------------------------------------- 1 | syntax { 'Bool = ['Enum ['False 'True]] } 2 | 3 | operator { (b : 'Bool) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } 4 | 5 | operator 6 | { 'True : 'Bool - ['if l] ~> l 7 | ; 'False : 'Bool - ['if l r] ~> r 8 | } 9 | -------------------------------------------------------------------------------- /test/operator-elab-fail-3.act: -------------------------------------------------------------------------------- 1 | syntax { 'Bool = ['Enum ['False 'True]] } 2 | 3 | operator { (b : 'Bool) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } 4 | 5 | operator 6 | { 'True : 'Bool - ['if l r] ~> l 7 | ; 'False : 'Bool - ['ifte l r] ~> r 8 | } 9 | -------------------------------------------------------------------------------- /test/operator-elab-fail-4.act: -------------------------------------------------------------------------------- 1 | syntax { 'Bool = ['Enum ['False 'True]] } 2 | 3 | operator { (b : 'Boo) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } 4 | 5 | 6 | operator 7 | { 'True : 'Bool - ['if l r] ~> l 8 | ; 'False : 'Bool - ['if l r] ~> r 9 | } 10 | -------------------------------------------------------------------------------- /test/operator-elab-fail.act: -------------------------------------------------------------------------------- 1 | syntax { 'Bool = ['Enum ['False 'True]] } 2 | 3 | operator { (b : 'Bool) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } 4 | 5 | operator 6 | { 'True : 'Bool - ['if l r] ~> l 7 | ; 'False : 'Bool - ['if l m r] ~> r 8 | } 9 | -------------------------------------------------------------------------------- /test/operator-fail.act: -------------------------------------------------------------------------------- 1 | success : ?['Pi 'Wildcard \_.'Wildcard]. ?'Wildcard. !'Wildcard. 2 | success@p = p?f. p?t. p!f - ['app t]. 3 | 4 | failure : ?['Pi 'Wildcard \_.'Wildcard]. ?'Wildcard. !'Wildcard. 5 | failure@p = p?f. p?t. p!f - 'app. 6 | -------------------------------------------------------------------------------- /test/parse-fail-2.act: -------------------------------------------------------------------------------- 1 | syntax { 'Type = ['Enum ['One 'Two]] 2 | ; 'Term = ['EnumOrTag ['One 'Tru 'Fls] 3 | [['Ifte 'Term 'Term 'Term]]] 4 | } 5 | 6 | check : ?'Type. ?'Term. 7 | check@p = p?ty. p?t. case t 8 | { 'One -> ty ~ 'One 9 | ; 'Tru -> ty ~ 'Two 10 | 'Fls -> ty ~ 'Two 11 | ; ['Ifte b l r ] -> 12 | ( check@q. q!'Two. q!b. 13 | | check@q. q!ty. q!l. 14 | | check@q. q!ty. q!r. 15 | ) 16 | } 17 | 18 | exec check@p. p!'One. p!['Ifte 'Tru 'One 'One]. -------------------------------------------------------------------------------- /test/parse-fail-3.act: -------------------------------------------------------------------------------- 1 | syntax { 'Type = ['Enum ['One 'Two]] 2 | ; 'Term = ['EnumOrTag ['One 'Tru 'Fls] 3 | [['Ifte 'Term 'Term 'Term]]] 4 | } 5 | 6 | check : ?'Type. ?'Term. 7 | check@p = p?ty. p?t. case t 8 | { 'One -> ty ~ 'One 9 | ; 'Tru -> ty ~ 'Two 10 | ; 'Fls -> ty ~ 'Two 11 | ; ['Ifte b l r ] -> 12 | ( check q. q!'Two. q!b. 13 | | check@q. q!ty. q!l. 14 | | check@q. q!ty. q!r. 15 | ) 16 | } 17 | 18 | exec check@p. p!'One. p!['Ifte 'Tru 'One 'One]. -------------------------------------------------------------------------------- /test/parse-fail.act: -------------------------------------------------------------------------------- 1 | syntax { 'Type = ['Enum ['One 'Two]] 2 | ; 'Term = ['EnumOrTag ['One 'Tru 'Fls] 3 | [['Ifte 'Term 'Term 'Term]]] 4 | } 5 | 6 | check : ?'Type. ?'Term 7 | check@p = p?ty. p?t. case t 8 | { 'One -> ty ~ 'One 9 | ; 'Tru -> ty ~ 'Two 10 | ; 'Fls -> ty ~ 'Two 11 | ; ['Ifte b l r ] -> 12 | ( check@q. q!'Two. q!b. 13 | | check@q. q!ty. q!l. 14 | | check@q. q!ty. q!r. 15 | ) 16 | } 17 | 18 | exec check@p. p!'One. p!['Ifte 'Tru 'One 'One]. -------------------------------------------------------------------------------- /test/plumbing.act: -------------------------------------------------------------------------------- 1 | -- trace { exec } 2 | 3 | syntax { 'Msg = ['Enum ['Ping 'Pong]] } 4 | 5 | ping : ?'Atom. !'Msg. ?'Msg. 6 | pong : ?'Atom. ?'Msg. !'Msg. 7 | 8 | ping@p = p?a. PRINTF "Ping %i" a. p!'Ping. p?m. case m 9 | { 'Pong -> PRINTF "Done %i" a. 10 | ; x -> # "Expected Pong; got %i" x 11 | } 12 | pong@p = p?a. p?m. case m 13 | { 'Ping -> PRINTF "Pong %i" a. p!'Pong. 14 | ; _ -> # "Expected Ping" 15 | } 16 | 17 | manual : ?'Atom. 18 | manual@p = p?a. ping@q. q!a. pong@r. r!a. q?m. r!m. r?n. q!n. 19 | 20 | plumbed : ?'Atom. 21 | plumbed@p = p?a. 22 | ( ping@q. q!a. pong@r. r!a. q <-> r 23 | | ping@q. q!a. pong@r. r!a. r <-> q 24 | ) 25 | 26 | exec manual@p. p!'Manual. 27 | plumbed@q. q!'Plumbed. 28 | -------------------------------------------------------------------------------- /test/printing-open.act: -------------------------------------------------------------------------------- 1 | operator 2 | { (x : a) - 'id : a } 3 | 4 | operator 5 | { x : a - 'id ~> x 6 | ; x : a - 'id ~> 'hello 7 | } 8 | -------------------------------------------------------------------------------- /test/printing-open2.act: -------------------------------------------------------------------------------- 1 | typecheck \X x.x : ['Pi 'Semantics \A. ['Pi A \_.A]] 2 | 3 | typecheck \X x.X : ['Pi 'Semantics \A. ['Pi A \_.A]] -------------------------------------------------------------------------------- /test/printing.act: -------------------------------------------------------------------------------- 1 | syntax { 'Bool = ['Enum ['False 'True]] } 2 | 3 | operator { (x : X) - ['if (b : 'Bool)] : X } 4 | 5 | operator { t : Y - ['if 'True] ~> t } 6 | 7 | strict : $'Bool. 8 | strict@p = p?b. case $b 9 | { 'True -> PRINTF "Raw: %r\nInstantiated: %i\nNormalised: %n" b b b. 10 | ; 'False -> PRINTF "Raw: %r\nInstantiated: %i\nNormalised: %n" b b b. 11 | } 12 | 13 | exec 'Bool?b c. 14 | ( strict@p. (p!b. | b ~ 'True) 15 | | strict@q. (c ~ 'False | q!c - ['if b].) 16 | ) 17 | -------------------------------------------------------------------------------- /test/printing.flags: -------------------------------------------------------------------------------- 1 | --no-colour -------------------------------------------------------------------------------- /test/reduce-neutrals-2.act: -------------------------------------------------------------------------------- 1 | operator 2 | { (x : A) - ['fst (b : ['Enum ['True]])] : A 3 | ; (x : B) - ['snd (b : ['Enum ['True]])] : B 4 | } 5 | 6 | operator { x : X - ['fst b1] : _ - ['snd b2] ~> x - ['fst b1 - ['snd b2]] } 7 | 8 | exec (['Enum ['True]]?b1 b2. let a : 'Atom = 'at . a - ['fst b1] - ['snd b2] ~ a - ['fst b1 - ['snd b2]]) 9 | -------------------------------------------------------------------------------- /test/reduce-neutrals-2.flags: -------------------------------------------------------------------------------- 1 | --no-colour 2 | --tracing clause -------------------------------------------------------------------------------- /test/reduce-neutrals.act: -------------------------------------------------------------------------------- 1 | trace { clause } 2 | 3 | operator { (y : A) - ['if (b : ['Enum ['True]])] : A } 4 | 5 | operator { x : X - ['if b1] : _ - ['if b2] ~> x - ['if b1 - ['if b2]] } 6 | 7 | exec (['Enum ['True]]?b1 b2. let a : 'Atom = 'at. a - ['if b1] - ['if b2] ~ a - ['if b1 - ['if b2]]) 8 | -------------------------------------------------------------------------------- /test/reduce-neutrals.flags: -------------------------------------------------------------------------------- 1 | --no-colour 2 | --tracing clause -------------------------------------------------------------------------------- /test/reserved-keyword.act: -------------------------------------------------------------------------------- 1 | invalid: ?'Wildcard. 2 | invalid@p = p?t. case t 3 | { let -> } -------------------------------------------------------------------------------- /test/restarting.act: -------------------------------------------------------------------------------- 1 | -- trace { move } 2 | 3 | syntax { 'Msg = ['Enum ['Ping 'Pong]] } 4 | 5 | ping : ?'Atom.!'Msg. ?'Msg. 6 | pong : ?'Msg. !'Msg. 7 | 8 | ping@p = p?a. case a {'Hi -> PRINTF "Ping". p!'Ping. p?m. case m 9 | { 'Pong -> PRINTF "Done". 10 | ; x -> # "Expected Pong; got %i" x 11 | } ; _ -> # "Expected Hi; got %i" a } 12 | pong@p = p?m. case m 13 | { 'Ping -> PRINTF "Pong". p!'Pong. 14 | ; x -> # "Expected Ping; got %i" x 15 | } 16 | 17 | plumbed : 18 | plumbed@p = 19 | ping@q. pong@r. 'Atom?a. q!a. (q <-> r | a ~ 'Hi) 20 | 21 | exec plumbed@q. 22 | -------------------------------------------------------------------------------- /test/scope-fail.act: -------------------------------------------------------------------------------- 1 | test : 2 | test@p = \tl. 3 | case [hd tl] 4 | {} -------------------------------------------------------------------------------- /test/semanticPi.act: -------------------------------------------------------------------------------- 1 | 2 | exec ['Pi 'Wildcard \_. 'Wildcard]?t. case t 3 | { \ x. b -> PRINTF "%i" b. 4 | ; y -> PRINTF "Not pi: %i" y. 5 | } 6 | -------------------------------------------------------------------------------- /test/shadowed-pattern.act: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- This should probably be rejected, because it is confusing: the z in 4 | -- the body is a pattern variable, because the z from the lambda has 5 | -- been evicted from the scope. 6 | a : ?'Wildcard. 7 | a@p = p?x. case x { (\ z . {z*}z) -> PRINTF "the body is %r" z. } 8 | 9 | exec a@p. p!(\ x . 'bbb). 10 | -------------------------------------------------------------------------------- /test/shadowing-fail.act: -------------------------------------------------------------------------------- 1 | test : 2 | test@p = 'Wildcard?fst. case fst { [_ snd trd] -> \snd. } -------------------------------------------------------------------------------- /test/spop-fail.act: -------------------------------------------------------------------------------- 1 | source : !'Wildcard. 2 | source@p = p!{x*}[]. -------------------------------------------------------------------------------- /test/spop-top-fail.act: -------------------------------------------------------------------------------- 1 | source : !'Wildcard. 2 | source@p 3 | = \x. \y. source@q. q?t. 4 | let v : 'Wildcard = {y x}t. 5 | p!v. -------------------------------------------------------------------------------- /test/stlcDidNotWin.act: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- Syntax declarations 3 | 4 | syntax 5 | { 'Type = ['EnumOrTag ['Nat] 6 | [['Arr 'Type 'Type]] 7 | ] 8 | } 9 | 10 | syntax 11 | { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] 12 | ['Emb 'Synth] 13 | ]] 14 | ; 'Synth = ['Tag [ ['Ann 'Check 'Type] 15 | ['App 'Synth 'Check] 16 | ]] 17 | } 18 | 19 | ------------------------------------------------------------------------------ 20 | -- Interface 21 | 22 | type : $'Type. 23 | check : ?'Type. $'Check. 24 | synth : $'Synth. !'Type. 25 | 26 | -- | myCtxt maps synthesisable variables to types 27 | myCtxt |- 'Synth -> 'Type 28 | 29 | ------------------------------------------------------------------------------ 30 | -- Contract 31 | 32 | {type T} check T t {} 33 | {} synth t T {type T} 34 | 35 | {} myCtxt |- x -> T {synth x T} 36 | 37 | ------------------------------------------------------------------------------ 38 | -- Implementation 39 | 40 | type@p = p?ty. case $ty 41 | { 'Nat -> 42 | ; ['Arr S T] -> 43 | ( type@q. q!S. 44 | | type@r. r!T. 45 | ) 46 | } 47 | 48 | check@p = p?ty. p?tm. case $tm 49 | { ['Lam \x. body] -> 50 | 'Type?S T. 51 | ( ty ~ ['Arr S T] 52 | | \x. 53 | myCtxt |- x -> S. 54 | check@q. q!T. q!body.) 55 | ; ['Emb e] -> synth@q. q!e. q?S. S ~ ty 56 | } 57 | 58 | synth@p = p?tm . case (lookup myCtxt tm) 59 | { ['Just S] -> p!S. 60 | ; 'Nothing -> case $tm 61 | { ['Ann t ty] -> 62 | ( type@q. q!ty. 63 | | check@r. r!ty. r!t. 64 | | p!ty. 65 | ) 66 | ; ['App f s] -> 'Type?U V. p!V. 67 | ( synth@q. q!f. q?ty. ty ~ ['Arr U V] 68 | | check@r. r!U. r!s. 69 | ) 70 | } 71 | } 72 | 73 | 74 | ------------------------------------------------------------------------------ 75 | -- Examples 76 | 77 | exec check@p. 78 | p! ['Arr 'Nat ['Arr 'Nat 'Nat]]. -- type error, should be ['Arr 'Nat 'Nat]. 79 | p! ['Lam \z. ['Emb 80 | ['App ['Ann ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] 81 | ['Emb z]]]]. 82 | PRINTF "Done?". 83 | 84 | -------------------------------------------------------------------------------- /test/stlcDidNotWin.flags: -------------------------------------------------------------------------------- 1 | --no-colour 2 | -------------------------------------------------------------------------------- /test/stuckguard.act: -------------------------------------------------------------------------------- 1 | syntax { 'Nat = ['EnumOrTag ['Z] [['S 'Nat]]] } 2 | 3 | isNat : $'Nat. 4 | isNat@p = p?n. case $n 5 | { 'Z -> 6 | ; ['S m] -> 7 | PRINTF "%r\n%i\n%n" n n n. 8 | case m -- this will be stuck because m has not been validated 9 | { 'Z -> PRINTF "zero". 10 | ; ['S _] -> PRINTF "nonzero". 11 | } 12 | } 13 | 14 | exec isNat@p. p!['S ['S 'Z]]. 15 | {- PRINTF "%S". -} -------------------------------------------------------------------------------- /test/subject-as-pattern-fail.act: -------------------------------------------------------------------------------- 1 | syntax { 'Bool = ['Enum ['True 'False]] } 2 | 3 | foo : $'Bool. -- this should work 4 | foo@p = p?x. case [ $x x] 5 | { [ 'True | y@z ] -> 6 | ; [ 'False | y@z ] -> 7 | } 8 | 9 | fooFail : $'Bool. -- this should not work 10 | fooFail@p = p?x. case [ x $x] 11 | { [ 'True | y@z ] -> 12 | ; [ 'False | y@z ] -> 13 | } 14 | -------------------------------------------------------------------------------- /test/subject-scrutinising-fail.act: -------------------------------------------------------------------------------- 1 | syntax { 'Bool = ['Enum ['True 'False]] } 2 | 3 | not : $'Bool. !'Bool. 4 | not@p = p?b. case (compare b 'True) -- b not scrutinised 5 | { 'GT -> p!'True. 6 | ; _ -> p!'False. 7 | } 8 | 9 | silly : $'Bool. !'Bool. 10 | silly@p = p?b. case (compare 'True 'True) 11 | { 'EQ -> p!'True. -- inconsistent scrutinisation 12 | ; _ -> case $b 13 | { 'True -> p!'False. 14 | ; 'False -> p!'False. 15 | } 16 | } 17 | 18 | rejectedFake : $'Bool. !'Bool. 19 | rerejectedFake : $'Bool. !'Bool. 20 | 21 | rejectedFake @p = p?i. case $i { _ -> p!'True. } -- i not scrutinised 22 | rerejectedFake@p = p?i. p!'True. -- i not scrutinised 23 | 24 | deadcode : $'Bool. !'Bool. 25 | deadcode@p = p?i. # "Oops" -- should succeed subject checks 26 | 27 | 28 | impossible : $'Bool. !'Bool. 29 | impossible@p = p?b. case (compare 'True 'True) 30 | { 'EQ -> case $b 31 | { 'False -> p!'True. 32 | ; 'True -> p!'True. 33 | } 34 | ; c -> p!'True. -- Should fail; b not scrutinised 35 | } 36 | 37 | stack |- 'Bool -> 'Wildcard 38 | 39 | strictIsVar : $'Bool. !'Bool. -- should succeed 40 | strictIsVar@p = p?tm. case (lookup stack tm) 41 | { ['Just b] -> p!'True. 42 | ; 'Nothing -> case $tm { 'True -> p!'False. 43 | ; 'False -> p!'False. } 44 | } 45 | 46 | isVar : $'Bool. !'Bool. 47 | isVar@p = p?tm. case (lookup stack tm) 48 | { ['Just b] -> p!'True. 49 | ; 'Nothing -> p!'False. -- should fail; tm not scrutinised 50 | } 51 | 52 | strictIsVarCombo : $'Bool. !'Bool. -- should ideally work 53 | strictIsVarCombo@p = p?tm. case ([ lookup stack tm | $tm ]) 54 | { [ ['Just b] | x ] -> p!'True. 55 | ; [ _ | 'False ] -> p!'False. 56 | ; [ _ | 'True ] -> p!'False. 57 | } 58 | 59 | sillyId : $'Bool. !'Bool. -- works just fine 60 | sillyId@p = p?tm. case [ $tm | tm ] 61 | { ['True | _ ] -> p!'True. 62 | ; ['False | _ ] -> p!'False. 63 | } 64 | 65 | renamingSubjects : $'Wildcard. !'Wildcard. 66 | renamingSubjects@p = p?t. case $t 67 | { \ x y . body -> \ z. renamingSubjects@q. q!{x=z, y=z}body. p <-> q -- should not be considered a sent subject, as it only treats the diagonal -- not general enough 68 | ; u -> renamingSubjects@q. q!u. p <-> q -- does not terminate (don't run!) 69 | } 70 | -------------------------------------------------------------------------------- /test/syntax-fail.act: -------------------------------------------------------------------------------- 1 | syntax { 'Type = ['Enum ['Zro 'One]] 2 | ; 'Term = ['EnumOrTag ['Zro 'One] 3 | [['Suc 'Term]]] 4 | ; 'Type = ['Tag [['Pair 'Type 'Type]]] 5 | } -------------------------------------------------------------------------------- /test/syntaxcat-fail.act: -------------------------------------------------------------------------------- 1 | syntax { 'Tic = ['Enum ['Tic]] 2 | ; 'Tac = ['Enum ['Tac]] 3 | } 4 | 5 | test : 6 | test@p = 'Tic?a. 'Tac?b. [a b] ~ [b a] -------------------------------------------------------------------------------- /test/toonice.act: -------------------------------------------------------------------------------- 1 | syntax { 'Input = ['Enum ['Valid 'Invalid]] 2 | ; 'Bool = ['Enum ['True 'False]] 3 | } 4 | 5 | toonice : $'Input. !'Bool. 6 | toonice@p = p?i. p!'True. 7 | 8 | thorough : $'Input. !'Bool. 9 | thorough@p = p?i. case $i 10 | { 'Invalid -> p!'False. 11 | ; 'Valid -> p!'True. 12 | } 13 | -------------------------------------------------------------------------------- /test/two-fail.act: -------------------------------------------------------------------------------- 1 | test : 2 | test@p = (# "left" 3 | |# "right" ) 4 | 5 | exec test@p. -------------------------------------------------------------------------------- /test/two-fail.flags: -------------------------------------------------------------------------------- 1 | --no-colour -------------------------------------------------------------------------------- /test/type-projection.act: -------------------------------------------------------------------------------- 1 | operator 2 | { (x : c) - 'typeOf : 'Semantics 3 | ; x : a - 'typeOf ~> a 4 | } 5 | 6 | syntax { 'Bool = ['Enum ['T 'F]] } 7 | 8 | exec 'Bool?b. PRINTF "The type of %r is %n" b (b - 'typeOf). 9 | -------------------------------------------------------------------------------- /test/typecheck.act: -------------------------------------------------------------------------------- 1 | typecheck 'Semantics : 'Semantics 2 | 3 | syntax { 4 | 'Nat = ['EnumOrTag ['Zero] [['Suc 'Nat]]] 5 | } 6 | 7 | typecheck 'Nat : 'Semantics 8 | typecheck 'Zero : 'Nat 9 | typecheck ['Suc 'Zero] : 'Nat 10 | 11 | typecheck ['Pi 'Nat \_.'Nat] : 'Semantics 12 | typecheck \x.x : ['Pi 'Nat \_.'Nat] 13 | typecheck \x.'Zero : ['Pi 'Nat \_.'Nat] 14 | 15 | typecheck ['Pi 'Semantics \X.['Pi X \_.X]] : 'Semantics 16 | typecheck \X x.x : ['Pi 'Semantics \X.['Pi X \_.X]] 17 | 18 | operator 19 | { (n : 'Nat) -[ 'add (m : 'Nat) ] : 'Nat 20 | ; (n : 'Nat) -[ 'mul (m : 'Nat) ] : 'Nat 21 | } 22 | 23 | -- TODO: improve error message for: 24 | -- \x.'Zero : ['Pi 'Nat \_.'Nat] -[ 'mul m ] ~> 'Zero 25 | 26 | operator 27 | { 'Zero : 'Nat -[ 'add n ] ~> n 28 | ; ['Suc m] : 'Nat -[ 'add n ] ~> ['Suc m -['add n]] 29 | 30 | ; 'Zero : 'Nat -[ 'mul n ] ~> 'Zero 31 | ; ['Suc m] : 'Nat -[ 'mul n ] ~> n -['add m -['mul n]] 32 | ; m : 'Nat -['add n ] : 'Nat -['mul p ] 33 | ~> (m -['mul p]) -['add (n -['mul p ])] 34 | } 35 | 36 | operator 37 | { (f : ['Pi a \x.b]) -['apply (t : a)] : {x=t}b 38 | ; (f : ['Pi a \x.b]) -['apply2 (x : a)] : b 39 | } 40 | 41 | operator 42 | { f : ['Pi 'Nat \_.'Nat] -[ 'apply t ] ~> 'Zero } 43 | 44 | exec PRINTF "Hurrah!". 45 | -------------------------------------------------------------------------------- /test/unfinished.act: -------------------------------------------------------------------------------- 1 | duplicate : ?'Wildcard. !'Wildcard. 2 | driver : ?'Wildcard. ?'Wildcard. 3 | stuck : ?'Wildcard. ?'Wildcard. 4 | 5 | duplicate@p = p?a. p![a a]. 6 | 7 | driver@p = p?a. 8 | duplicate@q. q!a. q?aa. 9 | stuck@r. r!aa. r <-> p 10 | 11 | stuck@p = p?a. p?b. 12 | duplicate@q. q!b. q?bb. 13 | a ~ bb 14 | 15 | exec driver@p. p!'a. p!'b. -------------------------------------------------------------------------------- /test/unfinished.flags: -------------------------------------------------------------------------------- 1 | --no-colour -------------------------------------------------------------------------------- /test/unsolved-meta.act: -------------------------------------------------------------------------------- 1 | exec 'Wildcard?s t u. s ~ t -------------------------------------------------------------------------------- /typos.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | name: typos 4 | version: 0.1.0.0 5 | author: Conor McBride, 6 | Fredrik Nordvall Forsberg, 7 | Guillaume Allais, 8 | Georgi Nakov, 9 | Craig Roy 10 | 11 | build-type: Simple 12 | extra-source-files: README.md 13 | 14 | common haskell 15 | default-extensions: DataKinds, 16 | DeriveTraversable, 17 | FlexibleContexts, 18 | FlexibleInstances, 19 | GeneralizedNewtypeDeriving, 20 | LambdaCase, 21 | MultiParamTypeClasses, 22 | NamedFieldPuns, 23 | RankNTypes, 24 | RecordWildCards, 25 | ScopedTypeVariables, 26 | StandaloneDeriving, 27 | TupleSections, 28 | TypeFamilies, 29 | TypeSynonymInstances 30 | 31 | library 32 | import: haskell 33 | exposed-modules: Actor, 34 | Actor.Display, 35 | Alarm, 36 | ANSI, 37 | Bwd, 38 | Command, 39 | Concrete.Base, 40 | Concrete.Parse, 41 | Concrete.Pretty, 42 | Display, 43 | Doc.Annotations, 44 | Elaboration, 45 | Elaboration.Monad, 46 | Elaboration.Pretty, 47 | Forget, 48 | Format, 49 | Hide, 50 | Info, 51 | LaTeX, 52 | Location, 53 | Machine, 54 | Machine.Base, 55 | Machine.Display, 56 | Machine.Exec, 57 | Machine.Matching, 58 | Machine.Steps, 59 | Machine.Trace, 60 | Main, 61 | Operator, 62 | Operator.Eval, 63 | Options, 64 | Parse, 65 | Pattern, 66 | Pattern.Coverage, 67 | Pretty, 68 | Scope, 69 | Semantics, 70 | Syntax, 71 | Syntax.Debug, 72 | Term, 73 | Term.Base, 74 | Term.Display, 75 | Term.Mangler, 76 | Term.Substitution, 77 | Thin, 78 | Unelaboration.Monad, 79 | Unelaboration, 80 | Utils, 81 | Vector 82 | 83 | build-depends: base <5 84 | , containers 85 | , filepath 86 | , mtl 87 | , optparse-applicative 88 | , pretty-compact 89 | , terminal-size 90 | , these 91 | hs-source-dirs: Src 92 | default-language: Haskell2010 93 | ghc-options: -Wunused-imports 94 | -- -fwarn-incomplete-patterns 95 | 96 | executable typos 97 | import: haskell 98 | main-is: Src/Main.hs 99 | build-depends: base <5 100 | , mtl 101 | , filepath 102 | , containers 103 | , optparse-applicative 104 | , pretty-compact 105 | , terminal-size 106 | , typos 107 | default-language: Haskell2010 108 | 109 | test-suite typos-tests 110 | type: exitcode-stdio-1.0 111 | hs-source-dirs: test/ 112 | main-is: Test/Main.hs 113 | build-depends: base <5 114 | , directory 115 | , filepath 116 | , tasty 117 | , tasty-silver 118 | build-tool-depends: typos:typos 119 | default-extensions: RecordWildCards, OverloadedStrings 120 | default-language: Haskell2010 121 | ghc-options: -Wunused-imports 122 | --------------------------------------------------------------------------------