├── .gitignore ├── LICENSE ├── README.md └── src ├── B.hs ├── R.hs └── Tm.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2018, Conor McBride 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Saturday 2 | being a thing I build on a Saturday 3 | 4 | 5 | ## What is it? 6 | 7 | It's a kind of revisionist LISP, with a bidirectional dependent type 8 | system. The implementation uses a *co-de-Bruijn* representation of 9 | terms: that's a nameless representation where variables are thrown out 10 | of scope at the *earliest* moment they're known to be unused (where 11 | *de Bruijn* representations of terms delay observations of non-use to 12 | the leaves of the syntax tree where we decide to use one variable and 13 | thus not the others). 14 | 15 | So far, I have a parser, an implementation of beta-reduction, a 16 | type-directed equality, and a typechecker for Pi-types. More will 17 | follow. The implementation of substitution should be good also for 18 | metavariable instantiation in construction by refinement. 19 | 20 | 21 | ## Concrete Syntax 22 | 23 | *construction* ::= *atom* | `(` *constructions* `)` | 24 | `[` *constructions* `]` | `\` *atom* *construction* | `{` *elimination* `}` 25 | 26 | *constructions* ::= | *construction* *constructions* | `,` 27 | *construction* 28 | 29 | *elimination* ::= *atom* | *elimination* *construction* | `{` 30 | *construction* `:` *construction* `}` 31 | 32 | *atom* ::= (*alpha* | *digit* | *symbol*)+ 33 | 34 | *alpha* ::= `A` | .. | `Z` | `a` | .. | `z` 35 | 36 | *digit* ::= `0` | .. | `9` 37 | 38 | *symbol* ::= `_` | `-` | `<` | `=` | `>` | `*` | `'` 39 | 40 | Atoms are used both as tags in constructions and as variables in 41 | eliminations. Brackets `[`..`]` mark the unrolling of syntactic 42 | fixpoints, and they typically contain right-nested null-terminated 43 | sequences of pairs, often with an atom at their head. Types, in 44 | particular, take that form. Abstractions, `\` *x* *t*, do not need 45 | parentheses, because they abstract exactly one variable and there 46 | are enough delimiters around to avoid ambiguity. 47 | 48 | Function types look like 49 | 50 | [Pi {S} \ s {T {s}}] 51 | 52 | Universes look like 53 | 54 | [Type {sort}] 55 | 56 | The joy of LISP is that I can add stuff to the language without 57 | changing its concrete syntax. Or rather, the *actual* concrete 58 | syntax is how you make stuff out of the LISP-like components. 59 | 60 | There is an 61 | [attoparsec](https://hackage.haskell.org/package/attoparsec-0.13.2.2/docs/Data-Attoparsec-Text.html) 62 | parser and an uglyprinter for this syntax in the engigmatically named [R.hs](src/R.hs) 63 | file. 64 | 65 | 66 | ## Co-de-Bruijn Representation 67 | 68 | The essence of co de Bruijn representation is to be explicit about 69 | *thinning*, or *order-preserving embedding* (`OPE`), embedding smaller 70 | scopes into larger scopes. Or, advancing from the root of a term, 71 | thinnings can be seen as expelling unused variables from scope. 72 | 73 | The basic machinery can be found in [B.hs](src/B.hs) for backward 74 | lists and bit-twiddling. 75 | 76 | In this development, `OPE` is not indexed over source and target 77 | scopes, as I often do in Agda. Rather, 78 | 79 | type OPE = Integer 80 | 81 | which is being misused as a representation of bit vectors. The bit at 82 | the little end tells you the fate of the most local variable (1 to 83 | keep it, 0 to throw it away); the next bit left tells you about the 84 | next-to-most-local, and so on. We may safely ignore the 'instructions' 85 | a thinning gives us about variables which aren't in scope, so we must 86 | identify them up to their least *n* significant bits when there are 87 | *n* variables in scope. 88 | 89 | The operation 90 | 91 | ( Int -> Int 92 | 93 | computes the number of variables in the domain of a thinning (or how 94 | may are not expelled), given how many there are in the range. Its 95 | friend 96 | 97 | ( Bwd x -> Bwd x 98 | 99 | computes the selection of a snoc-list given by a thinning. Morally, 100 | that extends vectors to a contravariant functor from thinnings to 101 | Set (i.e. an embedding from n to m tells you how to choose n things from m). 102 | 103 | Two's complement representation now comes in handy: -1 is the identity 104 | thinning (`oi`), with all bits set; 0 is the empty thinning (`oe`), 105 | discarding all variables. Thinnings are extended by two operations 106 | which decide the fate of some newly bound top variable: successor 107 | (`os`) retains it, and that's double-and-add-one; skipping (`o'`) 108 | discards it, and that's just doubling. Note that `oi` is the fixpoint 109 | of `os` and `oe` the fixpoint of `o'`. 110 | 111 | Composition of thinnings is a funny old operation. I write it 112 | *diagrammatically*, so θ `<<` φ means thinning by 113 | θ, then by φ, or expelling by φ then θ, if you 114 | take a rootist view. You can read the bits of φ (from the little 115 | end) as instructions for processing θ from the little end 116 | to construct the composite: 0 means 'insert 0, retaining θ', 1 117 | means 'move the next bit from θ'. 118 | 119 | (<<) :: OPE -> OPE -> OPE 120 | ai << (-1) = ai 121 | ai << 0 = oe 122 | (-1) << bi = bi 123 | 0 << bi = oe 124 | ai << bi = case bout bi of 125 | (bi, False) -> o' (ai << bi) 126 | (bi, True) -> case bout ai of 127 | (ai, a) -> (ai << bi) <\ a 128 | 129 | bout :: OPE -> (OPE, Bool) 130 | bout i = (shiftR i 1, testBit i 0) 131 | 132 | (<\) :: OPE -> Bool -> OPE 133 | i <\ False = shiftL i 1 134 | i <\ True = shiftL i 1 .|. bit 0 135 | 136 | We then do a lot of work with the type of *relevant* things 137 | 138 | data Re t = t :^ OPE deriving Show 139 | 140 | where *t* `:^` θ is intended to store *t*s which are sure to 141 | use all of the variables that θ has not thrown away. 142 | 143 | The crucial data structure is the *pair relevant* 144 | 145 | type PR s t = (Re s, Re t) 146 | 147 | where the key invariant is that the thinnings in each component of the 148 | pair cover the whole of the scope between them: if neither component 149 | want to use a given variable, it should have been expelled earlier. 150 | Given two thinnings, θ and φ, we can compute the thinnings which 151 | make θ `.|.` φ a *pushout*, embedding the subscopes selected 152 | by each thinning into their union. 153 | 154 | psh :: OPE -> OPE -> (OPE, OPE) 155 | 156 | This construction is exactly what we need to compute relevant pairing: 157 | 158 | pR :: Re s -> Re t -> Re (PR s t) 159 | pR (s :^ ai) (t :^ bi) = (s :^ ai', t :^ bi') :^ (ai .|. bi) where 160 | (ai', bi') = psh ai bi 161 | 162 | Constants embed directly, with no variables relevant. 163 | 164 | kR :: t -> Re t 165 | kR t = t :^ oe 166 | 167 | A *spine* is a snoc-list made by relevant pairing. 168 | 169 | data Sp x = S0 | SZ (PR (Sp x) x) deriving Show 170 | 171 | We may compute a backward list of relevant things from a relevant 172 | spine 173 | 174 | unSp :: Re (Sp x) -> Bwd (Re x) 175 | unSp (S0 :^ _) = B0 176 | unSp (SZ (xz, x) :^ ci) = unSp (xz ^<< ci) :\ (x ^<< ci) 177 | 178 | where the `^<<` operator post-composes a thinning 179 | 180 | (^<<) :: Re t -> OPE -> Re t 181 | (t :^ ai) ^<< bi = t :^ (ai << bi) 182 | 183 | without touching the underlying thing. 184 | 185 | Variables are trivial, because by the time you use one, there should 186 | be only one variable in scope. 187 | 188 | xR :: Int -> Re () 189 | xR i = () :^ bit i 190 | 191 | To construct bindings, we must say *how many* variables are bound, 192 | then immediately, *which* are relevant. 193 | 194 | data Bn t = (Int, OPE) :\\ t deriving Show 195 | 196 | We may then define the simultaneous abstraction: 197 | 198 | (\\) :: Int -> Re t -> Re (Bn t) 199 | n \\ (t :^ ci) = ((n, bi) :\\ t) :^ ai where (ai, bi) = bouts n ci 200 | 201 | where `bouts` *n* is the operation that comes out from under *n* 202 | binders, splitting a thinning into its free and bound components. 203 | 204 | bouts :: Int -> OPE -> (OPE, OPE) 205 | bouts n i = (shiftR i n, i .&. (2 ^ n - 1)) 206 | 207 | With constants and pairing, abstraction and usage, we have all the 208 | tools to build syntax trees. 209 | 210 | 211 | ## Abstract Syntax 212 | 213 | The file [Tm.hs](src/Tm.hs) contains the definition of the abstract 214 | syntax, and pretty much the rest of the workings (so it is sure to 215 | get split in due course). 216 | 217 | Constructions are as follows, 218 | 219 | data TC 220 | = A A -- atom a 221 | | V -- void () 222 | | P (PR TC TC) -- pair (car, cdr) 223 | | I TC -- inductive wrapping [stuff..] 224 | | L (Bn TC) -- lambda, never nullary, never nested \ x t 225 | | E TE -- elimination {elim..} 226 | deriving Show 227 | 228 | defined mutually with eliminations 229 | 230 | data TE 231 | = X (PR () (Sp (Bn TE))) -- use of (meta)variable, with spine of parameters 232 | | Z (PR TE TC) -- zapping something with an eliminator 233 | | T (PR TC TC) -- type annotation {term : Type} 234 | deriving Show 235 | 236 | The next step is to define the extraction of relevant terms from raw 237 | terms. Now, in Constructive Engine style, that ought to be done at the 238 | same time as typechecking. That's to say, we should represent only 239 | trusted terms in the abstract syntax. But I'm a wrong'un in a hurry. 240 | All that's needed to fuel the construction is the names (and parameter 241 | info) for the (meta)variables in scope. 242 | 243 | I should say something about metavariables and spines. The *object* 244 | variables of the calculus, bound with `L`, are usable as eliminations 245 | with an empty spine. However, this syntax also allows us to invoke 246 | *meta*variables, which live at the global end of scope and will be 247 | bound by the *proof state*. Metavariables can be hereditarily 248 | parametrised, and their parameters must be instantiated at usage 249 | sites, which is why variables take a spine. 250 | 251 | Making object variables the boring special case of metavariables means 252 | that we may use the same machinery (*hereditary substitution*) for 253 | hole-filling as well as for yer basic β-reduction. 254 | 255 | 256 | ## Simultaneous Hereditary Substitution 257 | 258 | In [B.hs](src/B.hs), I define a notion of 259 | morphism from a source scope to a target scope, keeping track of 260 | 261 | * which source variables are being overwritten 262 | * which target terms are overwriting them 263 | * how to embed the left variables into the target scope 264 | 265 | But not necessarily in that order (as I keep the left variables to the left): 266 | 267 | data Morph t = Morph {left :: OPE, write :: OPE, images :: Bwd (Re t)} 268 | deriving Show 269 | 270 | Now, we can refine a substitution down to those source variables which 271 | survive a thinning. 272 | 273 | (<%) :: OPE -> Morph t -> Morph t 274 | bi <% Morph th ps sz = Morph (th0 << th) bi0 (ps0 OPE -> (OPE, OPE) 281 | 282 | computes the embedding into two subscopes from their intersection, 283 | which tells you how to thin the variables which remain for thinning 284 | and which substitution images can be thrown away. The ` (Int, OPE) -> Morph t 291 | Morph th ps sz %+ (n, bi) = 292 | Morph (bins th n bi) (shiftL ps (bi Re t -> Re t 299 | wks n (t :^ bi) = t :^ shiftL bi n 300 | 301 | We need to left-shift the `write` selector by the number of new source 302 | variables, as none of them is being written. Correspondingly, we need 303 | to extend the thinning for the `left` variables into the target 304 | context with exactly the information from the binder. 305 | 306 | bins :: OPE -> Int -> OPE -> OPE 307 | bins ai n bi = shiftL ai n .|. (bi .&. (2 ^ n - 1)) 308 | 309 | What's pleasing is that we've got as far as pushing morphisms under 310 | binders without saying anything about the syntax at all. Unlike de 311 | Bruijn representations, we don't need to go all the way to the leaves 312 | to thin a substitution ready for use under a binder, because the 313 | substitution images carry a thinning at their root. 314 | 315 | Now we arrive in [Tm.hs](src/Tm.hs), and we choose substitution images 316 | to be binding forms, allowing metavariable instantiation to abstract 317 | over parameters. 318 | 319 | type HSub = Morph (Bn TE) 320 | 321 | I introduce a type class for things which admit hereditary 322 | substitution, mostly to try to make each mistake only once. 323 | 324 | class HSUB t where 325 | hs, hsGo :: HSub -> t -> Re t 326 | hs (Morph bi _ B0) t = t :^ bi 327 | hs sb t = hsGo sb t 328 | 329 | Things to note: 330 | 331 | * The `t` being substituted should use everything in scope so the 332 | morphism should have no junk in it. 333 | * A substitution does not promise to use all the target variables 334 | available, so the output needs a `Re`. 335 | * Accordingly, we know that if *none* of the variables is being 336 | written, they are all being left, which we do by action at the 337 | root. 338 | * The wrapper `hs` tests for whether a substitution and calls the 339 | worker `hsGo` only if there is work to do. 340 | * Instances should define only `hsGo`. Recursive calls should be to 341 | `hs` if the scope gets smaller, but `hsGo` if it stays the same or 342 | grows under a binder: if we were hunting a free variable before, 343 | we still are, now. 344 | * Although it potentially avoids vast swaths of closed term, we are 345 | still proceeding at a trundle. The notorious *underground* 346 | representation might improve things, allowing us to barrel along a 347 | network of *tubes* (closed one-hole contexts) between the interesting 348 | choice points. 349 | 350 | The action is in the `TE` instance, and specifically in the `X` case 351 | 352 | hsGo sb (X (() :^ x, sp :^ ai)) = case x <% sb of 353 | Morph y _ B0 -> fmap X (pR (() :^ y) (hs (ai <% sb) sp)) 354 | Morph _ _ (_ :\ pv) -> stan pv (hs (ai <% sb) sp) 355 | 356 | where we know that `x` is a singleton thinning, so refining the 357 | substitution by it will tell us pretty directly whether the variable 358 | gets substituted or not. If not, we have just the singleton we need 359 | to build the target. But if it's time to write, we need to turn the 360 | spine of (substituted) parameters into the hereditary substitution 361 | which instantiates the formal parameters if the image. 362 | 363 | stan :: HSUB t => Re (Bn t) -> Re (Sp (Bn TE)) -> Re t 364 | stan (((n, bi) :\\ t) :^ th) sp = 365 | hs (Morph th (bins oe (bi Re TC -> Re TC 391 | rnfE :: Cx -> Re TE -> (Re TE, Re TC) 392 | 393 | where the latter does type reconstruction, which is why both need to 394 | know the *context*. However, `rnfC` does *not* need to know the *type* 395 | of the thing being reduced exactly because we do not go under binders, 396 | so we need never *extend* the context. 397 | 398 | Now, there is something funny going on. If we were doing only 399 | β-reduction, we would not even need to do type reconstruction, 400 | because the bidirectional discipline ensures that every β-redex 401 | makes the active type *explicit*: we do not need to reconstruct the 402 | types of neutral terms exactly because they're not going to compute 403 | anyway. However, some type theories (notably, *cubical* type theories) 404 | have reduction rules which eliminate neutral terms to canonical values 405 | when their *types* tell us enough information (e.g., projecting an 406 | *endpoint* from a path whose type specifies the values at the ends). 407 | Type reconstruction for eliminations is not hard, and if we want such 408 | type-directed behaviour, we have to do it to stay Geuvers. 409 | 410 | 411 | ## Type Checking and Synthesis 412 | 413 | For constructions, we have 414 | 415 | chk :: Cx -- context 416 | -> Re TC -- type to check, already in rnf 417 | -> Re TC -- candidate inhabitant 418 | -> Maybe () -- well, did ya? 419 | 420 | and for eliminations 421 | 422 | syn :: Cx -- context 423 | -> Re TE -- elimination for which to synthesize type 424 | -> Maybe (Re TC) -- synthesized type in rnf 425 | 426 | We have to be careful to enforce the rnf invariants (or else the 427 | typechecker will reject valid things for want of a little elbow 428 | grease). Where we `E`mbed eliminations into constructions, we have 429 | a clearly directed type comparison to do: the type we've got meets 430 | the type we want, so there is an opportunity for subtyping (which I 431 | propose to use for *cumulativity*, at least). 432 | 433 | subtype :: Cx -- context 434 | -> Re TC -- candidate subtype in rnf 435 | -> Re TC -- candidate supertype in rnf 436 | -> Maybe () -- well, did ya? 437 | 438 | Canonical type constructors have structural rules imposing suitable 439 | co- or contravariant conditions on their children. For stuck 440 | eliminations, we revert to an equality test. We have 441 | type-reconstructing equality for eliminations 442 | 443 | qE :: Cx -- context 444 | -> Re TE -- e the first in rnf 445 | -> Re TE -- e the second in rnf 446 | -> Maybe (Re TC) -- are they equal with a synthesized type in rnf 447 | 448 | and type-directed equality for constructions 449 | 450 | qC :: Cx -- context 451 | -> Re TC -- type in rnf 452 | -> Re TC -- t the first in rnf 453 | -> Re TC -- t the second in rnf 454 | -> Maybe () -- well, were they? 455 | 456 | which allows us to impose η-laws wherever convenient, and 457 | certainly for functions. η-expansion is easy in co-de-Bruijn 458 | syntax because thinning is laughably cheap. 459 | 460 | -------------------------------------------------------------------------------- /src/B.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, 2 | GeneralizedNewtypeDeriving #-} 3 | 4 | module B where 5 | 6 | import Data.Bits 7 | import Control.Arrow ((***)) 8 | 9 | data Bwd x = B0 | Bwd x :\ x deriving (Show, Eq, Functor, Foldable, Traversable) 10 | 11 | instance Monoid (Bwd x) where 12 | mempty = B0 13 | mappend xz B0 = xz 14 | mappend xz (yz :\ y) = mappend xz yz :\ y 15 | 16 | blen :: Bwd x -> Int 17 | blen B0 = 0 18 | blen (xz :\ _) = 1 + blen xz 19 | 20 | type OPE = Integer -- it used to be a newtype deriving (Show, Eq, Bits) 21 | 22 | (<\) :: OPE -> Bool -> OPE 23 | i <\ False = shiftL i 1 24 | i <\ True = shiftL i 1 .|. bit 0 25 | 26 | os, o' :: OPE -> OPE 27 | os = (<\ True) 28 | o' = (<\ False) 29 | 30 | bout :: OPE -> (OPE, Bool) 31 | bout i = (shiftR i 1, testBit i 0) 32 | 33 | bouts :: Int -> OPE -> (OPE, OPE) 34 | bouts n i = (shiftR i n, i .&. (2 ^ n - 1)) 35 | 36 | bins :: OPE -> Int -> OPE -> OPE 37 | bins ai n bi = shiftL ai n .|. (bi .&. (2 ^ n - 1)) 38 | 39 | qOPE :: Int -> OPE -> OPE -> Bool 40 | qOPE n i j = (i .&. m) == (j .&. m) where m = 2 ^ n - 1 41 | 42 | oe, oi :: OPE 43 | oe = 0 44 | oi = (-1) 45 | 46 | (<<) :: OPE -> OPE -> OPE 47 | ai << (-1) = ai 48 | ai << 0 = oe 49 | (-1) << bi = bi 50 | 0 << bi = oe 51 | ai << bi = case bout bi of 52 | (bi, False) -> o' (ai << bi) 53 | (bi, True) -> case bout ai of 54 | (ai, a) -> (ai << bi) <\ a 55 | 56 | ( Int -> Int 57 | (-1) Bwd x -> Bwd x 65 | (-1) Re t -> Re t 75 | wks n (t :^ bi) = t :^ shiftL bi n 76 | 77 | instance Functor Re where 78 | fmap f (t :^ bi) = f t :^ bi 79 | 80 | (^<<) :: Re t -> OPE -> Re t 81 | (t :^ ai) ^<< bi = t :^ (ai << bi) 82 | 83 | kR :: t -> Re t 84 | kR t = t :^ oe 85 | 86 | jR :: Re (Re t) -> Re t 87 | jR ((t :^ ai) :^ bi) = t :^ (ai << bi) 88 | 89 | psh :: OPE -> OPE -> (OPE, OPE) 90 | psh (-1) bi = (oi, bi) 91 | psh ai (-1) = (ai, oi) 92 | psh 0 bi = (oe, oi) 93 | psh ai 0 = (oi, oe) 94 | psh ai bi = case (bout ai, bout bi) of 95 | ((ai, a), (bi, b)) -> 96 | (if a || b then (<\ a) *** (<\ b) else id) (psh ai bi) 97 | 98 | type PR s t = (Re s, Re t) 99 | 100 | pR :: Re s -> Re t -> Re (PR s t) 101 | pR (s :^ ai) (t :^ bi) = (s :^ ai', t :^ bi') :^ (ai .|. bi) where 102 | (ai', bi') = psh ai bi 103 | 104 | prjR :: Re (PR s t) -> (Re s, Re t) 105 | prjR ((s, t) :^ ci) = (s ^<< ci, t ^<< ci) 106 | 107 | xR :: Int -> Re () 108 | xR i = () :^ bit i 109 | 110 | data Bn t = (Int, OPE) :\\ t deriving Show 111 | (\\) :: Int -> Re t -> Re (Bn t) 112 | n \\ (t :^ ci) = ((n, bi) :\\ t) :^ ai where (ai, bi) = bouts n ci 113 | 114 | body :: Re (Bn t) -> Re t 115 | body (((n, bi) :\\ t) :^ ai) = t :^ bins ai n bi 116 | 117 | data Sp x = S0 | SZ (PR (Sp x) x) deriving Show 118 | 119 | unSp :: Re (Sp x) -> Bwd (Re x) 120 | unSp (S0 :^ _) = B0 121 | unSp (SZ (xz, x) :^ ci) = unSp (xz ^<< ci) :\ (x ^<< ci) 122 | 123 | (-\) :: Re (Sp x) -> Re x -> Re (Sp x) 124 | xz -\ x = fmap SZ (pR xz x) 125 | 126 | sp :: Bwd (Re x) -> Re (Sp x) 127 | sp B0 = kR S0 128 | sp (xz :\ x) = sp xz -\ x 129 | 130 | pll :: OPE -> OPE -> (OPE, OPE) 131 | pll (-1) bi = (bi, oi) 132 | pll ai (-1) = (oi, ai) 133 | pll 0 bi = (oe, oe) 134 | pll ai 0 = (oe, oe) 135 | pll ai bi = case (bout ai, bout bi) of 136 | ((ai, True), (bi, True)) -> (os *** os) (pll ai bi) 137 | ((ai, True), (bi, False)) -> (o' *** id) (pll ai bi) 138 | ((ai, False), (bi, True)) -> (id *** o') (pll ai bi) 139 | ((ai, False), (bi, False)) -> pll ai bi 140 | 141 | data Morph t = Morph {left :: OPE, write :: OPE, images :: Bwd (Re t)} 142 | deriving Show 143 | 144 | (<%) :: OPE -> Morph t -> Morph t 145 | bi <% Morph th ps sz = Morph (th0 << th) bi0 (ps0 (Int, OPE) -> Morph t 150 | Morph th ps sz %+ (n, bi) = 151 | Morph (bins th n bi) (shiftL ps (bi Text 32 | tC (At a) = a 33 | tC Vd = "()" 34 | tC (In (c :. d)) = T.concat ["[", tC c, tD d, "]"] 35 | tC (In d) = T.concat ["[", tD d, "]"] 36 | tC (Ld x c) = T.concat ["\\", x, " ", tC c] 37 | tC (Em e) = T.concat ["{", tE e, "}"] 38 | tC (c :. d) = T.concat ["(", tC c, tD d, ")"] 39 | 40 | tD :: RC -> Text 41 | tD Vd = "" 42 | tD (c :. d) = T.concat [" ", tC c, tD d] 43 | tD c = T.concat [", ", tC c] 44 | 45 | tE :: RE -> Text 46 | tE (x :# 0) = x 47 | tE (x :# i) = T.concat [x, "^", T.pack (show i)] 48 | tE (e :$ c) = T.concat [tE e, " ", tC c] 49 | tE (c :< d) = T.concat ["{", tC c, " : ", tC d, "}"] 50 | 51 | pC :: P.Parser RC -- assumes leading space has been consumed; leaves trailing space 52 | pC = id <$ P.char '(' <* skipSpace <*> pD <* skipSpace <* P.char ')' 53 | <|> In <$ P.char '[' <* skipSpace <*> pD <* skipSpace <* P.char ']' 54 | <|> Em <$ P.char '{' <* skipSpace <*> pE <* skipSpace <* P.char '}' 55 | <|> Ld <$ P.char '\\' <* skipSpace <*> pA <* skipSpace <*> pC 56 | <|> At <$> pA 57 | 58 | pD :: P.Parser RC 59 | pD = id <$ P.char ',' <* skipSpace <*> pC 60 | <|> (:.) <$> pC <* skipSpace <*> pD 61 | <|> pure Vd 62 | 63 | pA :: P.Parser A 64 | pA = takeWhile1 $ \ c -> 65 | isAlpha c || isDigit c || elem c ['_','-','<','=','>','*','\''] 66 | 67 | pE :: P.Parser RE 68 | pE = pH >>= pM 69 | 70 | pH :: P.Parser RE 71 | pH = (:<) <$ P.char '{' <* skipSpace <*> pC <* skipSpace <* 72 | P.char ':' <* skipSpace <*> pC <* skipSpace <* 73 | P.char '}' 74 | <|> (:#) <$> pA <*> (id <$ P.char '^' <*> decimal <|> pure 0) 75 | 76 | pM :: RE -> P.Parser RE 77 | pM e = (((e :$) <$ skipSpace <*> pC) >>= pM) <|> pure e 78 | -------------------------------------------------------------------------------- /src/Tm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances, 2 | PatternGuards #-} 3 | 4 | module Tm where 5 | 6 | import Control.Arrow ((***)) 7 | import Control.Monad 8 | import Data.Bits 9 | import R 10 | import B 11 | 12 | data TC 13 | = A A -- atom 14 | | V -- void 15 | | P (PR TC TC) -- pair 16 | | I TC -- inductive wrapping 17 | | L (Bn TC) -- lambda, never nullary, never nested 18 | | E TE -- elimination 19 | deriving Show 20 | 21 | data TE 22 | = X (PR () (Sp (Bn TE))) -- use of variable, with spine of parameters 23 | | Z (PR TE TC) -- zapping something with an eliminator 24 | | T (PR TC TC) -- type annotation 25 | deriving Show 26 | 27 | data Ki = Ki [Ki] 28 | 29 | rtC :: Bwd (A, Ki) -> RC -> Maybe (Re TC) 30 | rtC _ (At a) = return (kR (A a)) 31 | rtC _ Vd = return (kR V) 32 | rtC g (s :. t) = fmap P <$> (pR <$> rtC g s <*>rtC g t) 33 | rtC g (In t) = fmap I <$> rtC g t 34 | rtC g (Em e) = fmap E <$> rtE g e [] 35 | rtC g t = fmap L <$> ((n \\) <$> rtC g' t') where 36 | (n, g', t') = lu 0 g t 37 | lu n g (Ld x t) = lu (n + 1) (g :\ (x, Ki [])) t 38 | lu n g t = (n, g, t) 39 | 40 | rtX :: Bwd (A, Ki) -> A -> Int -> Maybe (Int, Ki) 41 | rtX B0 _ _ = Nothing 42 | rtX (g :\ (y, k)) x i 43 | | x == y = if i == 0 then Just (0, k) else rt' <$> rtX g x (i - 1) 44 | | otherwise = rt' <$> rtX g x i 45 | where rt' = succ *** id 46 | 47 | rtE :: Bwd (A, Ki) -> RE -> [RC] -> Maybe (Re TE) 48 | rtE g (e :$ t) ts = rtE g e (t : ts) 49 | rtE g (s :< t) ts = do 50 | e <- fmap T <$> (pR <$> rtC g s <*> rtC g t) 51 | rtZ e g ts 52 | rtE g (x :# i) ts = do 53 | (j, Ki ks) <- rtX g x i 54 | rtS (xR j) (kR S0) g ks ts 55 | 56 | rtS :: Re () -> Re (Sp (Bn TE)) -> Bwd (A, Ki) -> [Ki] -> [RC] -> Maybe (Re TE) 57 | rtS x tz g [] ts = rtZ (fmap X (pR x tz)) g ts 58 | rtS x tz g (Ki k : ks) (t : ts) = do 59 | t <- rtB g 0 k t 60 | rtS x (tz -\ t) g ks ts 61 | rtS _ _ _ _ _ = Nothing 62 | 63 | rtB :: Bwd (A, Ki) -> Int -> [Ki] -> RC -> Maybe (Re (Bn TE)) 64 | rtB g n [] (Em e) = (n \\) <$> rtE g e [] 65 | rtB g n (k : ks) (Ld x t) = rtB (g :\ (x, k)) (n + 1) ks t 66 | rtB _ _ _ _ = Nothing 67 | 68 | rtZ :: Re TE -> Bwd (A, Ki) -> [RC] -> Maybe (Re TE) 69 | rtZ e g [] = return e 70 | rtZ e g (t : ts) = do 71 | t <- rtC g t 72 | rtZ (fmap Z (pR e t)) g ts 73 | 74 | 75 | 76 | upsilon :: Re TE -> Re TC 77 | upsilon (T (t, _) :^ bi) = t ^<< bi 78 | upsilon e = fmap E e 79 | 80 | type HSub = Morph (Bn TE) 81 | 82 | class HSUB t where 83 | hs, hsGo :: HSub -> t -> Re t 84 | hs (Morph bi _ B0) t = t :^ bi 85 | hs sb t = hsGo sb t 86 | 87 | instance HSUB t => HSUB (Re t) where 88 | hsGo sb (t :^ bi) = hs (bi <% sb) t :^ oi 89 | 90 | instance (HSUB s, HSUB t) => HSUB (PR s t) where 91 | hsGo sb (s :^ ai, t :^ bi) = pR (hs (ai <% sb) s) (hs (bi <% sb) t) 92 | 93 | instance HSUB TC where 94 | hsGo sb (I t) = fmap I (hsGo sb t) 95 | hsGo sb (P st) = fmap P (hsGo sb st) 96 | hsGo sb (L t) = fmap L (hsGo sb t) 97 | hsGo sb (E e) = upsilon (hsGo sb e) 98 | 99 | instance HSUB TE where 100 | hsGo sb (X (() :^ x, sp :^ ai)) = case x <% sb of 101 | Morph y _ B0 -> fmap X (pR (() :^ y) (hs (ai <% sb) sp)) 102 | Morph _ _ (_ :\ pv) -> stan pv (hs (ai <% sb) sp) 103 | hsGo sb (Z et) = fmap Z (hsGo sb et) 104 | hsGo sb (T tT) = fmap T (hsGo sb tT) 105 | 106 | stan :: HSUB t => Re (Bn t) -> Re (Sp (Bn TE)) -> Re t 107 | stan (((n, bi) :\\ t) :^ th) sp = 108 | hs (Morph th (bins oe (bi HSUB (Sp t) where 111 | hsGo sb (SZ p) = fmap SZ (hsGo sb p) 112 | 113 | instance HSUB t => HSUB (Bn t) where 114 | hsGo sb (p@(n, _) :\\ e) = n \\ hsGo (sb %+ p) e 115 | 116 | 117 | ld :: Bn TC -> TC 118 | ld ((0, _) :\\ t) = t 119 | ld ((n, ai) :\\ L ((m, bi) :\\ t)) = L ((n + m, bins ai m bi) :\\ t) 120 | ld b = L b 121 | 122 | isL1 :: Re TC -> Maybe (Re (Bn TC)) 123 | isL1 (L ((0, _) :\\ t) :^ bi) = isL1 (t :^ bi) 124 | isL1 (L b@((1, _) :\\ _) :^ bi) = Just (b :^ bi) 125 | isL1 (L ((n, ai) :\\ t) :^ bi) = 126 | Just (((1, ci) :\\ ld (((n - 1), di) :\\ t)) :^ bi) where 127 | (ci, di) = bouts (n - 1) ai 128 | 129 | isL1 _ = Nothing 130 | 131 | type Cx = Bwd (Re (Bn TC)) 132 | 133 | rnfC :: Cx -> Re TC -> Re TC 134 | rnfC g z@(t :^ bi) = case t of 135 | I t -> fmap I (rnfC g (t :^ bi)) 136 | P st -> case prjR (st :^ bi) of 137 | (s, t) -> fmap P (pR (rnfC g s) (rnfC g t)) 138 | E e -> upsilon (fst (rnfE g (e :^ bi))) 139 | _ -> z 140 | 141 | rnfE :: Cx -> Re TE -> (Re TE, Re TC) 142 | rnfE g z@(e :^ bi) = case e of 143 | T tty -> case prjR (tty :^ bi) of 144 | (t, ty) -> let ty' = rnfC g ty 145 | in (radR (rnfC g t) ty', ty') 146 | X vs -> case prjR (vs :^ bi) of 147 | (() :^ x, sz) -> case x (z, rnfC g (stan pty sz)) 149 | Z es -> case prjR (es :^ bi) of 150 | (e, s) -> elim g (rnfE g e) (rnfC g s) 151 | 152 | radR :: Re TC -> Re TC -> Re TE 153 | radR t tT = fmap T (pR t tT) 154 | 155 | elim :: Cx -> (Re TE, Re TC) -> Re TC -> (Re TE, Re TC) 156 | elim g z@(e, ty) s = flip (,) ty' $ case isCan ty of 157 | Just ("Pi", [sS, tT]) | Just (f, _) <- isRad e, Just bt <- isL1 f -> 158 | radR (stan bt (tTspine s sS)) ty' 159 | _ -> fmap Z (pR e s) 160 | where 161 | ty' = elimTy g z s 162 | 163 | elimTy :: Cx -> (Re TE, Re TC) -> Re TC -> Re TC 164 | elimTy g (e, ty) s = case isCan ty of 165 | Just ("Pi", [sS, tT]) | Just bT <- isL1 tT -> 166 | stan bT (tTspine s sS) 167 | 168 | tTspine :: Re TC -> Re TC -> Re (Sp (Bn TE)) 169 | tTspine s sS = fmap SZ (pR (kR S0) (0 \\ radR s sS)) 170 | 171 | isRad :: Re TE -> Maybe (Re TC, Re TC) 172 | isRad (T tT :^ bi) = pure (prjR (tT :^ bi)) 173 | isRad _ = Nothing 174 | 175 | isList :: Re TC -> Maybe [Re TC] 176 | isList (V :^ _) = pure [] 177 | isList (P st :^ bi) = case prjR (st :^ bi) of 178 | (s, t) -> (s :) <$> isList t 179 | 180 | isCan :: Re TC -> Maybe (A, [Re TC]) 181 | isCan (I (P ct) :^ bi) = case prjR (ct :^ bi) of 182 | (A x :^ _, t) -> (,) x <$> isList t 183 | _ -> Nothing 184 | isCan _ = Nothing 185 | 186 | sortGt :: Re TC -> Re TC -> Maybe () 187 | sortGt _ _ = Just () -- bullshit, for now 188 | 189 | sortGe :: Re TC -> Re TC -> Maybe () 190 | sortGe _ _ = Just () -- bullshit, for now 191 | 192 | canQ :: Cx -> Re TC -> Re TC -> Maybe () 193 | canQ g i j = do 194 | (i, ss) <- isCan i 195 | (j, ts) <- isCan j 196 | guard (i == j) 197 | go ss ts 198 | where 199 | go [] [] = return () 200 | go (s : ss) (t : ts) = do 201 | canQ g (rnfC g s) (rnfC g t) 202 | go ss ts 203 | go _ _ = Nothing 204 | 205 | pushCx :: Cx -> Re TC -> (Cx -> Re TE -> t) -> t 206 | pushCx g sS k = 207 | k (fmap (^<< o' oi) (g :\ (0 \\ sS))) 208 | (fmap X (pR (xR 0) (kR S0))) 209 | 210 | isE :: Re TC -> Maybe (Re TE) 211 | isE (E e :^ bi) = Just (e :^ bi) 212 | isE _ = Nothing 213 | 214 | data Can 215 | = A :/ [Can] 216 | | Y (Re TC) 217 | 218 | can :: Can -> Re TC 219 | can (h :/ cs) = fmap (I . P) (pR (kR (A h)) (cans cs)) where 220 | cans [] = kR V 221 | cans (c : cs) = fmap P (pR (can c) (cans cs)) 222 | can (Y t) = t 223 | 224 | topSort :: Re TC 225 | topSort = can ("Type" :/ ["Type" :/ []]) 226 | 227 | chk :: Cx -- context 228 | -> Re TC -- type to check, already in rnf 229 | -> Re TC -- candidate inhabitant 230 | -> Maybe () -- well, did ya? 231 | chk g ty tm@(t :^ bi) = case (isCan ty, isCan tm) of 232 | (Just ("Type", [j]), Just ("Type", [i])) -> sortGt (rnfC g j) (rnfC g i) 233 | (Just ("Type", _), Just ("Pi", [sS, tT])) -> do 234 | bT <- isL1 tT 235 | chk g ty sS 236 | pushCx g sS $ \ g x -> chk g (wks 1 ty) (body bT) 237 | (Just ("Pi", [sS, tT]), _) | Just bt <- isL1 tm -> do 238 | bT <- isL1 tT 239 | pushCx g sS $ \ g x -> chk g (rnfC g (body bT)) (body bt) 240 | _ | Just e <- isE tm -> do 241 | sTy <- syn g e 242 | subtype g sTy ty 243 | _ -> Nothing 244 | 245 | syn :: Cx -- context 246 | -> Re TE -- elimination for which to synthesize type 247 | -> Maybe (Re TC) -- synthesized type in rnf 248 | syn g e | Just (tm, ty) <- isRad e = do 249 | chk g topSort ty 250 | chk g ty tm 251 | return (rnfC g ty) 252 | syn g (X xsz :^ bi) = do 253 | let (() :^ x, sz) = prjR (xsz :^ bi) 254 | let B0 :\ pty = x do 266 | chk g (rnfC g sS) s 267 | bT <- isL1 tT 268 | return (rnfC g (stan bT (tTspine s sS))) 269 | _ -> Nothing 270 | syn g e = Nothing 271 | 272 | subtype :: Cx -- context 273 | -> Re TC -- candidate subtype in rnf 274 | -> Re TC -- candidate supertype in rnf 275 | -> Maybe () -- well, did ya? 276 | subtype g s t = case (isCan s, isCan t) of 277 | (Just ("Type", [i]), Just ("Type", [j])) -> 278 | sortGe (rnfC g j) (rnfC g i) 279 | (Just ("Pi", [sS, sT]), Just ("Pi", [tS, tT])) -> do 280 | subtype g (rnfC g tS) (rnfC g sS) 281 | bsT <- isL1 sT 282 | btT <- isL1 tT 283 | pushCx g tS $ \ g x -> subtype g (rnfC g (body bsT)) (rnfC g (body btT)) 284 | _ -> do 285 | sE <- isE s 286 | tE <- isE t 287 | _ <- qE g sE tE 288 | return () 289 | 290 | qE :: Cx -- context 291 | -> Re TE -- e the first in rnf 292 | -> Re TE -- e the second in rnf 293 | -> Maybe (Re TC) -- are they equal with a synthesized type in rnf 294 | qE g e0 e1 | Just (tm, ty) <- isRad e0, Just e <- isE tm = qE g e e1 295 | qE g e0 e1 | Just (tm, ty) <- isRad e1, Just e <- isE tm = qE g e0 e 296 | qE g e@(X xsz :^ ai) (X ytz :^ bi) = case (prjR (xsz :^ ai), prjR (ytz :^ bi)) of 297 | ((() :^ x, sz :^ ai), (() :^ y, tz :^ bi)) -> do 298 | guard (qOPE (blen g) x y) 299 | -- compare spines 300 | syn g e 301 | qE g (Z es0 :^ ai) (Z es1 :^ bi) = case (prjR (es0 :^ ai), prjR (es1 :^ bi)) of 302 | ((e0, s0), (e1, s1)) -> do 303 | ty <- qE g e0 e1 304 | case isCan ty of 305 | Just ("Pi", [sS, tT]) -> do 306 | let sS' = rnfC g sS 307 | let s0' = rnfC g s0 308 | qC g sS' s0' (rnfC g s1) 309 | bT <- isL1 tT 310 | return (rnfC g (stan bT (tTspine s0' sS'))) 311 | _ -> Nothing 312 | qE _ _ _ = Nothing 313 | 314 | qC :: Cx -- context 315 | -> Re TC -- type in rnf 316 | -> Re TC -- t the first in rnf 317 | -> Re TC -- t the second in rnf 318 | -> Maybe () -- well, were they? 319 | qC g ty t0 t1 = case (isCan ty, isCan t0, isCan t1) of 320 | (Just ("Type", _), Just ("Type", [i]), Just ("Type", [j])) -> 321 | canQ g (rnfC g i) (rnfC g j) 322 | (Just ("Type", _), Just ("Pi", [sS, sT]), Just ("Pi", [tS, tT])) -> do 323 | qC g ty (rnfC g sS) (rnfC g tS) 324 | bsT <- isL1 sT 325 | btT <- isL1 tT 326 | pushCx g sS $ \ g x -> 327 | qC g (wks 1 ty) (rnfC g (body bsT)) (rnfC g (body btT)) 328 | (Just ty@("Pi", [sS, tT]), _, _) -> do 329 | bT <- isL1 tT 330 | b0 <- isL1 (etaPi t0) 331 | b1 <- isL1 (etaPi t1) 332 | pushCx g sS $ \ g x -> 333 | qC g (rnfC g (body bT)) (rnfC g (body b0)) (rnfC g (body b1)) 334 | _ -> do 335 | e0 <- isE t0 336 | e1 <- isE t1 337 | qE g e0 e1 338 | return () 339 | 340 | 341 | etaPi :: Re TC -> Re TC 342 | etaPi (E e :^ bi) = 343 | fmap L (1 \\ fmap (E . Z) (pR (e :^ o' bi) 344 | (fmap (E . X) (pR (xR 0) (kR S0))))) 345 | etaPi t = t --------------------------------------------------------------------------------